Merge branch 'develop' into staging

CHANGES.md

@@ -1,5 +1,39 @@
 # CHANGELOG
 
+## :rocket: Next
+
+### :boom: Breaking changes & Deprecations
+
+- The `PENPOT_LOGIN_WITH_LDAP` environment variable is finally removed (after
+  many version with deprecation). It is replaced with the
+  `enable-login-with-ldap` flag.
+- The `PENPOT_LDAP_ATTRS_PHOTO` finally removed, it was unused for many
+  versions.
+- If you are using social login (google, github, gitlab or generic OIDC) you
+  will need to ensure to add the following flags respectivelly to let them
+  enabled: `enable-login-with-google`, `enable-login-with-github`,
+  `enable-login-with-gitlab` and `enable-login-with-oidc`. If not, they will
+  remain disabled after application start independently if you set the client-id
+  and client-sectet options.
+- The `PENPOT_REGISTRATION_ENABLED` is finally removed in favour of
+  `<enable|disable>-registration` flag.
+- The OIDC providers are now initialized synchronously, and if you are using the
+  discovery mechanism of the generic OIDC integration, the start time of the
+  application will depend on how fast the OIDC provider responds to the
+  discovery http request.
+
+### :sparkles: New features
+
+- Allow for nested and rotated boards inside other boards and groups [Taiga #2874](https://tree.taiga.io/project/penpot/us/2874?milestone=319982)
+- View mode improvements to enable access and use in different conditions [Taiga #3023](https://tree.taiga.io/project/penpot/us/3023)
+- Improved share link options. Now you can allow non-team members to comment and/or inspect [Taiga #3056] (https://tree.taiga.io/project/penpot/us/3056)
+- Signin/Signup from shared link [Taiga #3472](https://tree.taiga.io/project/penpot/us/3472)
+- Support for import/export binary format [Taiga #2991](https://tree.taiga.io/project/penpot/us/2991)
+
+### :bug: Bugs fixed
+### :arrow_up: Deps updates
+### :heart: Community contributions by (Thank you!)
+
 ## 1.14.2-beta
 
 ### :bug: Bugs fixed

backend/deps.edn

@@ -1,13 +1,13 @@
 {:deps
  {penpot/common {:local/root "../common"}
-  org.clojure/clojure {:mvn/version "1.10.3"}
+  org.clojure/clojure {:mvn/version "1.11.1"}
   org.clojure/core.async {:mvn/version "1.5.648"}
 
   ;; Logging
   org.zeromq/jeromq {:mvn/version "0.5.2"}
 
   com.taoensso/nippy {:mvn/version "3.1.1"}
-  com.github.luben/zstd-jni {:mvn/version "1.5.2-2"}
+  com.github.luben/zstd-jni {:mvn/version "1.5.2-3"}
   org.clojure/data.fressian {:mvn/version "1.0.0"}
 
   io.prometheus/simpleclient {:mvn/version "0.15.0"}
@@ -17,24 +17,27 @@
                                                  org.eclipse.jetty/jetty-servlet]}
   io.prometheus/simpleclient_httpserver {:mvn/version "0.15.0"}
 
-  io.lettuce/lettuce-core {:mvn/version "6.1.6.RELEASE"}
+  io.lettuce/lettuce-core {:mvn/version "6.1.8.RELEASE"}
   java-http-clj/java-http-clj {:mvn/version "0.4.3"}
 
-  funcool/yetti {:git/tag "v9.1" :git/sha "63f35d9"
+  funcool/yetti {:git/tag "v9.2" :git/sha "4ddcc03"
                  :git/url "https://github.com/funcool/yetti.git"
                  :exclusions [org.slf4j/slf4j-api]}
 
-  com.github.seancorfield/next.jdbc {:mvn/version "1.2.772"}
+  com.github.seancorfield/next.jdbc {:mvn/version "1.2.780"}
-  metosin/reitit-core {:mvn/version "0.5.16"}
+  metosin/reitit-core {:mvn/version "0.5.18"}
-  org.postgresql/postgresql {:mvn/version "42.3.3"}
+  org.postgresql/postgresql {:mvn/version "42.4.0"}
   com.zaxxer/HikariCP {:mvn/version "5.0.1"}
-  funcool/datoteka {:mvn/version "2.0.0"}
+
+  funcool/datoteka {:mvn/version "3.0.64"}
 
   buddy/buddy-hashers {:mvn/version "1.8.158"}
   buddy/buddy-sign {:mvn/version "3.4.333"}
 
-  org.jsoup/jsoup {:mvn/version "1.14.3"}
+  org.jsoup/jsoup {:mvn/version "1.15.1"}
-  org.im4java/im4java {:mvn/version "1.4.0"}
+  org.im4java/im4java {:git/tag "1.4.0-penpot-2" :git/sha "e2b3e16"
+                       :git/url "https://github.com/penpot/im4java"}
+
   org.lz4/lz4-java {:mvn/version "1.8.0"}
 
   org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
@@ -43,11 +46,11 @@
   io.sentry/sentry {:mvn/version "5.6.1"}
 
   dawran6/emoji {:mvn/version "0.1.5"}
-  markdown-clj/markdown-clj {:mvn/version "1.11.0"}
+  markdown-clj/markdown-clj {:mvn/version "1.11.1"}
 
   ;; Pretty Print specs
   pretty-spec/pretty-spec {:mvn/version "0.1.4"}
-  software.amazon.awssdk/s3 {:mvn/version "2.17.136"}}
+  software.amazon.awssdk/s3 {:mvn/version "2.17.209"}}
 
  :paths ["src" "resources" "target/classes"]
  :aliases
@@ -64,7 +67,7 @@
 
   :build
   {:extra-deps
-   {io.github.clojure/tools.build {:git/tag "v0.7.7" :git/sha "1474ad6"}}
+   {io.github.clojure/tools.build {:git/tag "v0.8.2" :git/sha "ba1a2bf"}}
    :ns-default build}
 
   :test

backend/resources/api-doc.css

@@ -85,6 +85,16 @@ header {
 .rpc-row-info > .name {
   width: 280px;
   /* font-weight: bold; */
+  border-right: 1px dotted #777;
+  padding-right: 10px;
+}
+
+.rpc-row-info > .module {
+  width: 120px;
+  font-weight: bold;
+  border-right: 1px dotted #777;
+  text-align: right;
+  padding-right: 10px;
 }
 
 .rpc-row-info > .tags > .tag > span:first-child {

backend/resources/api-doc.tmpl

@@ -20,12 +20,42 @@
       </header>
       <section class="rpc-doc-content">
 
+        <h2>RPC COMMAND METHODS:</h2>
+        <ul class="rpc-items">
+          {% for item in command-methods %}
+            <li class="rpc-item">
+              <div class="rpc-row-info">
+                {# <div class="type">{{item.type}}</div> #}
+                <div class="module">{{item.module}}:</div>
+                <div class="name">{{item.name}}</div>
+                <div class="tags">
+                  <span class="tag">
+                    <span>Auth:</span>
+                    <span>{% if item.auth %}YES{% else %}NO{% endif %}</span>
+                  </span>
+                </div>
+              </div>
+              <div class="rpc-row-detail hidden">
+                {% if item.docs %}
+                  <h3>DOCSTRING:</h3>
+                  <p>{{item.docs}}</p>
+                {% endif %}
+
+                <h3>SPEC EXPLAIN:</h3>
+                <pre>{{item.spec}}</pre>
+              </div>
+            </li>
+          {% endfor %}
+        </ul>
+
         <h2>RPC QUERY METHODS:</h2>
         <ul class="rpc-items">
           {% for item in query-methods %}
             <li class="rpc-item">
               <div class="rpc-row-info">
                 {# <div class="type">{{item.type}}</div> #}
+
+                <div class="module">{{item.module}}:</div>
                 <div class="name">{{item.name}}</div>
                 <div class="tags">
                   <span class="tag">
@@ -53,6 +83,7 @@
             <li class="rpc-item">
               <div class="rpc-row-info">
                 {# <div class="type">{{item.type}}</div> #}
+                <div class="module">{{item.module}}:</div>
                 <div class="name">{{item.name}}</div>
                 <div class="tags">
                   <span class="tag">

backend/resources/log4j2-devenv.xml

@@ -20,11 +20,17 @@
   </Appenders>
 
   <Loggers>
-    <Logger name="com.zaxxer.hikari" level="error"/>
     <Logger name="io.lettuce" level="error" />
-    <Logger name="org.eclipse.jetty" level="error" />
+    <Logger name="com.zaxxer.hikari" level="error"/>
     <Logger name="org.postgresql" level="error" />
 
+    <Logger name="app.rpc.commands.binfile" level="debug" />
+    <Logger name="app.storage.tmp" level="trace" />
+    <Logger name="app.worker" level="info" />
+    <Logger name="app.msgbus" level="info" />
+    <Logger name="app.http.websocket" level="info" />
+    <Logger name="app.util.websocket" level="info" />
+
     <Logger name="app.cli" level="debug" additivity="false">
       <AppenderRef ref="console"/>
     </Logger>
@@ -38,11 +44,6 @@
       <AppenderRef ref="zmq" level="debug" />
     </Logger>
 
-    <Logger name="penpot" level="debug" additivity="false">
-      <AppenderRef ref="main" level="debug" />
-      <AppenderRef ref="zmq" level="debug" />
-    </Logger>
-
     <Logger name="user" level="trace" additivity="false">
       <AppenderRef ref="main" level="trace" />
     </Logger>

backend/resources/log4j2.xml

@@ -7,17 +7,21 @@
   </Appenders>
 
   <Loggers>
+    <Logger name="io.lettuce" level="error" />
     <Logger name="com.zaxxer.hikari" level="error" />
-    <Logger name="org.eclipse.jetty" level="error" />
+    <Logger name="org.postgresql" level="error" />
+
+    <Logger name="app.rpc.commands.binfile" level="info" />
+    <Logger name="app.storage.tmp" level="info" />
+    <Logger name="app.worker" level="info" />
+    <Logger name="app.msgbus" level="info" />
+    <Logger name="app.http.websocket" level="info" />
+    <Logger name="app.util.websocket" level="info" />
 
     <Logger name="app" level="debug" additivity="false">
       <AppenderRef ref="console" />
     </Logger>
 
-    <Logger name="penpot" level="fatal" additivity="false">
-      <AppenderRef ref="console" />
-    </Logger>
-
     <Root level="info">
       <AppenderRef ref="console" />
     </Root>

backend/resources/templates/debug.tmpl

@@ -10,23 +10,118 @@ Debug Main Page
   <div>[<a href="/dbg/error">ERRORS</a>]</div>
 </nav>
 <main class="index">
-  <section>
+  <section class="widget">
-    <h2>Download file data:</h2>
+    <fieldset>
-    <desc>Given an FILE-ID, downloads the file data as file. The file data is encoded using transit.</desc>
+      <legend>Download file data:</legend>
-    <form method="get" action="/dbg/file/data">
+      <desc>Given an FILE-ID, downloads the file data as file. The file data is encoded using transit.</desc>
-      <input type="text" style="width:300px" name="file-id" placeholder="file-id" />
+      <form method="get" action="/dbg/file/data">
-      <input type="hidden" name="download" value="1" />
+        <div class="row">
-      <input type="submit" value="Download" />
+          <input type="text" style="width:300px" name="file-id" placeholder="file-id" />
-    </form>
+        </div>
+        <div class="row">
+          <input type="submit" name="download" value="Download" />
+          <input type="submit" name="clone" value="Clone" />
+        </div>
+      </form>
+    </fieldset>
+
+    <fieldset>
+      <legend>Upload File Data:</legend>
+      <desc>Create a new file on your draft projects using the file downloaded from the previous section.</desc>
+      <form method="post" enctype="multipart/form-data" action="/dbg/file/data">
+        <div class="row">
+          <input type="file" name="file" value="" />
+        </div>
+        <div class="row">
+          <label>Import with same id?</label>
+          <input type="checkbox" name="reuseid" />
+        </div>
+
+        <input type="submit" value="Upload" />
+      </form>
+    </fieldset>
   </section>
 
-  <section>
+  <section class="widget">
-    <h2>Upload File Data:</h2>
+    <fieldset>
-    <desc>Create a new file on your draft projects using the file downloaded from the previous section.</desc>
+      <legend>Export binfile:</legend>
-    <form method="post" enctype="multipart/form-data" action="/dbg/file/data">
+      <desc>Given an FILE-ID, downloads the file and optionally all
-      <input type="file" name="file" value="" />
+      the related libraries in a single custom formatted binary
-      <input type="submit" value="Upload" />
+      file.</desc>
-    </form>
+
+      <form method="get" action="/dbg/file/export">
+        <div class="row set-of-inputs">
+          <input type="text" style="width:300px" name="file-ids" placeholder="file-id" />
+          <input type="text" style="width:300px" name="file-ids" placeholder="file-id" />
+          <input type="text" style="width:300px" name="file-ids" placeholder="file-id" />
+          <input type="text" style="width:300px" name="file-ids" placeholder="file-id" />
+        </div>
+
+        <div class="row">
+          <label>Include libraries?</label>
+          <input type="checkbox" name="includelibs" />
+        </div>
+
+        <div class="row">
+          <label>Embed assets?</label>
+          <input type="checkbox" name="embedassets" checked/>
+        </div>
+
+        <div class="row">
+          <input type="submit" name="download" value="Download" />
+          <input type="submit" name="clone" value="Clone" />
+        </div>
+      </form>
+    </fieldset>
+    <fieldset>
+      <legend>Import binfile:</legend>
+      <desc>Import penpot file in binary
+      format. If <strong>overwrite</strong> is checked, all files will
+      be overwriten using the same ids found in the file instead of
+      generating a new ones.</desc>
+
+      <form method="post" enctype="multipart/form-data" action="/dbg/file/import">
+        <div class="row">
+          <input type="file" name="file" value="" />
+        </div>
+
+        <div class="row">
+          <label>Overwrite?</label>
+          <input type="checkbox" name="overwrite" />
+          <br />
+          <small>
+            Instead of creating a new file with all relations remaped,
+            reuses all ids and updates/overwrites the objects that are
+            already exists on the database.
+            <strong>Warning, this operation should be used with caution.</strong>
+          </small>
+        </div>
+
+        <div class="row">
+          <label>Migrate?</label>
+          <input type="checkbox" name="migrate" />
+          <br />
+          <small>
+            Applies the file migrations on the importation process.
+          </small>
+        </div>
+
+        <div class="row">
+          <label>Ignore index errors?</label>
+          <input type="checkbox" name="ignore-index-errors" checked/>
+          <br />
+          <small>
+            Do not break on index lookup erros (remap operation).
+            Useful when importing a broken file that has broken
+            relations or missing pieces.
+          </small>
+        </div>
+
+        <div class="row">
+          <input type="submit" name="upload" value="Upload" />
+        </div>
+      </form>
+    </fieldset>
   </section>
 </main>
 {% endblock %}

backend/resources/templates/styles.css

@@ -14,7 +14,6 @@ pre {
 }
 
 desc {
-  display: flex;
   margin-bottom: 10px;
   font-size: 10px;
   color: #666;
@@ -28,6 +27,15 @@ main {
   margin: 20px;
 }
 
+small {
+  font-size: 9px;
+  color: #888;
+}
+
+small > strong {
+  font-size: 9px;
+}
+
 nav {
   position: fixed;
   width: 100vw;
@@ -95,17 +103,25 @@ nav > div:not(:last-child) {
 
 .index {
   margin-top: 40px;
+  display: flex;
 }
 
 .index > section {
   padding: 10px;
   background-color: #e3e3e3;
+  max-width: 400px;
+  margin: 5px;
+  height: fit-content;
 }
 
-.index > section:not(:last-child) {
+.index fieldset:not(:first-child) {
-  margin-bottom: 10px;
+  margin-top: 15px;
 }
 
+/* .index > section:not(:last-child) { */
+/*   margin-bottom: 10px; */
+/* } */
+
 
 .index > section > h2 {
   margin-top: 0px;
@@ -148,3 +164,16 @@ nav > div:not(:last-child) {
   color: inherit;
 }
 
+form .row {
+  padding: 5px 0;
+}
+
+.set-of-inputs {
+  flex-direction: column;
+  display: flex;
+}
+
+.set-of-inputs input:not(:last-child) {
+  margin-bottom: 3px;
+}
+

backend/scripts/repl

@@ -24,9 +24,8 @@ mc mb penpot-s3/penpot -p
 
 export AWS_ACCESS_KEY_ID=penpot-devenv
 export AWS_SECRET_ACCESS_KEY=penpot-devenv
-export PENPOT_ASSETS_STORAGE_BACKEND=assets-fs
+export PENPOT_ASSETS_STORAGE_BACKEND=assets-s3
 export PENPOT_STORAGE_ASSETS_S3_ENDPOINT=http://minio:9000
-export PENPOT_STORAGE_ASSETS_S3_REGION=eu-central-1
 export PENPOT_STORAGE_ASSETS_S3_BUCKET=penpot
 
 export OPTIONS="
@@ -40,6 +39,9 @@ export OPTIONS="
        -J-XX:+UnlockDiagnosticVMOptions \
        -J-XX:+DebugNonSafepoints";
 
+# Uncomment for use the ImageMagick v7.x
+# export OPTIONS="-J-Dim4java.useV7=true $OPTIONS";
+
 export OPTIONS_EVAL="nil"
 # export OPTIONS_EVAL="(set! *warn-on-reflection* true)"
 

backend/src/app/auth/ldap.clj

@@ -0,0 +1,137 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.auth.ldap
+  (:require
+   [app.common.exceptions :as ex]
+   [app.common.logging :as l]
+   [app.common.spec :as us]
+   [app.config :as cf]
+   [clj-ldap.client :as ldap]
+   [clojure.spec.alpha :as s]
+   [clojure.string]
+   [integrant.core :as ig]))
+
+(defn- prepare-params
+  [cfg]
+  {:ssl?      (:ssl cfg)
+   :startTLS? (:tls cfg)
+   :bind-dn   (:bind-dn cfg)
+   :password  (:bind-password cfg)
+   :host      {:address (:host cfg)
+               :port    (:port cfg)}})
+
+(defn- connect
+  "Connects to the LDAP provider and returns a connection. An
+  exception is raised if no connection is possible."
+  ^java.lang.AutoCloseable
+  [cfg]
+  (try
+    (-> cfg prepare-params ldap/connect)
+    (catch Throwable cause
+      (ex/raise :type :restriction
+                :code :unable-to-connect-to-ldap
+                :hint "unable to connect to ldap server"
+                :cause cause))))
+
+(defn- replace-several [s & {:as replacements}]
+  (reduce-kv clojure.string/replace s replacements))
+
+(defn- search-user
+  [{:keys [conn attrs base-dn] :as cfg} email]
+  (let [query   (replace-several (:query cfg) ":username" email)
+        params  {:filter query
+                 :sizelimit 1
+                 :attributes attrs}]
+    (first (ldap/search conn base-dn params))))
+
+(defn- retrieve-user
+  [{:keys [conn] :as cfg} {:keys [email password]}]
+  (when-let [{:keys [dn] :as user} (search-user cfg email)]
+    (when (ldap/bind? conn dn password)
+      {:fullname (get user (-> cfg :attrs-fullname keyword))
+       :email    email
+       :backend  "ldap"})))
+
+(s/def ::fullname ::us/not-empty-string)
+(s/def ::email ::us/email)
+(s/def ::backend ::us/not-empty-string)
+
+(s/def ::info-data
+  (s/keys :req-un [::fullname ::email ::backend]))
+
+(defn authenticate
+  [cfg params]
+  (with-open [conn (connect cfg)]
+    (when-let [user (-> (assoc cfg :conn conn)
+                        (retrieve-user params))]
+      (when-not (s/valid? ::info-data user)
+        (let [explain (s/explain-str ::info-data user)]
+          (l/warn ::l/raw (str "invalid response from ldap, looks like ldap is not configured correctly\n" explain))
+          (ex/raise :type :restriction
+                    :code :wrong-ldap-response
+                    :explain explain)))
+      user)))
+
+(defn- try-connectivity
+  [cfg]
+  ;; If we have ldap parameters, try to establish connection
+  (when (and (:bind-dn cfg)
+             (:bind-password cfg)
+             (:host cfg)
+             (:port cfg))
+    (try
+      (with-open [_ (connect cfg)]
+        (l/info :hint "provider initialized"
+                :provider "ldap"
+                :host (:host cfg)
+                :port (:port cfg)
+                :tls? (:tls cfg)
+                :ssl? (:ssl cfg)
+                :bind-dn (:bind-dn cfg)
+                :base-dn (:base-dn cfg)
+                :query (:query cfg))
+        cfg)
+      (catch Throwable cause
+        (l/error :hint "unable to connect to LDAP server (LDAP auth provider disabled)"
+                 :host (:host cfg) :port (:port cfg) :cause cause)
+        nil))))
+
+(defn- prepare-attributes
+  [cfg]
+  (assoc cfg :attrs [(:attrs-username cfg)
+                     (:attrs-email cfg)
+                     (:attrs-fullname cfg)]))
+
+(defmethod ig/init-key ::provider
+  [_ cfg]
+  (when (:enabled? cfg)
+    (some-> cfg try-connectivity prepare-attributes)))
+
+(s/def ::enabled? ::us/boolean)
+(s/def ::host ::cf/ldap-host)
+(s/def ::port ::cf/ldap-port)
+(s/def ::ssl ::cf/ldap-ssl)
+(s/def ::tls ::cf/ldap-starttls)
+(s/def ::query ::cf/ldap-user-query)
+(s/def ::base-dn ::cf/ldap-base-dn)
+(s/def ::bind-dn ::cf/ldap-bind-dn)
+(s/def ::bind-password ::cf/ldap-bind-password)
+(s/def ::attrs-email ::cf/ldap-attrs-email)
+(s/def ::attrs-fullname ::cf/ldap-attrs-fullname)
+(s/def ::attrs-username ::cf/ldap-attrs-username)
+
+(defmethod ig/pre-init-spec ::provider
+  [_]
+  (s/keys :opt-un [::host ::port
+                   ::ssl ::tls
+                   ::enabled?
+                   ::bind-dn
+                   ::bind-password
+                   ::query
+                   ::attrs-email
+                   ::attrs-username
+                   ::attrs-fullname]))

backend/src/app/auth/oidc.clj

@@ -4,19 +4,23 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.http.oauth
+(ns app.auth.oidc
+  "OIDC client implementation."
   (:require
    [app.common.data :as d]
+   [app.common.data.macros :as dm]
    [app.common.exceptions :as ex]
    [app.common.logging :as l]
    [app.common.spec :as us]
    [app.common.uri :as u]
    [app.config :as cf]
    [app.db :as db]
+   [app.http.middleware :as hmw]
    [app.loggers.audit :as audit]
    [app.rpc.queries.profile :as profile]
    [app.util.json :as json]
    [app.util.time :as dt]
+   [app.worker :as wrk]
    [clojure.set :as set]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
@@ -25,6 +29,218 @@
    [promesa.exec :as px]
    [yetti.response :as yrs]))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HELPERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- obfuscate-string
+  [s]
+  (if (< (count s) 10)
+    (apply str (take (count s) (repeat "*")))
+    (str (subs s 0 5)
+         (apply str (take (- (count s) 5) (repeat "*"))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; OIDC PROVIDER (GENERIC)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- discover-oidc-config
+  [{:keys [http-client]} {:keys [base-uri] :as opts}]
+  (let [discovery-uri (u/join base-uri ".well-known/openid-configuration")
+        response      (ex/try (http-client {:method :get :uri (str discovery-uri)} {:sync? true}))]
+    (cond
+      (ex/exception? response)
+      (do
+        (l/warn :hint "unable to discover oidc configuration"
+                :discover-uri (str discovery-uri)
+                :cause response)
+        nil)
+
+      (= 200 (:status response))
+      (let [data (json/read (:body response))]
+        {:token-uri (get data :token_endpoint)
+         :auth-uri  (get data :authorization_endpoint)
+         :user-uri  (get data :userinfo_endpoint)})
+
+      :else
+      (do
+        (l/warn :hint "unable to discover OIDC configuration"
+                :uri (str discovery-uri)
+                :response-status-code (:status response))
+        nil))))
+
+(defn- prepare-oidc-opts
+  [cfg]
+  (let [opts {:base-uri      (:base-uri cfg)
+              :client-id     (:client-id cfg)
+              :client-secret (:client-secret cfg)
+              :token-uri     (:token-uri cfg)
+              :auth-uri      (:auth-uri cfg)
+              :user-uri      (:user-uri cfg)
+              :scopes        (:scopes cfg #{"openid" "profile" "email"})
+              :roles-attr    (:roles-attr cfg)
+              :roles         (:roles cfg)
+              :name          "oidc"}
+
+        opts (d/without-nils opts)]
+
+    (when (and (string? (:base-uri opts))
+               (string? (:client-id opts))
+               (string? (:client-secret opts)))
+      (if (and (string? (:token-uri opts))
+               (string? (:user-uri opts))
+               (string? (:auth-uri opts)))
+        opts
+        (some-> (discover-oidc-config cfg opts)
+                (merge opts {:discover? true}))))))
+
+(defmethod ig/prep-key ::generic-provider
+  [_ cfg]
+  (d/without-nils cfg))
+
+(defmethod ig/init-key ::generic-provider
+  [_ cfg]
+  (when (:enabled? cfg)
+    (if-let [opts (prepare-oidc-opts cfg)]
+      (do
+        (l/info :hint "provider initialized"
+                :provider :oidc
+                :method (if (:discover? opts) "discover" "manual")
+                :client-id (:client-id opts)
+                :client-secret (obfuscate-string (:client-secret opts))
+                :scopes (str/join "," (:scopes opts))
+                :auth-uri (:auth-uri opts)
+                :user-uri (:user-uri opts)
+                :token-uri (:token-uri opts)
+                :roles-attr (:roles-attr opts)
+                :roles      (:roles opts))
+        opts)
+      (do
+        (l/warn :hint "unable to initialize auth provider, missing configuration" :provider :oidc)
+        nil))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; GOOGLE AUTH PROVIDER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod ig/prep-key ::google-provider
+  [_ cfg]
+  (d/without-nils cfg))
+
+(defmethod ig/init-key ::google-provider
+  [_ cfg]
+  (let [opts {:client-id     (:client-id cfg)
+              :client-secret (:client-secret cfg)
+              :scopes        #{"openid" "email" "profile"}
+              :auth-uri      "https://accounts.google.com/o/oauth2/v2/auth"
+              :token-uri     "https://oauth2.googleapis.com/token"
+              :user-uri      "https://openidconnect.googleapis.com/v1/userinfo"
+              :name          "google"}]
+
+    (when (:enabled? cfg)
+      (if (and (string? (:client-id opts))
+               (string? (:client-secret opts)))
+        (do
+          (l/info :hint "provider initialized"
+                  :provider :google
+                  :client-id (:client-id opts)
+                  :client-secret (obfuscate-string (:client-secret opts)))
+          opts)
+
+        (do
+          (l/warn :hint "unable to initialize auth provider, missing configuration" :provider :google)
+          nil)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; GITHUB AUTH PROVIDER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- retrieve-github-email
+  [{:keys [http-client]} tdata info]
+  (or (some-> info :email p/resolved)
+      (-> (http-client {:uri "https://api.github.com/user/emails"
+                        :headers {"Authorization" (dm/str (:type tdata) " " (:token tdata))}
+                        :timeout 6000
+                        :method :get})
+          (p/then (fn [{:keys [status body] :as response}]
+                    (when-not (s/int-in-range? 200 300 status)
+                      (ex/raise :type :internal
+                                :code :unable-to-retrieve-github-emails
+                                :hint "unable to retrieve github emails"
+                                :http-status status
+                                :http-body body))
+                    (->> response :body json/read (filter :primary) first :email))))))
+
+(defmethod ig/prep-key ::github-provider
+  [_ cfg]
+  (d/without-nils cfg))
+
+(defmethod ig/init-key ::github-provider
+  [_ cfg]
+  (let [opts {:client-id     (:client-id cfg)
+              :client-secret (:client-secret cfg)
+              :scopes        #{"read:user" "user:email"}
+              :auth-uri      "https://github.com/login/oauth/authorize"
+              :token-uri     "https://github.com/login/oauth/access_token"
+              :user-uri      "https://api.github.com/user"
+              :name          "github"
+
+              ;; Additional hooks for provider specific way of
+              ;; retrieve emails.
+              :get-email-fn           (partial retrieve-github-email cfg)}]
+
+    (when (:enabled? cfg)
+      (if (and (string? (:client-id opts))
+               (string? (:client-secret opts)))
+        (do
+          (l/info :hint "provider initialized"
+                  :provider :github
+                  :client-id (:client-id opts)
+                  :client-secret (obfuscate-string (:client-secret opts)))
+          opts)
+
+        (do
+          (l/warn :hint "unable to initialize auth provider, missing configuration" :provider :github)
+          nil)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; GITLAB AUTH PROVIDER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod ig/prep-key ::gitlab-provider
+  [_ cfg]
+  (d/without-nils cfg))
+
+(defmethod ig/init-key ::gitlab-provider
+  [_ cfg]
+  (let [base (:base-uri cfg "https://gitlab.com")
+        opts {:base-uri      base
+              :client-id     (:client-id cfg)
+              :client-secret (:client-secret cfg)
+              :scopes        #{"openid" "profile" "email"}
+              :auth-uri      (str base "/oauth/authorize")
+              :token-uri     (str base "/oauth/token")
+              :user-uri      (str base "/oauth/userinfo")
+              :name          "gitlab"}]
+    (when (:enabled? cfg)
+      (if (and (string? (:client-id opts))
+               (string? (:client-secret opts)))
+        (do
+          (l/info :hint "provider initialized"
+                  :provider :gitlab
+                  :base-uri base
+                  :client-id (:client-id opts)
+                  :client-secret (obfuscate-string (:client-secret opts)))
+          opts)
+
+        (do
+          (l/warn :hint "unable to initialize auth provider, missing configuration" :provider :gitlab)
+          nil)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HANDLERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (defn- build-redirect-uri
   [{:keys [provider] :as cfg}]
   (let [public (u/uri (:public-uri cfg))]
@@ -81,47 +297,35 @@
                           :timeout 6000
                           :method :get}))
 
-          (retrieve-emails []
+          (validate-response [response]
-            (if (some? (:emails-uri provider))
+            (when-not (s/int-in-range? 200 300 (:status response))
-              (http-client {:uri (:emails-uri provider)
-                            :headers {"Authorization" (str (:type tdata) " " (:token tdata))}
-                            :timeout 6000
-                            :method :get})
-              (p/resolved {:status 200})))
-
-          (validate-response [[retrieve-res emails-res]]
-            (when-not (s/int-in-range? 200 300 (:status retrieve-res))
               (ex/raise :type :internal
                         :code :unable-to-retrieve-user-info
                         :hint "unable to retrieve user info"
-                        :http-status (:status retrieve-res)
+                        :http-status (:status response)
-                        :http-body (:body retrieve-res)))
+                        :http-body (:body response)))
-            (when-not (s/int-in-range? 200 300 (:status emails-res))
+            response)
-              (ex/raise :type :internal
-                        :code :unable-to-retrieve-user-info
-                        :hint "unable to retrieve user info"
-                        :http-status (:status emails-res)
-                        :http-body (:body emails-res)))
-            [retrieve-res emails-res])
 
           (get-email [info]
-            (let [attr-kw (cf/get :oidc-email-attr :email)]
+            ;; Allow providers hook into this for custom email
-              (get info attr-kw)))
+            ;; retrieval method.
+            (if-let [get-email-fn (:get-email-fn provider)]
+              (get-email-fn tdata info)
+              (let [attr-kw (cf/get :oidc-email-attr :email)]
+                (get info attr-kw))))
 
           (get-name [info]
             (let [attr-kw (cf/get :oidc-name-attr :name)]
               (get info attr-kw)))
 
-          (process-response [[retrieve-res emails-res]]
+          (process-response [response]
-            (let [info (json/read (:body retrieve-res))
+            (p/let [info  (-> response :body json/read)
-                  email (if (some? (:extract-email-callback provider))
+                    email (get-email info)]
-                          ((:extract-email-callback provider) emails-res)
-                          (get-email info))]
               {:backend  (:name provider)
                :email    email
                :fullname (or (get-name info) email)
-               :props (->> (dissoc info :name :email)
+               :props    (->> (dissoc info :name :email)
-                           (qualify-props provider))}))
+                              (qualify-props provider))}))
 
           (validate-info [info]
             (when-not (s/valid? ::info info)
@@ -133,10 +337,10 @@
                         :info info))
             info)]
 
-    (-> (p/all [(retrieve) (retrieve-emails)])
+    (-> (retrieve)
-        (p/then' validate-response)
+        (p/then validate-response)
-        (p/then' process-response)
+        (p/then process-response)
-        (p/then' validate-info))))
+        (p/then validate-info))))
 
 (s/def ::backend ::us/not-empty-string)
 (s/def ::email ::us/not-empty-string)
@@ -195,8 +399,6 @@
           (p/then' validate-oidc)
           (p/then' (partial post-process state))))))
 
-;; --- HTTP HANDLERS
-
 (defn- retrieve-profile
   [{:keys [pool executor] :as cfg} info]
   (px/with-dispatch executor
@@ -256,21 +458,18 @@
       (redirect-response uri))))
 
 (defn- auth-handler
-  [{:keys [tokens] :as cfg} {:keys [params] :as request} respond raise]
+  [{:keys [tokens] :as cfg} {:keys [params] :as request}]
-  (try
+  (let [props (audit/extract-utm-params params)
-    (let [props (audit/extract-utm-params params)
+        state (tokens :generate
-          state (tokens :generate
+                      {:iss :oauth
-                        {:iss :oauth
+                       :invitation-token (:invitation-token params)
-                         :invitation-token (:invitation-token params)
+                       :props props
-                         :props props
+                       :exp (dt/in-future "15m")})
-                         :exp (dt/in-future "15m")})
+        uri   (build-auth-uri cfg state)]
-          uri   (build-auth-uri cfg state)]
+    (yrs/response 200 {:redirect-uri uri})))
-      (respond (yrs/response 200 {:redirect-uri uri})))
-    (catch Throwable cause
-      (raise cause))))
 
 (defn- callback-handler
-  [cfg request respond _]
+  [cfg request]
   (letfn [(process-request []
             (p/let [info    (retrieve-info cfg request)
                     profile (retrieve-profile cfg info)]
@@ -278,182 +477,62 @@
 
           (handle-error [cause]
             (l/error :hint "error on oauth process" :cause cause)
-            (respond (generate-error-redirect cfg cause)))]
+            (generate-error-redirect cfg cause))]
 
     (-> (process-request)
-        (p/then respond)
         (p/catch handle-error))))
 
-;; --- INIT
+(def provider-lookup
-
+  {:compile
-(declare initialize)
+   (fn [& _]
+     (fn [handler]
+       (fn [{:keys [providers] :as cfg} request]
+         (let [provider (some-> request :path-params :provider keyword)]
+           (if-let [provider (get providers provider)]
+             (handler (assoc cfg :provider provider) request)
+             (ex/raise :type :restriction
+                       :code :provider-not-configured
+                       :provider provider
+                       :hint "provider not configured"))))))})
 
 (s/def ::public-uri ::us/not-empty-string)
+(s/def ::http-client fn?)
 (s/def ::session map?)
 (s/def ::tokens fn?)
-(s/def ::rpc map?)
+(s/def ::providers map?)
 
-(defmethod ig/pre-init-spec ::handler [_]
+(defmethod ig/pre-init-spec ::routes
-  (s/keys :req-un [::public-uri ::session ::tokens ::rpc ::db/pool]))
+  [_]
+  (s/keys :req-un [::public-uri
+                   ::session
+                   ::tokens
+                   ::http-client
+                   ::providers
+                   ::db/pool
+                   ::wrk/executor]))
 
-(defn wrap-handler
+(defmethod ig/init-key ::routes
-  [cfg handler]
+  [_ {:keys [executor session] :as cfg}]
-  (fn [request respond raise]
+  (let [cfg (update cfg :provider d/without-nils)]
-    (let [provider (get-in request [:path-params :provider])
+    ["" {:middleware [[(:middleware session)]
-          provider (get-in @cfg [:providers provider])]
+                      [hmw/with-promise-async executor]
-      (if provider
+                      [hmw/with-config cfg]
-        (handler (assoc @cfg :provider provider)
+                      [provider-lookup]
-                 request
+                      ]}
-                 respond
+     ;; We maintain the both URI prefixes for backward compatibility.
-                 raise)
-        (raise
-         (ex/error
-          :type :not-found
-          :provider provider
-          :hint "provider not configured"))))))
 
-(defmethod ig/init-key ::handler
+     ["/auth/oauth"
-  [_ cfg]
+      ["/:provider"
-  (let [cfg (initialize cfg)]
+       {:handler auth-handler
-    {:handler (wrap-handler cfg auth-handler)
+        :allowed-methods #{:post}}]
-     :callback-handler (wrap-handler cfg callback-handler)}))
+      ["/:provider/callback"
+       {:handler callback-handler
+        :allowed-methods #{:get}}]]
 
-(defn- discover-oidc-config
+     ["/auth/oidc"
-  [{:keys [http-client]} {:keys [base-uri] :as opts}]
+      ["/:provider"
-
+       {:handler auth-handler
-  (let [discovery-uri (u/join base-uri ".well-known/openid-configuration")
+        :allowed-methods #{:post}}]
-        response      (ex/try (http-client {:method :get :uri (str discovery-uri)} {:sync? true}))]
+      ["/:provider/callback"
-    (cond
+       {:handler callback-handler
-      (ex/exception? response)
+        :allowed-methods #{:get}}]]]))
-      (do
-        (l/warn :hint "unable to discover oidc configuration"
-                :discover-uri (str discovery-uri)
-                :cause response)
-        nil)
-
-      (= 200 (:status response))
-      (let [data (json/read (:body response))]
-        {:token-uri (get data :token_endpoint)
-         :auth-uri  (get data :authorization_endpoint)
-         :user-uri  (get data :userinfo_endpoint)})
-
-      :else
-      (do
-        (l/warn :hint "unable to discover OIDC configuration"
-                :uri (str discovery-uri)
-                :response-status-code (:status response))
-        nil))))
-
-(defn- obfuscate-string
-  [s]
-  (if (< (count s) 10)
-    (apply str (take (count s) (repeat "*")))
-    (str (subs s 0 5)
-         (apply str (take (- (count s) 5) (repeat "*"))))))
-
-(defn- initialize-oidc-provider
-  [cfg]
-  (let [opts {:base-uri      (cf/get :oidc-base-uri)
-              :client-id     (cf/get :oidc-client-id)
-              :client-secret (cf/get :oidc-client-secret)
-              :token-uri     (cf/get :oidc-token-uri)
-              :auth-uri      (cf/get :oidc-auth-uri)
-              :user-uri      (cf/get :oidc-user-uri)
-              :scopes        (cf/get :oidc-scopes #{"openid" "profile" "email"})
-              :roles-attr    (cf/get :oidc-roles-attr)
-              :roles         (cf/get :oidc-roles)
-              :name          "oidc"}]
-
-    (if (and (string? (:base-uri opts))
-             (string? (:client-id opts))
-             (string? (:client-secret opts)))
-      (do
-        (l/debug :hint "initialize oidc provider" :name "generic-oidc"
-                 :opts (update opts :client-secret obfuscate-string))
-        (if (and (string? (:token-uri opts))
-                 (string? (:user-uri opts))
-                 (string? (:auth-uri opts)))
-          (do
-            (l/debug :hint "initialized with user provided configuration")
-            (assoc-in cfg [:providers "oidc"] opts))
-          (do
-            (l/debug :hint "trying to discover oidc provider configuration using BASE_URI")
-            (if-let [opts' (discover-oidc-config cfg opts)]
-              (do
-                (l/debug :hint "discovered opts" :additional-opts opts')
-                (assoc-in cfg [:providers "oidc"] (merge opts opts')))
-
-              cfg))))
-      cfg)))
-
-(defn- initialize-google-provider
-  [cfg]
-  (let [opts {:client-id     (cf/get :google-client-id)
-              :client-secret (cf/get :google-client-secret)
-              :scopes        #{"openid" "email" "profile"}
-              :auth-uri      "https://accounts.google.com/o/oauth2/v2/auth"
-              :token-uri     "https://oauth2.googleapis.com/token"
-              :user-uri      "https://openidconnect.googleapis.com/v1/userinfo"
-              :name          "google"}]
-    (if (and (string? (:client-id opts))
-             (string? (:client-secret opts)))
-      (do
-        (l/info :action "initialize" :provider "google"
-                :opts (pr-str (update opts :client-secret obfuscate-string)))
-        (assoc-in cfg [:providers "google"] opts))
-      cfg)))
-
-(defn extract-github-email
-  [response]
-  (let [emails (json/read (:body response))
-        primary-email (->> emails
-                           (filter #(:primary %))
-                           first)]
-  (:email primary-email)))
-
-(defn- initialize-github-provider
-  [cfg]
-  (let [opts {:client-id              (cf/get :github-client-id)
-              :client-secret          (cf/get :github-client-secret)
-              :scopes                 #{"read:user" "user:email"}
-              :auth-uri               "https://github.com/login/oauth/authorize"
-              :token-uri              "https://github.com/login/oauth/access_token"
-              :emails-uri             "https://api.github.com/user/emails"
-              :extract-email-callback extract-github-email
-              :user-uri               "https://api.github.com/user"
-              :name                   "github"}]
-    (if (and (string? (:client-id opts))
-             (string? (:client-secret opts)))
-      (do
-        (l/info :action "initialize" :provider "github"
-                :opts (pr-str (update opts :client-secret obfuscate-string)))
-        (assoc-in cfg [:providers "github"] opts))
-      cfg)))
-
-(defn- initialize-gitlab-provider
-  [cfg]
-  (let [base (cf/get :gitlab-base-uri "https://gitlab.com")
-        opts {:base-uri      base
-              :client-id     (cf/get :gitlab-client-id)
-              :client-secret (cf/get :gitlab-client-secret)
-              :scopes        #{"openid" "profile" "email"}
-              :auth-uri      (str base "/oauth/authorize")
-              :token-uri     (str base "/oauth/token")
-              :user-uri      (str base "/oauth/userinfo")
-              :name          "gitlab"}]
-    (if (and (string? (:client-id opts))
-             (string? (:client-secret opts)))
-      (do
-        (l/info :action "initialize" :provider "gitlab"
-                :opts (pr-str (update opts :client-secret obfuscate-string)))
-        (assoc-in cfg [:providers "gitlab"] opts))
-      cfg)))
-
-(defn- initialize
-  [cfg]
-  (let [cfg (agent cfg :error-mode :continue)]
-    (send-off cfg initialize-google-provider)
-    (send-off cfg initialize-gitlab-provider)
-    (send-off cfg initialize-github-provider)
-    (send-off cfg initialize-oidc-provider)
-    cfg))

backend/src/app/cli/manage.clj

@@ -10,6 +10,7 @@
    [app.common.logging :as l]
    [app.db :as db]
    [app.main :as main]
+   [app.rpc.commands.auth :as cmd.auth]
    [app.rpc.mutations.profile :as profile]
    [app.rpc.queries.profile :refer [retrieve-profile-data-by-email]]
    [clojure.string :as str]
@@ -54,13 +55,13 @@
                                          :type :password}))]
     (try
       (db/with-atomic [conn (:app.db/pool system)]
-        (->> (profile/create-profile conn
+        (->> (cmd.auth/create-profile conn
                                      {:fullname fullname
                                       :email email
                                       :password password
                                       :is-active true
                                       :is-demo false})
-             (profile/create-profile-relations conn)))
+             (cmd.auth/create-profile-relations conn)))
 
       (when (pos? (:verbosity options))
         (println "User created successfully."))

backend/src/app/config.clj

@@ -11,6 +11,7 @@
    [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.flags :as flags]
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.common.version :as v]
    [app.util.time :as dt]
@@ -79,18 +80,14 @@
    :ldap-attrs-username "uid"
    :ldap-attrs-email "mail"
    :ldap-attrs-fullname "cn"
-   :ldap-attrs-photo "jpegPhoto"
 
    ;; a server prop key where initial project is stored.
    :initial-project-skey "initial-project"})
 
-(s/def ::flags ::us/set-of-keywords)
+(s/def ::flags ::us/vec-of-keywords)
 
 ;; DEPRECATED PROPERTIES
-(s/def ::registration-enabled ::us/boolean)
-(s/def ::smtp-enabled ::us/boolean)
 (s/def ::telemetry-enabled ::us/boolean)
-(s/def ::asserts-enabled ::us/boolean)
 ;; END DEPRECATED
 
 (s/def ::audit-log-archive-uri ::us/string)
@@ -149,7 +146,6 @@
 (s/def ::initial-project-skey ::us/string)
 (s/def ::ldap-attrs-email ::us/string)
 (s/def ::ldap-attrs-fullname ::us/string)
-(s/def ::ldap-attrs-photo ::us/string)
 (s/def ::ldap-attrs-username ::us/string)
 (s/def ::ldap-base-dn ::us/string)
 (s/def ::ldap-bind-dn ::us/string)
@@ -256,7 +252,6 @@
                    ::initial-project-skey
                    ::ldap-attrs-email
                    ::ldap-attrs-fullname
-                   ::ldap-attrs-photo
                    ::ldap-attrs-username
                    ::ldap-base-dn
                    ::ldap-bind-dn
@@ -276,7 +271,6 @@
                    ::public-uri
                    ::redis-uri
                    ::registration-domain-whitelist
-                   ::registration-enabled
                    ::rlimit-font
                    ::rlimit-file-update
                    ::rlimit-image
@@ -287,7 +281,6 @@
                    ::sentry-trace-sample-rate
                    ::smtp-default-from
                    ::smtp-default-reply-to
-                   ::smtp-enabled
                    ::smtp-host
                    ::smtp-password
                    ::smtp-port
@@ -354,8 +347,12 @@
                        (str/trim))
                "%version%")))
 
-(def ^:dynamic config (read-config))
+(defonce ^:dynamic config (read-config))
-(def ^:dynamic flags  (parse-flags config))
+
+(defonce ^:dynamic flags
+  (let [flags (parse-flags config)]
+    (l/info :hint "flags initialized" :flags (str/join "," (map name flags)))
+    flags))
 
 (def deletion-delay
   (dt/duration {:days 7}))

backend/src/app/db.clj

@@ -55,54 +55,66 @@
 (s/def ::migrations map?)
 (s/def ::name keyword?)
 (s/def ::password ::us/string)
-(s/def ::read-only ::us/boolean)
 (s/def ::uri ::us/not-empty-string)
 (s/def ::username ::us/string)
 (s/def ::validation-timeout ::us/integer)
+(s/def ::read-only? ::us/boolean)
 
-(defmethod ig/pre-init-spec ::pool [_]
+(s/def ::pool-options
-  (s/keys :req-un [::uri ::name
+  (s/keys :opt-un [::uri ::name
                    ::min-size
                    ::max-size
                    ::connection-timeout
-                   ::validation-timeout]
+                   ::validation-timeout
-          :opt-un [::migrations
+                   ::migrations
                    ::username
                    ::password
                    ::mtx/metrics
-                   ::read-only]))
+                   ::read-only?]))
+
+(def defaults
+  {:name :main
+   :min-size 0
+   :max-size 30
+   :connection-timeout 10000
+   :validation-timeout 10000
+   :idle-timeout 120000 ; 2min
+   :max-lifetime 1800000 ; 30m
+   :read-only? false})
 
 (defmethod ig/prep-key ::pool
   [_ cfg]
-  (merge {:name :main
+  (merge defaults (d/without-nils cfg)))
-          :min-size 0
+
-          :max-size 30
+;; Don't validate here, just validate that a map is received.
-          :connection-timeout 10000
+(defmethod ig/pre-init-spec ::pool [_] ::pool-options)
-          :validation-timeout 10000
-          :idle-timeout 120000 ; 2min
-          :max-lifetime 1800000 ; 30m
-          :read-only false}
-         (d/without-nils cfg)))
 
 (defmethod ig/init-key ::pool
-  [_ {:keys [migrations name read-only] :as cfg}]
+  [_ {:keys [migrations read-only? uri] :as cfg}]
-  (l/info :hint "initialize connection pool"
+  (if uri
-          :name (d/name name)
+    (let [pool (create-pool cfg)]
-          :uri (:uri cfg)
+      (l/info :hint "initialize connection pool"
-          :read-only read-only
+              :name (d/name (:name cfg))
-          :with-credentials (and (contains? cfg :username)
+              :uri uri
-                                 (contains? cfg :password))
+              :read-only read-only?
-          :min-size (:min-size cfg)
+              :with-credentials (and (contains? cfg :username)
-          :max-size (:max-size cfg))
+                                     (contains? cfg :password))
+              :min-size (:min-size cfg)
+              :max-size (:max-size cfg))
+      (when-not read-only?
+        (some->> (seq migrations) (apply-migrations! pool)))
+      pool)
 
-  (let [pool (create-pool cfg)]
+    (do
-    (when-not read-only
+      (l/warn :hint "unable to initialize pool, missing url"
-      (some->> (seq migrations) (apply-migrations! pool)))
+              :name (d/name (:name cfg))
-    pool))
+              :read-only read-only?)
+      nil)))
 
 (defmethod ig/halt-key! ::pool
   [_ pool]
-  (.close ^HikariDataSource pool))
+  (when pool
+    (.close ^HikariDataSource pool)))
 
 (defn- apply-migrations!
   [pool migrations]
@@ -126,7 +138,7 @@
       (.setJdbcUrl           (str "jdbc:" uri))
       (.setPoolName          (d/name (:name cfg)))
       (.setAutoCommit true)
-      (.setReadOnly          (:read-only cfg))
+      (.setReadOnly          (:read-only? cfg))
       (.setConnectionTimeout (:connection-timeout cfg))
       (.setValidationTimeout (:validation-timeout cfg))
       (.setIdleTimeout       (:idle-timeout cfg))
@@ -213,7 +225,7 @@
   [& args]
   `(jdbc/with-transaction ~@args))
 
-(defn ^Connection open
+(defn open
   [pool]
   (jdbc/get-connection pool))
 

backend/src/app/http.clj

@@ -9,7 +9,6 @@
    [app.common.data :as d]
    [app.common.logging :as l]
    [app.common.transit :as t]
-   [app.http.doc :as doc]
    [app.http.errors :as errors]
    [app.http.middleware :as middleware]
    [app.metrics :as mtx]
@@ -67,8 +66,10 @@
                  :xnio/worker-threads (:worker-threads cfg)
                  :xnio/dispatch (:executor cfg)
                  :ring/async true}
+
         handler (if (some? router)
                   (wrap-router router)
+
                   handler)
         server  (yt/server handler (d/without-nils options))]
     (assoc cfg :server (yt/start! server))))
@@ -113,23 +114,35 @@
 ;; HTTP ROUTER
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(s/def ::rpc map?)
 (s/def ::oauth map?)
 (s/def ::storage map?)
 (s/def ::assets map?)
 (s/def ::feedback fn?)
 (s/def ::ws fn?)
 (s/def ::audit-handler fn?)
-(s/def ::debug map?)
 (s/def ::awsns-handler fn?)
 (s/def ::session map?)
+(s/def ::rpc-routes (s/nilable vector?))
+(s/def ::debug-routes (s/nilable vector?))
+(s/def ::oidc-routes (s/nilable vector?))
+(s/def ::doc-routes (s/nilable vector?))
 
 (defmethod ig/pre-init-spec ::router [_]
-  (s/keys :req-un [::rpc ::mtx/metrics ::ws ::oauth ::storage ::assets
+  (s/keys :req-un [::mtx/metrics
-                   ::session ::feedback ::awsns-handler ::debug ::audit-handler]))
+                   ::ws
+                   ::storage
+                   ::assets
+                   ::session
+                   ::feedback
+                   ::awsns-handler
+                   ::debug-routes
+                   ::oidc-routes
+                   ::audit-handler
+                   ::rpc-routes
+                   ::doc-routes]))
 
 (defmethod ig/init-key ::router
-  [_ {:keys [ws session rpc oauth metrics assets feedback debug] :as cfg}]
+  [_ {:keys [ws session metrics assets feedback] :as cfg}]
   (rr/router
    [["" {:middleware [[middleware/server-timing]
                       [middleware/format-response]
@@ -137,20 +150,14 @@
                       [middleware/parse-request]
                       [middleware/errors errors/handle]
                       [middleware/restrict-methods]]}
+
      ["/metrics" {:handler (:handler metrics)}]
      ["/assets" {:middleware [(:middleware session)]}
       ["/by-id/:id" {:handler (:objects-handler assets)}]
       ["/by-file-media-id/:id" {:handler (:file-objects-handler assets)}]
       ["/by-file-media-id/:id/thumbnail" {:handler (:file-thumbnails-handler assets)}]]
 
-     ["/dbg" {:middleware [(:middleware session)]}
+     (:debug-routes cfg)
-      ["" {:handler (:index debug)}]
-      ["/changelog" {:handler (:changelog debug)}]
-      ["/error-by-id/:id" {:handler (:retrieve-error debug)}]
-      ["/error/:id" {:handler (:retrieve-error debug)}]
-      ["/error" {:handler (:retrieve-error-list debug)}]
-      ["/file/data" {:handler (:file-data debug)}]
-      ["/file/changes" {:handler (:retrieve-file-changes debug)}]]
 
      ["/webhooks"
       ["/sns" {:handler (:awsns-handler cfg)
@@ -161,22 +168,12 @@
                            :allowed-methods #{:get}}]
 
      ["/api" {:middleware [[middleware/cors]
-                           (:middleware session)]}
+                           [(:middleware session)]]}
-      ["/health" {:handler (:health-check debug)}]
-      ["/_doc" {:handler (doc/handler rpc)
-                :allowed-methods #{:get}}]
-      ["/feedback" {:handler feedback
-                    :allowed-methods #{:post}}]
-
-      ["/auth/oauth/:provider" {:handler (:handler oauth)
-                                :allowed-methods #{:post}}]
-      ["/auth/oauth/:provider/callback" {:handler (:callback-handler oauth)
-                                         :allowed-methods #{:get}}]
-
       ["/audit/events" {:handler (:audit-handler cfg)
                         :allowed-methods #{:post}}]
+      ["/feedback" {:handler feedback
+                    :allowed-methods #{:post}}]
+      (:doc-routes cfg)
+      (:oidc-routes cfg)
+      (:rpc-routes cfg)]]]))
 
-      ["/rpc"
-       ["/query/:type" {:handler (:query-handler rpc)}]
-       ["/mutation/:type" {:handler (:mutation-handler rpc)
-                           :allowed-methods #{:post}}]]]]]))

backend/src/app/http/debug.clj

@@ -5,36 +5,39 @@
 ;; Copyright (c) UXBOX Labs SL
 
 (ns app.http.debug
+  (:refer-clojure :exclude [error-handler])
   (:require
-   [app.common.data :as d]
    [app.common.exceptions :as ex]
+   [app.common.pprint :as pp]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
-   [app.db.sql :as sql]
+   [app.http.middleware :as mw]
-   [app.rpc.mutations.files :as m.files]
+   [app.rpc.commands.binfile :as binf]
+   [app.rpc.mutations.files :refer [create-file]]
    [app.rpc.queries.profile :as profile]
    [app.util.blob :as blob]
+   [app.util.bytes :as bs]
    [app.util.template :as tmpl]
    [app.util.time :as dt]
    [app.worker :as wrk]
    [clojure.java.io :as io]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
-   [datoteka.core :as fs]
    [emoji.core :as emj]
-   [fipp.edn :as fpp]
    [integrant.core :as ig]
    [markdown.core :as md]
    [markdown.transformers :as mdt]
-   [promesa.core :as p]
-   [promesa.exec :as px]
    [yetti.request :as yrq]
    [yetti.response :as yrs]))
 
 ;; (selmer.parser/cache-off!)
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HELPERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (defn authorized?
   [pool {:keys [profile-id]}]
   (or (= "devenv" (cf/get :host))
@@ -42,7 +45,22 @@
             admins  (or (cf/get :admins) #{})]
         (contains? admins (:email profile)))))
 
-(defn index
+(defn prepare-response
+  [body]
+  (let [headers {"content-type" "application/transit+json"}]
+    (yrs/response :status 200 :body body :headers headers)))
+
+(defn prepare-download-response
+  [body filename]
+  (let [headers {"content-disposition" (str "attachment; filename=" filename)
+                 "content-type" "application/octet-stream"}]
+    (yrs/response :status 200 :body body :headers headers)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; INDEX
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn index-handler
   [{:keys [pool]} request]
   (when-not (authorized? pool request)
     (ex/raise :type :authentication
@@ -52,6 +70,9 @@
                 :body    (-> (io/resource "templates/debug.tmpl")
                              (tmpl/render {}))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; FILE CHANGES
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (def sql:retrieve-range-of-changes
   "select revn, changes from file_change where file_id=? and revn >= ? and revn <= ? order by revn")
@@ -59,28 +80,16 @@
 (def sql:retrieve-single-change
   "select revn, changes, data from file_change where file_id=? and revn = ?")
 
-(defn prepare-response
-  [{:keys [params] :as request} body filename]
-  (when-not body
-    (ex/raise :type :not-found
-              :code :enpty-data
-              :hint "empty response"))
-
-  (cond-> (yrs/response :status  200
-                        :body    body
-                        :headers {"content-type" "application/transit+json"})
-    (contains? params :download)
-    (update :headers assoc "content-disposition" (str "attachment; filename=" filename))))
-
 (defn- retrieve-file-data
-  [{:keys [pool]} {:keys [params] :as request}]
+  [{:keys [pool]} {:keys [params profile-id] :as request}]
   (when-not (authorized? pool request)
     (ex/raise :type :authentication
               :code :only-admins-allowed))
 
-  (let [file-id  (some-> (get-in request [:params :file-id]) uuid/uuid)
+  (let [file-id  (some-> params :file-id parse-uuid)
-        revn     (some-> (get-in request [:params :revn]) d/parse-integer)
+        revn     (some-> params :revn parse-long)
         filename (str file-id)]
+
     (when-not file-id
       (ex/raise :type :validation
                 :code :missing-arguments))
@@ -88,35 +97,63 @@
     (let [data (if (integer? revn)
                  (some-> (db/exec-one! pool [sql:retrieve-single-change file-id revn]) :data)
                  (some-> (db/get-by-id pool :file file-id) :data))]
-      (if (contains? params :download)
+
-        (-> (prepare-response request data filename)
+      (when-not data
-            (update :headers assoc "content-type" "application/octet-stream"))
+        (ex/raise :type :not-found
-        (prepare-response request (some-> data blob/decode) filename)))))
+                  :code :enpty-data
+                  :hint "empty response"))
+      (cond
+        (contains? params :download)
+        (prepare-download-response data filename)
+
+        (contains? params :clone)
+        (let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)
+              data       (some-> data blob/decode)]
+          (create-file pool {:id (uuid/next)
+                             :name (str "Cloned file: " filename)
+                             :project-id project-id
+                             :profile-id profile-id
+                             :data data})
+          (yrs/response 201 "OK CREATED"))
+
+        :else
+        (prepare-response (some-> data blob/decode))))))
+
+(defn- is-file-exists?
+  [pool id]
+  (let [sql "select exists (select 1 from file where id=?) as exists;"]
+    (-> (db/exec-one! pool [sql id]) :exists)))
 
 (defn- upload-file-data
   [{:keys [pool]} {:keys [profile-id params] :as request}]
   (let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)
-        data       (some-> params :file :path fs/slurp-bytes blob/decode)]
+        data       (some-> params :file :path bs/read-as-bytes blob/decode)]
 
     (if (and data project-id)
-      (let [fname (str "imported-file-" (dt/now))
+      (let [fname      (str "Imported file *: " (dt/now))
-            file-id (try
+            overwrite? (contains? params :overwrite?)
-                      (uuid/uuid (-> params :file :filename))
+            file-id    (or (and overwrite? (ex/ignoring (-> params :file :filename parse-uuid)))
-                      (catch Exception _ (uuid/next)))
+                           (uuid/next))]
-            file (db/exec-one! pool (sql/select :file {:id file-id}))]
+
-        (if file
+        (if (and overwrite? file-id
-          (db/update! pool :file
+                 (is-file-exists? pool file-id))
-                      {:data (blob/encode data)}
+          (do
-                      {:id file-id})
+            (db/update! pool :file
-          (m.files/create-file pool {:id file-id
+                        {:data (blob/encode data)}
-                                     :name fname
+                        {:id file-id})
-                                     :project-id project-id
+            (yrs/response 200 "OK UPDATED"))
-                                     :profile-id profile-id
+
-                                     :data data}))
+          (do
-        (yrs/response 200 "OK"))
+            (create-file pool {:id file-id
+                               :name fname
+                               :project-id project-id
+                               :profile-id profile-id
+                               :data data})
+            (yrs/response 201 "OK CREATED"))))
+
       (yrs/response 500 "ERROR"))))
 
-(defn file-data
+(defn file-data-handler
   [cfg request]
   (case (yrq/method request)
     :get (retrieve-file-data cfg request)
@@ -124,43 +161,47 @@
     (ex/raise :type :http
               :code :method-not-found)))
 
-(defn retrieve-file-changes
+(defn file-changes-handler
-  [{:keys [pool]} request]
+  [{:keys [pool]} {:keys [params] :as request}]
   (when-not (authorized? pool request)
     (ex/raise :type :authentication
               :code :only-admins-allowed))
 
-  (let [file-id  (some-> (get-in request [:params :id]) uuid/uuid)
+  (letfn [(retrieve-changes [file-id revn]
-        revn     (or (get-in request [:params :revn]) "latest")
+            (if (str/includes? revn ":")
-        filename (str file-id)]
+              (let [[start end] (->> (str/split revn #":")
+                                     (map str/trim)
+                                     (map parse-long))]
+                (some->> (db/exec! pool [sql:retrieve-range-of-changes file-id start end])
+                         (map :changes)
+                         (map blob/decode)
+                         (mapcat identity)
+                         (vec)))
 
-    (when (or (not file-id) (not revn))
+              (if-let [revn (parse-long revn)]
-      (ex/raise :type :validation
+                (let [item (db/exec-one! pool [sql:retrieve-single-change file-id revn])]
-                :code :invalid-arguments
+                  (some-> item :changes blob/decode vec))
-                :hint "missing arguments"))
+                (ex/raise :type :validation :code :invalid-arguments))))]
 
-    (cond
+    (let [file-id  (some-> params :id parse-uuid)
-      (d/num-string? revn)
+          revn     (or (some-> params :revn parse-long) "latest")
-      (let [item (db/exec-one! pool [sql:retrieve-single-change file-id (d/parse-integer revn)])]
+          filename (str file-id)]
-        (prepare-response request (some-> item :changes blob/decode vec) filename))
 
-      (str/includes? revn ":")
+      (when (or (not file-id) (not revn))
-      (let [[start end] (->> (str/split revn #":")
+        (ex/raise :type :validation
-                             (map str/trim)
+                  :code :invalid-arguments
-                             (map d/parse-integer))
+                  :hint "missing arguments"))
-            items       (db/exec! pool [sql:retrieve-range-of-changes file-id start end])]
-        (prepare-response request
-                          (some->> items
-                                   (map :changes)
-                                   (map blob/decode)
-                                   (mapcat identity)
-                                   (vec))
-                          filename))
-      :else
-      (ex/raise :type :validation :code :invalid-arguments))))
 
+      (let [data (retrieve-changes file-id revn)]
+        (if (contains? params :download)
+          (prepare-download-response data filename)
+          (prepare-response data))))))
 
-(defn retrieve-error
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ERROR BROWSER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn error-handler
   [{:keys [pool]} request]
   (letfn [(parse-id [request]
             (let [id (get-in request [:path-params :id])
@@ -176,9 +217,8 @@
             (let [context (dissoc report
                                   :trace :cause :params :data :spec-problems
                                   :spec-explain :spec-value :error :explain :hint)
-                  params  {:context (with-out-str
+                  params  {:context       (pp/pprint-str context :width 200)
-                                      (fpp/pprint context {:width 200}))
+                           :hint          (:hint report)
-                           :hint    (:hint report)
                            :spec-explain  (:spec-explain report)
                            :spec-problems (:spec-problems report)
                            :spec-value    (:spec-value report)
@@ -206,7 +246,7 @@
 (def sql:error-reports
   "select id, created_at from server_error_report order by created_at desc limit 100")
 
-(defn retrieve-error-list
+(defn error-list-handler
   [{:keys [pool]} request]
   (when-not (authorized? pool request)
     (ex/raise :type :authentication
@@ -219,14 +259,94 @@
                   :headers {"content-type" "text/html; charset=utf-8"
                             "x-robots-tag" "noindex"})))
 
-(defn health-check
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; EXPORT/IMPORT
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn export-handler
+  [{:keys [pool] :as cfg} {:keys [params profile-id] :as request}]
+
+  (let [file-ids (->> (:file-ids params)
+                      (remove empty?)
+                      (mapv parse-uuid))
+        libs?    (contains? params :includelibs)
+        clone?   (contains? params :clone)
+        embed?   (contains? params :embedassets)]
+
+    (when-not (seq file-ids)
+      (ex/raise :type :validation
+                :code :missing-arguments))
+
+    (let [path (-> cfg
+                   (assoc ::binf/file-ids file-ids)
+                   (assoc ::binf/embed-assets? embed?)
+                   (assoc ::binf/include-libraries? libs?)
+                   (binf/export!))]
+      (if clone?
+        (let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)]
+          (binf/import!
+           (assoc cfg
+                  ::binf/input path
+                  ::binf/overwrite? false
+                  ::binf/ignore-index-errors? true
+                  ::binf/profile-id profile-id
+                  ::binf/project-id project-id))
+
+          (yrs/response
+           :status  200
+           :headers {"content-type" "text/plain"}
+           :body    "OK CLONED"))
+
+        (yrs/response
+         :status  200
+         :headers {"content-type" "application/octet-stream"
+                   "content-disposition" (str "attachmen; filename=" (first file-ids) ".penpot")}
+         :body    (io/input-stream path))))))
+
+
+(defn import-handler
+  [{:keys [pool] :as cfg} {:keys [params profile-id] :as request}]
+  (when-not (contains? params :file)
+    (ex/raise :type :validation
+              :code :missing-upload-file
+              :hint "missing upload file"))
+
+  (let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)
+        overwrite? (contains? params :overwrite)
+        migrate? (contains? params :migrate)
+        ignore-index-errors? (contains? params :ignore-index-errors)]
+
+    (when-not project-id
+      (ex/raise :type :validation
+                :code :missing-project
+                :hint "project not found"))
+
+    (binf/import!
+     (assoc cfg
+            ::binf/input (-> params :file :path)
+            ::binf/overwrite? overwrite?
+            ::binf/migrate? migrate?
+            ::binf/ignore-index-errors? ignore-index-errors?
+            ::binf/profile-id profile-id
+            ::binf/project-id project-id))
+
+    (yrs/response
+     :status  200
+     :headers {"content-type" "text/plain"}
+     :body    "OK")))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; OTHER SMALL VIEWS/HANDLERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn health-handler
   "Mainly a task that performs a health check."
   [{:keys [pool]} _]
   (db/with-atomic [conn pool]
     (db/exec-one! conn ["select count(*) as count from server_prop;"])
     (yrs/response 200 "OK")))
 
-(defn changelog
+(defn changelog-handler
   [_ _]
   (letfn [(transform-emoji [text state]
             [(emj/emojify text) state])
@@ -238,22 +358,39 @@
                     :body (-> clog slurp md->html))
       (yrs/response :status 404 :body "NOT FOUND"))))
 
-(defn- wrap-async
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  [{:keys [executor] :as cfg} f]
+;; INIT
-  (fn [request respond raise]
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-    (-> (px/submit! executor #(f cfg request))
-        (p/then respond)
-        (p/catch raise))))
 
-(defmethod ig/pre-init-spec ::handlers [_]
+(def with-authorization
-  (s/keys :req-un [::db/pool ::wrk/executor]))
+  {:compile
+   (fn [& _]
+     (fn [handler pool]
+       (fn [request respond raise]
+         (if (authorized? pool request)
+           (handler request respond raise)
+           (raise (ex/error :type :authentication
+                            :code :only-admins-allowed))))))})
 
-(defmethod ig/init-key ::handlers
+
-  [_ cfg]
+(s/def ::session map?)
-  {:index (wrap-async cfg index)
+
-   :health-check (wrap-async cfg health-check)
+(defmethod ig/pre-init-spec ::routes [_]
-   :retrieve-file-changes (wrap-async cfg retrieve-file-changes)
+  (s/keys :req-un [::db/pool ::wrk/executor ::session]))
-   :retrieve-error (wrap-async cfg retrieve-error)
+
-   :retrieve-error-list (wrap-async cfg retrieve-error-list)
+(defmethod ig/init-key ::routes
-   :file-data (wrap-async cfg file-data)
+  [_ {:keys [session pool executor] :as cfg}]
-   :changelog (wrap-async cfg changelog)})
+  ["/dbg" {:middleware [[(:middleware session)]
+                        [with-authorization pool]
+                        [mw/with-promise-async executor]
+                        [mw/with-config cfg]]}
+   ["" {:handler index-handler}]
+   ["/health" {:handler health-handler}]
+   ["/changelog" {:handler changelog-handler}]
+   ;; ["/error-by-id/:id" {:handler error-handler}]
+   ["/error/:id" {:handler error-handler}]
+   ["/error" {:handler error-list-handler}]
+   ["/file/export" {:handler export-handler}]
+   ["/file/import" {:handler import-handler}]
+   ["/file/data" {:handler file-data-handler}]
+   ["/file/changes" {:handler file-changes-handler}]])

backend/src/app/http/doc.clj

@@ -9,14 +9,17 @@
   (:require
    [app.common.data :as d]
    [app.config :as cf]
+   [app.rpc :as-alias rpc]
    [app.util.services :as sv]
    [app.util.template :as tmpl]
    [clojure.java.io :as io]
    [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [integrant.core :as ig]
    [pretty-spec.core :as ps]
    [yetti.response :as yrs]))
 
-(defn get-spec-str
+(defn- get-spec-str
   [k]
   (with-out-str
     (ps/pprint (s/form k)
@@ -24,31 +27,47 @@
                              "clojure.core.specs.alpha" "score"
                              "clojure.core" nil}})))
 
-(defn prepare-context
+(defn- prepare-context
-  [rpc]
+  [methods]
   (letfn [(gen-doc [type [name f]]
             (let [mdata (meta f)]
-              ;; (prn name mdata)
               {:type (d/name type)
                :name (d/name name)
+               :module (-> (:ns mdata) (str/split ".") last)
                :auth (:auth mdata true)
                :docs (::sv/docs mdata)
                :spec (get-spec-str (::sv/spec mdata))}))]
-    {:query-methods
-     (into []
-           (map (partial gen-doc :query))
-           (->> rpc :methods :query (sort-by first)))
-     :mutation-methods
-     (into []
-           (map (partial gen-doc :mutation))
-           (->> rpc :methods :mutation (sort-by first)))}))
 
-(defn handler
+    {:command-methods
-  [rpc]
+     (->> (:commands methods)
-  (let [context (prepare-context rpc)]
+          (map (partial gen-doc :command))
-    (if (contains? cf/flags :backend-api-doc)
+          (sort-by (juxt :module :name)))
+
+     :query-methods
+     (->> (:queries methods)
+          (map (partial gen-doc :query))
+          (sort-by (juxt :module :name)))
+     :mutation-methods
+     (->> (:mutations methods)
+          (map (partial gen-doc :query))
+          (sort-by (juxt :module :name)))}))
+
+(defn- handler
+  [methods]
+  (if (contains? cf/flags :backend-api-doc)
+    (let [context (prepare-context methods)]
       (fn [_ respond _]
         (respond (yrs/response 200 (-> (io/resource "api-doc.tmpl")
-                                       (tmpl/render context)))))
+                                       (tmpl/render context))))))
-      (fn [_ respond _]
+    (fn [_ respond _]
-        (respond (yrs/response 404))))))
+      (respond (yrs/response 404)))))
+
+
+(defmethod ig/pre-init-spec ::routes [_]
+  (s/keys :req-un [::rpc/methods]))
+
+(defmethod ig/init-key ::routes
+  [_ {:keys [methods] :as cfg}]
+  ["/_doc" {:handler (handler methods)
+            :allowed-methods #{:get}}])
+

backend/src/app/http/errors.clj

@@ -71,7 +71,7 @@
   [error request]
   (let [edata (ex-data error)
         explain (us/pretty-explain edata)]
-    (l/error ::l/raw (ex-message error)
+    (l/error ::l/raw (str (ex-message error) "\n" explain)
              ::l/context (get-context request)
              :cause error)
     (yrs/response :status 500
@@ -143,13 +143,11 @@
 
 (defn handle
   [cause request]
-
   (cond
     (or (instance? java.util.concurrent.CompletionException cause)
         (instance? java.util.concurrent.ExecutionException cause))
     (handle-exception (.getCause ^Throwable cause) request)
 
-
     (ex/wrapped? cause)
     (let [context (meta cause)
           cause   (deref cause)]

backend/src/app/http/middleware.clj

@@ -12,6 +12,8 @@
    [app.config :as cf]
    [app.util.json :as json]
    [cuerdas.core :as str]
+   [promesa.core :as p]
+   [promesa.exec :as px]
    [yetti.adapter :as yt]
    [yetti.middleware :as ymw]
    [yetti.request :as yrq]
@@ -192,3 +194,21 @@
 (def restrict-methods
   {:name ::restrict-methods
    :compile compile-restrict-methods})
+
+(def with-promise-async
+  {:compile
+   (fn [& _]
+     (fn [handler executor]
+       (fn [request respond raise]
+         (-> (px/submit! executor #(handler request))
+             (p/bind p/wrap)
+             (p/then respond)
+             (p/catch raise)))))})
+
+(def with-config
+  {:compile
+   (fn [& _]
+     (fn [handler config]
+       (fn
+         ([request] (handler config request))
+         ([request respond raise] (handler config request respond raise)))))})

backend/src/app/http/session.clj

@@ -162,21 +162,22 @@
 
 (defn- make-middleware
   [{:keys [::events-ch store] :as cfg}]
-  {:name :session-middleware
+  {:name :session
-   :wrap (fn [handler]
+   :compile (fn [& _]
-           (fn [request respond raise]
+              (fn [handler]
-             (try
+                (fn [request respond raise]
-               (-> (retrieve-session store request)
+                  (try
-                   (p/then' #(merge request %))
+                    (-> (retrieve-session store request)
-                   (p/finally (fn [request cause]
+                        (p/then' #(merge request %))
-                                (if cause
+                        (p/finally (fn [request cause]
-                                  (raise cause)
+                                     (if cause
-                                  (do
+                                       (raise cause)
+                                       (do
                                     (when-let [session-id (:session-id request)]
                                       (a/offer! events-ch session-id))
                                     (handler request respond raise))))))
-               (catch Throwable cause
+                    (catch Throwable cause
-                 (raise cause)))))})
+                      (raise cause))))))})
 
 
 ;; --- STATE INIT: SESSION

backend/src/app/http/websocket.clj

@@ -9,28 +9,103 @@
   (:require
    [app.common.exceptions :as ex]
    [app.common.logging :as l]
+   [app.common.pprint :as pp]
    [app.common.spec :as us]
    [app.db :as db]
    [app.metrics :as mtx]
+   [app.util.time :as dt]
    [app.util.websocket :as ws]
    [clojure.core.async :as a]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]
    [yetti.websocket :as yws]))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; WEBSOCKET HOOKS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def state (atom {}))
+
+(defn- on-connect
+  [{:keys [metrics]} wsp]
+  (let [created-at (dt/now)]
+    (swap! state assoc (::ws/id @wsp) wsp)
+    (mtx/run! metrics {:id :websocket-active-connections :inc 1})
+    (fn []
+      (swap! state dissoc (::ws/id @wsp))
+      (mtx/run! metrics {:id :websocket-active-connections :dec 1})
+      (mtx/run! metrics {:id :websocket-session-timing
+                         :val (/ (inst-ms (dt/diff created-at (dt/now))) 1000.0)}))))
+
+(defn- on-rcv-message
+  [{:keys [metrics]} _ message]
+  (mtx/run! metrics {:id :websocket-messages-total :labels ["recv"] :inc 1})
+  message)
+
+(defn- on-snd-message
+  [{:keys [metrics]} _ message]
+  (mtx/run! metrics {:id :websocket-messages-total :labels ["send"] :inc 1})
+  message)
+
+;; REPL HELPERS
+
+(defn repl-get-connections-for-file
+  [file-id]
+  (->> (vals @state)
+       (filter #(= file-id (-> % deref ::file-subscription :file-id)))
+       (map deref)
+       (map ::ws/id)))
+
+(defn repl-get-connections-for-team
+  [team-id]
+  (->> (vals @state)
+       (filter #(= team-id (-> % deref ::team-subscription :team-id)))
+       (map deref)
+       (map ::ws/id)))
+
+(defn repl-close-connection
+  [id]
+  (when-let [wsp (get @state id)]
+    (a/>!! (::ws/close-ch @wsp) [8899 "closed from server"])
+    (a/close! (::ws/close-ch @wsp))))
+
+(defn repl-get-connection-info
+  [id]
+  (when-let [wsp (get @state id)]
+    {:id id
+     :created-at (dt/instant id)
+     :profile-id (::profile-id @wsp)
+     :session-id (::session-id @wsp)
+     :user-agent (::ws/user-agent @wsp)
+     :ip-addr    (::ws/remote-addr @wsp)
+     :last-activity-at (::ws/last-activity-at @wsp)
+     :http-session-id  (::ws/http-session-id @wsp)
+     :subscribed-file  (-> wsp deref ::file-subscription :file-id)
+     :subscribed-team  (-> wsp deref ::team-subscription :team-id)}))
+
+(defn repl-print-connection-info
+  [id]
+  (some-> id repl-get-connection-info pp/pprint))
+
+(defn repl-print-connection-info-for-file
+  [file-id]
+  (some->> (repl-get-connections-for-file file-id)
+           (map repl-get-connection-info)
+           (pp/pprint)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; WEBSOCKET HANDLER
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defmulti handle-message
-  (fn [_ message]
+  (fn [_ _ message]
     (:type message)))
 
 (defmethod handle-message :connect
-  [wsp _]
+  [cfg wsp _]
-  (l/trace :fn "handle-message" :event :connect)
 
-  (let [msgbus-fn  (:msgbus @wsp)
+  (let [msgbus-fn  (:msgbus cfg)
+        conn-id    (::ws/id @wsp)
         profile-id (::profile-id @wsp)
         session-id (::session-id @wsp)
         output-ch  (::ws/output-ch @wsp)
@@ -38,94 +113,122 @@
         xform      (remove #(= (:session-id %) session-id))
         channel    (a/chan (a/dropping-buffer 16) xform)]
 
-    (swap! wsp assoc ::profile-subs-channel channel)
+    (l/trace :fn "handle-message" :event :connect :conn-id conn-id)
+
+    ;; Subscribe to the profile channel and forward all messages to
+    ;; websocket output channel (send them to the client).
+    (swap! wsp assoc ::profile-subscription channel)
     (a/pipe channel output-ch false)
     (msgbus-fn :cmd :sub :topic profile-id :chan channel)))
 
 (defmethod handle-message :disconnect
-  [wsp _]
+  [cfg wsp _]
-  (l/trace :fn "handle-message" :event :disconnect)
+  (let [msgbus-fn  (:msgbus cfg)
-  (a/go
+        conn-id    (::ws/id @wsp)
-    (let [msgbus-fn  (:msgbus @wsp)
+        profile-id (::profile-id @wsp)
-          profile-id (::profile-id @wsp)
+        session-id (::session-id @wsp)
-          session-id (::session-id @wsp)
+        profile-ch (::profile-subscription @wsp)
-          profile-ch (::profile-subs-channel @wsp)
+        fsub       (::file-subscription @wsp)
-          subs       (::subscriptions @wsp)]
+        tsub       (::team-subscription @wsp)
 
+        message    {:type :disconnect
+                    :subs-id profile-id
+                    :profile-id profile-id
+                    :session-id session-id}]
+
+    (l/trace :fn "handle-message"
+             :event :disconnect
+             :conn-id conn-id)
+
+    (a/go
       ;; Close the main profile subscription
       (a/close! profile-ch)
       (a/<! (msgbus-fn :cmd :purge :chans [profile-ch]))
 
-      ;; Close all other active subscrption on this websocket context.
+      ;; Close tram subscription if exists
-      (doseq [{:keys [channel topic]} (map second subs)]
+      (when-let [channel (:channel tsub)]
         (a/close! channel)
-        (a/<! (msgbus-fn :cmd :pub :topic topic
+        (a/<! (msgbus-fn :cmd :purge :chans [channel])))
-                         :message {:type :disconnect
+
-                                   :profile-id profile-id
+      (when-let [{:keys [topic channel]} fsub]
-                                   :session-id session-id}))
+        (a/close! channel)
-        (a/<! (msgbus-fn :cmd :purge :chans [channel]))))))
+        (a/<! (msgbus-fn :cmd :purge :chans [channel]))
+        (a/<! (msgbus-fn :cmd :pub :topic topic :message message))))))
 
 (defmethod handle-message :subscribe-team
-  [wsp {:keys [team-id] :as params}]
+  [cfg wsp {:keys [team-id] :as params}]
-  (l/trace :fn "handle-message" :event :subscribe-team :team-id team-id)
+  (let [msgbus-fn  (:msgbus cfg)
-
+        conn-id    (::ws/id @wsp)
-  (let [msgbus-fn  (:msgbus @wsp)
         session-id (::session-id @wsp)
         output-ch  (::ws/output-ch @wsp)
-        subs       (get-in @wsp [::subscriptions team-id])
+        prev-subs  (get @wsp ::team-subscription)
         xform      (comp
                     (remove #(= (:session-id %) session-id))
-                    (map #(assoc % :subs-id team-id)))]
+                    (map #(assoc % :subs-id team-id)))
-
-    (a/go
-      (when (not= (:team-id subs) team-id)
-        ;; if it exists we just need to close that
-        (when-let [channel (:channel subs)]
-          (a/close! channel)
-          (a/<! (msgbus-fn :cmd :purge :chans [channel])))
-
-
-        (let [channel (a/chan (a/dropping-buffer 64) xform)]
-          ;; Message forwarding
-          (a/pipe channel output-ch false)
-
-          (let [state {:team-id team-id :channel channel :topic team-id}]
-            (swap! wsp update ::subscriptions assoc team-id state))
-
-          (a/<! (msgbus-fn :cmd :sub :topic team-id :chan channel)))))))
-
-(defmethod handle-message :subscribe-file
-  [wsp {:keys [subs-id file-id] :as params}]
-  (l/trace :fn "handle-message" :event :subscribe-file :subs-id subs-id :file-id file-id)
-  (let [msgbus-fn  (:msgbus @wsp)
-        profile-id (::profile-id @wsp)
-        session-id (::session-id @wsp)
-        output-ch  (::ws/output-ch @wsp)
-
-        xform      (comp
-                    (remove #(= (:session-id %) session-id))
-                    (map #(assoc % :subs-id subs-id)))
 
         channel    (a/chan (a/dropping-buffer 64) xform)]
 
-    ;; Message forwarding
+    (l/trace :fn "handle-message"
-    (a/go-loop []
+             :event :subscribe-team
-      (when-let [{:keys [type] :as message} (a/<! channel)]
+             :team-id team-id
-        (when (or (= :join-file type)
+             :conn-id conn-id)
-                  (= :leave-file type)
+
-                  (= :disconnect type))
+    (a/pipe channel output-ch false)
-          (let [message {:type :presence
+
-                         :file-id file-id
+    (let [state {:team-id team-id :channel channel :topic team-id}]
-                         :session-id session-id
+      (swap! wsp assoc ::team-subscription state))
-                         :profile-id profile-id}]
+
-            (a/<! (msgbus-fn :cmd :pub
+    (a/go
-                             :topic file-id
+      ;; Close previous subscription if exists
-                             :message message))))
+      (when-let [channel (:channel prev-subs)]
-        (a/>! output-ch message)
+        (a/close! channel)
-        (recur)))
+        (a/<! (msgbus-fn :cmd :purge :chans [channel]))))
+
+    (a/go
+      (a/<! (msgbus-fn :cmd :sub :topic team-id :chan channel)))))
+
+(defmethod handle-message :subscribe-file
+  [cfg wsp {:keys [file-id] :as params}]
+  (let [msgbus-fn  (:msgbus cfg)
+        conn-id    (::ws/id @wsp)
+        profile-id (::profile-id @wsp)
+        session-id (::session-id @wsp)
+        output-ch  (::ws/output-ch @wsp)
+        prev-subs  (::file-subscription @wsp)
+        xform      (comp (remove #(= (:session-id %) session-id))
+                         (map #(assoc % :subs-id file-id)))
+        channel    (a/chan (a/dropping-buffer 64) xform)]
+
+    (l/trace :fn "handle-message"
+             :event :subscribe-file
+             :file-id file-id
+             :conn-id conn-id)
 
     (let [state {:file-id file-id :channel channel :topic file-id}]
-      (swap! wsp update ::subscriptions assoc subs-id state))
+      (swap! wsp assoc ::file-subscription state))
+
+    (a/go
+      ;; Close previous subscription if exists
+      (when-let [channel (:channel prev-subs)]
+        (a/close! channel)
+        (a/<! (msgbus-fn :cmd :purge :chans [channel]))))
+
+    ;; Message forwarding
+    (a/go
+      (loop []
+        (when-let [{:keys [type] :as message} (a/<! channel)]
+          (when (or (= :join-file type)
+                    (= :leave-file type)
+                    (= :disconnect type))
+            (let [message {:type :presence
+                           :file-id file-id
+                           :session-id session-id
+                           :profile-id profile-id}]
+              (a/<! (msgbus-fn :cmd :pub
+                               :topic file-id
+                               :message message))))
+          (a/>! output-ch message)
+          (recur))))
 
     (a/go
       ;; Subscribe to file topic
@@ -134,6 +237,7 @@
       ;; Notifify the rest of participants of the new connection.
       (let [message {:type :join-file
                      :file-id file-id
+                     :subs-id file-id
                      :session-id session-id
                      :profile-id profile-id}]
         (a/<! (msgbus-fn :cmd :pub
@@ -141,49 +245,59 @@
                          :message message))))))
 
 (defmethod handle-message :unsubscribe-file
-  [wsp {:keys [subs-id] :as params}]
+  [cfg wsp {:keys [file-id] :as params}]
-  (l/trace :fn "handle-message" :event :unsubscribe-file :subs-id subs-id)
+  (let [msgbus-fn  (:msgbus cfg)
-  (let [msgbus-fn  (:msgbus @wsp)
+        conn-id    (::ws/id @wsp)
         session-id (::session-id @wsp)
-        profile-id (::profile-id @wsp)]
+        profile-id (::profile-id @wsp)
+        subs       (::file-subscription @wsp)
+
+        message    {:type :leave-file
+                    :file-id file-id
+                    :session-id session-id
+                    :profile-id profile-id}]
+
+    (l/trace :fn "handle-message"
+             :event :unsubscribe-file
+             :file-id file-id
+             :conn-id conn-id)
+
     (a/go
-      (when-let [{:keys [file-id channel]} (get-in @wsp [::subscriptions subs-id])]
+      (when (= (:file-id subs) file-id)
-        (let [message {:type :leave-file
+        (let [channel (:channel subs)]
-                       :file-id file-id
-                       :session-id session-id
-                       :profile-id profile-id}]
           (a/close! channel)
-          (a/<! (msgbus-fn :cmd :pub :topic file-id :message message))
+          (a/<! (msgbus-fn :cmd :purge :chans [channel]))
-          (a/<! (msgbus-fn :cmd :purge :chans [channel])))))))
+          (a/<! (msgbus-fn :cmd :pub :topic file-id :message message)))))))
 
 (defmethod handle-message :keepalive
-  [_ _]
+  [_ _ _]
   (l/trace :fn "handle-message" :event :keepalive)
   (a/go :nothing))
 
 (defmethod handle-message :pointer-update
-  [wsp {:keys [subs-id] :as message}]
+  [cfg wsp {:keys [file-id] :as message}]
-  (a/go
+  (let [msgbus-fn  (:msgbus cfg)
-    ;; Only allow receive pointer updates when active subscription
+        profile-id (::profile-id @wsp)
-    (when-let [{:keys [topic]} (get-in @wsp [::subscriptions subs-id])]
+        session-id (::session-id @wsp)
-      (let [msgbus-fn  (:msgbus @wsp)
+        subs       (::file-subscription @wsp)
-            profile-id (::profile-id @wsp)
+        message    (-> message
-            session-id (::session-id @wsp)
+                       (assoc :subs-id file-id)
-            message    (-> message
+                       (assoc :profile-id profile-id)
-                           (dissoc :subs-id)
+                       (assoc :session-id session-id))]
-                           (assoc :profile-id profile-id)
+    (a/go
-                           (assoc :session-id session-id))]
+      ;; Only allow receive pointer updates when active subscription
-
+      (when subs
         (a/<! (msgbus-fn :cmd :pub
-                         :topic topic
+                         :topic file-id
                          :message message))))))
 
 (defmethod handle-message :default
-  [_ message]
+  [_ wsp message]
-  (a/go
+  (let [conn-id (::ws/id @wsp)]
-    (l/log :level :warn
+    (l/warn :hint "received unexpected message"
-           :msg "received unexpected message"
+            :message message
-           :message message)))
+            :conn-id conn-id)
+    (a/go :none)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; HTTP HANDLER
@@ -201,12 +315,7 @@
 (defmethod ig/init-key ::handler
   [_ cfg]
   (fn [{:keys [profile-id params] :as req} respond raise]
-    (let [{:keys [session-id]} (us/conform ::handler-params params)
+    (let [{:keys [session-id]} (us/conform ::handler-params params)]
-          cfg    (-> cfg
-                     (assoc ::profile-id profile-id)
-                     (assoc ::session-id session-id))]
-
-      (l/trace :hint "http request to websocket" :profile-id profile-id :session-id session-id)
       (cond
         (not profile-id)
         (raise (ex/error :type :authentication
@@ -218,6 +327,15 @@
                          :hint "this endpoint only accepts websocket connections"))
 
         :else
-        (->> (ws/handler handle-message cfg)
+        (do
-             (yws/upgrade req)
+          (l/trace :hint "websocket request" :profile-id profile-id :session-id session-id)
-             (respond))))))
+
+          (->> (ws/handler
+                ::ws/on-rcv-message (partial on-rcv-message cfg)
+                ::ws/on-snd-message (partial on-snd-message cfg)
+                ::ws/on-connect (partial on-connect cfg)
+                ::ws/handler (partial handle-message cfg)
+                ::profile-id profile-id
+                ::session-id session-id)
+               (yws/upgrade req)
+               (respond)))))))

backend/src/app/loggers/audit.clj

@@ -32,7 +32,7 @@
   [request]
   (or (some-> (yrq/get-header request "x-forwarded-for") (str/split ",") first)
       (yrq/get-header request "x-real-ip")
-      (yrq/remote-addr request)))
+      (some-> (yrq/remote-addr request) str)))
 
 (defn extract-utm-params
   "Extracts additional data from params and namespace them under
@@ -257,12 +257,16 @@
         (ex/raise :type :internal
                   :code :task-not-configured
                   :hint "archive task not configured, missing uri"))
+
       (when enabled
-        (loop []
+        (loop [total 0]
-          (let [res (archive-events cfg)]
+          (let [n (archive-events cfg)]
-            (when (= res :continue)
+            (if n
-              (aa/thread-sleep 200)
+              (do
-              (recur))))))))
+                (aa/thread-sleep 200)
+                (recur (+ total n)))
+              (when (pos? total)
+                (l/trace :hint "events chunk archived" :num total)))))))))
 
 (def sql:retrieve-batch-of-audit-log
   "select * from audit_log
@@ -332,7 +336,7 @@
           (l/debug :action "archive-events" :uri uri :events (count events))
           (when (send events)
             (mark-as-archived conn rows)
-            :continue))))))
+            (count events)))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; GC Task

backend/src/app/main.clj

@@ -6,6 +6,7 @@
 
 (ns app.main
   (:require
+   [app.auth.oidc]
    [app.common.logging :as l]
    [app.config :as cf]
    [app.util.time :as dt]
@@ -71,6 +72,10 @@
    :app.tokens/tokens
    {:keys (ig/ref :app.setup/keys)}
 
+   :app.storage.tmp/cleaner
+   {:executor (ig/ref [::worker :app.worker/executor])
+    :scheduler (ig/ref :app.worker/scheduler)}
+
    :app.storage/gc-deleted-task
    {:pool     (ig/ref :app.db/pool)
     :storage  (ig/ref :app.storage/storage)
@@ -86,6 +91,9 @@
    :app.http/session
    {:store (ig/ref :app.http.session/store)}
 
+   :app.http.doc/routes
+   {:methods (ig/ref :app.rpc/methods)}
+
    :app.http.session/store
    {:pool     (ig/ref :app.db/pool)
     :tokens   (ig/ref :app.tokens/tokens)
@@ -119,25 +127,88 @@
     :max-body-size           (cf/get :http-server-max-body-size)
     :max-multipart-body-size (cf/get :http-server-max-multipart-body-size)}
 
+   :app.auth.ldap/provider
+   {:host           (cf/get :ldap-host)
+    :port           (cf/get :ldap-port)
+    :ssl            (cf/get :ldap-ssl)
+    :tls            (cf/get :ldap-starttls)
+    :query          (cf/get :ldap-user-query)
+    :attrs-email    (cf/get :ldap-attrs-email)
+    :attrs-fullname (cf/get :ldap-attrs-fullname)
+    :attrs-username (cf/get :ldap-attrs-username)
+    :base-dn        (cf/get :ldap-base-dn)
+    :bind-dn        (cf/get :ldap-bind-dn)
+    :bind-password  (cf/get :ldap-bind-password)
+    :enabled?       (contains? cf/flags :login-with-ldap)}
+
+   :app.auth.oidc/google-provider
+   {:enabled?      (contains? cf/flags :login-with-google)
+    :client-id     (cf/get :google-client-id)
+    :client-secret (cf/get :google-client-secret)}
+
+   :app.auth.oidc/github-provider
+   {:enabled?      (contains? cf/flags :login-with-github)
+    :http-client   (ig/ref :app.http/client)
+    :client-id     (cf/get :github-client-id)
+    :client-secret (cf/get :github-client-secret)}
+
+   :app.auth.oidc/gitlab-provider
+   {:enabled?      (contains? cf/flags :login-with-gitlab)
+    :base-uri      (cf/get :gitlab-base-uri "https://gitlab.com")
+    :client-id     (cf/get :gitlab-client-id)
+    :client-secret (cf/get :gitlab-client-secret)}
+
+   :app.auth.oidc/generic-provider
+   {:enabled?      (contains? cf/flags :login-with-oidc)
+    :http-client   (ig/ref :app.http/client)
+
+    :client-id     (cf/get :oidc-client-id)
+    :client-secret (cf/get :oidc-client-secret)
+
+    :base-uri      (cf/get :oidc-base-uri)
+
+    :token-uri     (cf/get :oidc-token-uri)
+    :auth-uri      (cf/get :oidc-auth-uri)
+    :user-uri      (cf/get :oidc-user-uri)
+
+    :scopes        (cf/get :oidc-scopes)
+    :roles-attr    (cf/get :oidc-roles-attr)
+    :roles         (cf/get :oidc-roles)}
+
+   :app.auth.oidc/routes
+   {:providers   {:google (ig/ref :app.auth.oidc/google-provider)
+                  :github (ig/ref :app.auth.oidc/github-provider)
+                  :gitlab (ig/ref :app.auth.oidc/gitlab-provider)
+                  :oidc   (ig/ref :app.auth.oidc/generic-provider)}
+    :tokens      (ig/ref :app.tokens/tokens)
+    :http-client (ig/ref :app.http/client)
+    :pool        (ig/ref :app.db/pool)
+    :session     (ig/ref :app.http/session)
+    :public-uri  (cf/get :public-uri)
+    :executor    (ig/ref [::default :app.worker/executor])}
+
    :app.http/router
    {:assets        (ig/ref :app.http.assets/handlers)
     :feedback      (ig/ref :app.http.feedback/handler)
     :session       (ig/ref :app.http/session)
     :awsns-handler (ig/ref :app.http.awsns/handler)
-    :oauth         (ig/ref :app.http.oauth/handler)
+    :debug-routes  (ig/ref :app.http.debug/routes)
-    :debug         (ig/ref :app.http.debug/handlers)
+    :oidc-routes   (ig/ref :app.auth.oidc/routes)
     :ws            (ig/ref :app.http.websocket/handler)
     :metrics       (ig/ref :app.metrics/metrics)
     :public-uri    (cf/get :public-uri)
     :storage       (ig/ref :app.storage/storage)
     :tokens        (ig/ref :app.tokens/tokens)
     :audit-handler (ig/ref :app.loggers.audit/http-handler)
-    :rpc           (ig/ref :app.rpc/rpc)
+    :rpc-routes    (ig/ref :app.rpc/routes)
+    :doc-routes    (ig/ref :app.http.doc/routes)
     :executor      (ig/ref [::default :app.worker/executor])}
 
-   :app.http.debug/handlers
+   :app.http.debug/routes
-   {:pool (ig/ref :app.db/pool)
+   {:pool     (ig/ref :app.db/pool)
-    :executor (ig/ref [::worker :app.worker/executor])}
+    :executor (ig/ref [::worker :app.worker/executor])
+    :storage  (ig/ref :app.storage/storage)
+    :session  (ig/ref :app.http/session)}
 
    :app.http.websocket/handler
    {:pool     (ig/ref :app.db/pool)
@@ -156,17 +227,7 @@
    {:pool     (ig/ref :app.db/pool)
     :executor (ig/ref [::default :app.worker/executor])}
 
-   :app.http.oauth/handler
+   :app.rpc/methods
-   {:rpc         (ig/ref :app.rpc/rpc)
-    :session     (ig/ref :app.http/session)
-    :pool        (ig/ref :app.db/pool)
-    :tokens      (ig/ref :app.tokens/tokens)
-    :audit       (ig/ref :app.loggers.audit/collector)
-    :executor    (ig/ref [::default :app.worker/executor])
-    :http-client (ig/ref :app.http/client)
-    :public-uri  (cf/get :public-uri)}
-
-   :app.rpc/rpc
    {:pool        (ig/ref :app.db/pool)
     :session     (ig/ref :app.http/session)
     :tokens      (ig/ref :app.tokens/tokens)
@@ -175,9 +236,13 @@
     :msgbus      (ig/ref :app.msgbus/msgbus)
     :public-uri  (cf/get :public-uri)
     :audit       (ig/ref :app.loggers.audit/collector)
+    :ldap        (ig/ref :app.auth.ldap/provider)
     :http-client (ig/ref :app.http/client)
     :executors   (ig/ref :app.worker/executors)}
 
+   :app.rpc/routes
+   {:methods (ig/ref :app.rpc/methods)}
+
    :app.worker/worker
    {:executor (ig/ref [::worker :app.worker/executor])
     :tasks    (ig/ref :app.worker/registry)
@@ -336,23 +401,12 @@
 
     :backends
     {:assets-s3 (ig/ref [::assets :app.storage.s3/backend])
-     :assets-db (ig/ref [::assets :app.storage.db/backend])
      :assets-fs (ig/ref [::assets :app.storage.fs/backend])
 
-     :tmp       (ig/ref [::tmp  :app.storage.fs/backend])
-     :fdata-s3  (ig/ref [::fdata :app.storage.s3/backend])
-
      ;; keep this for backward compatibility
      :s3        (ig/ref [::assets :app.storage.s3/backend])
      :fs        (ig/ref [::assets :app.storage.fs/backend])}}
 
-   [::fdata :app.storage.s3/backend]
-   {:region   (cf/get :storage-fdata-s3-region)
-    :bucket   (cf/get :storage-fdata-s3-bucket)
-    :endpoint (cf/get :storage-fdata-s3-endpoint)
-    :prefix   (cf/get :storage-fdata-s3-prefix)
-    :executor (ig/ref [::default :app.worker/executor])}
-
    [::assets :app.storage.s3/backend]
    {:region   (cf/get :storage-assets-s3-region)
     :endpoint (cf/get :storage-assets-s3-endpoint)
@@ -361,12 +415,7 @@
 
    [::assets :app.storage.fs/backend]
    {:directory (cf/get :storage-assets-fs-directory)}
-
+   })
-   [::tmp :app.storage.fs/backend]
-   {:directory "/tmp/penpot"}
-
-   [::assets :app.storage.db/backend]
-   {:pool (ig/ref :app.db/pool)}})
 
 (def system nil)
 

backend/src/app/media.clj

@@ -12,18 +12,16 @@
    [app.common.media :as cm]
    [app.common.spec :as us]
    [app.config :as cf]
+   [app.storage.tmp :as tmp]
+   [app.util.bytes :as bs]
    [app.util.svg :as svg]
    [buddy.core.bytes :as bb]
    [buddy.core.codecs :as bc]
-   [clojure.java.io :as io]
    [clojure.java.shell :as sh]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [datoteka.core :as fs])
   (:import
-   java.io.ByteArrayInputStream
-   java.io.OutputStream
-   org.apache.commons.io.IOUtils
    org.im4java.core.ConvertCmd
    org.im4java.core.IMOperation
    org.im4java.core.Info))
@@ -93,18 +91,16 @@
   (let [{:keys [path mtype]} input
         format (or (cm/mtype->format mtype) format)
         ext    (cm/format->extension format)
-        tmp    (fs/create-tempfile :suffix ext)]
+        tmp    (tmp/tempfile :prefix "penpot.media." :suffix ext)]
 
     (doto (ConvertCmd.)
       (.run operation (into-array (map str [path tmp]))))
 
-    (let [thumbnail-data (fs/slurp-bytes tmp)]
+    (assoc params
-      (fs/delete tmp)
+           :format format
-      (assoc params
+           :mtype  (cm/format->mtype format)
-             :format format
+           :size   (fs/size tmp)
-             :mtype  (cm/format->mtype format)
+           :data   tmp)))
-             :size   (alength ^bytes thumbnail-data)
-             :data   (ByteArrayInputStream. thumbnail-data)))))
 
 (defmethod process :generic-thumbnail
   [{:keys [quality width height] :as params}]
@@ -201,59 +197,54 @@
 (defmethod process :generate-fonts
   [{:keys [input] :as params}]
   (letfn [(ttf->otf [data]
-            (let [input-file  (fs/create-tempfile :prefix "penpot")
+            (let [finput  (tmp/tempfile :prefix "penpot.font." :suffix "")
-                  output-file (fs/path (str input-file ".otf"))
+                  foutput (fs/path (str finput ".otf"))
-                  _           (with-open [out (io/output-stream input-file)]
+                  _       (bs/write-to-file! data finput)
-                                (IOUtils/writeChunked ^bytes data ^OutputStream out)
+                  res     (sh/sh "fontforge" "-lang=ff" "-c"
-                                (.flush ^OutputStream out))
+                                 (str/fmt "Open('%s'); Generate('%s')"
-                  res         (sh/sh "fontforge" "-lang=ff" "-c"
+                                          (str finput)
-                                     (str/fmt "Open('%s'); Generate('%s')"
+                                          (str foutput)))]
-                                              (str input-file)
-                                              (str output-file)))]
               (when (zero? (:exit res))
-                (fs/slurp-bytes output-file))))
+                foutput)))
-
 
           (otf->ttf [data]
-            (let [input-file  (fs/create-tempfile :prefix "penpot")
+            (let [finput  (tmp/tempfile :prefix "penpot.font." :suffix "")
-                  output-file (fs/path (str input-file ".ttf"))
+                  foutput (fs/path (str finput ".ttf"))
-                  _           (with-open [out (io/output-stream input-file)]
+                  _       (bs/write-to-file! data finput)
-                                (IOUtils/writeChunked ^bytes data ^OutputStream out)
+                  res     (sh/sh "fontforge" "-lang=ff" "-c"
-                                (.flush ^OutputStream out))
+                                 (str/fmt "Open('%s'); Generate('%s')"
-                  res         (sh/sh "fontforge" "-lang=ff" "-c"
+                                          (str finput)
-                                     (str/fmt "Open('%s'); Generate('%s')"
+                                          (str foutput)))]
-                                              (str input-file)
-                                              (str output-file)))]
               (when (zero? (:exit res))
-                (fs/slurp-bytes output-file))))
+                foutput)))
 
           (ttf-or-otf->woff [data]
-            (let [input-file  (fs/create-tempfile :prefix "penpot" :suffix "")
+            ;; NOTE: foutput is not used directly, it represents the
-                  output-file (fs/path (str input-file ".woff"))
+            ;; default output of the exection of the underlying
-                  _           (with-open [out (io/output-stream input-file)]
+            ;; command.
-                                (IOUtils/writeChunked ^bytes data ^OutputStream out)
+            (let [finput  (tmp/tempfile :prefix "penpot.font." :suffix "")
-                                (.flush ^OutputStream out))
+                  foutput (fs/path (str finput ".woff"))
-                  res         (sh/sh "sfnt2woff" (str input-file))]
+                  _       (bs/write-to-file! data finput)
+                  res     (sh/sh "sfnt2woff" (str finput))]
               (when (zero? (:exit res))
-                (fs/slurp-bytes output-file))))
+                foutput)))
 
           (ttf-or-otf->woff2 [data]
-            (let [input-file  (fs/create-tempfile :prefix "penpot" :suffix "")
+            ;; NOTE: foutput is not used directly, it represents the
-                  output-file (fs/path (str input-file ".woff2"))
+            ;; default output of the exection of the underlying
-                  _           (with-open [out (io/output-stream input-file)]
+            ;; command.
-                                (IOUtils/writeChunked ^bytes data ^OutputStream out)
+            (let [finput  (tmp/tempfile :prefix "penpot.font." :suffix ".tmp")
-                                (.flush ^OutputStream out))
+                  foutput (fs/path (str (fs/base finput) ".woff2"))
-                  res         (sh/sh "woff2_compress" (str input-file))]
+                  _       (bs/write-to-file! data finput)
+                  res      (sh/sh "woff2_compress" (str finput))]
               (when (zero? (:exit res))
-                (fs/slurp-bytes output-file))))
+                foutput)))
 
           (woff->sfnt [data]
-            (let [input-file  (fs/create-tempfile :prefix "penpot" :suffix "")
+            (let [finput  (tmp/tempfile :prefix "penpot" :suffix "")
-                  _           (with-open [out (io/output-stream input-file)]
+                  _       (bs/write-to-file! data finput)
-                                (IOUtils/writeChunked ^bytes data ^OutputStream out)
+                  res     (sh/sh "woff2sfnt" (str finput)
-                                (.flush ^OutputStream out))
+                                 :out-enc :bytes)]
-                  res         (sh/sh "woff2sfnt" (str input-file)
-                                     :out-enc :bytes)]
               (when (zero? (:exit res))
                 (:out res))))
 

backend/src/app/migrations.clj

@@ -226,6 +226,15 @@
 
    {:name "0072-mod-file-object-thumbnail-table"
     :fn (mg/resource "app/migrations/sql/0072-mod-file-object-thumbnail-table.sql")}
+
+   {:name "0073-mod-file-media-object-constraints"
+    :fn (mg/resource "app/migrations/sql/0073-mod-file-media-object-constraints.sql")}   
+
+   {:name "0074-mod-file-library-rel-constraints"
+    :fn (mg/resource "app/migrations/sql/0074-mod-file-library-rel-constraints.sql")}
+   
+   {:name "0075-mod-share-link-table"
+    :fn (mg/resource "app/migrations/sql/0075-mod-share-link-table.sql")}
    ])
 
 

backend/src/app/migrations/sql/0073-mod-file-media-object-constraints.sql

@@ -0,0 +1,11 @@
+ALTER TABLE file_media_object
+ALTER CONSTRAINT file_media_object_media_id_fkey DEFERRABLE INITIALLY IMMEDIATE;
+
+ALTER TABLE file_media_object
+ALTER CONSTRAINT file_media_object_thumbnail_id_fkey DEFERRABLE INITIALLY IMMEDIATE;
+
+ALTER TABLE file_media_object
+RENAME CONSTRAINT media_object_file_id_fkey TO file_media_object_file_id_fkey;
+
+ALTER TABLE file_media_object
+ALTER CONSTRAINT file_media_object_file_id_fkey DEFERRABLE INITIALLY IMMEDIATE;

backend/src/app/migrations/sql/0074-mod-file-library-rel-constraints.sql

@@ -0,0 +1,5 @@
+ALTER TABLE file_library_rel
+ALTER CONSTRAINT file_library_rel_file_id_fkey DEFERRABLE INITIALLY IMMEDIATE;
+
+ALTER TABLE file_library_rel
+ALTER CONSTRAINT file_library_rel_library_file_id_fkey DEFERRABLE INITIALLY IMMEDIATE;

backend/src/app/migrations/sql/0075-mod-share-link-table.sql

@@ -0,0 +1,5 @@
+ALTER TABLE share_link
+  ADD COLUMN who_comment text NOT NULL DEFAULT('team'),
+  ADD COLUMN who_inspect text NOT NULL DEFAULT('team');
+
+--- TODO: remove flags column in 1.15.x

backend/src/app/msgbus.clj

@@ -160,7 +160,6 @@
   "Function responsible to attach local subscription to the
   state. Intended to be used in agent."
   [state cfg topics chan done-ch]
-  (l/trace :hint "subscribe-to-topics" :topics topics ::l/async false)
   (aa/with-closing done-ch
     (let [state (update state :chans assoc chan topics)]
       (reduce (fn [state topic]
@@ -184,15 +183,15 @@
   useful when client disconnects or in-bulk unsubscribe
   operations. Intended to be executed in agent."
   [state cfg channels done-ch]
-  (l/trace :hint "unsubscribe-channels" :chans (count channels) ::l/async false)
   (aa/with-closing done-ch
     (reduce #(unsubscribe-single-channel %1 cfg %2) state channels)))
 
+
 (defn- subscribe
   [{:keys [::state executor] :as cfg} {:keys [topic topics chan]}]
   (let [done-ch (a/chan)
         topics  (into [] (map prefix-topic) (if topic [topic] topics))]
-    (l/trace :hint "subscribe" :topics topics)
+    (l/debug :hint "subscribe" :topics topics)
     (send-via executor state subscribe-to-topics cfg topics chan done-ch)
     done-ch))
 

backend/src/app/rpc.clj

@@ -86,6 +86,30 @@
                      (let [context {:profile-id profile-id}]
                        (raise (ex/wrap-with-context cause context)))))))))
 
+(defn- rpc-command-handler
+  "Ring handler that dispatches cmd requests and convert between
+  internal async flow into ring async flow."
+  [methods {:keys [profile-id session-id params] :as request} respond raise]
+  (letfn [(handle-response [result]
+            (let [mdata (meta result)]
+              (p/-> (yrs/response 200 result)
+                    (handle-response-transformation request mdata)
+                    (handle-before-comple-hook mdata))))]
+
+    (let [cmd    (keyword (:command params))
+          data   (into {::request request} params)
+          data   (if profile-id
+                   (assoc data :profile-id profile-id ::session-id session-id)
+                   (dissoc data :profile-id))
+
+          method (get methods cmd default-handler)]
+      (-> (method data)
+          (p/then handle-response)
+          (p/then respond)
+          (p/catch (fn [cause]
+                     (let [context {:profile-id profile-id}]
+                       (raise (ex/wrap-with-context cause context)))))))))
+
 (defn- wrap-metrics
   "Wrap service method with metrics measurement."
   [{:keys [metrics ::metrics-id]} f mdata]
@@ -180,8 +204,9 @@
 (defn- process-method
   [cfg vfn]
   (let [mdata (meta vfn)]
+    ;; (prn mdata)
     [(keyword (::sv/name mdata))
-     (wrap cfg (deref vfn) mdata)]))
+     (wrap cfg vfn mdata)]))
 
 (defn- resolve-query-methods
   [cfg]
@@ -199,35 +224,81 @@
 (defn- resolve-mutation-methods
   [cfg]
   (let [cfg (assoc cfg ::type "mutation" ::metrics-id :rpc-mutation-timing)]
-    (->> (sv/scan-ns 'app.rpc.mutations.demo
+    (->> (sv/scan-ns 'app.rpc.mutations.media
-                     'app.rpc.mutations.media
                      'app.rpc.mutations.profile
                      'app.rpc.mutations.files
                      'app.rpc.mutations.comments
                      'app.rpc.mutations.projects
                      'app.rpc.mutations.teams
                      'app.rpc.mutations.management
-                     'app.rpc.mutations.ldap
                      'app.rpc.mutations.fonts
                      'app.rpc.mutations.share-link
                      'app.rpc.mutations.verify-token)
          (map (partial process-method cfg))
          (into {}))))
 
-(s/def ::storage some?)
+(defn- resolve-command-methods
-(s/def ::session map?)
+  [cfg]
-(s/def ::tokens fn?)
+  (let [cfg (assoc cfg ::type "command" ::metrics-id :rpc-command-timing)]
+    (->> (sv/scan-ns 'app.rpc.commands.binfile
+                     'app.rpc.commands.auth
+                     'app.rpc.commands.ldap
+                     'app.rpc.commands.demo)
+         (map (partial process-method cfg))
+         (into {}))))
+
 (s/def ::audit (s/nilable fn?))
 (s/def ::executors (s/map-of keyword? ::wrk/executor))
+(s/def ::executors map?)
+(s/def ::http-client fn?)
+(s/def ::ldap (s/nilable map?))
+(s/def ::msgbus fn?)
+(s/def ::public-uri ::us/not-empty-string)
+(s/def ::session map?)
+(s/def ::storage some?)
+(s/def ::tokens fn?)
 
-(defmethod ig/pre-init-spec ::rpc [_]
+(defmethod ig/pre-init-spec ::methods [_]
-  (s/keys :req-un [::storage ::session ::tokens ::audit
+  (s/keys :req-un [::storage
-                   ::executors ::mtx/metrics ::db/pool]))
+                   ::session
+                   ::tokens
+                   ::audit
+                   ::executors
+                   ::public-uri
+                   ::msgbus
+                   ::http-client
+                   ::mtx/metrics
+                   ::db/pool
+                   ::ldap]))
 
-(defmethod ig/init-key ::rpc
+(defmethod ig/init-key ::methods
   [_ cfg]
-  (let [mq (resolve-query-methods cfg)
+  {:mutations (resolve-mutation-methods cfg)
-        mm (resolve-mutation-methods cfg)]
+   :queries   (resolve-query-methods cfg)
-    {:methods {:query mq :mutation mm}
+   :commands  (resolve-command-methods cfg)})
-     :query-handler (partial rpc-query-handler mq)
+
-     :mutation-handler (partial rpc-mutation-handler mm)}))
+(s/def ::mutations
+  (s/map-of keyword? fn?))
+
+(s/def ::queries
+  (s/map-of keyword? fn?))
+
+(s/def ::commands
+  (s/map-of keyword? fn?))
+
+(s/def ::methods
+  (s/keys :req-un [::mutations
+                   ::queries
+                   ::commands]))
+
+(defmethod ig/pre-init-spec ::routes [_]
+  (s/keys :req-un [::methods]))
+
+(defmethod ig/init-key ::routes
+  [_ {:keys [methods] :as cfg}]
+  [["/rpc"
+    ["/command/:command" {:handler (partial rpc-command-handler (:commands methods))}]
+    ["/query/:type" {:handler (partial rpc-query-handler (:queries methods))}]
+    ["/mutation/:type" {:handler (partial rpc-mutation-handler (:mutations methods))
+                        :allowed-methods #{:post}}]]])
+

backend/src/app/rpc/commands/auth.clj

@@ -0,0 +1,416 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.rpc.commands.auth
+  (:require
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.config :as cf]
+   [app.db :as db]
+   [app.emails :as eml]
+   [app.loggers.audit :as audit]
+   [app.rpc.mutations.teams :as teams]
+   [app.rpc.queries.profile :as profile]
+   [app.rpc.rlimit :as rlimit]
+   [app.util.services :as sv]
+   [app.util.time :as dt]
+   [buddy.hashers :as hashers]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]))
+
+(s/def ::email ::us/email)
+(s/def ::fullname ::us/not-empty-string)
+(s/def ::lang ::us/string)
+(s/def ::path ::us/string)
+(s/def ::profile-id ::us/uuid)
+(s/def ::password ::us/not-empty-string)
+(s/def ::old-password ::us/not-empty-string)
+(s/def ::theme ::us/string)
+(s/def ::invitation-token ::us/not-empty-string)
+(s/def ::token ::us/not-empty-string)
+
+;; ---- HELPERS
+
+(defn derive-password
+  [password]
+  (hashers/derive password
+                  {:alg :argon2id
+                   :memory 16384
+                   :iterations 20
+                   :parallelism 2}))
+
+(defn verify-password
+  [attempt password]
+  (try
+    (hashers/verify attempt password)
+    (catch Exception _e
+      {:update false
+       :valid false})))
+
+(defn email-domain-in-whitelist?
+  "Returns true if email's domain is in the given whitelist or if
+  given whitelist is an empty string."
+  [domains email]
+  (if (or (empty? domains)
+          (nil? domains))
+    true
+    (let [[_ candidate] (-> (str/lower email)
+                            (str/split #"@" 2))]
+      (contains? domains candidate))))
+
+(def ^:private sql:profile-existence
+  "select exists (select * from profile
+                   where email = ?
+                     and deleted_at is null) as val")
+
+(defn check-profile-existence!
+  [conn {:keys [email] :as params}]
+  (let [email  (str/lower email)
+        result (db/exec-one! conn [sql:profile-existence email])]
+    (when (:val result)
+      (ex/raise :type :validation
+                :code :email-already-exists))
+    params))
+
+;; ---- COMMAND: login with password
+
+(defn login-with-password
+  [{:keys [pool session tokens] :as cfg} {:keys [email password] :as params}]
+
+  (when-not (contains? cf/flags :login)
+    (ex/raise :type :restriction
+              :code :login-disabled
+              :hint "login is disabled in this instance"))
+
+  (letfn [(check-password [profile password]
+            (when (= (:password profile) "!")
+              (ex/raise :type :validation
+                        :code :account-without-password
+                        :hint "the current account does not have password"))
+            (:valid (verify-password password (:password profile))))
+
+          (validate-profile [profile]
+            (when-not (:is-active profile)
+              (ex/raise :type :validation
+                        :code :wrong-credentials))
+            (when-not profile
+              (ex/raise :type :validation
+                        :code :wrong-credentials))
+            (when-not (check-password profile password)
+              (ex/raise :type :validation
+                        :code :wrong-credentials))
+            profile)]
+
+    (db/with-atomic [conn pool]
+      (let [profile    (->> (profile/retrieve-profile-data-by-email conn email)
+                            (validate-profile)
+                            (profile/strip-private-attrs)
+                            (profile/populate-additional-data conn)
+                            (profile/decode-profile-row))
+
+            invitation (when-let [token (:invitation-token params)]
+                         (tokens :verify {:token token :iss :team-invitation}))
+
+            ;; If invitation member-id does not matches the profile-id, we just proceed to ignore the
+            ;; invitation because invitations matches exactly; and user can't loging with other email and
+            ;; accept invitation with other email
+            response   (if (and (some? invitation) (= (:id profile) (:member-id invitation)))
+                         {:invitation-token (:invitation-token params)}
+                         profile)]
+
+        (with-meta response
+          {:transform-response ((:create session) (:id profile))
+           ::audit/props (audit/profile->props profile)
+           ::audit/profile-id (:id profile)})))))
+
+(s/def ::login-with-password
+  (s/keys :req-un [::email ::password]
+          :opt-un [::invitation-token]))
+
+(sv/defmethod ::login-with-password
+  "Performs authentication using penpot password."
+  {:auth false ::rlimit/permits (cf/get :rlimit-password)}
+  [cfg params]
+  (login-with-password cfg params))
+
+;; ---- COMMAND: Logout
+
+(s/def ::logout
+  (s/keys :opt-un [::profile-id]))
+
+(sv/defmethod ::logout
+  "Clears the authentication cookie and logout the current session."
+  {:auth false}
+  [{:keys [session] :as cfg} _]
+  (with-meta {}
+    {:transform-response (:delete session)}))
+
+;; ---- COMMAND: Recover Profile
+
+(defn recover-profile
+  [{:keys [pool tokens] :as cfg} {:keys [token password]}]
+  (letfn [(validate-token [token]
+            (let [tdata (tokens :verify {:token token :iss :password-recovery})]
+              (:profile-id tdata)))
+
+          (update-password [conn profile-id]
+            (let [pwd (derive-password password)]
+              (db/update! conn :profile {:password pwd} {:id profile-id})))]
+
+    (db/with-atomic [conn pool]
+      (->> (validate-token token)
+           (update-password conn))
+      nil)))
+
+(s/def ::token ::us/not-empty-string)
+(s/def ::recover-profile
+  (s/keys :req-un [::token ::password]))
+
+(sv/defmethod ::recover-profile
+  {:auth false ::rlimit/permits (cf/get :rlimit-password)}
+  [cfg params]
+  (recover-profile cfg params))
+
+;; ---- COMMAND: Prepare Register
+
+(defn prepare-register
+  [{:keys [pool tokens] :as cfg} params]
+  (when-not (contains? cf/flags :registration)
+    (if-not (contains? params :invitation-token)
+      (ex/raise :type :restriction
+                :code :registration-disabled)
+      (let [invitation (tokens :verify {:token (:invitation-token params) :iss :team-invitation})]
+        (when-not (= (:email params) (:member-email invitation))
+          (ex/raise :type :restriction
+                    :code :email-does-not-match-invitation
+                    :hint "email should match the invitation")))))
+
+  (when-let [domains (cf/get :registration-domain-whitelist)]
+    (when-not (email-domain-in-whitelist? domains (:email params))
+      (ex/raise :type :validation
+                :code :email-domain-is-not-allowed)))
+
+  ;; Don't allow proceed in preparing registration if the profile is
+  ;; already reported as spammer.
+  (when (eml/has-bounce-reports? pool (:email params))
+    (ex/raise :type :validation
+              :code :email-has-permanent-bounces
+              :hint "looks like the email has one or many bounces reported"))
+
+  (check-profile-existence! pool params)
+
+  (when (= (str/lower (:email params))
+           (str/lower (:password params)))
+    (ex/raise :type :validation
+              :code :email-as-password
+              :hint "you can't use your email as password"))
+
+  (let [params {:email (:email params)
+                :password (:password params)
+                :invitation-token (:invitation-token params)
+                :backend "penpot"
+                :iss :prepared-register
+                :exp (dt/in-future "48h")}
+
+        token  (tokens :generate params)]
+    (with-meta {:token token}
+      {::audit/profile-id uuid/zero})))
+
+(s/def ::prepare-register-profile
+  (s/keys :req-un [::email ::password]
+          :opt-un [::invitation-token]))
+
+(sv/defmethod ::prepare-register-profile {:auth false}
+  [cfg params]
+  (prepare-register cfg params))
+
+;; ---- COMMAND: Register Profile
+
+(defn create-profile
+  "Create the profile entry on the database with limited input filling
+  all the other fields with defaults."
+  [conn params]
+  (let [id        (or (:id params) (uuid/next))
+
+        props     (-> (audit/extract-utm-params params)
+                      (merge (:props params))
+                      (db/tjson))
+
+        password  (if-let [password (:password params)]
+                    (derive-password password)
+                    "!")
+
+        locale    (:locale params)
+        locale    (when (and (string? locale) (not (str/blank? locale)))
+                    locale)
+
+        backend   (:backend params "penpot")
+        is-demo   (:is-demo params false)
+        is-muted  (:is-muted params false)
+        is-active (:is-active params false)
+        email     (str/lower (:email params))
+
+        params    {:id id
+                   :fullname (:fullname params)
+                   :email email
+                   :auth-backend backend
+                   :lang locale
+                   :password password
+                   :deleted-at (:deleted-at params)
+                   :props props
+                   :is-active is-active
+                   :is-muted is-muted
+                   :is-demo is-demo}]
+    (try
+      (-> (db/insert! conn :profile params)
+          (profile/decode-profile-row))
+      (catch org.postgresql.util.PSQLException e
+        (let [state (.getSQLState e)]
+          (if (not= state "23505")
+            (throw e)
+            (ex/raise :type :validation
+                      :code :email-already-exists
+                      :cause e)))))))
+
+(defn create-profile-relations
+  [conn profile]
+  (let [team (teams/create-team conn {:profile-id (:id profile)
+                                      :name "Default"
+                                      :is-default true})]
+    (-> profile
+        (profile/strip-private-attrs)
+        (assoc :default-team-id (:id team))
+        (assoc :default-project-id (:default-project-id team)))))
+
+(defn register-profile
+  [{:keys [conn tokens session] :as cfg} {:keys [token] :as params}]
+  (let [claims    (tokens :verify {:token token :iss :prepared-register})
+        params    (merge params claims)]
+    (check-profile-existence! conn params)
+    (let [is-active  (or (:is-active params)
+                         (contains? cf/flags :insecure-register))
+          profile    (->> (assoc params :is-active is-active)
+                          (create-profile conn)
+                          (create-profile-relations conn)
+                          (profile/decode-profile-row))
+          invitation (when-let [token (:invitation-token params)]
+                       (tokens :verify {:token token :iss :team-invitation}))]
+      (cond
+        ;; If invitation token comes in params, this is because the user comes from team-invitation process;
+        ;; in this case, regenerate token and send back to the user a new invitation token (and mark current
+        ;; session as logged). This happens only if the invitation email matches with the register email.
+        (and (some? invitation) (= (:email profile) (:member-email invitation)))
+        (let [claims (assoc invitation :member-id  (:id profile))
+              token  (tokens :generate claims)
+              resp   {:invitation-token token}]
+          (with-meta resp
+            {:transform-response ((:create session) (:id profile))
+             ::audit/replace-props (audit/profile->props profile)
+             ::audit/profile-id (:id profile)}))
+
+        ;; If auth backend is different from "penpot" means user is
+        ;; registering using third party auth mechanism; in this case
+        ;; we need to mark this session as logged.
+        (not= "penpot" (:auth-backend profile))
+        (with-meta (profile/strip-private-attrs profile)
+          {:transform-response ((:create session) (:id profile))
+           ::audit/replace-props (audit/profile->props profile)
+           ::audit/profile-id (:id profile)})
+
+        ;; If the `:enable-insecure-register` flag is set, we proceed
+        ;; to sign in the user directly, without email verification.
+        (true? is-active)
+        (with-meta (profile/strip-private-attrs profile)
+          {:transform-response ((:create session) (:id profile))
+           ::audit/replace-props (audit/profile->props profile)
+           ::audit/profile-id (:id profile)})
+
+        ;; In all other cases, send a verification email.
+        :else
+        (let [vtoken (tokens :generate
+                             {:iss :verify-email
+                              :exp (dt/in-future "48h")
+                              :profile-id (:id profile)
+                              :email (:email profile)})
+              ptoken (tokens :generate-predefined
+                             {:iss :profile-identity
+                              :profile-id (:id profile)})]
+          (eml/send! {::eml/conn conn
+                      ::eml/factory eml/register
+                      :public-uri (:public-uri cfg)
+                      :to (:email profile)
+                      :name (:fullname profile)
+                      :token vtoken
+                      :extra-data ptoken})
+
+          (with-meta profile
+            {::audit/replace-props (audit/profile->props profile)
+             ::audit/profile-id (:id profile)}))))))
+
+(s/def ::register-profile
+  (s/keys :req-un [::token ::fullname]))
+
+(sv/defmethod ::register-profile
+  {:auth false ::rlimit/permits (cf/get :rlimit-password)}
+  [{:keys [pool] :as cfg} params]
+  (db/with-atomic [conn pool]
+    (-> (assoc cfg :conn conn)
+        (register-profile params))))
+
+;; ---- COMMAND: Request Profile Recovery
+
+(defn request-profile-recovery
+  [{:keys [pool tokens] :as cfg} {:keys [email] :as params}]
+  (letfn [(create-recovery-token [{:keys [id] :as profile}]
+            (let [token (tokens :generate
+                                {:iss :password-recovery
+                                 :exp (dt/in-future "15m")
+                                 :profile-id id})]
+              (assoc profile :token token)))
+
+          (send-email-notification [conn profile]
+            (let [ptoken (tokens :generate-predefined
+                                 {:iss :profile-identity
+                                  :profile-id (:id profile)})]
+              (eml/send! {::eml/conn conn
+                          ::eml/factory eml/password-recovery
+                          :public-uri (:public-uri cfg)
+                          :to (:email profile)
+                          :token (:token profile)
+                          :name (:fullname profile)
+                          :extra-data ptoken})
+              nil))]
+
+    (db/with-atomic [conn pool]
+      (when-let [profile (profile/retrieve-profile-data-by-email conn email)]
+        (when-not (eml/allow-send-emails? conn profile)
+          (ex/raise :type :validation
+                    :code :profile-is-muted
+                    :hint "looks like the profile has reported repeatedly as spam or has permanent bounces."))
+
+        (when-not (:is-active profile)
+          (ex/raise :type :validation
+                    :code :profile-not-verified
+                    :hint "the user need to validate profile before recover password"))
+
+        (when (eml/has-bounce-reports? conn (:email profile))
+          (ex/raise :type :validation
+                    :code :email-has-permanent-bounces
+                    :hint "looks like the email you invite has been repeatedly reported as spam or permanent bounce"))
+
+        (->> profile
+             (create-recovery-token)
+             (send-email-notification conn))))))
+
+(s/def ::request-profile-recovery
+  (s/keys :req-un [::email]))
+
+(sv/defmethod ::request-profile-recovery {:auth false}
+  [cfg params]
+  (request-profile-recovery cfg params))
+
+

backend/src/app/rpc/commands/binfile.clj

@@ -0,0 +1,836 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.rpc.commands.binfile
+  (:refer-clojure :exclude [assert])
+  (:require
+   [app.common.data :as d]
+   [app.common.exceptions :as ex]
+   [app.common.logging :as l]
+   [app.common.pages.migrations :as pmg]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.config :as cf]
+   [app.db :as db]
+   [app.media :as media]
+   [app.rpc.queries.files :as files]
+   [app.rpc.queries.projects :as projects]
+   [app.storage :as sto]
+   [app.storage.tmp :as tmp]
+   [app.tasks.file-gc]
+   [app.util.blob :as blob]
+   [app.util.bytes :as bs]
+   [app.util.fressian :as fres]
+   [app.util.services :as sv]
+   [app.util.time :as dt]
+   [clojure.java.io :as io]
+   [clojure.spec.alpha :as s]
+   [clojure.walk :as walk]
+   [cuerdas.core :as str]
+   [yetti.adapter :as yt])
+  (:import
+   java.io.DataInputStream
+   java.io.DataOutputStream
+   java.io.InputStream
+   java.io.OutputStream
+   java.lang.AutoCloseable))
+
+(set! *warn-on-reflection* true)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; VARS & DEFAULTS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Threshold in MiB when we pass from using
+;; in-memory byte-array's to use temporal files.
+(def temp-file-threshold
+  (* 1024 1024 2))
+
+;; Represents the current processing file-id on
+;; export process.
+(def ^:dynamic *file-id*)
+
+;; Stores all media file object references of
+;; processed files on import process.
+(def ^:dynamic *media*)
+
+;; Stores the objects index on reamping subprocess
+;; part of the import process.
+(def ^:dynamic *index*)
+
+;; Has the current connection used on the import
+;; process.
+(def ^:dynamic *conn*)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; LOW LEVEL STREAM IO API
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^:const buffer-size (:xnio/buffer-size yt/defaults))
+(def ^:const penpot-magic-number 800099563638710213)
+(def ^:const max-object-size (* 1024 1024 100)) ; Only allow 100MiB max file size.
+
+(def ^:dynamic *position* nil)
+
+(defn get-mark
+  [id]
+  (case id
+    :header  1
+    :stream  2
+    :uuid    3
+    :label   4
+    :obj     5
+    (ex/raise :type :validation
+              :code :invalid-mark-id
+              :hint (format "invalid mark id %s" id))))
+
+(defmacro assert
+  [expr hint]
+  `(when-not ~expr
+     (ex/raise :type :validation
+               :code :unexpected-condition
+               :hint ~hint)))
+
+(defmacro assert-mark
+  [v type]
+  `(let [expected# (get-mark ~type)
+         val#      (long ~v)]
+     (when (not= val# expected#)
+       (ex/raise :type :validation
+                 :code :unexpected-mark
+                 :hint (format "received mark %s, expected %s" val# expected#)))))
+
+(defmacro assert-label
+  [expr label]
+  `(let [v# ~expr]
+     (when (not= v# ~label)
+       (ex/raise :type :assertion
+                 :code :unexpected-label
+                 :hint (format "received label %s, expected %s" v# ~label)))))
+
+;; --- PRIMITIVE IO
+
+(defn write-byte!
+  [^DataOutputStream output data]
+  (l/trace :fn "write-byte!" :data data :position @*position* ::l/async false)
+  (.writeByte output (byte data))
+  (swap! *position* inc))
+
+(defn read-byte!
+  [^DataInputStream input]
+  (let [v (.readByte input)]
+    (l/trace :fn "read-byte!" :val v :position @*position* ::l/async false)
+    (swap! *position* inc)
+    v))
+
+(defn write-long!
+  [^DataOutputStream output data]
+  (l/trace :fn "write-long!" :data data :position @*position* ::l/async false)
+  (.writeLong output (long data))
+  (swap! *position* + 8))
+
+
+(defn read-long!
+  [^DataInputStream input]
+  (let [v (.readLong input)]
+    (l/trace :fn "read-long!" :val v :position @*position* ::l/async false)
+    (swap! *position* + 8)
+    v))
+
+(defn write-bytes!
+  [^DataOutputStream output ^bytes data]
+  (let [size (alength data)]
+    (l/trace :fn "write-bytes!" :size size :position @*position* ::l/async false)
+    (.write output data 0 size)
+    (swap! *position* + size)))
+
+(defn read-bytes!
+  [^InputStream input ^bytes buff]
+  (let [size   (alength buff)
+        readed (.readNBytes input buff 0 size)]
+    (l/trace :fn "read-bytes!" :expected (alength buff) :readed readed :position @*position* ::l/async false)
+    (swap! *position* + readed)
+    readed))
+
+;; --- COMPOSITE IO
+
+(defn write-uuid!
+  [^DataOutputStream output id]
+  (l/trace :fn "write-uuid!" :position @*position* :WRITTEN? (.size output) ::l/async false)
+
+  (doto output
+    (write-byte! (get-mark :uuid))
+    (write-long! (uuid/get-word-high id))
+    (write-long! (uuid/get-word-low id))))
+
+(defn read-uuid!
+  [^DataInputStream input]
+  (l/trace :fn "read-uuid!" :position @*position* ::l/async false)
+  (let [m (read-byte! input)]
+    (assert-mark m :uuid)
+    (let [a (read-long! input)
+          b (read-long! input)]
+      (uuid/custom a b))))
+
+(defn write-obj!
+  [^DataOutputStream output data]
+  (l/trace :fn "write-obj!" :position @*position* ::l/async false)
+  (let [^bytes data (fres/encode data)]
+    (doto output
+      (write-byte! (get-mark :obj))
+      (write-long! (alength data))
+      (write-bytes! data))))
+
+(defn read-obj!
+  [^DataInputStream input]
+  (l/trace :fn "read-obj!" :position @*position* ::l/async false)
+  (let [m (read-byte! input)]
+    (assert-mark m :obj)
+    (let [size (read-long! input)]
+      (assert (pos? size) "incorrect header size found on reading header")
+      (let [buff (byte-array size)]
+        (read-bytes! input buff)
+        (fres/decode buff)))))
+
+(defn write-label!
+  [^DataOutputStream output label]
+  (l/trace :fn "write-label!" :label label :position @*position* ::l/async false)
+  (doto output
+    (write-byte! (get-mark :label))
+    (write-obj! label)))
+
+(defn read-label!
+  [^DataInputStream input]
+  (l/trace :fn "read-label!" :position @*position* ::l/async false)
+  (let [m (read-byte! input)]
+    (assert-mark m :label)
+    (read-obj! input)))
+
+(defn write-header!
+  [^DataOutputStream output & {:keys [version metadata]}]
+  (l/trace :fn "write-header!"
+           :version version
+           :metadata metadata
+           :position @*position*
+           ::l/async false)
+
+  (doto output
+    (write-byte! (get-mark :header))
+    (write-long! penpot-magic-number)
+    (write-long! version)
+    (write-obj! metadata)))
+
+(defn read-header!
+  [^DataInputStream input]
+  (l/trace :fn "read-header!" :position @*position* ::l/async false)
+  (let [mark  (read-byte! input)
+        mnum  (read-long! input)
+        vers  (read-long! input)]
+
+    (when (or (not= mark (get-mark :header))
+              (not= mnum penpot-magic-number))
+      (ex/raise :type :validation
+                :code :invalid-penpot-file))
+
+    (-> (read-obj! input)
+        (assoc ::version vers))))
+
+(defn copy-stream!
+  [^OutputStream output ^InputStream input ^long size]
+  (let [written (bs/copy! input output :size size)]
+    (l/trace :fn "copy-stream!" :position @*position* :size size :written written ::l/async false)
+    (swap! *position* + written)
+    written))
+
+(defn write-stream!
+  [^DataOutputStream output stream size]
+  (l/trace :fn "write-stream!" :position @*position* ::l/async false :size size)
+  (doto output
+    (write-byte! (get-mark :stream))
+    (write-long! size))
+
+  (copy-stream! output stream size))
+
+(defn read-stream!
+  [^DataInputStream input]
+  (l/trace :fn "read-stream!" :position @*position* ::l/async false)
+  (let [m (read-byte! input)
+        s (read-long! input)
+        p (tmp/tempfile :prefix "penpot.binfile.")]
+    (assert-mark m :stream)
+
+    (when (> s max-object-size)
+      (ex/raise :type :validation
+                :code :max-file-size-reached
+                :hint (str/ffmt "unable to import storage object with size % bytes" s)))
+
+    (if (> s temp-file-threshold)
+      (with-open [^OutputStream output (io/output-stream p)]
+        (let [readed (bs/copy! input output :offset 0 :size s)]
+          (l/trace :fn "read-stream*!" :expected s :readed readed :position @*position* ::l/async false)
+          (swap! *position* + readed)
+          [s p]))
+      [s (bs/read-as-bytes input :size s)])))
+
+(defmacro assert-read-label!
+  [input expected-label]
+  `(let [readed# (read-label! ~input)
+         expected# ~expected-label]
+     (when (not= readed# expected#)
+       (ex/raise :type :validation
+                 :code :unexpected-label
+                 :hint (format "unxpected label found: %s, expected: %s" readed# expected#)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; API
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; --- HELPERS
+
+(defn- retrieve-file
+  [pool file-id]
+  (->> (db/query pool :file {:id file-id})
+       (map files/decode-row)
+       (first)))
+
+(def ^:private sql:file-media-objects
+  "SELECT * FROM file_media_object WHERE id = ANY(?)")
+
+(defn- retrieve-file-media
+  [pool {:keys [data] :as file}]
+  (with-open [^AutoCloseable conn (db/open pool)]
+    (let [ids (app.tasks.file-gc/collect-used-media data)
+          ids (db/create-array conn "uuid" ids)]
+      (db/exec! conn [sql:file-media-objects ids]))))
+
+(def ^:private storage-object-id-xf
+  (comp
+   (mapcat (juxt :media-id :thumbnail-id))
+   (filter uuid?)))
+
+(def ^:private sql:file-libraries
+  "WITH RECURSIVE libs AS (
+     SELECT fl.id, fl.deleted_at
+       FROM file AS fl
+       JOIN file_library_rel AS flr ON (flr.library_file_id = fl.id)
+      WHERE flr.file_id = ANY(?)
+    UNION
+     SELECT fl.id, fl.deleted_at
+       FROM file AS fl
+       JOIN file_library_rel AS flr ON (flr.library_file_id = fl.id)
+       JOIN libs AS l ON (flr.file_id = l.id)
+   )
+   SELECT DISTINCT l.id
+     FROM libs AS l
+    WHERE l.deleted_at IS NULL OR l.deleted_at > now();")
+
+(defn- retrieve-libraries
+  [pool ids]
+  (with-open [^AutoCloseable conn (db/open pool)]
+    (let [ids (db/create-array conn "uuid" ids)]
+      (map :id (db/exec! pool [sql:file-libraries ids])))))
+
+(def ^:private sql:file-library-rels
+  "SELECT * FROM file_library_rel
+    WHERE file_id = ANY(?)")
+
+(defn- retrieve-library-relations
+  [pool ids]
+  (with-open [^AutoCloseable conn (db/open pool)]
+    (db/exec! conn [sql:file-library-rels (db/create-array conn "uuid" ids)])))
+
+;; --- EXPORT WRITTER
+
+(s/def ::output bs/output-stream?)
+(s/def ::file-ids (s/every ::us/uuid :kind vector? :min-count 1))
+(s/def ::include-libraries? (s/nilable ::us/boolean))
+(s/def ::embed-assets? (s/nilable ::us/boolean))
+
+(s/def ::write-export-options
+  (s/keys :req-un [::db/pool ::sto/storage]
+          :req    [::output ::file-ids]
+          :opt    [::include-libraries? ::embed-assets?]))
+
+(defn write-export!
+  "Do the exportation of a speficied file in custom penpot binary
+  format. There are some options available for customize the output:
+
+  `::include-libraries?`: additionaly to the specified file, all the
+  linked libraries also will be included (including transitive
+  dependencies).
+
+  `::embed-assets?`: instead of including the libraryes, embedd in the
+  same file library all assets used from external libraries.
+  "
+
+  [{:keys [pool storage ::output ::file-ids ::include-libraries? ::embed-assets?] :as options}]
+
+  (us/assert! ::write-export-options options)
+
+  (us/verify!
+   :expr (not (and include-libraries? embed-assets?))
+   :hint "the `include-libraries?` and `embed-assets?` are mutally excluding options")
+
+  (letfn [(write-header [output files]
+            (let [sections [:v1/files :v1/rels :v1/sobjects]
+                  mdata    {:penpot-version (:full cf/version)
+                            :sections sections
+                            :files files}]
+              (write-header! output :version 1 :metadata mdata)))
+
+          (write-files [output files sids]
+            (l/debug :hint "write section" :section :v1/files :total (count files) ::l/async false)
+            (write-label! output :v1/files)
+            (doseq [file-id files]
+              (let [file  (cond-> (retrieve-file pool file-id)
+                            embed-assets? (update :data embed-file-assets file-id))
+                    media (retrieve-file-media pool file)]
+
+                ;; Collect all storage ids for later write them all under
+                ;; specific storage objects section.
+                (vswap! sids into (sequence storage-object-id-xf media))
+
+                (l/trace :hint "write penpot file"
+                         :id file-id
+                         :media (count media)
+                         ::l/async false)
+
+                (doto output
+                  (write-obj! file)
+                  (write-obj! media)))))
+
+          (write-rels [output files]
+            (let [rels (when include-libraries? (retrieve-library-relations pool files))]
+              (l/debug :hint "write section" :section :v1/rels :total (count rels) ::l/async false)
+              (doto output
+                (write-label! :v1/rels)
+                (write-obj! rels))))
+
+          (write-sobjects [output sids]
+            (l/debug :hint "write section"
+                     :section :v1/sobjects
+                     :items (count sids)
+                     ::l/async false)
+
+            ;; Write all collected storage objects
+            (doto output
+              (write-label! :v1/sobjects)
+              (write-obj! sids))
+
+            (let [storage (media/configure-assets-storage storage)]
+              (doseq [id sids]
+                (let [{:keys [size] :as obj} @(sto/get-object storage id)]
+                  (l/trace :hint "write sobject" :id id ::l/async false)
+
+                  (doto output
+                    (write-uuid! id)
+                    (write-obj! (meta obj)))
+
+                  (with-open [^InputStream stream @(sto/get-object-data storage obj)]
+                    (let [written (write-stream! output stream size)]
+                      (when (not= written size)
+                        (ex/raise :type :validation
+                                  :code :mismatch-readed-size
+                                  :hint (str/ffmt "found unexpected object size; size=% written=%" size written)))))))))
+
+          (embed-file-assets [data file-id]
+            (binding [*file-id* file-id]
+              (let [assets (volatile! [])]
+                (walk/postwalk #(cond-> % (map? %) (walk-map-form assets)) data)
+                (->> (deref assets)
+                     (filter #(as-> (first %) $ (and (uuid? $) (not= $ file-id))))
+                     (d/group-by first rest)
+                     (reduce process-group-of-assets data)))))
+
+          (walk-map-form [form state]
+            (cond
+              (uuid? (:fill-color-ref-file form))
+              (do
+                (vswap! state conj [(:fill-color-ref-file form) :colors (:fill-color-ref-id form)])
+                (assoc form :fill-color-ref-file *file-id*))
+
+              (uuid? (:stroke-color-ref-file form))
+              (do
+                (vswap! state conj [(:stroke-color-ref-file form) :colors (:stroke-color-ref-id form)])
+                (assoc form :stroke-color-ref-file *file-id*))
+
+              (uuid? (:typography-ref-file form))
+              (do
+                (vswap! state conj [(:typography-ref-file form) :typographies (:typography-ref-id form)])
+                (assoc form :typography-ref-file *file-id*))
+
+              (uuid? (:component-file form))
+              (do
+                (vswap! state conj [(:component-file form) :components (:component-id form)])
+                (assoc form :component-file *file-id*))
+
+              :else
+              form))
+
+          (process-group-of-assets [data [lib-id items]]
+            ;; NOTE: there are a posibility that shape refers to a not
+            ;; existing file because the file was removed. In this
+            ;; case we just ignore the asset.
+            (if-let [lib (retrieve-file pool lib-id)]
+              (reduce #(process-asset %1 lib %2) data items)
+              data))
+
+          (process-asset [data lib [bucket asset-id]]
+            (let [asset (get-in lib [:data bucket asset-id])
+                  ;; Add a special case for colors that need to have
+                  ;; correctly set the :file-id prop (pending of the
+                  ;; refactor that will remove it).
+                  asset (cond-> asset
+                          (= bucket :colors) (assoc :file-id *file-id*))]
+              (update data bucket assoc asset-id asset)))]
+
+    (with-open [output (bs/zstd-output-stream output :level 12)]
+      (with-open [output (bs/data-output-stream output)]
+        (let [libs  (when include-libraries? (retrieve-libraries pool file-ids))
+              files (into file-ids libs)
+              sids  (volatile! #{})]
+
+          ;; Write header with metadata
+          (l/debug :hint "exportation summary"
+                   :files (count files)
+                   :embed-assets? embed-assets?
+                   :include-libs? include-libraries?
+                   ::l/async false)
+
+          (write-header output files)
+          (write-files output files sids)
+          (write-rels output files)
+          (write-sobjects output (vec @sids)))))))
+
+(s/def ::project-id ::us/uuid)
+(s/def ::input bs/input-stream?)
+(s/def ::overwrite? (s/nilable ::us/boolean))
+(s/def ::migrate? (s/nilable ::us/boolean))
+(s/def ::ignore-index-errors? (s/nilable ::us/boolean))
+
+(s/def ::read-import-options
+  (s/keys :req-un [::db/pool ::sto/storage]
+          :req    [::project-id ::input]
+          :opt    [::overwrite? ::migrate? ::ignore-index-errors?]))
+
+(defn read-import!
+  "Do the importation of the specified resource in penpot custom binary
+  format. There are some options for customize the importation
+  behavior:
+
+  `::overwrite?`: if true, instead of creating new files and remaping id references,
+  it reuses all ids and updates existing objects; defaults to `false`.
+
+  `::migrate?`: if true, applies the migration before persisting the
+  file data; defaults to `false`.
+
+  `::ignore-index-errors?`: if true, do not fail on index lookup errors, can
+  happen with broken files; defaults to: `false`.
+  "
+
+  [{:keys [pool storage ::project-id ::timestamp ::input ::overwrite? ::migrate? ::ignore-index-errors?]
+    :or {overwrite? false migrate? false timestamp (dt/now)}
+    :as options}]
+
+  (us/assert! ::read-import-options options)
+
+  (letfn [(lookup-index [id]
+            (if ignore-index-errors?
+              (or (get @*index* id) id)
+              (let [val (get @*index* id)]
+                (l/trace :fn "lookup-index" :id id :val val ::l/async false)
+                (when-not val
+                  (ex/raise :type :validation
+                            :code :incomplete-index
+                            :hint "looks like index has missing data"))
+                val)))
+
+          (update-index [index coll]
+            (loop [items (seq coll)
+                   index index]
+              (if-let [id (first items)]
+                (let [new-id (if overwrite? id (uuid/next))]
+                  (l/trace :fn "update-index" :id id :new-id new-id ::l/async false)
+                  (recur (rest items)
+                         (assoc index id new-id)))
+                index)))
+
+          (process-map-form [form]
+            (cond-> form
+              ;; Relink Image Shapes
+              (and (map? (:metadata form))
+                   (= :image (:type form)))
+              (update-in [:metadata :id] lookup-index)
+
+              ;; This covers old shapes and the new :fills.
+              (uuid? (:fill-color-ref-file form))
+              (update :fill-color-ref-file lookup-index)
+
+              ;; This covers the old shapes and the new :strokes
+              (uuid? (:storage-color-ref-file form))
+              (update :stroke-color-ref-file lookup-index)
+
+              ;; This covers all text shapes that have typography referenced
+              (uuid? (:typography-ref-file form))
+              (update :typography-ref-file lookup-index)
+
+              ;; This covers the shadows and grids (they have directly
+              ;; the :file-id prop)
+              (uuid? (:file-id form))
+              (update :file-id lookup-index)))
+
+          ;; a function responsible to analyze all file data and
+          ;; replace the old :component-file reference with the new
+          ;; ones, using the provided file-index
+          (relink-shapes [data]
+            (walk/postwalk (fn [form]
+                             (if (map? form)
+                               (try
+                                 (process-map-form form)
+                                 (catch Throwable cause
+                                   (l/trace :hint "failed form" :form (pr-str form) ::l/async false)
+                                   (throw cause)))
+                               form))
+                           data))
+
+          ;; A function responsible of process the :media attr of file
+          ;; data and remap the old ids with the new ones.
+          (relink-media [media]
+            (reduce-kv (fn [res k v]
+                         (let [id (lookup-index k)]
+                           (if (uuid? id)
+                             (-> res
+                                 (assoc id (assoc v :id id))
+                                 (dissoc k))
+                             res)))
+                       media
+                       media))
+
+          (create-or-update-file [params]
+            (let [sql (str "INSERT INTO file (id, project_id, name, revn, is_shared, data, created_at, modified_at) "
+                           "VALUES (?, ?, ?, ?, ?, ?, ?, ?) "
+                           "ON CONFLICT (id) DO UPDATE SET data=?")]
+              (db/exec-one! *conn* [sql
+                                    (:id params)
+                                    (:project-id params)
+                                    (:name params)
+                                    (:revn params)
+                                    (:is-shared params)
+                                    (:data params)
+                                    (:created-at params)
+                                    (:modified-at params)
+                                    (:data params)])))
+
+          (read-files-section! [input expected-files]
+            (l/debug :hint "reading section" :section :v1/files ::l/async false)
+            (assert-read-label! input :v1/files)
+
+            ;; Process/Read all file
+            (doseq [expected-file-id expected-files]
+              (let [file    (read-obj! input)
+                    media'  (read-obj! input)
+                    file-id (:id file)]
+
+                (when (not= file-id expected-file-id)
+                  (ex/raise :type :validation
+                            :code :inconsistent-penpot-file
+                            :hint "the penpot file seems corrupt, found unexpected uuid (file-id)"))
+
+
+                ;; Update index using with media
+                (l/trace :hint "update index with media" ::l/async false)
+                (vswap! *index* update-index (map :id media'))
+
+                ;; Store file media for later insertion
+                (l/trace :hint "update media references" ::l/async false)
+                (vswap! *media* into (map #(update % :id lookup-index)) media')
+
+                (l/trace :hint "procesing file" :file-id file-id ::l/async false)
+
+                (let [file-id' (lookup-index file-id)
+                      data     (-> (:data file)
+                                   (assoc :id file-id')
+                                   (cond-> migrate? (pmg/migrate-data))
+                                   (update :pages-index relink-shapes)
+                                   (update :components relink-shapes)
+                                   (update :media relink-media))
+
+                      params  {:id file-id'
+                               :project-id project-id
+                               :name (str "Imported: " (:name file))
+                               :revn (:revn file)
+                               :is-shared (:is-shared file)
+                               :data (blob/encode data)
+                               :created-at timestamp
+                               :modified-at timestamp}]
+
+                  (l/trace :hint "create file" :id file-id' ::l/async false)
+
+                  (if overwrite?
+                    (create-or-update-file params)
+                    (db/insert! *conn* :file params))
+
+                  (when overwrite?
+                    (db/delete! *conn* :file-thumbnail {:file-id file-id'}))))))
+
+          (read-rels-section! [input]
+            (l/debug :hint "reading section" :section :v1/rels ::l/async false)
+            (assert-read-label! input :v1/rels)
+
+            (let [rels (read-obj! input)]
+              ;; Insert all file relations
+              (doseq [rel rels]
+                (let [rel (-> rel
+                              (assoc :synced-at timestamp)
+                              (update :file-id lookup-index)
+                              (update :library-file-id lookup-index))]
+                  (l/trace :hint "create file library link"
+                           :file-id (:file-id rel)
+                           :lib-id (:library-file-id rel)
+                           ::l/async false)
+                  (db/insert! *conn* :file-library-rel rel)))))
+
+          (read-sobjects-section! [input]
+            (l/debug :hint "reading section" :section :v1/sobjects ::l/async false)
+            (assert-read-label! input :v1/sobjects)
+
+            (let [storage (media/configure-assets-storage storage)
+                  ids     (read-obj! input)]
+
+              ;; Step 1: process all storage objects
+              (doseq [expected-storage-id ids]
+                (let [id    (read-uuid! input)
+                      mdata (read-obj! input)]
+
+                  (when (not= id expected-storage-id)
+                    (ex/raise :type :validation
+                              :code :inconsistent-penpot-file
+                              :hint "the penpot file seems corrupt, found unexpected uuid (storage-object-id)"))
+
+                  (l/trace :hint "readed storage object" :id id ::l/async false)
+
+                  (let [[size resource] (read-stream! input)
+                        hash            (sto/calculate-hash resource)
+                        content         (-> (sto/content resource size)
+                                            (sto/wrap-with-hash hash))
+                        params          (-> mdata
+                                            (assoc ::sto/deduplicate? true)
+                                            (assoc ::sto/content content)
+                                            (assoc ::sto/touched-at (dt/now)))
+                        sobject         @(sto/put-object! storage params)]
+                    (l/trace :hint "persisted storage object" :id id :new-id (:id sobject) ::l/async false)
+                    (vswap! *index* assoc id (:id sobject)))))
+
+              ;; Step 2: insert all file-media-object rows with correct
+              ;; storage-id reference.
+              (doseq [item @*media*]
+                (l/trace :hint "inserting file media objects" :id (:id item) ::l/async false)
+                (db/insert! *conn* :file-media-object
+                            (-> item
+                                (update :file-id lookup-index)
+                                (d/update-when :media-id lookup-index)
+                                (d/update-when :thumbnail-id lookup-index))
+                            {:on-conflict-do-nothing overwrite?}))))]
+
+    (with-open [input (bs/zstd-input-stream input)]
+      (with-open [input (bs/data-input-stream input)]
+        (db/with-atomic [conn pool]
+          (db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED;"])
+
+          ;; Verify that we received a proper .penpot file
+          (let [{:keys [sections files]} (read-header! input)]
+            (l/debug :hint "import verified" :files files :overwrite? overwrite?)
+            (binding [*index* (volatile! (update-index {} files))
+                      *media* (volatile! [])
+                      *conn*  conn]
+
+              (doseq [section sections]
+                (case section
+                  :v1/rels (read-rels-section! input)
+                  :v1/files (read-files-section! input files)
+                  :v1/sobjects (read-sobjects-section! input))))))))))
+
+(defn export!
+  [cfg]
+  (let [path (tmp/tempfile :prefix "penpot.export.")
+        id   (uuid/next)
+        ts   (dt/now)
+        cs   (volatile! nil)]
+    (try
+      (l/info :hint "start exportation" :export-id id)
+      (with-open [output (io/output-stream path)]
+        (binding [*position* (atom 0)]
+          (write-export! (assoc cfg ::output output))
+          path))
+
+      (catch Throwable cause
+        (vreset! cs cause)
+        (throw cause))
+
+      (finally
+        (l/info :hint "exportation finished" :export-id id
+                :elapsed (str (inst-ms (dt/diff ts (dt/now))) "ms")
+                :cause @cs)))))
+
+(defn import!
+  [{:keys [::input] :as cfg}]
+  (let [id (uuid/next)
+        ts (dt/now)
+        cs (volatile! nil)]
+    (try
+      (l/info :hint "start importation" :import-id id)
+      (binding [*position* (atom 0)]
+        (with-open [input (io/input-stream input)]
+          (read-import! (assoc cfg ::input input))))
+
+      (catch Throwable cause
+        (vreset! cs cause)
+        (throw cause))
+
+      (finally
+        (l/info :hint "importation finished" :import-id id
+                :elapsed (str (inst-ms (dt/diff ts (dt/now))) "ms")
+                :error? (some? @cs)
+                :cause @cs)))))
+
+;; --- Command: export-binfile
+
+(s/def ::file-id ::us/uuid)
+(s/def ::profile-id ::us/uuid)
+(s/def ::include-libraries? ::us/boolean)
+(s/def ::embed-assets? ::us/boolean)
+
+(s/def ::export-binfile
+  (s/keys :req-un [::profile-id ::file-id ::include-libraries? ::embed-assets?]))
+
+(sv/defmethod ::export-binfile
+  "Export a penpot file in a binary format."
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id include-libraries? embed-assets?] :as params}]
+  (db/with-atomic [conn pool]
+    (files/check-read-permissions! conn profile-id file-id)
+    (let [path (export! (assoc cfg
+                               ::file-ids [file-id]
+                               ::embed-assets? embed-assets?
+                               ::include-libraries? include-libraries?))]
+      (with-meta {}
+        {:transform-response (fn [_ response]
+                               (assoc response
+                                      :body (io/input-stream path)
+                                      :headers {"content-type" "application/octet-stream"}))}))))
+
+(s/def ::file ::media/upload)
+(s/def ::import-binfile
+  (s/keys :req-un [::profile-id ::project-id ::file]))
+
+(sv/defmethod ::import-binfile
+  "Import a penpot file in a binary format."
+  [{:keys [pool] :as cfg} {:keys [profile-id project-id file] :as params}]
+  (db/with-atomic [conn pool]
+    (projects/check-read-permissions! conn profile-id project-id)
+    (import! (assoc cfg
+                    ::input (:path file)
+                    ::project-id project-id
+                    ::ignore-index-errors? true))))

backend/src/app/rpc/commands/demo.clj

@@ -4,7 +4,7 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.rpc.mutations.demo
+(ns app.rpc.commands.demo
   "A demo specific mutations."
   (:require
    [app.common.exceptions :as ex]
@@ -12,7 +12,7 @@
    [app.config :as cf]
    [app.db :as db]
    [app.loggers.audit :as audit]
-   [app.rpc.mutations.profile :as profile]
+   [app.rpc.commands.auth :as cmd.auth]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [buddy.core.codecs :as bc]
@@ -45,8 +45,8 @@
                 :hint "Demo users are disabled by config."))
 
     (db/with-atomic [conn pool]
-      (->> (#'profile/create-profile conn params)
+      (->> (cmd.auth/create-profile conn params)
-           (#'profile/create-profile-relations conn))
+           (cmd.auth/create-profile-relations conn))
 
       (with-meta {:email email
                   :password password}

backend/src/app/rpc/commands/ldap.clj

@@ -0,0 +1,75 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.rpc.commands.ldap
+  (:require
+   [app.auth.ldap :as ldap]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.db :as db]
+   [app.loggers.audit :as-alias audit]
+   [app.rpc.commands.auth :as cmd.auth]
+   [app.rpc.queries.profile :as profile]
+   [app.util.services :as sv]
+   [clojure.spec.alpha :as s]))
+
+;; --- COMMAND: login-with-ldap
+
+(declare login-or-register)
+
+(s/def ::email ::us/email)
+(s/def ::password ::us/string)
+(s/def ::invitation-token ::us/string)
+
+(s/def ::login-with-ldap
+  (s/keys :req-un [::email ::password]
+          :opt-un [::invitation-token]))
+
+(sv/defmethod ::login-with-ldap {:auth false}
+  [{:keys [session tokens ldap] :as cfg} params]
+  (when-not ldap
+    (ex/raise :type :restriction
+              :code :ldap-not-initialized
+              :hide "ldap auth provider is not initialized"))
+
+  (let [info (ldap/authenticate ldap params)]
+    (when-not info
+      (ex/raise :type :validation
+                :code :wrong-credentials))
+
+    (let [profile (login-or-register cfg info)]
+      (if-let [token (:invitation-token params)]
+        ;; If invitation token comes in params, this is because the
+        ;; user comes from team-invitation process; in this case,
+        ;; regenerate token and send back to the user a new invitation
+        ;; token (and mark current session as logged).
+        (let [claims (tokens :verify {:token token :iss :team-invitation})
+              claims (assoc claims
+                            :member-id  (:id profile)
+                            :member-email (:email profile))
+              token  (tokens :generate claims)]
+          (with-meta {:invitation-token token}
+            {:transform-response ((:create session) (:id profile))
+             ::audit/props (:props profile)
+             ::audit/profile-id (:id profile)}))
+
+        (with-meta profile
+          {:transform-response ((:create session) (:id profile))
+           ::audit/props (:props profile)
+           ::audit/profile-id (:id profile)})))))
+
+(defn- login-or-register
+  [{:keys [pool] :as cfg} info]
+  (db/with-atomic [conn pool]
+    (or (some->> (:email info)
+                 (profile/retrieve-profile-data-by-email conn)
+                 (profile/populate-additional-data conn)
+                 (profile/decode-profile-row))
+        (->> (assoc info :is-active true :is-demo false)
+             (cmd.auth/create-profile conn)
+             (cmd.auth/create-profile-relations conn)
+             (profile/strip-private-attrs)))))
+

backend/src/app/rpc/mutations/comments.clj

@@ -26,19 +26,21 @@
 
 (s/def ::page-id ::us/uuid)
 (s/def ::file-id ::us/uuid)
+(s/def ::share-id (s/nilable ::us/uuid))
 (s/def ::profile-id ::us/uuid)
 (s/def ::position ::gpt/point)
 (s/def ::content ::us/string)
 
 (s/def ::create-comment-thread
-  (s/keys :req-un [::profile-id ::file-id ::position ::content ::page-id]))
+  (s/keys :req-un [::profile-id ::file-id ::position ::content ::page-id]
+          :opt-un [::share-id]))
 
 (sv/defmethod ::create-comment-thread
   {::retry/max-retries 3
    ::retry/matches retry/conflict-db-insert?}
-  [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id share-id] :as params}]
   (db/with-atomic [conn pool]
-    (files/check-read-permissions! conn profile-id file-id)
+    (files/check-comment-permissions! conn profile-id file-id share-id)
     (create-comment-thread conn params)))
 
 (defn- retrieve-next-seqn
@@ -92,18 +94,20 @@
 ;; --- Mutation: Update Comment Thread Status
 
 (s/def ::id ::us/uuid)
+(s/def ::share-id (s/nilable ::us/uuid))
 
 (s/def ::update-comment-thread-status
-  (s/keys :req-un [::profile-id ::id]))
+  (s/keys :req-un [::profile-id ::id]
+          :opt-un [::share-id]))
 
 (sv/defmethod ::update-comment-thread-status
-  [{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
+  [{:keys [pool] :as cfg} {:keys [profile-id id share-id] :as params}]
   (db/with-atomic [conn pool]
     (let [cthr (db/get-by-id conn :comment-thread id {:for-update true})]
       (when-not cthr
         (ex/raise :type :not-found))
 
-      (files/check-read-permissions! conn profile-id (:file-id cthr))
+      (files/check-comment-permissions! conn profile-id (:file-id cthr) share-id)
       (upsert-comment-thread-status! conn profile-id (:id cthr)))))
 
 (def sql:upsert-comment-thread-status
@@ -122,16 +126,17 @@
 
 (s/def ::is-resolved ::us/boolean)
 (s/def ::update-comment-thread
-  (s/keys :req-un [::profile-id ::id ::is-resolved]))
+  (s/keys :req-un [::profile-id ::id ::is-resolved]
+          :opt-un [::share-id]))
 
 (sv/defmethod ::update-comment-thread
-  [{:keys [pool] :as cfg} {:keys [profile-id id is-resolved] :as params}]
+  [{:keys [pool] :as cfg} {:keys [profile-id id is-resolved share-id] :as params}]
   (db/with-atomic [conn pool]
     (let [thread (db/get-by-id conn :comment-thread id {:for-update true})]
       (when-not thread
         (ex/raise :type :not-found))
 
-      (files/check-read-permissions! conn profile-id (:file-id thread))
+      (files/check-comment-permissions! conn profile-id (:file-id thread) share-id)
 
       (db/update! conn :comment-thread
                   {:is-resolved is-resolved}
@@ -142,10 +147,11 @@
 ;; --- Mutation: Add Comment
 
 (s/def ::add-comment
-  (s/keys :req-un [::profile-id ::thread-id ::content]))
+  (s/keys :req-un [::profile-id ::thread-id ::content]
+          :opt-un [::share-id]))
 
 (sv/defmethod ::add-comment
-  [{:keys [pool] :as cfg} {:keys [profile-id thread-id content] :as params}]
+  [{:keys [pool] :as cfg} {:keys [profile-id thread-id content share-id] :as params}]
   (db/with-atomic [conn pool]
     (let [thread (-> (db/get-by-id conn :comment-thread thread-id {:for-update true})
                      (comments/decode-row))
@@ -155,7 +161,7 @@
       (when-not thread (ex/raise :type :not-found))
 
       ;; Permission Checks
-      (files/check-read-permissions! conn profile-id (:file-id thread))
+      (files/check-comment-permissions! conn profile-id (:file-id thread) share-id)
 
       ;; Update the page-name cachedattribute on comment thread table.
       (when (not= pname (:page-name thread))
@@ -199,10 +205,11 @@
 ;; --- Mutation: Update Comment
 
 (s/def ::update-comment
-  (s/keys :req-un [::profile-id ::id ::content]))
+  (s/keys :req-un [::profile-id ::id ::content]
+          :opt-un [::share-id]))
 
 (sv/defmethod ::update-comment
-  [{:keys [pool] :as cfg} {:keys [profile-id id content] :as params}]
+  [{:keys [pool] :as cfg} {:keys [profile-id id content share-id] :as params}]
   (db/with-atomic [conn pool]
     (let [comment (db/get-by-id conn :comment id {:for-update true})
           _       (when-not comment (ex/raise :type :not-found))
@@ -210,7 +217,7 @@
           _       (when-not thread (ex/raise :type :not-found))
           pname   (retrieve-page-name conn thread)]
 
-      (files/check-read-permissions! conn profile-id (:file-id thread))
+      (files/check-comment-permissions! conn profile-id (:file-id thread) share-id)
 
       ;; Don't allow edit comments to not owners
       (when-not (= (:owner-id thread) profile-id)

backend/src/app/rpc/mutations/files.clj

@@ -6,6 +6,7 @@
 
 (ns app.rpc.mutations.files
   (:require
+   [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.pages :as cp]
    [app.common.pages.migrations :as pmg]
@@ -63,21 +64,23 @@
          (db/insert! conn :file-profile-rel))))
 
 (defn create-file
-  [conn {:keys [id name project-id is-shared data deleted-at revn]
+  [conn {:keys [id name project-id is-shared data revn
-         :or {is-shared false
+                modified-at deleted-at ignore-sync-until]
-              revn 0
+         :or {is-shared false revn 0}
-              deleted-at nil}
          :as params}]
   (let [id   (or id (:id data) (uuid/next))
         data (or data (cp/make-file-data id))
         file (db/insert! conn :file
-                         {:id id
+                         (d/without-nils
-                          :project-id project-id
+                          {:id id
-                          :name name
+                           :project-id project-id
-                          :revn revn
+                           :name name
-                          :is-shared is-shared
+                           :revn revn
-                          :data (blob/encode data)
+                           :is-shared is-shared
-                          :deleted-at deleted-at})]
+                           :data (blob/encode data)
+                           :ignore-sync-until ignore-sync-until
+                           :modified-at modified-at
+                           :deleted-at deleted-at}))]
 
     (->> (assoc params :file-id id :role :owner)
          (create-file-role conn))

backend/src/app/rpc/mutations/fonts.clj

@@ -71,9 +71,9 @@
             data)
 
           (persist-font-object [data mtype]
-            (when-let [fdata (get data mtype)]
+            (when-let [resource (get data mtype)]
-              (p/let [hash    (calculate-hash fdata)
+              (p/let [hash    (calculate-hash resource)
-                      content (-> (sto/content fdata)
+                      content (-> (sto/content resource)
                                   (sto/wrap-with-hash hash))]
                 (sto/put-object! storage {::sto/content content
                                           ::sto/touched-at (dt/now)

backend/src/app/rpc/mutations/ldap.clj

@@ -1,140 +0,0 @@
-;; This Source Code Form is subject to the terms of the Mozilla Public
-;; License, v. 2.0. If a copy of the MPL was not distributed with this
-;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
-;;
-;; Copyright (c) UXBOX Labs SL
-
-(ns app.rpc.mutations.ldap
-  (:require
-   [app.common.exceptions :as ex]
-   [app.common.logging :as l]
-   [app.common.spec :as us]
-   [app.config :as cfg]
-   [app.db :as db]
-   [app.loggers.audit :as audit]
-   [app.rpc.mutations.profile :as profile-m]
-   [app.rpc.queries.profile :as profile-q]
-   [app.util.services :as sv]
-   [clj-ldap.client :as ldap]
-   [clojure.spec.alpha :as s]
-   [clojure.string]))
-
-
-(s/def ::fullname ::us/not-empty-string)
-(s/def ::email ::us/email)
-(s/def ::backend ::us/not-empty-string)
-
-(s/def ::info-data
-  (s/keys :req-un [::fullname ::email ::backend]))
-
-(defn ^java.lang.AutoCloseable connect
-  []
-  (let [params {:ssl?      (cfg/get :ldap-ssl)
-                :startTLS? (cfg/get :ldap-starttls)
-                :bind-dn   (cfg/get :ldap-bind-dn)
-                :password  (cfg/get :ldap-bind-password)
-                :host      {:address (cfg/get :ldap-host)
-                            :port    (cfg/get :ldap-port)}}]
-    (try
-      (ldap/connect params)
-      (catch Exception e
-        (ex/raise :type :restriction
-                  :code :ldap-disabled
-                  :hint "ldap disabled or unable to connect"
-                  :cause e)))))
-
-;; --- Mutation: login-with-ldap
-
-(declare authenticate)
-(declare login-or-register)
-
-(s/def ::email ::us/email)
-(s/def ::password ::us/string)
-(s/def ::invitation-token ::us/string)
-
-(s/def ::login-with-ldap
-  (s/keys :req-un [::email ::password]
-          :opt-un [::invitation-token]))
-
-(sv/defmethod ::login-with-ldap {:auth false}
-  [{:keys [pool session tokens] :as cfg} params]
-  (db/with-atomic [conn pool]
-    (let [info (authenticate params)
-          cfg  (assoc cfg :conn conn)]
-
-      (when-not info
-        (ex/raise :type :validation
-                  :code :wrong-credentials))
-
-      (when-not (s/valid? ::info-data info)
-        (let [explain (s/explain-str ::info-data info)]
-          (l/warn ::l/raw (str "invalid response from ldap, looks like ldap is not configured correctly\n" explain))
-          (ex/raise :type :restriction
-                    :code :wrong-ldap-response
-                    :reason explain)))
-
-      (let [profile (login-or-register cfg {:email (:email info)
-                                            :backend (:backend info)
-                                            :fullname (:fullname info)})]
-        (if-let [token (:invitation-token params)]
-          ;; If invitation token comes in params, this is because the
-          ;; user comes from team-invitation process; in this case,
-          ;; regenerate token and send back to the user a new invitation
-          ;; token (and mark current session as logged).
-          (let [claims (tokens :verify {:token token :iss :team-invitation})
-                claims (assoc claims
-                              :member-id  (:id profile)
-                              :member-email (:email profile))
-                token  (tokens :generate claims)]
-            (with-meta {:invitation-token token}
-              {:transform-response ((:create session) (:id profile))
-               ::audit/props (:props profile)
-               ::audit/profile-id (:id profile)}))
-
-          (with-meta profile
-            {:transform-response ((:create session) (:id profile))
-             ::audit/props (:props profile)
-             ::audit/profile-id (:id profile)}))))))
-
-(defn- replace-several [s & {:as replacements}]
-  (reduce-kv clojure.string/replace s replacements))
-
-(defn- get-ldap-user
-  [cpool {:keys [email] :as params}]
-  (let [query   (-> (cfg/get :ldap-user-query)
-                    (replace-several ":username" email))
-
-        attrs   [(cfg/get :ldap-attrs-username)
-                 (cfg/get :ldap-attrs-email)
-                 (cfg/get :ldap-attrs-photo)
-                 (cfg/get :ldap-attrs-fullname)]
-
-        base-dn (cfg/get :ldap-base-dn)
-        params  {:filter query
-                 :sizelimit 1
-                 :attributes attrs}]
-    (first (ldap/search cpool base-dn params))))
-
-(defn- authenticate
-  [{:keys [password email] :as params}]
-  (with-open [conn (connect)]
-    (when-let [{:keys [dn] :as luser} (get-ldap-user conn params)]
-      (when (ldap/bind? conn dn password)
-        {:photo    (get luser (keyword (cfg/get :ldap-attrs-photo)))
-         :fullname (get luser (keyword (cfg/get :ldap-attrs-fullname)))
-         :email    email
-         :backend  "ldap"}))))
-
-(defn- login-or-register
-  [{:keys [conn] :as cfg} info]
-  (or (some->> (:email info)
-               (profile-q/retrieve-profile-data-by-email conn)
-               (profile-q/populate-additional-data conn)
-               (profile-q/decode-profile-row))
-      (let [params  (-> info
-                        (assoc :is-active true)
-                        (assoc :is-demo false))]
-        (->> params
-             (profile-m/create-profile conn)
-             (profile-m/create-profile-relations conn)
-             (profile-q/strip-private-attrs)))))

backend/src/app/rpc/mutations/media.clj

@@ -17,6 +17,8 @@
    [app.rpc.queries.teams :as teams]
    [app.rpc.rlimit :as rlimit]
    [app.storage :as sto]
+   [app.storage.tmp :as tmp]
+   [app.util.bytes :as bs]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
@@ -179,11 +181,12 @@
   (* 1024 1024 100)) ; 100MiB
 
 (defn- create-file-media-object-from-url
-  [{:keys [storage http-client] :as cfg} {:keys [url name] :as params}]
+  [{:keys [http-client] :as cfg} {:keys [url name] :as params}]
   (letfn [(parse-and-validate-size [headers]
             (let [size   (some-> (get headers "content-length") d/parse-integer)
                   mtype  (get headers "content-type")
                   format (cm/mtype->format mtype)]
+
               (when-not size
                 (ex/raise :type :validation
                           :code :unknown-size
@@ -203,24 +206,24 @@
                :mtype mtype
                :format format}))
 
-          (get-upload-object [sobj]
-            (p/let [path  (sto/get-object-path storage sobj)
-                    mdata (meta sobj)]
-              {:filename "tempfile"
-               :size (:size sobj)
-               :path path
-               :mtype (:content-type mdata)}))
-
           (download-media [uri]
-            (p/let [{:keys [body headers]} (http-client {:method :get :uri uri} {:response-type :input-stream})
+            (-> (http-client {:method :get :uri uri} {:response-type :input-stream})
-                    {:keys [size mtype]} (parse-and-validate-size headers)]
+                (p/then process-response)))
 
-              (-> (assoc storage :backend :tmp)
+          (process-response [{:keys [body headers] :as response}]
-                  (sto/put-object! {::sto/content (sto/content body size)
+            (let [{:keys [size mtype]} (parse-and-validate-size headers)
-                                    ::sto/expired-at (dt/in-future {:minutes 30})
+                  path                 (tmp/tempfile :prefix "penpot.media.download.")
-                                    :content-type mtype
+                  written              (bs/write-to-file! body path :size size)]
-                                    :bucket "file-media-object"})
+
-                  (p/then get-upload-object))))]
+              (when (not= written size)
+                (ex/raise :type :internal
+                          :code :mismatch-write-size
+                          :hint "unexpected state: unable to write to file"))
+
+              {:filename "tempfile"
+               :size size
+               :path path
+               :mtype mtype}))]
 
     (p/let [content (download-media url)]
       (->> (merge params {:content content :name (or name (:filename content))})

backend/src/app/rpc/mutations/profile.clj

@@ -9,19 +9,18 @@
    [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
-   [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
    [app.emails :as eml]
    [app.loggers.audit :as audit]
    [app.media :as media]
+   [app.rpc.commands.auth :as cmd.auth]
    [app.rpc.mutations.teams :as teams]
    [app.rpc.queries.profile :as profile]
    [app.rpc.rlimit :as rlimit]
    [app.storage :as sto]
    [app.util.services :as sv]
    [app.util.time :as dt]
-   [buddy.hashers :as hashers]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [promesa.core :as p]
@@ -37,310 +36,6 @@
 (s/def ::password ::us/not-empty-string)
 (s/def ::old-password ::us/not-empty-string)
 (s/def ::theme ::us/string)
-(s/def ::invitation-token ::us/not-empty-string)
-
-(declare check-profile-existence!)
-(declare create-profile)
-(declare create-profile-relations)
-(declare register-profile)
-
-(defn email-domain-in-whitelist?
-  "Returns true if email's domain is in the given whitelist or if
-  given whitelist is an empty string."
-  [domains email]
-  (if (or (empty? domains)
-          (nil? domains))
-    true
-    (let [[_ candidate] (-> (str/lower email)
-                            (str/split #"@" 2))]
-      (contains? domains candidate))))
-
-(def ^:private sql:profile-existence
-  "select exists (select * from profile
-                   where email = ?
-                     and deleted_at is null) as val")
-
-(defn check-profile-existence!
-  [conn {:keys [email] :as params}]
-  (let [email  (str/lower email)
-        result (db/exec-one! conn [sql:profile-existence email])]
-    (when (:val result)
-      (ex/raise :type :validation
-                :code :email-already-exists))
-    params))
-
-(defn derive-password
-  [password]
-  (hashers/derive password
-                  {:alg :argon2id
-                   :memory 16384
-                   :iterations 20
-                   :parallelism 2}))
-
-(defn verify-password
-  [attempt password]
-  (try
-    (hashers/verify attempt password)
-    (catch Exception _e
-      {:update false
-       :valid false})))
-
-(defn decode-profile-row
-  [{:keys [props] :as profile}]
-  (cond-> profile
-    (db/pgobject? props "jsonb")
-    (assoc :props (db/decode-transit-pgobject props))))
-
-;; --- MUTATION: Prepare Register
-
-(s/def ::prepare-register-profile
-  (s/keys :req-un [::email ::password]
-          :opt-un [::invitation-token]))
-
-(sv/defmethod ::prepare-register-profile {:auth false}
-  [{:keys [pool tokens] :as cfg} params]
-  (when-not (contains? cf/flags :registration)
-    (if-not (contains? params :invitation-token)
-      (ex/raise :type :restriction
-                :code :registration-disabled)
-      (let [invitation (tokens :verify {:token (:invitation-token params) :iss :team-invitation})]
-        (when-not (= (:email params) (:member-email invitation))
-          (ex/raise :type :restriction
-                    :code :email-does-not-match-invitation
-                    :hint "email should match the invitation")))))
-
-  (when-let [domains (cf/get :registration-domain-whitelist)]
-    (when-not (email-domain-in-whitelist? domains (:email params))
-      (ex/raise :type :validation
-                :code :email-domain-is-not-allowed)))
-
-  ;; Don't allow proceed in preparing registration if the profile is
-  ;; already reported as spammer.
-  (when (eml/has-bounce-reports? pool (:email params))
-    (ex/raise :type :validation
-              :code :email-has-permanent-bounces
-              :hint "looks like the email has one or many bounces reported"))
-
-  (check-profile-existence! pool params)
-
-  (when (= (str/lower (:email params))
-           (str/lower (:password params)))
-    (ex/raise :type :validation
-              :code :email-as-password
-              :hint "you can't use your email as password"))
-
-  (let [params {:email (:email params)
-                :password (:password params)
-                :invitation-token (:invitation-token params)
-                :backend "penpot"
-                :iss :prepared-register
-                :exp (dt/in-future "48h")}
-
-        token  (tokens :generate params)]
-    (with-meta {:token token}
-      {::audit/profile-id uuid/zero})))
-
-;; --- MUTATION: Register Profile
-
-(s/def ::token ::us/not-empty-string)
-(s/def ::register-profile
-  (s/keys :req-un [::token ::fullname]))
-
-(sv/defmethod ::register-profile
-  {:auth false ::rlimit/permits (cf/get :rlimit-password)}
-  [{:keys [pool] :as cfg} params]
-  (db/with-atomic [conn pool]
-    (-> (assoc cfg :conn conn)
-        (register-profile params))))
-
-(defn register-profile
-  [{:keys [conn tokens session] :as cfg} {:keys [token] :as params}]
-  (let [claims    (tokens :verify {:token token :iss :prepared-register})
-        params    (merge params claims)]
-    (check-profile-existence! conn params)
-    (let [is-active  (or (:is-active params)
-                         (contains? cf/flags :insecure-register))
-          profile    (->> (assoc params :is-active is-active)
-                          (create-profile conn)
-                          (create-profile-relations conn)
-                          (decode-profile-row))
-          invitation (when-let [token (:invitation-token params)]
-                       (tokens :verify {:token token :iss :team-invitation}))]
-      (cond
-        ;; If invitation token comes in params, this is because the user comes from team-invitation process;
-        ;; in this case, regenerate token and send back to the user a new invitation token (and mark current
-        ;; session as logged). This happens only if the invitation email matches with the register email.
-        (and (some? invitation) (= (:email profile) (:member-email invitation)))
-        (let [claims (assoc invitation :member-id  (:id profile))
-              token  (tokens :generate claims)
-              resp   {:invitation-token token}]
-          (with-meta resp
-            {:transform-response ((:create session) (:id profile))
-             ::audit/replace-props (audit/profile->props profile)
-             ::audit/profile-id (:id profile)}))
-
-        ;; If auth backend is different from "penpot" means user is
-        ;; registering using third party auth mechanism; in this case
-        ;; we need to mark this session as logged.
-        (not= "penpot" (:auth-backend profile))
-        (with-meta (profile/strip-private-attrs profile)
-          {:transform-response ((:create session) (:id profile))
-           ::audit/replace-props (audit/profile->props profile)
-           ::audit/profile-id (:id profile)})
-
-        ;; If the `:enable-insecure-register` flag is set, we proceed
-        ;; to sign in the user directly, without email verification.
-        (true? is-active)
-        (with-meta (profile/strip-private-attrs profile)
-          {:transform-response ((:create session) (:id profile))
-           ::audit/replace-props (audit/profile->props profile)
-           ::audit/profile-id (:id profile)})
-
-        ;; In all other cases, send a verification email.
-        :else
-        (let [vtoken (tokens :generate
-                             {:iss :verify-email
-                              :exp (dt/in-future "48h")
-                              :profile-id (:id profile)
-                              :email (:email profile)})
-              ptoken (tokens :generate-predefined
-                             {:iss :profile-identity
-                              :profile-id (:id profile)})]
-          (eml/send! {::eml/conn conn
-                      ::eml/factory eml/register
-                      :public-uri (:public-uri cfg)
-                      :to (:email profile)
-                      :name (:fullname profile)
-                      :token vtoken
-                      :extra-data ptoken})
-
-          (with-meta profile
-            {::audit/replace-props (audit/profile->props profile)
-             ::audit/profile-id (:id profile)}))))))
-
-(defn create-profile
-  "Create the profile entry on the database with limited input filling
-  all the other fields with defaults."
-  [conn params]
-  (let [id        (or (:id params) (uuid/next))
-
-        props     (-> (audit/extract-utm-params params)
-                      (merge (:props params))
-                      (db/tjson))
-
-        password  (if-let [password (:password params)]
-                    (derive-password password)
-                    "!")
-
-        locale    (:locale params)
-        locale    (when (and (string? locale) (not (str/blank? locale)))
-                    locale)
-
-        backend   (:backend params "penpot")
-        is-demo   (:is-demo params false)
-        is-muted  (:is-muted params false)
-        is-active (:is-active params false)
-        email     (str/lower (:email params))
-
-        params    {:id id
-                   :fullname (:fullname params)
-                   :email email
-                   :auth-backend backend
-                   :lang locale
-                   :password password
-                   :deleted-at (:deleted-at params)
-                   :props props
-                   :is-active is-active
-                   :is-muted is-muted
-                   :is-demo is-demo}]
-    (try
-      (-> (db/insert! conn :profile params)
-          (decode-profile-row))
-      (catch org.postgresql.util.PSQLException e
-        (let [state (.getSQLState e)]
-          (if (not= state "23505")
-            (throw e)
-            (ex/raise :type :validation
-                      :code :email-already-exists
-                      :cause e)))))))
-
-(defn create-profile-relations
-  [conn profile]
-  (let [team (teams/create-team conn {:profile-id (:id profile)
-                                      :name "Default"
-                                      :is-default true})]
-    (-> profile
-        (profile/strip-private-attrs)
-        (assoc :default-team-id (:id team))
-        (assoc :default-project-id (:default-project-id team)))))
-
-;; --- MUTATION: Login
-
-(s/def ::email ::us/email)
-(s/def ::scope ::us/string)
-
-(s/def ::login
-  (s/keys :req-un [::email ::password]
-          :opt-un [::scope ::invitation-token]))
-
-(sv/defmethod ::login
-  {:auth false ::rlimit/permits (cf/get :rlimit-password)}
-  [{:keys [pool session tokens] :as cfg} {:keys [email password] :as params}]
-
-  (when-not (contains? cf/flags :login)
-    (ex/raise :type :restriction
-              :code :login-disabled
-              :hint "login is disabled in this instance"))
-
-  (letfn [(check-password [profile password]
-            (when (= (:password profile) "!")
-              (ex/raise :type :validation
-                        :code :account-without-password))
-            (:valid (verify-password password (:password profile))))
-
-          (validate-profile [profile]
-            (when-not (:is-active profile)
-              (ex/raise :type :validation
-                        :code :wrong-credentials))
-            (when-not profile
-              (ex/raise :type :validation
-                        :code :wrong-credentials))
-            (when-not (check-password profile password)
-              (ex/raise :type :validation
-                        :code :wrong-credentials))
-            profile)]
-
-    (db/with-atomic [conn pool]
-      (let [profile    (->> (profile/retrieve-profile-data-by-email conn email)
-                            (validate-profile)
-                            (profile/strip-private-attrs)
-                            (profile/populate-additional-data conn)
-                            (decode-profile-row))
-
-            invitation (when-let [token (:invitation-token params)]
-                         (tokens :verify {:token token :iss :team-invitation}))
-
-            ;; If invitation member-id does not matches the profile-id, we just proceed to ignore the
-            ;; invitation because invitations matches exactly; and user can't loging with other email and
-            ;; accept invitation with other email
-            response   (if (and (some? invitation) (= (:id profile) (:member-id invitation)))
-                         {:invitation-token (:invitation-token params)}
-                         profile)]
-
-        (with-meta response
-          {:transform-response ((:create session) (:id profile))
-           ::audit/props (audit/profile->props profile)
-           ::audit/profile-id (:id profile)})))))
-
-;; --- MUTATION: Logout
-
-(s/def ::logout
-  (s/keys :opt-un [::profile-id]))
-
-(sv/defmethod ::logout {:auth false}
-  [{:keys [session] :as cfg} _]
-  (with-meta {}
-    {:transform-response (:delete session)}))
 
 ;; --- MUTATION: Update Profile (own)
 
@@ -414,7 +109,7 @@
 (defn- validate-password!
   [conn {:keys [profile-id old-password] :as params}]
   (let [profile (db/get-by-id conn :profile profile-id)]
-    (when-not (:valid (verify-password old-password (:password profile)))
+    (when-not (:valid (cmd.auth/verify-password old-password (:password profile)))
       (ex/raise :type :validation
                 :code :old-password-not-match))
     profile))
@@ -422,7 +117,7 @@
 (defn update-profile-password!
   [conn {:keys [id password] :as profile}]
   (db/update! conn :profile
-              {:password (derive-password password)}
+              {:password (cmd.auth/derive-password password)}
               {:id id}))
 
 ;; --- MUTATION: Update Photo
@@ -481,7 +176,7 @@
 (defn- change-email-immediately
   [{:keys [conn]} {:keys [profile email] :as params}]
   (when (not= email (:email profile))
-    (check-profile-existence! conn params))
+    (cmd.auth/check-profile-existence! conn params))
   (db/update! conn :profile
               {:email email}
               {:id (:id profile)})
@@ -499,7 +194,7 @@
                          :profile-id (:id profile)})]
 
     (when (not= email (:email profile))
-      (check-profile-existence! conn params))
+      (cmd.auth/check-profile-existence! conn params))
 
     (when-not (eml/allow-send-emails? conn profile)
       (ex/raise :type :validation
@@ -526,76 +221,6 @@
   [conn id]
   (db/get-by-id conn :profile id {:for-update true}))
 
-;; --- MUTATION: Request Profile Recovery
-
-(s/def ::request-profile-recovery
-  (s/keys :req-un [::email]))
-
-(sv/defmethod ::request-profile-recovery {:auth false}
-  [{:keys [pool tokens] :as cfg} {:keys [email] :as params}]
-  (letfn [(create-recovery-token [{:keys [id] :as profile}]
-            (let [token (tokens :generate
-                                {:iss :password-recovery
-                                 :exp (dt/in-future "15m")
-                                 :profile-id id})]
-              (assoc profile :token token)))
-
-          (send-email-notification [conn profile]
-            (let [ptoken (tokens :generate-predefined
-                                 {:iss :profile-identity
-                                  :profile-id (:id profile)})]
-              (eml/send! {::eml/conn conn
-                          ::eml/factory eml/password-recovery
-                          :public-uri (:public-uri cfg)
-                          :to (:email profile)
-                          :token (:token profile)
-                          :name (:fullname profile)
-                          :extra-data ptoken})
-              nil))]
-
-    (db/with-atomic [conn pool]
-      (when-let [profile (profile/retrieve-profile-data-by-email conn email)]
-        (when-not (eml/allow-send-emails? conn profile)
-          (ex/raise :type :validation
-                    :code :profile-is-muted
-                    :hint "looks like the profile has reported repeatedly as spam or has permanent bounces."))
-
-        (when-not (:is-active profile)
-          (ex/raise :type :validation
-                    :code :profile-not-verified
-                    :hint "the user need to validate profile before recover password"))
-
-        (when (eml/has-bounce-reports? conn (:email profile))
-          (ex/raise :type :validation
-                    :code :email-has-permanent-bounces
-                    :hint "looks like the email you invite has been repeatedly reported as spam or permanent bounce"))
-
-        (->> profile
-             (create-recovery-token)
-             (send-email-notification conn))))))
-
-
-;; --- MUTATION: Recover Profile
-
-(s/def ::token ::us/not-empty-string)
-(s/def ::recover-profile
-  (s/keys :req-un [::token ::password]))
-
-(sv/defmethod ::recover-profile
-  {:auth false ::rlimit/permits (cf/get :rlimit-password)}
-  [{:keys [pool tokens] :as cfg} {:keys [token password]}]
-  (letfn [(validate-token [token]
-            (let [tdata (tokens :verify {:token token :iss :password-recovery})]
-              (:profile-id tdata)))
-
-          (update-password [conn profile-id]
-            (let [pwd (derive-password password)]
-              (db/update! conn :profile {:password pwd} {:id profile-id})))]
-
-    (db/with-atomic [conn pool]
-      (->> (validate-token token)
-           (update-password conn))
-      nil)))
 
 ;; --- MUTATION: Update Profile Props
 
@@ -668,3 +293,61 @@
                 :code :owner-teams-with-people
                 :hint "The user need to transfer ownership of owned teams."
                 :context {:teams (mapv :team-id rows)}))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; DEPRECATED METHODS (TO BE REMOVED ON 1.16.x)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; --- MUTATION: Login
+
+(s/def ::login ::cmd.auth/login-with-password)
+
+(sv/defmethod ::login
+  {:auth false ::rlimit/permits (cf/get :rlimit-password)}
+  [cfg params]
+  (cmd.auth/login-with-password cfg params))
+
+;; --- MUTATION: Logout
+
+(s/def ::logout ::cmd.auth/logout)
+
+(sv/defmethod ::logout {:auth false}
+  [{:keys [session] :as cfg} _]
+  (with-meta {}
+    {:transform-response (:delete session)}))
+
+;; --- MUTATION: Recover Profile
+
+(s/def ::recover-profile ::cmd.auth/recover-profile)
+
+(sv/defmethod ::recover-profile
+  {:auth false ::rlimit/permits (cf/get :rlimit-password)}
+  [cfg params]
+  (cmd.auth/recover-profile cfg params))
+
+;; --- MUTATION: Prepare Register
+
+(s/def ::prepare-register-profile ::cmd.auth/prepare-register-profile)
+
+(sv/defmethod ::prepare-register-profile {:auth false}
+  [cfg params]
+  (cmd.auth/prepare-register cfg params))
+
+;; --- MUTATION: Register Profile
+
+(s/def ::register-profile ::cmd.auth/register-profile)
+
+(sv/defmethod ::register-profile
+  {:auth false ::rlimit/permits (cf/get :rlimit-password)}
+  [{:keys [pool] :as cfg} params]
+  (db/with-atomic [conn pool]
+    (-> (assoc cfg :conn conn)
+        (cmd.auth/register-profile params))))
+
+;; --- MUTATION: Request Profile Recovery
+
+(s/def ::request-profile-recovery ::cmd.auth/request-profile-recovery)
+
+(sv/defmethod ::request-profile-recovery {:auth false}
+  [cfg params]
+  (cmd.auth/request-profile-recovery cfg params))

backend/src/app/rpc/mutations/share_link.clj

@@ -19,7 +19,8 @@
 (s/def ::id ::us/uuid)
 (s/def ::profile-id ::us/uuid)
 (s/def ::file-id ::us/uuid)
-(s/def ::flags (s/every ::us/string :kind set?))
+(s/def ::who-comment ::us/string)
+(s/def ::who-inspect ::us/string)
 (s/def ::pages (s/every ::us/uuid :kind set?))
 
 ;; --- Mutation: Create Share Link
@@ -27,14 +28,13 @@
 (declare create-share-link)
 
 (s/def ::create-share-link
-  (s/keys :req-un [::profile-id ::file-id ::flags]
+  (s/keys :req-un [::profile-id ::file-id ::who-comment ::who-inspect ::pages]))
-          :opt-un [::pages]))
 
 (sv/defmethod ::create-share-link
   "Creates a share-link object.
 
-  Share links are resources that allows external users access to
+  Share links are resources that allows external users access to specific
-  specific files with specific permissions (flags)."
+  pages of a file with specific permissions (who-comment and who-inspect)."
 
   [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
   (db/with-atomic [conn pool]
@@ -42,19 +42,17 @@
     (create-share-link conn params)))
 
 (defn create-share-link
-  [conn {:keys [profile-id file-id pages flags]}]
+  [conn {:keys [profile-id file-id pages who-comment who-inspect]}]
   (let [pages (db/create-array conn "uuid" pages)
-        flags (->> (map name flags)
-                   (db/create-array conn "text"))
         slink (db/insert! conn :share-link
                           {:id (uuid/next)
                            :file-id file-id
-                           :flags flags
+                           :who-comment who-comment
+                           :who-inspect who-inspect
                            :pages pages
                            :owner-id profile-id})]
     (-> slink
-        (update :pages db/decode-pgarray #{})
+        (update :pages db/decode-pgarray #{}))))
-        (update :flags db/decode-pgarray #{}))))
 
 ;; --- Mutation: Delete Share Link
 

backend/src/app/rpc/permissions.clj

@@ -53,6 +53,16 @@
     ([perms] (:can-read perms))
     ([conn & args] (check (apply qfn conn args)))))
 
+(defn make-comment-predicate-fn
+  "A simple factory for comment permission predicate functions."
+  [qfn]
+  (us/assert fn? qfn)
+  (fn check
+    ([perms]
+     (and (:is-logged perms) (= (:who-comment perms) "all")))
+    ([conn & args]
+     (check (apply qfn conn args)))))
+
 (defn make-check-fn
   "Helper that converts a predicate permission function to a check
   function (function that raises an exception)."

backend/src/app/rpc/queries/comments.clj

@@ -25,16 +25,16 @@
 
 (s/def ::team-id ::us/uuid)
 (s/def ::file-id ::us/uuid)
+(s/def ::share-id (s/nilable ::us/uuid))
 
 (s/def ::comment-threads
   (s/and (s/keys :req-un [::profile-id]
-                 :opt-un [::file-id ::team-id])
+                 :opt-un [::file-id ::share-id ::team-id])
          #(or (:file-id %) (:team-id %))))
 
 (sv/defmethod ::comment-threads
-  [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
+  [{:keys [pool] :as cfg} params]
   (with-open [conn (db/open pool)]
-    (files/check-read-permissions! conn profile-id file-id)
     (retrieve-comment-threads conn params)))
 
 (def sql:comment-threads
@@ -60,8 +60,8 @@
    window w as (partition by c.thread_id order by c.created_at asc)")
 
 (defn- retrieve-comment-threads
-  [conn {:keys [profile-id file-id]}]
+  [conn {:keys [profile-id file-id share-id]}]
-  (files/check-read-permissions! conn profile-id file-id)
+  (files/check-comment-permissions! conn profile-id file-id share-id)
   (->> (db/exec! conn [sql:comment-threads profile-id file-id])
        (into [] (map decode-row))))
 
@@ -116,13 +116,15 @@
 ;; --- Query: Single Comment Thread
 
 (s/def ::id ::us/uuid)
+(s/def ::share-id (s/nilable ::us/uuid))
 (s/def ::comment-thread
-  (s/keys :req-un [::profile-id ::file-id ::id]))
+  (s/keys :req-un [::profile-id ::file-id ::id]
+          :opt-un [::share-id]))
 
 (sv/defmethod ::comment-thread
-  [{:keys [pool] :as cfg} {:keys [profile-id file-id id] :as params}]
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id id share-id] :as params}]
   (with-open [conn (db/open pool)]
-    (files/check-read-permissions! conn profile-id file-id)
+    (files/check-comment-permissions! conn profile-id file-id share-id)
     (let [sql (str "with threads as (" sql:comment-threads ")"
                    "select * from threads where id = ?")]
       (-> (db/exec-one! conn [sql profile-id file-id id])
@@ -133,15 +135,17 @@
 (declare retrieve-comments)
 
 (s/def ::file-id ::us/uuid)
+(s/def ::share-id (s/nilable ::us/uuid))
 (s/def ::thread-id ::us/uuid)
 (s/def ::comments
-  (s/keys :req-un [::profile-id ::thread-id]))
+  (s/keys :req-un [::profile-id ::thread-id]
+          :opt-un [::share-id]))
 
 (sv/defmethod ::comments
-  [{:keys [pool] :as cfg} {:keys [profile-id thread-id] :as params}]
+  [{:keys [pool] :as cfg} {:keys [profile-id thread-id share-id] :as params}]
   (with-open [conn (db/open pool)]
     (let [thread (db/get-by-id conn :comment-thread thread-id)]
-      (files/check-read-permissions! conn profile-id (:file-id thread))
+      (files/check-comment-permissions! conn profile-id (:file-id thread) share-id)
       (retrieve-comments conn thread-id))))
 
 (def sql:comments
@@ -153,3 +157,40 @@
   [conn thread-id]
   (->> (db/exec! conn [sql:comments thread-id])
        (into [] (map decode-row))))
+
+;; file-comments-users
+
+(declare retrieve-file-comments-users)
+
+(s/def ::file-id ::us/uuid)
+(s/def ::share-id (s/nilable ::us/uuid))
+
+(s/def ::file-comments-users
+  (s/keys :req-un [::profile-id ::file-id]
+          :opt-un [::share-id]))
+
+(sv/defmethod ::file-comments-users
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id share-id]}]
+  (with-open [conn (db/open pool)]
+    (files/check-comment-permissions! conn profile-id file-id share-id)
+    (retrieve-file-comments-users conn file-id profile-id)))
+
+(def sql:file-comment-users
+  "select p.id,
+          p.email,
+          p.fullname as name,
+          p.fullname as fullname,
+          p.photo_id,
+          p.is_active
+     from profile p
+     where p.id in
+       (select owner_id from comment
+          where thread_id in
+            (select id from comment_thread
+              where file_id=?))
+     or p.id=?
+   ") ;; all the users that had comment the file, plus the current user
+
+(defn retrieve-file-comments-users
+  [conn file-id profile-id]
+  (db/exec! conn [sql:file-comment-users file-id profile-id]))

backend/src/app/rpc/queries/files.clj

@@ -9,6 +9,7 @@
    [app.common.data :as d]
    [app.common.data.macros :as dm]
    [app.common.exceptions :as ex]
+   [app.common.geom.shapes :as gsh]
    [app.common.pages.helpers :as cph]
    [app.common.pages.migrations :as pmg]
    [app.common.spec :as us]
@@ -84,7 +85,8 @@
         :is-owner is-owner
         :is-admin (or is-owner is-admin)
         :can-edit (or is-owner is-admin can-edit)
-        :can-read true})))
+        :can-read true
+        :is-logged (some? profile-id)})))
   ([conn profile-id file-id share-id]
    (let [perms  (get-permissions conn profile-id file-id)
          ldata  (retrieve-share-link conn file-id share-id)]
@@ -97,7 +99,9 @@
        (some? perms) perms
        (some? ldata) {:type :share-link
                       :can-read true
-                      :flags (:flags ldata)}))))
+                      :is-logged (some? profile-id)
+                      :who-comment (:who-comment ldata)
+                      :who-inspect (:who-inspect ldata)}))))
 
 (def has-edit-permissions?
   (perms/make-edition-predicate-fn get-permissions))
@@ -105,12 +109,26 @@
 (def has-read-permissions?
   (perms/make-read-predicate-fn get-permissions))
 
+(def has-comment-permissions?
+  (perms/make-comment-predicate-fn get-permissions))
+
 (def check-edition-permissions!
   (perms/make-check-fn has-edit-permissions?))
 
 (def check-read-permissions!
   (perms/make-check-fn has-read-permissions?))
 
+;; A user has comment permissions if she has read permissions, or comment permissions
+(defn check-comment-permissions!
+  [conn profile-id file-id share-id]
+   (let [can-read (has-read-permissions? conn profile-id file-id)
+         can-comment  (has-comment-permissions? conn profile-id file-id share-id)
+         ]
+     (when-not (or can-read can-comment)
+       (ex/raise :type :not-found
+                 :code :object-not-found
+                 :hint "not found"))))
+
 ;; --- Query: Files search
 
 ;; TODO: this query need to a good refactor
@@ -289,7 +307,7 @@
                           frame (-> page :objects cph/get-frames)]
                       (assoc frame :page-id (:id page)))))
 
-          ;; function responsible to filter objects data strucuture of
+          ;; function responsible to filter objects data structure of
           ;; all unneded shapes if a concrete frame is provided. If no
           ;; frame, the objects is returned untouched.
           (filter-objects [objects frame-id]
@@ -307,10 +325,24 @@
                       object-id (str page-id frame-id)
                       frame (if-let [thumb (get thumbnails object-id)]
                               (assoc frame :thumbnail thumb :shapes [])
-                              (dissoc frame :thumbnail))]
+                              (dissoc frame :thumbnail))
+
+                      children-ids
+                      (cph/get-children-ids objects frame-id)
+
+                      bounds
+                      (when (:show-content frame)
+                        (gsh/selection-rect (concat [frame] (->> children-ids (map (d/getf objects))))))
+
+                      frame
+                      (cond-> frame
+                        (some? bounds)
+                        (assoc :children-bounds bounds))]
+
                   (if (:thumbnail frame)
-                    (recur (-> (assoc objects frame-id frame)
+                    (recur (-> objects
-                               (d/without-keys (cph/get-children-ids objects frame-id)))
+                               (assoc frame-id frame)
+                               (d/without-keys children-ids))
                            (rest frames))
                     (recur (assoc objects frame-id frame)
                            (rest frames))))

backend/src/app/rpc/queries/share_link.clj

@@ -11,7 +11,6 @@
 (defn decode-share-link-row
   [row]
   (-> row
-      (update :flags db/decode-pgarray #{})
       (update :pages db/decode-pgarray #{})))
 
 (defn retrieve-share-link

backend/src/app/rpc/queries/viewer.clj

@@ -9,9 +9,9 @@
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.db :as db]
+   [app.rpc.queries.comments :as comments]
    [app.rpc.queries.files :as files]
-   [app.rpc.queries.share-link :as slnk]
+   [app.rpc.queries.share-link :as slnk]   
-   [app.rpc.queries.teams :as teams]
    [app.util.services :as sv]
    [clojure.spec.alpha :as s]
    [promesa.core :as p]))
@@ -23,11 +23,11 @@
   (db/get-by-id pool :project id {:columns [:id :name :team-id]}))
 
 (defn- retrieve-bundle
-  [{:keys [pool] :as cfg} file-id]
+  [{:keys [pool] :as cfg} file-id profile-id]
   (p/let [file    (files/retrieve-file cfg file-id)
           project (retrieve-project pool (:project-id file))
           libs    (files/retrieve-file-libraries cfg false file-id)
-          users   (teams/retrieve-users pool (:team-id project))
+          users   (comments/retrieve-file-comments-users pool file-id profile-id)
 
           links   (->> (db/query pool :share-link {:file-id file-id})
                        (mapv slnk/decode-share-link-row))
@@ -54,7 +54,7 @@
   (p/let [slink  (slnk/retrieve-share-link pool file-id share-id)
           perms  (files/get-permissions pool profile-id file-id share-id)
           thumbs (files/retrieve-object-thumbnails cfg file-id)
-          bundle (p/-> (retrieve-bundle cfg file-id)
+          bundle (p/-> (retrieve-bundle cfg file-id profile-id)
                        (assoc :permissions perms)
                        (assoc-in [:file :thumbnails] thumbs))]
 

backend/src/app/srepl/dev.clj

@@ -3,7 +3,7 @@
   (:require
    [app.db :as db]
    [app.config :as cfg]
-   [app.rpc.mutations.profile :refer [derive-password]]
+   [app.rpc.commands.auth :refer [derive-password]]
    [app.main :refer [system]]))
 
 (defn reset-passwords

backend/src/app/srepl/main.clj

@@ -7,7 +7,6 @@
    [app.common.logging :as l]
    [app.common.pages :as cp]
    [app.common.pages.migrations :as pmg]
-   [app.common.spec.file :as spec.file]
    [app.common.uuid :as uuid]
    [app.config :as cfg]
    [app.db :as db]

backend/src/app/storage.clj

@@ -14,7 +14,6 @@
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
    [app.db :as db]
-   [app.storage.db :as sdb]
    [app.storage.fs :as sfs]
    [app.storage.impl :as impl]
    [app.storage.s3 :as ss3]
@@ -32,14 +31,12 @@
 
 (s/def ::s3 ::ss3/backend)
 (s/def ::fs ::sfs/backend)
-(s/def ::db ::sdb/backend)
 
 (s/def ::backends
   (s/map-of ::us/keyword
             (s/nilable
              (s/or :s3 ::ss3/backend
-                   :fs ::sfs/backend
+                   :fs ::sfs/backend))))
-                   :db ::sdb/backend))))
 
 (defmethod ig/pre-init-spec ::storage [_]
   (s/keys :req-un [::db/pool ::wrk/executor ::backends]))
@@ -84,13 +81,14 @@
                  "   and backend = ?"
                  "   and deleted_at is null"
                  " limit 1")]
-    (db/exec-one! conn [sql hash bucket (name backend)])))
+    (some-> (db/exec-one! conn [sql hash bucket (name backend)])
+            (update :metadata db/decode-transit-pgobject))))
 
 (defn- create-database-object
   [{:keys [conn backend executor]} {:keys [::content ::expired-at ::touched-at] :as params}]
   (us/assert ::storage-content content)
   (px/with-dispatch executor
-    (let [id     (uuid/random)
+    (let [id     (uuid/next)
 
           mdata  (cond-> (get-metadata params)
                    (satisfies? impl/IContentHash content)
@@ -106,13 +104,15 @@
                    (get-database-object-by-hash conn backend (:bucket mdata) (:hash mdata)))
 
           result (or result
-                     (db/insert! conn :storage-object
+                     (-> (db/insert! conn :storage-object
-                                 {:id id
+                                     {:id id
-                                  :size (count content)
+                                      :size (impl/get-size content)
-                                  :backend (name backend)
+                                      :backend (name backend)
-                                  :metadata (db/tjson mdata)
+                                      :metadata (db/tjson mdata)
-                                  :deleted-at expired-at
+                                      :deleted-at expired-at
-                                  :touched-at touched-at}))]
+                                      :touched-at touched-at})
+                         (update :metadata db/decode-transit-pgobject)
+                         (update :metadata assoc ::created? true)))]
 
       (StorageObject. (:id result)
                       (:size result)
@@ -120,7 +120,7 @@
                       (:deleted-at result)
                       (:touched-at result)
                       backend
-                      mdata
+                      (:metadata result)
                       nil))))
 
 (def ^:private sql:retrieve-storage-object
@@ -173,9 +173,10 @@
   (p/let [storage (assoc storage :conn (or conn pool))
           object  (create-database-object storage params)]
 
-    ;; Store the data finally on the underlying storage subsystem.
+    (when (::created? (meta object))
-    (-> (impl/resolve-backend storage backend)
+      ;; Store the data finally on the underlying storage subsystem.
-        (impl/put-object object content))
+      (-> (impl/resolve-backend storage backend)
+          (impl/put-object object content)))
 
     object))
 
@@ -259,7 +260,8 @@
 ;; A task responsible to permanently delete already marked as deleted
 ;; storage files. The storage objects are practically never marked to
 ;; be deleted directly by the api call. The touched-gc is responsible
-;; of collecting the usage of the object and mark it as deleted.
+;; of collecting the usage of the object and mark it as deleted. Only
+;; the TMP files are are created with expiration date in future.
 
 (declare sql:retrieve-deleted-objects-chunk)
 

backend/src/app/storage/db.clj

@@ -1,67 +0,0 @@
-;; This Source Code Form is subject to the terms of the Mozilla Public
-;; License, v. 2.0. If a copy of the MPL was not distributed with this
-;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
-;;
-;; Copyright (c) UXBOX Labs SL
-
-(ns app.storage.db
-  (:require
-   [app.common.spec :as us]
-   [app.db :as db]
-   [app.storage.impl :as impl]
-   [clojure.spec.alpha :as s]
-   [integrant.core :as ig]
-   [promesa.exec :as px])
-  (:import
-   java.io.ByteArrayInputStream))
-
-;; --- BACKEND INIT
-
-(defmethod ig/pre-init-spec ::backend [_]
-  (s/keys :opt-un [::db/pool]))
-
-(defmethod ig/init-key ::backend
-  [_ cfg]
-  (assoc cfg :type :db))
-
-(s/def ::type ::us/keyword)
-(s/def ::backend
-  (s/keys :req-un [::type ::db/pool]))
-
-;; --- API IMPL
-
-(defmethod impl/put-object :db
-  [{:keys [conn executor] :as storage} {:keys [id] :as object} content]
-  (px/with-dispatch executor
-    (let [data (impl/slurp-bytes content)]
-      (db/insert! conn :storage-data {:id id :data data})
-      object)))
-
-(defmethod impl/get-object-data :db
-  [{:keys [conn executor] :as backend} {:keys [id] :as object}]
-  (px/with-dispatch executor
-    (let [result (db/exec-one! conn ["select data from storage_data where id=?" id])]
-      (ByteArrayInputStream. (:data result)))))
-
-(defmethod impl/get-object-bytes :db
-  [{:keys [conn executor] :as backend} {:keys [id] :as object}]
-  (px/with-dispatch executor
-    (let [result (db/exec-one! conn ["select data from storage_data where id=?" id])]
-      (:data result))))
-
-(defmethod impl/get-object-url :db
-  [_ _]
-  (throw (UnsupportedOperationException. "not supported")))
-
-(defmethod impl/del-object :db
-  [_ _]
-  ;; NOOP: because deleting the row already deletes the file data from
-  ;; the database.
-  nil)
-
-(defmethod impl/del-objects-in-bulk :db
-  [_ _]
-  ;; NOOP: because deleting the row already deletes the file data from
-  ;; the database.
-  nil)
-

backend/src/app/storage/fs.clj

@@ -10,11 +10,13 @@
    [app.common.spec :as us]
    [app.common.uri :as u]
    [app.storage.impl :as impl]
+   [app.util.bytes :as bs]
    [clojure.java.io :as io]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [datoteka.core :as fs]
    [integrant.core :as ig]
+   [promesa.core :as p]
    [promesa.exec :as px])
   (:import
    java.io.InputStream
@@ -72,9 +74,10 @@
       (io/input-stream full))))
 
 (defmethod impl/get-object-bytes :fs
-  [{:keys [executor] :as backend} object]
+  [backend object]
-  (px/with-dispatch executor
+  (p/let [input (impl/get-object-data backend object)]
-    (fs/slurp-bytes (impl/get-object-data backend object))))
+    (ex/with-always (bs/close! input)
+      (bs/read-as-bytes input))))
 
 (defmethod impl/get-object-url :fs
   [{:keys [uri executor] :as backend} {:keys [id] :as object} _]

backend/src/app/storage/impl.clj

@@ -9,18 +9,15 @@
   (:require
    [app.common.data.macros :as dm]
    [app.common.exceptions :as ex]
-   [app.common.uuid :as uuid]
+   [app.util.bytes :as bs]
    [buddy.core.codecs :as bc]
    [buddy.core.hash :as bh]
    [clojure.java.io :as io])
   (:import
    java.nio.ByteBuffer
-   java.util.UUID
-   java.io.ByteArrayInputStream
-   java.io.InputStream
    java.nio.file.Files
-   org.apache.commons.io.input.BoundedInputStream
+   java.nio.file.Path
-   ))
+   java.util.UUID))
 
 ;; --- API Definition
 
@@ -95,23 +92,23 @@
 (defn coerce-id
   [id]
   (cond
-    (string? id) (uuid/uuid id)
+    (string? id) (parse-uuid id)
-    (uuid? id) id
+    (uuid? id)   id
-    :else (ex/raise :type :internal
+    :else        (ex/raise :type :internal
-                    :code :invalid-id-type
+                           :code :invalid-id-type
-                    :hint "id should be string or uuid")))
+                           :hint "id should be string or uuid")))
 
 (defprotocol IContentObject
-  (size [_] "get object size"))
+  (get-size [_] "get object size"))
 
 (defprotocol IContentHash
   (get-hash [_] "get precalculated hash"))
 
-(defn- make-content
+(defn- path->content
-  [^InputStream is ^long size]
+  [^Path path ^long size]
   (reify
     IContentObject
-    (size [_] size)
+    (get-size [_] size)
 
     io/IOFactory
     (make-reader [this opts]
@@ -119,47 +116,53 @@
     (make-writer [_ _]
       (throw (UnsupportedOperationException. "not implemented")))
     (make-input-stream [_ _]
-      (doto (BoundedInputStream. is size)
+      (-> (io/input-stream path)
-        (.setPropagateClose false)))
+          (bs/bounded-input-stream size)))
     (make-output-stream [_ _]
+      (throw (UnsupportedOperationException. "not implemented")))))
+
+(defn- bytes->content
+  [^bytes data ^long size]
+  (reify
+    IContentObject
+    (get-size [_] size)
+
+    io/IOFactory
+    (make-reader [this opts]
+      (io/make-reader this opts))
+    (make-writer [_ _]
       (throw (UnsupportedOperationException. "not implemented")))
-
+    (make-input-stream [_ _]
-    clojure.lang.Counted
+      (-> (bs/bytes-input-stream data)
-    (count [_] size)
+          (bs/bounded-input-stream size)))
-
+    (make-output-stream [_ _]
-    java.lang.AutoCloseable
+      (throw (UnsupportedOperationException. "not implemented")))))
-    (close [_]
-      (.close is))))
 
 (defn content
   ([data] (content data nil))
   ([data size]
    (cond
      (instance? java.nio.file.Path data)
-     (make-content (io/input-stream data)
+     (path->content data (or size (Files/size data)))
-                   (Files/size data))
 
      (instance? java.io.File data)
-     (content (.toPath ^java.io.File data) nil)
+     (content (.toPath ^java.io.File data) size)
 
      (instance? String data)
-     (let [data (.getBytes data "UTF-8")
+     (let [data (.getBytes data "UTF-8")]
-           bais (ByteArrayInputStream. ^bytes data)]
+       (bytes->content data (alength data)))
-       (make-content bais (alength data)))
 
      (bytes? data)
-     (let [size (alength ^bytes data)
+     (bytes->content data (or size (alength ^bytes data)))
-           bais (ByteArrayInputStream. ^bytes data)]
-       (make-content bais size))
 
-     (instance? InputStream data)
+     ;; (instance? InputStream data)
-     (do
+     ;; (do
-       (when-not size
+     ;;   (when-not size
-         (throw (UnsupportedOperationException. "size should be provided on InputStream")))
+     ;;     (throw (UnsupportedOperationException. "size should be provided on InputStream")))
-       (make-content data size))
+     ;;   (make-content data size))
 
      :else
-     (throw (UnsupportedOperationException. "type not supported")))))
+     (throw (IllegalArgumentException. "invalid argument type")))))
 
 (defn wrap-with-hash
   [content ^String hash]
@@ -171,7 +174,7 @@
 
   (reify
     IContentObject
-    (size [_] (size content))
+    (get-size [_] (get-size content))
 
     IContentHash
     (get-hash [_] hash)
@@ -184,43 +187,17 @@
     (make-input-stream [_ opts]
       (io/make-input-stream content opts))
     (make-output-stream [_ opts]
-      (io/make-output-stream content opts))
+      (io/make-output-stream content opts))))
-
-    clojure.lang.Counted
-    (count [_] (count content))
-
-    java.lang.AutoCloseable
-    (close [_]
-      (.close ^java.lang.AutoCloseable content))))
 
 (defn content?
   [v]
   (satisfies? IContentObject v))
 
-(defn slurp-bytes
-  [content]
-  (with-open [input  (io/input-stream content)
-              output (java.io.ByteArrayOutputStream. (count content))]
-    (io/copy input output)
-    (.toByteArray output)))
-
 (defn calculate-hash
-  [path-or-stream]
+  [resource]
-  (let [result (cond
+  (let [result (with-open [input (io/input-stream resource)]
-                 (instance? InputStream path-or-stream)
+                 (-> (bh/blake2b-256 input)
-                 (let [result (-> (bh/blake2b-256 path-or-stream)
+                     (bc/bytes->hex)))]
-                                  (bc/bytes->hex))]
-                   (.reset path-or-stream)
-                   result)
-
-                 (string? path-or-stream)
-                 (-> (bh/blake2b-256 path-or-stream)
-                     (bc/bytes->hex))
-
-                 :else
-                 (with-open [is (io/input-stream path-or-stream)]
-                   (-> (bh/blake2b-256 is)
-                       (bc/bytes->hex))))]
     (str "blake2b:" result)))
 
 (defn resolve-backend

backend/src/app/storage/s3.clj

@@ -12,14 +12,17 @@
    [app.common.spec :as us]
    [app.common.uri :as u]
    [app.storage.impl :as impl]
+   [app.storage.tmp :as tmp]
    [app.util.time :as dt]
    [app.worker :as wrk]
    [clojure.java.io :as io]
    [clojure.spec.alpha :as s]
+   [datoteka.core :as fs]
    [integrant.core :as ig]
    [promesa.core :as p]
    [promesa.exec :as px])
   (:import
+   java.io.FilterInputStream
    java.io.InputStream
    java.nio.ByteBuffer
    java.time.Duration
@@ -30,6 +33,7 @@
    org.reactivestreams.Subscription
    software.amazon.awssdk.core.ResponseBytes
    software.amazon.awssdk.core.async.AsyncRequestBody
+   software.amazon.awssdk.core.async.AsyncResponseTransformer
    software.amazon.awssdk.core.client.config.ClientAsyncConfiguration
    software.amazon.awssdk.core.client.config.SdkAdvancedAsyncClientOption
    software.amazon.awssdk.http.nio.netty.NettyNioAsyncHttpClient
@@ -68,9 +72,10 @@
   (s/keys :opt-un [::region ::bucket ::prefix ::endpoint ::wrk/executor]))
 
 (defmethod ig/prep-key ::backend
-  [_ {:keys [prefix] :as cfg}]
+  [_ {:keys [prefix region] :as cfg}]
   (cond-> (d/without-nils cfg)
-    prefix (assoc :prefix prefix)))
+    (some? prefix) (assoc :prefix prefix)
+    (nil? region)  (assoc :region :eu-central-1)))
 
 (defmethod ig/init-key ::backend
   [_ cfg]
@@ -106,7 +111,16 @@
 
 (defmethod impl/get-object-data :s3
   [backend object]
-  (get-object-data backend object))
+  (letfn [(no-such-key? [cause]
+            (instance? software.amazon.awssdk.services.s3.model.NoSuchKeyException cause))
+          (handle-not-found [cause]
+            (ex/raise :type :not-found
+                      :code :object-not-found
+                      :hint "s3 object not found"
+                      :cause cause))]
+
+    (-> (get-object-data backend object)
+        (p/catch no-such-key? handle-not-found))))
 
 (defmethod impl/get-object-bytes :s3
   [backend object]
@@ -130,7 +144,8 @@
 (def default-timeout
   (dt/duration {:seconds 30}))
 
-(defn- ^Region lookup-region
+(defn- lookup-region
+  ^Region
   [region]
   (Region/of (name region)))
 
@@ -202,7 +217,7 @@
     (reify
       AsyncRequestBody
       (contentLength [_]
-        (Optional/of (long (count content))))
+        (Optional/of (long (impl/get-size content))))
 
       (^void subscribe [_ ^Subscriber s]
        (let [thread (Thread. #(writer-fn s))]
@@ -214,7 +229,6 @@
                            (cancel [_]
                              (.interrupt thread)
                              (.release sem 1))
-
                            (request [_ n]
                              (.release sem (int n))))))))))
 
@@ -236,16 +250,31 @@
                   ^AsyncRequestBody content))))
 
 (defn get-object-data
-  [{:keys [client bucket prefix]} {:keys [id]}]
+  [{:keys [client bucket prefix]} {:keys [id size]}]
-  (p/let [gor (.. (GetObjectRequest/builder)
+  (let [gor (.. (GetObjectRequest/builder)
-                  (bucket bucket)
+                (bucket bucket)
-                  (key (str prefix (impl/id->path id)))
+                (key (str prefix (impl/id->path id)))
-                  (build))
+                (build))]
-          obj (.getObject ^S3AsyncClient client ^GetObjectRequest gor)
+
-          ;; rsp (.response ^ResponseInputStream obj)
+    ;; If the file size is greater than 2MiB then stream the content
-          ;; len (.contentLength ^GetObjectResponse rsp)
+    ;; to the filesystem and then read with buffered inputstream; if
-          ]
+    ;; not, read the contento into memory using bytearrays.
-    (io/input-stream obj)))
+    (if (> size (* 1024 1024 2))
+      (p/let [path (tmp/tempfile :prefix "penpot.storage.s3.")
+              rxf  (AsyncResponseTransformer/toFile path)
+              _    (.getObject ^S3AsyncClient client
+                               ^GetObjectRequest gor
+                               ^AsyncResponseTransformer rxf)]
+        (proxy [FilterInputStream] [(io/input-stream path)]
+          (close []
+            (fs/delete path)
+            (proxy-super close))))
+
+      (p/let [rxf (AsyncResponseTransformer/toBytes)
+              obj (.getObject ^S3AsyncClient client
+                              ^GetObjectRequest gor
+                              ^AsyncResponseTransformer rxf)]
+        (.asInputStream ^ResponseBytes obj)))))
 
 (defn get-object-bytes
   [{:keys [client bucket prefix]} {:keys [id]}]
@@ -253,7 +282,10 @@
                   (bucket bucket)
                   (key (str prefix (impl/id->path id)))
                   (build))
-          obj (.getObjectAsBytes ^S3AsyncClient client ^GetObjectRequest gor)]
+          rxf (AsyncResponseTransformer/toBytes)
+          obj (.getObjectAsBytes ^S3AsyncClient client
+                                 ^GetObjectRequest gor
+                                 ^AsyncResponseTransformer rxf)]
     (.asByteArray ^ResponseBytes obj)))
 
 (def default-max-age

backend/src/app/storage/tmp.clj

@@ -0,0 +1,83 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.storage.tmp
+  "Temporal files service all created files will be tried to clean after
+  1 hour afrer creation. This is a best effort, if this process fails,
+  the operating system cleaning task should be responsible of
+  permanently delete these files (look at systemd-tempfiles)."
+  (:require
+   [app.common.data :as d]
+   [app.common.logging :as l]
+   [app.util.time :as dt]
+   [app.worker :as wrk]
+   [clojure.core.async :as a]
+   [clojure.spec.alpha :as s]
+   [datoteka.core :as fs]
+   [integrant.core :as ig]
+   [promesa.exec :as px]))
+
+(declare remove-temp-file)
+(defonce queue (a/chan 128))
+
+(s/def ::min-age ::dt/duration)
+
+(defmethod ig/pre-init-spec ::cleaner [_]
+  (s/keys :req-un [::min-age ::wrk/scheduler ::wrk/executor]))
+
+(defmethod ig/prep-key ::cleaner
+  [_ cfg]
+  (merge {:min-age (dt/duration {:minutes 30})}
+         (d/without-nils cfg)))
+
+(defmethod ig/init-key ::cleaner
+  [_ {:keys [scheduler executor min-age] :as cfg}]
+  (l/info :hint "starting tempfile cleaner service")
+  (let [cch (a/chan)]
+    (a/go-loop []
+      (let [[path port] (a/alts! [queue cch])]
+        (when (not= port cch)
+          (l/trace :hint "schedule tempfile deletion" :path path
+                   :expires-at (dt/plus (dt/now) min-age))
+          (px/schedule! scheduler
+                        (inst-ms min-age)
+                        (partial remove-temp-file executor path))
+          (recur))))
+    cch))
+
+(defmethod ig/halt-key! ::cleaner
+  [_ close-ch]
+  (l/info :hint "stoping tempfile cleaner service")
+  (some-> close-ch a/close!))
+
+(defn- remove-temp-file
+  "Permanently delete tempfile"
+  [executor path]
+  (px/with-dispatch executor
+    (l/trace :hint "permanently delete tempfile" :path path)
+    (when (fs/exists? path)
+      (fs/delete path))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; API
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn tempfile
+  "Returns a tmpfile candidate (without creating it)"
+  [& {:keys [suffix prefix]
+      :or {prefix "penpot."
+           suffix ".tmp"}}]
+  (let [candidate (fs/tempfile :suffix suffix :prefix prefix)]
+    (a/offer! queue candidate)
+    candidate))
+
+(defn create-tempfile
+  [& {:keys [suffix prefix]
+      :or {prefix "penpot."
+           suffix ".tmp"}}]
+  (let [path (fs/create-tempfile :suffix suffix :prefix prefix)]
+    (a/offer! queue path)
+    path))

backend/src/app/tasks/file_gc.clj

@@ -82,7 +82,7 @@
                                :kf first
                                :initk (dt/now)))))
 
-(defn- collect-used-media
+(defn collect-used-media
   [data]
   (let [xform (comp
                (map :objects)

backend/src/app/util/bytes.clj

@@ -0,0 +1,126 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.util.bytes
+  "Bytes & Byte Streams helpers"
+  (:require
+   [clojure.java.io :as io]
+   [datoteka.core :as fs]
+   [yetti.adapter :as yt])
+  (:import
+   com.github.luben.zstd.ZstdInputStream
+   com.github.luben.zstd.ZstdOutputStream
+   java.io.ByteArrayInputStream
+   java.io.ByteArrayOutputStream
+   java.io.DataInputStream
+   java.io.DataOutputStream
+   java.io.OutputStream
+   java.io.InputStream
+   java.lang.AutoCloseable
+   org.apache.commons.io.IOUtils
+   org.apache.commons.io.input.BoundedInputStream))
+
+(set! *warn-on-reflection* true)
+
+(def ^:const default-buffer-size
+  (:xnio/buffer-size yt/defaults))
+
+(defn input-stream?
+  [s]
+  (instance? InputStream s))
+
+(defn output-stream?
+  [s]
+  (instance? OutputStream s))
+
+(defn data-input-stream?
+  [s]
+  (instance? DataInputStream s))
+
+(defn data-output-stream?
+  [s]
+  (instance? DataOutputStream s))
+
+(defn copy!
+  [src dst & {:keys [offset size buffer-size]
+              :or {offset 0 buffer-size default-buffer-size}}]
+  (let [^bytes buff (byte-array buffer-size)]
+    (if size
+      (IOUtils/copyLarge ^InputStream src ^OutputStream dst (long offset) (long size) buff)
+      (IOUtils/copyLarge ^InputStream src ^OutputStream dst buff))))
+
+(defn write-to-file!
+  [src dst & {:keys [size]}]
+  (with-open [^OutputStream output (io/output-stream dst)]
+    (cond
+      (bytes? src)
+      (if size
+        (with-open [^InputStream input (ByteArrayInputStream. ^bytes src)]
+          (with-open [^InputStream input (BoundedInputStream. input (or size (alength ^bytes src)))]
+            (copy! input output :size size)))
+
+        (do
+          (IOUtils/writeChunked ^bytes src output)
+          (.flush ^OutputStream output)
+          (alength ^bytes src)))
+
+      (instance? InputStream src)
+      (copy! src output :size size)
+
+      :else
+      (throw (IllegalArgumentException. "invalid arguments")))))
+
+(defn read-as-bytes
+  "Read input stream as byte array."
+  [input & {:keys [size]}]
+  (cond
+    (instance? InputStream input)
+    (with-open [output (ByteArrayOutputStream. (or size (.available ^InputStream input)))]
+      (copy! input output :size size)
+      (.toByteArray output))
+
+    (fs/path? input)
+    (with-open [input  (io/input-stream input)
+                output (ByteArrayOutputStream. (or size (.available input)))]
+      (copy! input output :size size)
+      (.toByteArray output))
+
+    :else
+    (throw (IllegalArgumentException. "invalid arguments"))))
+
+(defn bytes-input-stream
+  "Creates an instance of ByteArrayInputStream."
+  [^bytes data]
+  (ByteArrayInputStream. data))
+
+(defn bounded-input-stream
+  [input size & {:keys [close?] :or {close? true}}]
+  (doto (BoundedInputStream. ^InputStream input ^long size)
+    (.setPropagateClose close?)))
+
+(defn zstd-input-stream
+  ^InputStream
+  [input]
+  (ZstdInputStream. ^InputStream input))
+
+(defn zstd-output-stream
+  ^OutputStream
+  [output & {:keys [level] :or {level 0}}]
+  (ZstdOutputStream. ^OutputStream output (int level)))
+
+(defn data-input-stream
+  ^DataInputStream
+  [input]
+  (DataInputStream. ^InputStream input))
+
+(defn data-output-stream
+  ^DataOutputStream
+  [output]
+  (DataOutputStream. ^OutputStream output))
+
+(defn close!
+  [^AutoCloseable stream]
+  (.close stream))

backend/src/app/util/emails.clj

@@ -30,7 +30,8 @@
   [v]
   (InternetAddress/parse ^String v))
 
-(defn- ^Message$RecipientType resolve-recipient-type
+(defn- resolve-recipient-type
+  ^Message$RecipientType
   [type]
   (case type
     :to  Message$RecipientType/TO
@@ -157,7 +158,8 @@
     (.setDebug session debug)
     session))
 
-(defn ^MimeMessage smtp-message
+(defn smtp-message
+  ^MimeMessage
   [cfg message]
   (let [^Session session (smtp-session cfg)]
     (build-message cfg session message)))

backend/src/app/util/services.clj

@@ -40,9 +40,14 @@
   (comp
    (d/domap require)
    (map find-ns)
-   (mapcat ns-publics)
+   (mapcat (fn [ns]
-   (map second)
+             (->> (ns-publics ns)
-   (filter #(::spec (meta %)))))
+                  (map second)
+                  (filter #(::spec (meta %)))
+                  (map (fn [fvar]
+                         (with-meta (deref fvar)
+                           (-> (meta fvar)
+                               (assoc :ns (-> ns ns-name str)))))))))))
 
 (defn scan-ns
   [& nsyms]

backend/src/app/util/websocket.clj

@@ -10,9 +10,10 @@
    [app.common.exceptions :as ex]
    [app.common.logging :as l]
    [app.common.transit :as t]
-   [app.metrics :as mtx]
+   [app.loggers.audit :refer [parse-client-ip]]
    [app.util.time :as dt]
    [clojure.core.async :as a]
+   [yetti.request :as yr]
    [yetti.util :as yu]
    [yetti.websocket :as yws])
   (:import
@@ -25,8 +26,10 @@
 (declare process-output)
 (declare ws-ping!)
 (declare ws-send!)
+(declare filter-options)
 
 (def noop (constantly nil))
+(def identity-3 (fn [_ _ o] o))
 
 (defn handler
   "A WebSocket upgrade handler factory. Returns a handler that can be
@@ -39,94 +42,123 @@
   It also accepts some options that allows you parametrize the
   protocol behavior. The options map will be used as-as for the
   initial data of the `ws` data structure"
-  ([handle-message] (handler handle-message {}))
+  [& {:keys [::on-rcv-message
-  ([handle-message {:keys [::input-buff-size
+             ::on-snd-message
-                           ::output-buff-size
+             ::on-connect
-                           ::idle-timeout
+             ::input-buff-size
-                           metrics]
+             ::output-buff-size
-                    :or {input-buff-size 64
+             ::handler
-                         output-buff-size 64
+             ::idle-timeout]
-                         idle-timeout 30000}
+      :or {input-buff-size 64
-                    :as options}]
+           output-buff-size 64
-   (fn [{:keys [::yws/channel] :as request}]
+           idle-timeout 30000
-     (let [input-ch   (a/chan input-buff-size)
+           on-connect noop
-           output-ch  (a/chan output-buff-size)
+           on-snd-message identity-3
-           pong-ch    (a/chan (a/sliding-buffer 6))
+           on-rcv-message identity-3}
-           close-ch   (a/chan)
+      :as options}]
 
-           options    (atom
+  (assert (fn? on-rcv-message) "'on-rcv-message' should be a function")
-                       (-> options
+  (assert (fn? on-snd-message) "'on-snd-message' should be a function")
-                           (assoc ::input-ch input-ch)
+  (assert (fn? on-connect) "'on-connect' should be a function")
-                           (assoc ::output-ch output-ch)
-                           (assoc ::close-ch close-ch)
-                           (assoc ::channel channel)
-                           (dissoc ::metrics)))
 
-           terminated (atom false)
+  (fn [{:keys [::yws/channel session-id] :as request}]
-           created-at (dt/now)
+    (let [input-ch   (a/chan input-buff-size)
+          output-ch  (a/chan output-buff-size)
+          pong-ch    (a/chan (a/sliding-buffer 6))
+          close-ch   (a/chan)
+          stop-ch    (a/chan)
 
-           on-open
+          ip-addr    (parse-client-ip request)
-           (fn [channel]
+          uagent     (yr/get-header request "user-agent")
-             (mtx/run! metrics {:id :websocket-active-connections :inc 1})
+          id         (inst-ms (dt/now))
-             (yws/idle-timeout! channel (dt/duration idle-timeout)))
 
-           on-terminate
+          options    (-> (filter-options options)
-           (fn [& _args]
+                         (merge {::id id
-             (when (compare-and-set! terminated false true)
+                                 ::input-ch input-ch
-               (mtx/run! metrics {:id :websocket-active-connections :dec 1})
+                                 ::output-ch output-ch
-               (mtx/run! metrics {:id :websocket-session-timing :val (/ (inst-ms (dt/diff created-at (dt/now))) 1000.0)})
+                                 ::close-ch close-ch
+                                 ::stop-ch stop-ch
+                                 ::channel channel
+                                 ::remote-addr ip-addr
+                                 ::http-session-id session-id
+                                 ::user-agent uagent})
+                         (atom))
 
-               (a/close! close-ch)
+          ;; call the on-connect hook and memoize the on-terminate instance
-               (a/close! pong-ch)
+          on-terminate (on-connect options)
-               (a/close! output-ch)
-               (a/close! input-ch)))
 
-           on-error
+          on-ws-open
-           (fn [_ error]
+          (fn [channel]
-             (on-terminate)
+            (l/trace :fn "on-ws-open" :conn-id id)
-             ;; TODO: properly log timeout exceptions
+            (yws/idle-timeout! channel (dt/duration idle-timeout)))
-             (when-not (or (instance? java.nio.channels.ClosedChannelException error)
-                           (instance? java.net.SocketException error))
-               (l/error :hint (ex-message error) :cause error)))
 
-           on-message
+          on-ws-terminate
-           (fn [_ message]
+          (fn [_ code reason]
-             (mtx/run! metrics {:id :websocket-messages-total :labels ["recv"] :inc 1})
+            (l/trace :fn "on-ws-terminate" :conn-id id :code code :reason reason)
-             (try
+            (a/close! close-ch))
-               (let [message (t/decode-str message)]
-                 (a/offer! input-ch message))
-               (catch Throwable e
-                 (l/warn :hint "error on decoding incoming message from websocket"
-                         :wsmsg (pr-str message)
-                         :cause e)
-                 (on-terminate))))
 
-           on-pong
+          on-ws-error
-           (fn [_ buffers]
+          (fn [_ error]
-             (a/>!! pong-ch (yu/copy-many buffers)))]
+            (a/close! close-ch)
+            (when-not (or (instance? java.nio.channels.ClosedChannelException error)
+                          (instance? java.net.SocketException error))
+              (l/error :hint (ex-message error) :cause error)))
 
-       ;; launch heartbeat process
+          on-ws-message
-       (-> @options
+          (fn [_ message]
-           (assoc ::pong-ch pong-ch)
+            (try
-           (assoc ::on-close on-terminate)
+              (let [message (on-rcv-message options message)
-           (process-heartbeat))
+                    message (t/decode-str message)]
+                (a/offer! input-ch message)
+                (swap! options assoc ::last-activity-at (dt/now)))
+              (catch Throwable e
+                (l/warn :hint "error on decoding incoming message from websocket"
+                        :wsmsg (pr-str message)
+                        :cause e)
+                (a/>! close-ch [8801 "decode error"])
+                (a/close! close-ch))))
 
-       ;; Forward all messages from output-ch to the websocket
+          on-ws-pong
-       ;; connection
+          (fn [_ buffers]
-       (a/go-loop []
+            (a/>!! pong-ch (yu/copy-many buffers)))]
-         (when-let [val (a/<! output-ch)]
-           (mtx/run! metrics {:id :websocket-messages-total :labels ["send"] :inc 1})
-           (a/<! (ws-send! channel (t/encode-str val)))
-           (recur)))
 
-       ;; React on messages received from the client
+      ;; Launch heartbeat process
-       (process-input options handle-message)
+      (-> @options
+          (assoc ::pong-ch pong-ch)
+          (process-heartbeat))
 
-       {:on-open on-open
+      ;; Wait a close signal
-        :on-error on-error
+      (a/go
-        :on-close on-terminate
+        (let [[code reason] (a/<! close-ch)]
-        :on-text on-message
+          (a/close! stop-ch)
-        :on-pong on-pong}))))
+          (a/close! pong-ch)
+          (a/close! output-ch)
+          (a/close! input-ch)
+
+          (when (and code reason)
+            (l/trace :hint "close channel condition" :code code :reason reason)
+            (yws/close! channel code reason))
+
+          (when (fn? on-terminate)
+            (on-terminate))))
+
+      ;; Forward all messages from output-ch to the websocket
+      ;; connection
+      (a/go-loop []
+        (when-let [val (a/<! output-ch)]
+          (let [val (on-snd-message options val)]
+            (a/<! (ws-send! channel (t/encode-str val)))
+            (recur))))
+
+      ;; React on messages received from the client
+
+      (process-input options handler)
+
+      {:on-open on-ws-open
+       :on-error on-ws-error
+       :on-close on-ws-terminate
+       :on-text on-ws-message
+       :on-pong on-ws-pong})))
 
 (defn- ws-send!
   [channel s]
@@ -172,14 +204,14 @@
 
 (defn- process-input
   [wsp handler]
-  (let [{:keys [::input-ch ::output-ch ::close-ch]} @wsp
+  (let [{:keys [::input-ch ::output-ch ::stop-ch]} @wsp
         handler (wrap-handler handler)]
     (a/go
       (a/<! (handler wsp {:type :connect}))
       (a/<! (a/go-loop []
               (when-let [message (a/<! input-ch)]
-                (let [[val port] (a/alts! [(handler wsp message) close-ch])]
+                (let [[val port] (a/alts! [stop-ch (handler wsp message)] :priority true)]
-                  (when-not (= port close-ch)
+                  (when-not (= port stop-ch)
                     (cond
                       (ex/ex-info? val)
                       (a/>! output-ch {:type :error :error (ex-data val)})
@@ -193,19 +225,21 @@
       (a/<! (handler wsp {:type :disconnect})))))
 
 (defn- process-heartbeat
-  [{:keys [::channel ::close-ch ::on-close ::pong-ch
+  [{:keys [::channel ::stop-ch ::close-ch ::pong-ch
            ::heartbeat-interval ::max-missed-heartbeats]
     :or {heartbeat-interval 2000
          max-missed-heartbeats 4}}]
   (let [beats (atom #{})]
     (a/go-loop [i 0]
-      (let [[_ port] (a/alts! [close-ch (a/timeout heartbeat-interval)])]
+      (let [[_ port] (a/alts! [stop-ch (a/timeout heartbeat-interval)] :priority true)]
         (when (and (yws/connected? channel)
-                   (not= port close-ch))
+                   (not= port stop-ch))
           (a/<! (ws-ping! channel (encode-beat i)))
           (let [issued (swap! beats conj (long i))]
             (if (>= (count issued) max-missed-heartbeats)
-              (on-close channel -1 "heartbeat-timeout")
+              (do
+                (a/>! close-ch [8802 "heart-beat timeout"])
+                (a/close! close-ch))
               (recur (inc i)))))))
 
     (a/go-loop []
@@ -213,3 +247,11 @@
         (swap! beats disj (decode-beat buffer))
         (recur)))))
 
+(defn- filter-options
+  "Remove from options all namespace qualified keys that matches the
+  current namespace."
+  [options]
+  (into {}
+        (remove (fn [[key]]
+                  (= (namespace key) "app.util.websocket")))
+        options))

backend/src/app/worker.clj

@@ -203,8 +203,7 @@
 
           (instance? Exception val)
           (do
-            (l/warn :cause val
+            (l/warn :hint "unexpected error ocurried on polling the database (will resume in some instants)" :cause val)
-                    :hint "unexpected error ocurried on polling the database (will resume in some instants)")
             (a/<! (a/timeout poll-ms))
             (recur))
 
@@ -377,7 +376,7 @@
   [{:keys [tasks]} item]
   (let [name (d/name (:name item))]
     (try
-      (l/debug :action "execute task"
+      (l/trace :action "execute task"
                :id (:id item)
                :name name
                :retry (:retry-num item))
@@ -425,7 +424,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (declare schedule-cron-task)
-(declare synchronize-cron-entries)
+(declare synchronize-cron-entries!)
 
 (s/def ::fn (s/or :var var? :fn fn?))
 (s/def ::id keyword?)
@@ -466,8 +465,8 @@
 
           cfg     (assoc cfg :entries entries :running running)]
 
-        (l/info :hint "cron started" :registred-tasks (count entries))
+        (l/info :hint "cron initialized" :tasks (count entries))
-        (synchronize-cron-entries cfg)
+        (synchronize-cron-entries! cfg)
 
         (->> (filter some? entries)
              (run! (partial schedule-cron-task cfg)))
@@ -494,16 +493,12 @@
        on conflict (id)
        do update set cron_expr=?")
 
-(defn- synchronize-cron-item
+(defn- synchronize-cron-entries!
-  [conn {:keys [id cron]}]
+  [{:keys [pool entries]}]
-  (let [cron (str cron)]
-    (l/debug :action "initialize scheduled task" :id id :cron cron)
-    (db/exec-one! conn [sql:upsert-cron-task id cron cron])))
-
-(defn- synchronize-cron-entries
-  [{:keys [pool schedule]}]
   (db/with-atomic [conn pool]
-    (run! (partial synchronize-cron-item conn) schedule)))
+    (doseq [{:keys [id cron]} entries]
+      (l/trace :hint "register cron task" :id id :cron (str cron))
+      (db/exec-one! conn [sql:upsert-cron-task id (str cron) (str cron)]))))
 
 (def sql:lock-cron-task
   "select id from scheduled_task where id=? for update skip locked")
@@ -512,7 +507,7 @@
   [{:keys [executor pool] :as cfg} {:keys [id] :as task}]
   (letfn [(run-task [conn]
             (when (db/exec-one! conn [sql:lock-cron-task (d/name id)])
-              (l/debug :action "execute scheduled task" :id id)
+              (l/trace :hint "execute cron task" :id id)
               ((:fn task) task)))
 
           (handle-task []
@@ -567,9 +562,10 @@
 
 (defmethod ig/init-key ::registry
   [_ {:keys [metrics tasks]}]
+  (l/info :hint "registry initialized" :tasks (count tasks))
   (reduce-kv (fn [res k v]
                (let [tname (name k)]
-                 (l/debug :hint "register task" :name tname)
+                 (l/trace :hint "register task" :name tname)
                  (assoc res k (wrap-task-handler metrics tname v))))
              {}
              tasks))

backend/test/app/services_fonts_test.clj

@@ -11,6 +11,7 @@
    [app.http :as http]
    [app.storage :as sto]
    [app.test-helpers :as th]
+   [app.util.bytes :as bs]
    [clojure.java.io :as io]
    [clojure.test :as t]
    [datoteka.core :as fs]))
@@ -25,7 +26,8 @@
         font-id (uuid/custom 10 1)
 
         ttfdata (-> (io/resource "app/test_files/font-1.ttf")
-                    (fs/slurp-bytes))
+                    io/input-stream
+                    bs/read-as-bytes)
 
         params  {::th/type :create-font-variant
                  :profile-id (:id prof)
@@ -60,7 +62,8 @@
         font-id (uuid/custom 10 1)
 
         data    (-> (io/resource "app/test_files/font-1.woff")
-                    (fs/slurp-bytes))
+                    io/input-stream
+                    bs/read-as-bytes)
 
         params  {::th/type :create-font-variant
                  :profile-id (:id prof)

backend/test/app/services_media_test.clj

@@ -46,7 +46,13 @@
         (t/is (sto/storage-object? mobj1))
         (t/is (sto/storage-object? mobj2))
         (t/is (= 122785 (:size mobj1)))
-        (t/is (= 3303   (:size mobj2)))))
+
+        ;; This is because in ubuntu 21.04 generates different
+        ;; thumbnail that in ubuntu 22.04. This hack should be removed
+        ;; when we all use the ubuntu 22.04 devenv image.
+        (t/is (or
+               (= 3302 (:size mobj2))
+               (= 3303 (:size mobj2))))))
     ))
 
 (t/deftest media-object-upload

backend/test/app/services_profile_test.clj

@@ -10,6 +10,7 @@
    [app.config :as cf]
    [app.db :as db]
    [app.rpc.mutations.profile :as profile]
+   [app.rpc.commands.auth :as cauth]
    [app.test-helpers :as th]
    [app.util.time :as dt]
    [clojure.java.io :as io]
@@ -27,11 +28,10 @@
 ;; Test with wrong credentials
 (t/deftest profile-login-failed-1
   (let [profile (th/create-profile* 1)
-        data    {::th/type :login
+        data    {::th/type :login-with-password
                  :email "profile1.test@nodomain.com"
-                 :password "foobar"
+                 :password "foobar"}
-                 :scope "foobar"}
+        out     (th/command! data)]
-        out     (th/mutation! data)]
 
     #_(th/print-result! out)
     (let [error (:error out)]
@@ -42,11 +42,10 @@
 ;; Test with good credentials but profile not activated.
 (t/deftest profile-login-failed-2
   (let [profile (th/create-profile* 1)
-        data    {::th/type :login
+        data    {::th/type :login-with-password
                  :email "profile1.test@nodomain.com"
-                 :password "123123"
+                 :password "123123"}
-                 :scope "foobar"}
+        out     (th/command! data)]
-        out     (th/mutation! data)]
     ;; (th/print-result! out)
     (let [error (:error out)]
       (t/is (th/ex-info? error))
@@ -58,8 +57,7 @@
   (let [profile (th/create-profile* 1 {:is-active true})
         data    {::th/type :login
                  :email "profile1.test@nodomain.com"
-                 :password "123123"
+                 :password "123123"}
-                 :scope "foobar"}
         out     (th/mutation! data)]
     ;; (th/print-result! out)
     (t/is (nil? (:error out)))
@@ -161,11 +159,11 @@
 (t/deftest registration-domain-whitelist
   (let [whitelist #{"gmail.com" "hey.com" "ya.ru"}]
     (t/testing "allowed email domain"
-      (t/is (true? (profile/email-domain-in-whitelist? whitelist "username@ya.ru")))
+      (t/is (true? (cauth/email-domain-in-whitelist? whitelist "username@ya.ru")))
-      (t/is (true? (profile/email-domain-in-whitelist? #{} "username@somedomain.com"))))
+      (t/is (true? (cauth/email-domain-in-whitelist? #{} "username@somedomain.com"))))
 
     (t/testing "not allowed email domain"
-      (t/is (false? (profile/email-domain-in-whitelist? whitelist "username@somedomain.com"))))))
+      (t/is (false? (cauth/email-domain-in-whitelist? whitelist "username@somedomain.com"))))))
 
 (t/deftest prepare-register-and-register-profile
   (let [data  {::th/type :prepare-register-profile

backend/test/app/services_viewer_test.clj

@@ -49,7 +49,8 @@
                   :profile-id (:id prof)
                   :file-id (:id file)
                   :pages #{(get-in file [:data :pages 0])}
-                  :flags #{}}
+                  :who-comment "team"
+                  :who-inspect "all"}
             out  (th/mutation! data)]
 
         ;; (th/print-result! out)

backend/test/app/storage_test.clj

@@ -12,6 +12,7 @@
    [app.storage :as sto]
    [app.test-helpers :as th]
    [app.util.time :as dt]
+   [app.util.bytes :as bs]
    [clojure.java.io :as io]
    [clojure.test :as t]
    [cuerdas.core :as str]
@@ -27,11 +28,11 @@
   "Given storage map, returns a storage configured with the appropriate
   backend for assets."
   ([storage]
-   (assoc storage :backend :tmp))
+   (assoc storage :backend :assets-fs))
   ([storage conn]
    (-> storage
        (assoc :conn conn)
-       (assoc :backend :tmp))))
+       (assoc :backend :assets-fs))))
 
 (t/deftest put-and-retrieve-object
   (let [storage (-> (:app.storage/storage th/*system*)
@@ -43,7 +44,7 @@
     (t/is (sto/storage-object? object))
     (t/is (fs/path? @(sto/get-object-path storage object)))
     (t/is (nil? (:expired-at object)))
-    (t/is (= :tmp (:backend object)))
+    (t/is (= :assets-fs (:backend object)))
     (t/is (= "data" (:other (meta object))))
     (t/is (= "text/plain" (:content-type (meta object))))
     (t/is (= "content" (slurp @(sto/get-object-data storage object))))
@@ -197,7 +198,8 @@
                                     :is-shared false})
 
         ttfdata (-> (io/resource "app/test_files/font-1.ttf")
-                    (fs/slurp-bytes))
+                    io/input-stream
+                    bs/read-as-bytes)
 
         mfile   {:filename "sample.jpg"
                  :path (th/tempfile "app/test_files/sample.jpg")

backend/test/app/test_helpers.clj

@@ -9,14 +9,15 @@
    [app.common.data :as d]
    [app.common.flags :as flags]
    [app.common.pages :as cp]
+   [app.common.pprint :as pp]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
-   [app.common.pprint :as pp]
    [app.config :as cf]
    [app.db :as db]
    [app.main :as main]
    [app.media]
    [app.migrations]
+   [app.rpc.commands.auth :as cmd.auth]
    [app.rpc.mutations.files :as files]
    [app.rpc.mutations.profile :as profile]
    [app.rpc.mutations.projects :as projects]
@@ -31,8 +32,8 @@
    [expound.alpha :as expound]
    [integrant.core :as ig]
    [mockery.core :as mk]
-   [yetti.request :as yrq]
+   [promesa.core :as p]
-   [promesa.core :as p])
+   [yetti.request :as yrq])
   (:import org.postgresql.ds.PGSimpleDataSource))
 
 (def ^:dynamic *system* nil)
@@ -59,10 +60,12 @@
                            :app.http/router
                            :app.http.awsns/handler
                            :app.http.session/updater
-                           :app.http.oauth/google
+                           :app.auth.oidc/google-provider
-                           :app.http.oauth/gitlab
+                           :app.auth.oidc/gitlab-provider
-                           :app.http.oauth/github
+                           :app.auth.oidc/github-provider
-                           :app.http.oauth/all
+                           :app.auth.oidc/generic-provider
+                           :app.auth.oidc/routes
+                           ;; :app.auth.ldap/provider
                            :app.worker/executors-monitor
                            :app.http.oauth/handler
                            :app.notifications/handler
@@ -81,9 +84,9 @@
     (try
       (binding [*system* system
                 *pool*   (:app.db/pool system)]
-        (mk/with-mocks [mock1 {:target 'app.rpc.mutations.profile/derive-password
+        (mk/with-mocks [mock1 {:target 'app.rpc.commands.auth/derive-password
                                :return identity}
-                        mock2 {:target 'app.rpc.mutations.profile/verify-password
+                        mock2 {:target 'app.rpc.commands.auth/verify-password
                                :return (fn [a b] {:valid (= a b)})}]
           (next)))
       (finally
@@ -140,8 +143,8 @@
                         :is-demo false}
                        params)]
      (->> params
-          (#'profile/create-profile conn)
+          (cmd.auth/create-profile conn)
-          (#'profile/create-profile-relations conn)))))
+          (cmd.auth/create-profile-relations conn)))))
 
 (defn create-project*
   ([i params] (create-project* *pool* i params))
@@ -267,17 +270,21 @@
        {:error (handle-error e#)
         :result nil})))
 
+(defn command!
+  [{:keys [::type] :as data}]
+  (let [method-fn (get-in *system* [:app.rpc/methods :commands type])]
+    ;; (app.common.pprint/pprint (:app.rpc/methods *system*))
+    (try-on! (method-fn (dissoc data ::type)))))
+
 (defn mutation!
   [{:keys [::type] :as data}]
-  (let [method-fn (get-in *system* [:app.rpc/rpc :methods :mutation type])]
+  (let [method-fn (get-in *system* [:app.rpc/methods :mutations type])]
-    (try-on!
+    (try-on! (method-fn (dissoc data ::type)))))
-     (method-fn (dissoc data ::type)))))
 
 (defn query!
   [{:keys [::type] :as data}]
-  (let [method-fn (get-in *system* [:app.rpc/rpc :methods :query type])]
+  (let [method-fn (get-in *system* [:app.rpc/methods :queries type])]
-    (try-on!
+    (try-on! (method-fn (dissoc data ::type)))))
-     (method-fn (dissoc data ::type)))))
 
 ;; --- UTILS
 

common/deps.edn

@@ -1,9 +1,9 @@
 {:deps
- {org.clojure/clojure {:mvn/version "1.10.3"}
+ {org.clojure/clojure {:mvn/version "1.11.1"}
   org.clojure/data.json {:mvn/version "2.4.0"}
   org.clojure/tools.cli {:mvn/version "1.0.206"}
-  metosin/jsonista {:mvn/version "0.3.5"}
+  metosin/jsonista {:mvn/version "0.3.6"}
-  org.clojure/clojurescript {:mvn/version "1.11.4"}
+  org.clojure/clojurescript {:mvn/version "1.11.57"}
 
   ;; Logging
   org.apache.logging.log4j/log4j-api {:mvn/version "2.17.2"}
@@ -13,7 +13,7 @@
   org.apache.logging.log4j/log4j-slf4j18-impl {:mvn/version "2.17.2"}
   org.slf4j/slf4j-api {:mvn/version "2.0.0-alpha1"}
 
-  selmer/selmer {:mvn/version "1.12.50"}
+  selmer/selmer {:mvn/version "1.12.51"}
   criterium/criterium {:mvn/version "0.4.6"}
 
   expound/expound {:mvn/version "0.9.0"}
@@ -22,7 +22,7 @@
   java-http-clj/java-http-clj {:mvn/version "0.4.3"}
 
   funcool/promesa {:mvn/version "8.0.450"}
-  funcool/cuerdas {:mvn/version "2022.03.27-397"}
+  funcool/cuerdas {:mvn/version "2022.06.16-403"}
 
   lambdaisland/uri {:mvn/version "1.13.95"
                     :exclusions [org.clojure/data.json]}
@@ -33,7 +33,7 @@
   com.sun.mail/jakarta.mail {:mvn/version "2.0.1"}
 
   ;; exception printing
-  fipp/fipp {:mvn/version "0.6.25"}
+  fipp/fipp {:mvn/version "0.6.26"}
   io.aviso/pretty {:mvn/version "1.1.1"}
   environ/environ {:mvn/version "1.2.0"}}
  :paths ["src"]
@@ -42,7 +42,7 @@
   {:extra-deps
    {org.clojure/tools.namespace {:mvn/version "RELEASE"}
     org.clojure/test.check {:mvn/version "RELEASE"}
-    thheller/shadow-cljs {:mvn/version "2.17.8"}
+    thheller/shadow-cljs {:mvn/version "2.19.5"}
     com.bhauman/rebel-readline {:mvn/version "RELEASE"}
     criterium/criterium {:mvn/version "RELEASE"}
     mockery/mockery {:mvn/version "RELEASE"}}

common/package.json

@@ -13,7 +13,7 @@
     "test": "yarn run compile-test && yarn run run-test"
   },
   "devDependencies": {
-    "shadow-cljs": "2.17.8",
+    "shadow-cljs": "2.19.5",
     "source-map-support": "^0.5.19",
     "ws": "^7.4.6"
   }

common/src/app/common/data.cljc

@@ -23,6 +23,9 @@
   #?(:clj
      (:import linked.set.LinkedSet)))
 
+(def boolean-or-nil?
+  (some-fn nil? boolean?))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Data Structures
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

common/src/app/common/exceptions.cljc

@@ -50,6 +50,12 @@
   [& exprs]
   `(try* (^:once fn* [] ~@exprs) identity))
 
+(defn with-always
+  "A helper that evaluates an exptession independently if the body
+  raises exception or not."
+  [always-expr & body]
+  `(try ~@body (finally ~always-expr)))
+
 (defn ex-info?
   [v]
   (instance? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core.ExceptionInfo) v))

common/src/app/common/file_builder.cljc

@@ -11,9 +11,9 @@
    [app.common.geom.matrix :as gmt]
    [app.common.geom.shapes :as gsh]
    [app.common.pages.changes :as ch]
+   [app.common.pages.changes-spec :as pcs]
    [app.common.pages.init :as init]
    [app.common.spec :as us]
-   [app.common.spec.change :as spec.change]
    [app.common.uuid :as uuid]
    [cuerdas.core :as str]))
 
@@ -44,9 +44,9 @@
                          :frame-id (:current-frame-id file)))]
 
      (when fail-on-spec?
-       (us/verify ::spec.change/change change))
+       (us/verify ::pcs/change change))
 
-     (let [valid? (us/valid? ::spec.change/change change)]
+     (let [valid? (us/valid? ::pcs/change change)]
        #?(:cljs
           (when-not valid? (.warn js/console "Invalid shape" (clj->js change))))
 
@@ -222,9 +222,13 @@
 
 (defn close-artboard [file]
   (assert (nil? (:current-component-id file)))
-  (-> file
+
-      (assoc :current-frame-id root-frame)
+  (let [parent-id (-> file :parent-id peek)
-      (update :parent-stack pop)))
+        parent (lookup-shape file parent-id)
+        current-frame-id (or (:frame-id parent) root-frame)]
+    (-> file
+        (assoc :current-frame-id current-frame-id)
+        (update :parent-stack pop))))
 
 (defn add-group [file data]
   (let [frame-id (:current-frame-id file)

common/src/app/common/geom/shapes.cljc

@@ -98,13 +98,6 @@
 (defn distance-shapes [shape other]
   (distance-selrect (:selrect shape) (:selrect other)))
 
-(defn shape-stroke-margin
-  [shape stroke-width]
-  (if (= (:type shape) :path)
-    ;; TODO: Calculate with the stroke offset (not implemented yet
-    (mth/sqrt (* 2 stroke-width stroke-width))
-    (- (mth/sqrt (* 2 stroke-width stroke-width)) stroke-width)))
-
 (defn close-attrs?
   "Compares two shapes attributes to see if they are equal or almost
   equal (in case of numeric). Takes into account attributes that are
@@ -159,6 +152,7 @@
 (dm/export gtr/move)
 (dm/export gtr/absolute-move)
 (dm/export gtr/transform-matrix)
+(dm/export gtr/transform-str)
 (dm/export gtr/inverse-transform-matrix)
 (dm/export gtr/transform-point-center)
 (dm/export gtr/transform-rect)
@@ -171,6 +165,7 @@
 (dm/export gtr/merge-modifiers)
 (dm/export gtr/transform-shape)
 (dm/export gtr/transform-selrect)
+(dm/export gtr/transform-selrect-matrix)
 (dm/export gtr/transform-bounds)
 (dm/export gtr/modifiers->transform)
 (dm/export gtr/empty-modifiers?)

common/src/app/common/geom/shapes/bounds.cljc

@@ -0,0 +1,157 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.common.geom.shapes.bounds
+  (:require
+   [app.common.data :as d]
+   [app.common.geom.shapes.rect :as gsr]
+   [app.common.math :as mth]
+   [app.common.pages.helpers :as cph]))
+
+(defn shape-stroke-margin
+  [shape stroke-width]
+  (if (= (:type shape) :path)
+    ;; TODO: Calculate with the stroke offset (not implemented yet
+    (mth/sqrt (* 2 stroke-width stroke-width))
+    (- (mth/sqrt (* 2 stroke-width stroke-width)) stroke-width)))
+
+(defn blur-filters [type value]
+  (->> [value]
+       (remove :hidden)
+       (filter #(= (:type %) type))
+       (map #(hash-map :id (str "filter_" (:id %))
+                       :type (:type %)
+                       :params %))))
+
+(defn shadow-filters [type filters]
+  (->> filters
+       (remove :hidden)
+       (filter #(= (:style %) type))
+       (map #(hash-map :id (str "filter_" (:id %))
+                       :type (:style %)
+                       :params %))))
+
+(defn shape->filters
+  [shape]
+  (d/concat-vec
+   [{:id "BackgroundImageFix" :type :image-fix}]
+
+   ;; Background blur won't work in current SVG specification
+   ;; We can revisit this in the future
+   #_(->> shape :blur   (blur-filters   :background-blur))
+
+   (->> shape :shadow (shadow-filters :drop-shadow))
+   [{:id "shape" :type :blend-filters}]
+   (->> shape :shadow (shadow-filters :inner-shadow))
+   (->> shape :blur   (blur-filters   :layer-blur))))
+
+(defn calculate-filter-bounds [{:keys [x y width height]} filter-entry]
+  (let [{:keys [offset-x offset-y blur spread] :or {offset-x 0 offset-y 0 blur 0 spread 0}} (:params filter-entry)
+        filter-x (min x (+ x offset-x (- spread) (- blur) -5))
+        filter-y (min y (+ y offset-y (- spread) (- blur) -5))
+        filter-width (+ width (mth/abs offset-x) (* spread 2) (* blur 2) 10)
+        filter-height (+ height (mth/abs offset-y) (* spread 2) (* blur 2) 10)]
+    (gsr/make-selrect filter-x filter-y filter-width filter-height)))
+
+(defn get-rect-filter-bounds
+  [selrect filters blur-value]
+  (let [filter-bounds (->> filters
+                           (filter #(= :drop-shadow (:type %)))
+                           (map (partial calculate-filter-bounds selrect))
+                           (concat [selrect])
+                           (gsr/join-selrects))
+        delta-blur (* blur-value 2)
+
+        result
+        (-> filter-bounds
+            (update :x - delta-blur)
+            (update :y - delta-blur)
+            (update :x1 - delta-blur)
+            (update :x1 - delta-blur)
+            (update :x2 + delta-blur)
+            (update :y2 + delta-blur)
+            (update :width + (* delta-blur 2))
+            (update :height + (* delta-blur 2)))]
+
+    result))
+
+(defn get-shape-filter-bounds
+  ([shape]
+   (let [svg-root? (and (= :svg-raw (:type shape)) (not= :svg (get-in shape [:content :tag])))]
+     (if svg-root?
+       (:selrect shape)
+
+       (let [filters (shape->filters shape)
+             blur-value (or (-> shape :blur :value) 0)]
+         (get-rect-filter-bounds (-> shape :points gsr/points->selrect) filters blur-value))))))
+
+(defn calculate-padding
+  ([shape]
+   (calculate-padding shape false))
+
+  ([shape ignore-margin?]
+   (let [stroke-width (apply max 0 (map #(case (:stroke-alignment % :center)
+                                           :center (/ (:stroke-width % 0) 2)
+                                           :outer (:stroke-width % 0)
+                                           0) (:strokes shape)))
+
+         margin (if ignore-margin?
+                  0
+                  (apply max 0 (map #(shape-stroke-margin % stroke-width) (:strokes shape))))
+
+         shadow-width (apply max 0 (map #(case (:style % :drop-shadow)
+                                           :drop-shadow (+ (mth/abs (:offset-x %)) (* (:spread %) 2) (* (:blur %) 2) 10)
+                                           0) (:shadow shape)))
+
+         shadow-height (apply max 0 (map #(case (:style % :drop-shadow)
+                                            :drop-shadow (+ (mth/abs (:offset-y %)) (* (:spread %) 2) (* (:blur %) 2) 10)
+                                            0) (:shadow shape)))]
+
+     {:horizontal (+ stroke-width margin shadow-width)
+      :vertical (+ stroke-width margin shadow-height)})))
+
+(defn- add-padding
+  [bounds padding]
+  (-> bounds
+      (update :x - (:horizontal padding))
+      (update :y - (:vertical padding))
+      (update :width + (* 2 (:horizontal padding)))
+      (update :height + (* 2 (:vertical padding)))))
+
+(defn get-object-bounds
+  [objects shape]
+
+  (let [calculate-base-bounds
+        (fn [shape]
+          (-> (get-shape-filter-bounds shape)
+              (add-padding (calculate-padding shape true))))
+
+        bounds
+        (cph/reduce-objects
+         objects
+         (fn [shape]
+           (and (d/not-empty? (:shapes shape))
+                (or (not (cph/frame-shape? shape))
+                    (:show-content shape))
+
+                (or (not (cph/group-shape? shape))
+                    (not (:masked-group? shape)))))
+
+         (:id shape)
+
+         (fn [result shape]
+           (conj result (get-object-bounds objects shape)))
+
+         [(calculate-base-bounds shape)])
+
+
+        children-bounds (or (:children-bounds shape) (gsr/join-selrects bounds))
+
+        filters (shape->filters shape)
+        blur-value (or (-> shape :blur :value) 0)]
+
+    (get-rect-filter-bounds children-bounds filters blur-value)))
+

common/src/app/common/geom/shapes/transforms.cljc

@@ -7,6 +7,7 @@
 (ns app.common.geom.shapes.transforms
   (:require
    [app.common.data :as d]
+   [app.common.data.macros :as dm]
    [app.common.geom.matrix :as gmt]
    [app.common.geom.point :as gpt]
    [app.common.geom.shapes.common :as gco]
@@ -143,16 +144,30 @@
   ([shape params]
    (transform-matrix shape params (or (gco/center-shape shape) (gpt/point 0 0))))
 
-  ([{:keys [flip-x flip-y] :as shape} {:keys [no-flip]} shape-center]
+  ([{:keys [flip-x flip-y transform] :as shape} {:keys [no-flip]} shape-center]
    (-> (gmt/matrix)
        (gmt/translate shape-center)
 
-       (gmt/multiply (:transform shape (gmt/matrix)))
+       (cond-> (some? transform)
+         (gmt/multiply transform))
+
        (cond->
            (and (not no-flip) flip-x) (gmt/scale (gpt/point -1 1))
            (and (not no-flip) flip-y) (gmt/scale (gpt/point 1 -1)))
        (gmt/translate (gpt/negate shape-center)))))
 
+(defn transform-str
+  ([shape]
+   (transform-str shape nil))
+
+  ([{:keys [transform flip-x flip-y] :as shape} {:keys [no-flip]}]
+   (if (and (some? shape)
+            (or (some? transform)
+                (and (not no-flip) flip-x)
+                (and (not no-flip) flip-y)))
+     (dm/str (transform-matrix shape))
+     "")))
+
 (defn inverse-transform-matrix
   ([shape]
    (let [shape-center (or (gco/center-shape shape)
@@ -632,6 +647,13 @@
         (transform-bounds center modifiers)
         (gpr/points->selrect))))
 
+(defn transform-selrect-matrix
+  [selrect mtx]
+  (-> selrect
+      (gpr/rect->points)
+      (gco/transform-points mtx)
+      (gpr/points->selrect)))
+
 (defn selection-rect
   "Returns a rect that contains all the shapes and is aware of the
   rotation of each shape. Mainly used for multiple selection."

common/src/app/common/pages.cljc

@@ -26,8 +26,8 @@
 (dm/export focus/is-in-focus?)
 
 ;; Indices
-(dm/export indices/calculate-z-index)
+#_(dm/export indices/calculate-z-index)
-(dm/export indices/update-z-index)
+#_(dm/export indices/update-z-index)
 (dm/export indices/generate-child-all-parents-index)
 (dm/export indices/generate-child-parent-index)
 (dm/export indices/create-clip-index)

common/src/app/common/pages/changes.cljc

@@ -16,8 +16,8 @@
    [app.common.pages.helpers :as cph]
    [app.common.pages.init :as init]
    [app.common.spec :as us]
-   [app.common.spec.change :as spec.change]
+   [app.common.pages.changes-spec :as pcs]
-   [app.common.spec.shape :as spec.shape]))
+   [app.common.types.shape :as cts]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Specific helpers
@@ -49,7 +49,7 @@
    ;; When verify? false we spec the schema validation. Currently used to make just
    ;; 1 validation even if the changes are applied twice
    (when verify?
-     (us/assert ::spec.change/changes items))
+     (us/assert ::pcs/changes items))
 
    (let [result (reduce #(or (process-change %1 %2) %1) data items)]
      ;; Validate result shapes (only on the backend)
@@ -59,7 +59,7 @@
             (doseq [[id shape] (:objects page)]
               (when-not (= shape (get-in data [:pages-index page-id :objects id]))
                 ;; If object has change verify is correct
-                (us/verify ::spec.shape/shape shape))))))
+                (us/verify ::cts/shape shape))))))
 
      result)))
 
@@ -211,7 +211,7 @@
             (let [invalid-targets (calculate-invalid-targets objects shape-id)]
               (and (contains? objects shape-id)
                    (not (invalid-targets parent-id))
-                   (cph/valid-frame-target? objects parent-id shape-id))))
+                   #_(cph/valid-frame-target? objects parent-id shape-id))))
 
           (insert-items [prev-shapes index shapes]
             (let [prev-shapes (or prev-shapes [])]

common/src/app/common/pages/changes_spec.cljc

@@ -4,14 +4,14 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.common.spec.change
+(ns app.common.pages.changes-spec
   (:require
    [app.common.spec :as us]
-   [app.common.spec.color :as color]
+   [app.common.types.color :as ctc]
-   [app.common.spec.file :as file]
+   [app.common.types.file :as ctf]
-   [app.common.spec.page :as page]
+   [app.common.types.page :as ctp]
-   [app.common.spec.shape :as shape]
+   [app.common.types.shape :as cts]
-   [app.common.spec.typography :as typg]
+   [app.common.types.typography :as ctt]
    [clojure.spec.alpha :as s]))
 
 (s/def ::index integer?)
@@ -52,7 +52,7 @@
   (s/keys :req-un [:internal.changes.set-option/option
                    :internal.changes.set-option/value]))
 
-(s/def :internal.changes.add-obj/obj ::shape/shape)
+(s/def :internal.changes.add-obj/obj ::cts/shape)
 
 (defn- valid-container-id-frame?
   [o]
@@ -89,18 +89,18 @@
          valid-container-id?))
 
 (defmethod change-spec :reg-objects [_]
-  (s/and (s/keys :req-un [::shape/shapes]
+  (s/and (s/keys :req-un [::cts/shapes]
                  :opt-un [::page-id ::component-id])
          valid-container-id?))
 
 (defmethod change-spec :mov-objects [_]
-  (s/and (s/keys :req-un [::parent-id ::shape/shapes]
+  (s/and (s/keys :req-un [::parent-id ::cts/shapes]
                  :opt-un [::page-id ::component-id ::index])
          valid-container-id?))
 
 (defmethod change-spec :add-page [_]
   (s/or :empty (s/keys :req-un [::id ::name])
-        :complete (s/keys :req-un [::page/page])))
+        :complete (s/keys :req-un [::ctp/page])))
 
 (defmethod change-spec :mod-page [_]
   (s/keys :req-un [::id ::name]))
@@ -112,21 +112,21 @@
   (s/keys :req-un [::id ::index]))
 
 (defmethod change-spec :add-color [_]
-  (s/keys :req-un [::color/color]))
+  (s/keys :req-un [::ctc/color]))
 
 (defmethod change-spec :mod-color [_]
-  (s/keys :req-un [::color/color]))
+  (s/keys :req-un [::ctc/color]))
 
 (defmethod change-spec :del-color [_]
   (s/keys :req-un [::id]))
 
-(s/def :internal.changes.add-recent-color/color ::color/recent-color)
+(s/def :internal.changes.add-recent-color/color ::ctc/recent-color)
 
 (defmethod change-spec :add-recent-color [_]
   (s/keys :req-un [:internal.changes.add-recent-color/color]))
 
 
-(s/def :internal.changes.add-media/object ::file/media-object)
+(s/def :internal.changes.add-media/object ::ctf/media-object)
 (defmethod change-spec :add-media [_]
   (s/keys :req-un [:internal.changes.add-media/object]))
 
@@ -149,7 +149,7 @@
   (s/keys :req-un [::id]))
 
 (s/def :internal.changes.add-component/shapes
-  (s/coll-of ::shape/shape))
+  (s/coll-of ::cts/shape))
 
 (defmethod change-spec :add-component [_]
   (s/keys :req-un [::id ::name :internal.changes.add-component/shapes]
@@ -163,13 +163,13 @@
   (s/keys :req-un [::id]))
 
 (defmethod change-spec :add-typography [_]
-  (s/keys :req-un [::typg/typography]))
+  (s/keys :req-un [::ctt/typography]))
 
 (defmethod change-spec :mod-typography [_]
-  (s/keys :req-un [::typg/typography]))
+  (s/keys :req-un [::ctt/typography]))
 
 (defmethod change-spec :del-typography [_]
-  (s/keys :req-un [::typg/id]))
+  (s/keys :req-un [::ctt/id]))
 
 (s/def ::change (s/multi-spec change-spec :type))
 (s/def ::changes (s/coll-of ::change))

common/src/app/common/pages/common.cljc

@@ -80,8 +80,11 @@
             :x :y
             :rx :ry
             :r1 :r2 :r3 :r4
+            :rotation
             :selrect
             :points
+            :show-content
+            :hide-in-viewer
 
             :opacity
             :blend-mode

common/src/app/common/pages/focus.cljc

@@ -8,26 +8,20 @@
   (:require
    [app.common.data :as d]
    [app.common.pages.helpers :as cph]
-   [app.common.pages.indices :as cpi]
    [app.common.uuid :as uuid]))
 
 (defn focus-objects
   [objects focus]
-  (let [[ids-with-children z-index]
+  (let [ids-with-children
         (when (d/not-empty? focus)
-          [(into (conj focus uuid/zero)
+          (into (conj focus uuid/zero)
-                 (mapcat (partial cph/get-children-ids objects))
+                (mapcat (partial cph/get-children-ids objects))
-                 focus)
+                focus))]
-           (cpi/calculate-z-index objects)])
-
-        sort-by-z-index
-        (fn [coll]
-          (->> coll (sort-by (fn [a b] (- (get z-index a) (get z-index b))))))]
 
     (cond-> objects
       (some? ids-with-children)
       (-> (select-keys ids-with-children)
-          (assoc-in [uuid/zero :shapes] (sort-by-z-index focus))))))
+          (assoc-in [uuid/zero :shapes] (cph/sort-z-index objects focus))))))
 
 (defn filter-not-focus
   [objects focus ids]

common/src/app/common/pages/helpers.cljc

@@ -9,23 +9,36 @@
    [app.common.data :as d]
    [app.common.data.macros :as dm]
    [app.common.geom.shapes :as gsh]
+   [app.common.math :as mth]
    [app.common.spec :as us]
-   [app.common.spec.page :as spec.page]
+   [app.common.types.page :as ctp]
    [app.common.uuid :as uuid]
    [cuerdas.core :as str]))
 
+(declare reduce-objects)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; GENERIC SHAPE SELECTORS AND PREDICATES
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defn root-frame?
+(defn root?
   [{:keys [id type]}]
-  (and (= type :frame)
+  (and (= type :frame) (= id uuid/zero)))
-       (= id uuid/zero)))
+
+(defn root-frame?
+  ([objects id]
+   (root-frame? (get objects id)))
+
+  ([{:keys [frame-id type]}]
+   (and (= type :frame)
+        (= frame-id uuid/zero))))
 
 (defn frame-shape?
-  [{:keys [type]}]
+  ([objects id]
-  (= type :frame))
+   (frame-shape? (get objects id)))
+
+  ([{:keys [type]}]
+   (= type :frame)))
 
 (defn group-shape?
   [{:keys [type]}]
@@ -39,6 +52,10 @@
   [{:keys [type]}]
   (= type :image))
 
+(defn svg-raw-shape?
+  [{:keys [type]}]
+  (= type :svg-raw))
+
 (defn unframed-shape?
   "Checks if it's a non-frame shape in the top level."
   [shape]
@@ -47,7 +64,7 @@
 
 (defn get-shape
   [container shape-id]
-  (us/assert ::spec.page/container container)
+  (us/assert ::ctp/container container)
   (us/assert ::us/uuid shape-id)
   (-> container
       (get :objects)
@@ -93,9 +110,10 @@
   "Returns a vector of parents of the specified shape."
   [objects shape-id]
   (loop [result [] id shape-id]
-    (if-let [parent-id (dm/get-in objects [id :parent-id])]
+    (let [parent-id (dm/get-in objects [id :parent-id])]
-      (recur (conj result parent-id) parent-id)
+      (if (and (some? parent-id) (not= parent-id id))
-      result)))
+        (recur (conj result parent-id) parent-id)
+        result))))
 
 (defn get-frame
   "Get the frame that contains the shape. If the shape is already a
@@ -140,38 +158,146 @@
           (:shapes)
           (keep lookup)))))
 
-(defn get-frames-ids
-  "Retrieves all frame objects as vector. It is not implemented in
-  function of `get-immediate-children` for performance reasons. This
-  function is executed in the render hot path."
-  [objects]
-  (let [lookup (d/getf objects)
-        xform  (comp (keep lookup)
-                     (filter frame-shape?)
-                     (map :id))]
-    (->> (:shapes (lookup uuid/zero))
-         (into [] xform))))
-
 (defn get-frames
+  "Retrieves all frame objects as vector"
+  [objects]
+  (if (contains? (meta objects) ::index-frames)
+    (::index-frames (meta objects))
+    (let [lookup (d/getf objects)
+          xform  (comp (remove #(= uuid/zero %))
+                       (keep lookup)
+                       (filter frame-shape?))]
+      (->> (keys objects)
+           (into [] xform)))))
+
+(defn get-frames-ids
+  "Retrieves all frame ids as vector"
+  [objects]
+  (->> (get-frames objects)
+       (mapv :id)))
+
+(defn get-nested-frames
+  [objects frame-id]
+  (into #{}
+        (comp (filter frame-shape?)
+              (map :id))
+        (get-children objects frame-id)))
+
+(defn get-root-frames-ids
   "Retrieves all frame objects as vector. It is not implemented in
   function of `get-immediate-children` for performance reasons. This
   function is executed in the render hot path."
   [objects]
-  (let [lookup (d/getf objects)
+  (let [add-frame
-        xform  (comp (keep lookup)
+        (fn [result shape]
-                     (filter frame-shape?))]
+          (cond-> result
-    (->> (:shapes (lookup uuid/zero))
+            (frame-shape? shape)
-         (into [] xform))))
+            (conj (:id shape))))]
+    (reduce-objects objects (complement frame-shape?) add-frame [])))
+
+(defn get-root-objects
+  "Get all the objects under the root object"
+  [objects]
+  (let [add-shape
+        (fn [result shape]
+          (conj result shape))]
+    (reduce-objects objects (complement frame-shape?) add-shape [])))
+
+(defn get-root-shapes
+  "Get all shapes that are not frames"
+  [objects]
+  (let [add-shape
+        (fn [result shape]
+          (cond-> result
+            (not (frame-shape? shape))
+            (conj shape)))]
+    (reduce-objects objects (complement frame-shape?) add-shape [])))
+
+(defn get-root-shapes-ids
+  [objects]
+  (->> (get-root-shapes objects)
+       (mapv :id)))
+
+(defn- get-base
+  [objects id-a id-b]
+
+  (let [parents-a (reverse (get-parents-seq objects id-a))
+        parents-b (reverse (get-parents-seq objects id-b))
+
+        [base base-child-a base-child-b]
+        (loop [parents-a (rest parents-a)
+               parents-b (rest parents-b)
+               base uuid/zero]
+          (cond
+            (not= (first parents-a) (first parents-b))
+            [base (first parents-a) (first parents-b)]
+
+            (or (empty? parents-a) (empty? parents-b))
+            [uuid/zero (first parents-a) (first parents-b)]
+
+            :else
+            (recur (rest parents-a) (rest parents-b) (first parents-a))))
+
+        index-base-a (when base-child-a (get-position-on-parent objects base-child-a))
+        index-base-b (when base-child-b (get-position-on-parent objects base-child-b))]
+
+    [base index-base-a index-base-b]))
+
+(defn is-shape-over-shape?
+  [objects base-shape-id over-shape-id {:keys [top-frames?]}]
+
+  (let [[base index-a index-b] (get-base objects base-shape-id over-shape-id)]
+    (cond
+      (= base base-shape-id)
+      (and (not top-frames?)
+           (frame-shape? objects base-shape-id)
+           (root-frame? objects base-shape-id))
+
+      (= base over-shape-id)
+      (or top-frames?
+          (not (frame-shape? objects over-shape-id))
+          (not (root-frame? objects over-shape-id)))
+
+      :else
+      (< index-a index-b))))
+
+(defn sort-z-index
+  ([objects ids]
+   (sort-z-index objects ids nil))
+
+  ([objects ids {:keys [bottom-frames?] :as options}]
+   (letfn [(comp [id-a id-b]
+             (let [type-a (dm/get-in objects [id-a :type])
+                   type-b (dm/get-in objects [id-b :type])]
+               (cond
+                 (and bottom-frames? (= :frame type-a) (not= :frame type-b))
+                 1
+
+                 (and bottom-frames? (not= :frame type-a) (= :frame type-b))
+                 -1
+
+                 (= id-a id-b)
+                 0
+
+                 (is-shape-over-shape? objects id-a id-b options)
+                 1
+
+                 :else
+                 -1)))]
+     (sort comp ids))))
 
 (defn frame-id-by-position
   [objects position]
-  (let [frames (get-frames objects)]
+  (let [top-frame
-    (or
+        (->> (get-frames-ids objects)
-     (->> frames
+             (sort-z-index objects)
-          (reverse)
+             (d/seek #(and position (gsh/has-point? (get objects %) position))))]
-          (d/seek #(and position (gsh/has-point? % position)))
+    (or top-frame uuid/zero)))
-          :id)
+
-     uuid/zero)))
+(defn frame-by-position
+  [objects position]
+  (let [frame-id (frame-id-by-position objects position)]
+    (get objects frame-id)))
 
 (declare indexed-shapes)
 
@@ -520,3 +646,87 @@
 
     (-> (select-keys objects selected+parents)
         (d/update-vals remove-children))))
+
+(defn is-child?
+  [objects parent-id candidate-child-id]
+  (let [parents (get-parents-seq objects candidate-child-id)]
+    (some? (d/seek #(= % parent-id) parents))))
+
+(defn reduce-objects
+  ([objects reducer-fn init-val]
+   (reduce-objects objects nil reducer-fn init-val))
+
+  ([objects check-children? reducer-fn init-val]
+   (reduce-objects objects check-children? uuid/zero reducer-fn init-val))
+
+  ([objects check-children? root-id reducer-fn init-val]
+   (let [root-children (get-in objects [root-id :shapes])]
+     (if (empty? root-children)
+       init-val
+
+       (loop [current-val init-val
+              current-id  (first root-children)
+              pending-ids (rest root-children)]
+
+
+         (let [current-shape (get objects current-id)
+               next-val (reducer-fn current-val current-shape)
+               next-pending-ids
+               (if (or (nil? check-children?) (check-children? current-shape))
+                 (concat (or (:shapes current-shape) []) pending-ids)
+                 pending-ids)]
+
+           (if (empty? next-pending-ids)
+             next-val
+             (recur next-val (first next-pending-ids) (rest next-pending-ids)))))))))
+
+(defn selected-with-children
+  [objects selected]
+
+  (into selected
+        (mapcat #(get-children-ids objects %))
+        selected))
+
+(defn get-shape-id-root-frame
+  [objects shape-id]
+  (->> (get-parents-seq objects shape-id)
+       (map (d/getf objects))
+       (d/seek #(and (= :frame (:type %))
+                     (= uuid/zero (:frame-id %))))
+
+       :id))
+
+(defn get-viewer-frames
+  ([objects]
+   (get-viewer-frames objects nil))
+
+  ([objects {:keys [all-frames?]}]
+   (into []
+         (comp (map (d/getf objects))
+               (if all-frames?
+                 identity
+                 (remove :hide-in-viewer)))
+         (sort-z-index objects (get-frames-ids objects) {:top-frames? true}))))
+
+
+(defn start-page-index
+  [objects]
+  (with-meta objects {::index-frames (get-frames (with-meta objects nil))}))
+
+(defn update-page-index
+  [objects]
+  (with-meta objects {::index-frames (get-frames (with-meta objects nil))}))
+
+(defn start-object-indices
+  [file]
+  (letfn [(process-index [page-index page-id]
+            (update-in page-index [page-id :objects] start-page-index))]
+    (update file :pages-index #(reduce process-index % (keys %)))))
+
+(defn update-object-indices
+  [file page-id]
+  (update-in file [:pages-index page-id :objects] update-page-index))
+
+(defn rotated-frame?
+  [frame]
+  (not (mth/almost-zero? (:rotation frame 0))))

common/src/app/common/pages/indices.cljc

@@ -8,76 +8,7 @@
   (:require
    [app.common.data :as d]
    [app.common.pages.helpers :as cph]
-   [app.common.uuid :as uuid]
+   [app.common.uuid :as uuid]))
-   [clojure.set :as set]))
-
-(defn calculate-frame-z-index
-  [z-index frame-id base-idx objects]
-
-  (let [is-frame?    (fn [id] (= :frame (get-in objects [id :type])))
-        children     (or (get-in objects [frame-id :shapes]) [])]
-
-    (if (empty? children)
-      z-index
-      (loop [current (peek children)
-             pending (pop children)
-             current-idx base-idx
-             z-index z-index]
-
-        (let [children  (get-in objects [current :shapes])
-              is-frame? (is-frame? current)
-              pending   (if (not is-frame?)
-                          (d/concat-vec pending children)
-                          pending)]
-
-          (if (empty? pending)
-            (assoc z-index current current-idx)
-            (recur (peek pending)
-                   (pop pending)
-                   (dec current-idx)
-                   (assoc z-index current current-idx))))))))
-
-;; The z-index is really calculated per-frame. Every frame will have its own
-;; internal z-index. To calculate the "final" z-index we add the shape z-index with
-;; the z-index of its frame. This way we can update the z-index per frame without
-;; the need of recalculate all the frames
-(defn calculate-z-index
-  "Given a collection of shapes calculates their z-index. Greater index
-  means is displayed over other shapes with less index."
-  [objects]
-
-  (let [frames  (cph/get-frames objects)
-
-        by-frame (cph/objects-by-frame objects)
-        frame-base-idx (d/update-vals by-frame count)
-
-        z-index (calculate-frame-z-index {} uuid/zero (get frame-base-idx uuid/zero) objects)]
-    (->> frames
-         (reduce
-          (fn [z-index {:keys [id]}]
-            (calculate-frame-z-index z-index id (get frame-base-idx id) objects)) z-index))))
-
-(defn update-z-index
-  "Updates the z-index given a set of ids to change and the old and new objects
-  representations"
-  [z-index changed-ids old-objects new-objects]
-
-  (let [old-frames (into #{} (map #(get-in old-objects [% :frame-id])) changed-ids)
-        new-frames (into #{} (map #(get-in new-objects [% :frame-id])) changed-ids)
-
-        changed-frames (set/union old-frames new-frames)
-
-        frames (->> (cph/get-frames new-objects)
-                    (map :id)
-                    (filter #(contains? changed-frames %)))
-
-        by-frame       (cph/objects-by-frame new-objects)
-        frame-base-idx (d/update-vals by-frame count)
-        z-index (calculate-frame-z-index z-index uuid/zero (get frame-base-idx uuid/zero) new-objects)]
-
-    (->> frames
-         (reduce (fn [z-index id]
-                   (calculate-frame-z-index z-index id (get frame-base-idx id) new-objects)) z-index))))
 
 (defn generate-child-parent-index
   [objects]
@@ -102,11 +33,16 @@
   "Retrieves the mask information for an object"
   [objects parents-index]
   (let [retrieve-clips
-        (fn [_ parents]
+        (fn [parents]
           (let [lookup-object (fn [id] (get objects id))
                 get-clip-parents
                 (fn [shape]
                   (cond-> []
+                    (and (= :frame (:type shape))
+                         (not (:show-content shape))
+                         (not= uuid/zero (:id shape)))
+                    (conj shape)
+
                     (:masked-group? shape)
                     (conj (get objects (->> shape :shapes first)))
 
@@ -117,5 +53,5 @@
                   (comp (map lookup-object)
                         (mapcat get-clip-parents))
                   parents)))]
-    (->> parents-index
+    (-> parents-index
-         (d/mapm retrieve-clips))))
+        (d/update-vals retrieve-clips))))

common/src/app/common/path/shapes_to_path.cljc

@@ -15,7 +15,7 @@
    [app.common.geom.shapes.path :as gsp]
    [app.common.path.bool :as pb]
    [app.common.path.commands :as pc]
-   [app.common.spec.radius :as ctr]))
+   [app.common.types.shape.radius :as ctsr]))
 
 (def ^:const bezier-circle-c 0.551915024494)
 
@@ -152,7 +152,7 @@
 (defn rect->path
   "Creates a bezier curve that approximates a rounded corner rectangle"
   [{:keys [x y width height] :as shape}]
-  (case (ctr/radius-mode shape)
+  (case (ctsr/radius-mode shape)
     :radius-1
     (let [radius (gso/shape-corners-1 shape)]
       (draw-rounded-rect-path x y width height radius))

common/src/app/common/pprint.cljc

@@ -7,21 +7,16 @@
 (ns app.common.pprint
   (:refer-clojure :exclude [prn])
   (:require
-   [cuerdas.core :as str]
    [fipp.edn :as fpp]))
 
 (defn pprint-str
-  [expr]
+  [expr & {:keys [width level length]
-  (binding [*print-level* 8
+           :or {width 110 level 8 length 25}}]
-            *print-length* 25]
+  (binding [*print-level* level
+            *print-length* length]
     (with-out-str
-      (fpp/pprint expr {:width 110}))))
+      (fpp/pprint expr {:width width}))))
 
 (defn pprint
-  ([expr]
+  [expr & {:as opts}]
-   (println (pprint-str expr)))
+  (println (pprint-str expr opts)))
-  ([label expr]
-   (println (str/concat "============ " label "============"))
-   (pprint expr)))
-
-

common/src/app/common/spec.cljc

@@ -5,7 +5,7 @@
 ;; Copyright (c) UXBOX Labs SL
 
 (ns app.common.spec
-  "Data manipulation and query helper functions."
+  "Data validation & assertion helpers."
   (:refer-clojure :exclude [assert bytes?])
   #?(:cljs (:require-macros [app.common.spec :refer [assert]]))
   (:require
@@ -31,8 +31,6 @@
 (def max-safe-int (int 1e6))
 (def min-safe-int (int -1e6))
 
-(def valid? s/valid?)
-
 ;; --- Conformers
 
 (defn uuid-conformer
@@ -220,46 +218,102 @@
    (fn [s]
      (str/join "," s))))
 
-;; --- Macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; MACROS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defn spec-assert*
+(defn explain-data
-  [spec val hint ctx]
+  [spec value]
-  (if (s/valid? spec val)
+  (s/explain-data spec value))
-    val
-    (let [data (s/explain-data spec val)]
-      (ex/raise :type :assertion
-                :code :spec-validation
-                :hint hint
-                ::ex/data (merge ctx data)))))
 
-(defmacro assert
+(defn valid?
-  "Development only assertion macro."
+  [spec value]
-  [spec x]
+  (s/valid? spec value))
-  (when *assert*
-    (let [nsdata  (:ns &env)
-          context (if nsdata
-                    {:ns (str (:name nsdata))
-                     :name (pr-str spec)
-                     :line (:line &env)
-                     :file (:file (:meta nsdata))}
-                    (let [mdata (meta &form)]
-                      {:ns   (str (ns-name *ns*))
-                       :name (pr-str spec)
-                       :line (:line mdata)}))
-          message (str "spec assert: '" (pr-str spec) "'")]
-      `(spec-assert* ~spec ~x ~message ~context))))
 
-(defmacro verify
+(defmacro assert-expr*
-  "Always active assertion macro (does not obey to :elide-asserts)"
+  "Auxiliar macro for expression assertion."
-  [spec x]
+  [expr hint]
-  (let [nsdata  (:ns &env)
+  `(when-not ~expr
-        context (when nsdata
+     (ex/raise :type :assertion
+               :code :expr-validation
+               :hint ~hint)))
+
+(defmacro assert-spec*
+  "Auxiliar macro for spec assertion."
+  [spec value hint]
+  (let [context (if-let [nsdata (:ns &env)]
                   {:ns (str (:name nsdata))
                    :name (pr-str spec)
                    :line (:line &env)
-                   :file (:file (:meta nsdata))})
+                   :file (:file (:meta nsdata))}
-        message (str "spec verify: '" (pr-str spec) "'")]
+                  {:ns   (str (ns-name *ns*))
-    `(spec-assert* ~spec ~x ~message ~context)))
+                   :name (pr-str spec)
+                   :line (:line (meta &form))})
+        hint    (or hint (str "spec assert: " (pr-str spec)))]
+
+    `(if (valid? ~spec ~value)
+       ~value
+       (let [data# (explain-data ~spec ~value)]
+         (ex/raise :type :assertion
+                   :code :spec-validation
+                   :hint ~hint
+                   ::ex/data (merge ~context data#))))))
+
+(defmacro assert
+  "Is a spec specific assertion macro that only evaluates if *assert*
+  is true. DEPRECATED: it should be replaced by the new, general
+  purpose assert! macro."
+  [spec value]
+  (when *assert*
+    `(assert-spec* ~spec ~value nil)))
+
+(defmacro verify
+  "Is a spec specific assertion macro that evaluates always,
+  independently of *assert* value. DEPRECATED: should be replaced by
+  the new, general purpose `verify!` macro."
+  [spec value]
+  `(assert-spec* ~spec ~value nil))
+
+(defmacro assert!
+  "General purpose assertion macro."
+  [& params]
+  ;; If we only receive two arguments, this means we use the simplified form
+  (let [pcnt (count params)]
+    (cond
+      ;; When we have a single argument, this means a simplified form
+      ;; of expr assertion
+      (= 1 pcnt)
+      (let [expr (first params)
+            hint (str "expr assert failed:" (pr-str expr))]
+        (when *assert*
+          `(assert-expr* ~expr ~hint)))
+
+      ;; If we have two arguments, this can be spec or expr
+      ;; assertion. The spec assertion is determined if the first
+      ;; argument is a qualified keyword.
+      (= 2 pcnt)
+      (let [[spec-or-expr value-or-msg] params]
+        (if (qualified-keyword? spec-or-expr)
+          `(assert-spec* ~spec-or-expr ~value-or-msg nil)
+          `(assert-expr* ~spec-or-expr ~value-or-msg)))
+
+      (= 3 pcnt)
+      (let [[spec value hint] params]
+        `(assert-spec* ~spec ~value ~hint))
+
+      :else
+      (let [{:keys [spec expr hint always? val]} params]
+        (when (or always? *assert*)
+          (if spec
+            `(assert-spec* ~spec ~val ~hint)
+            `(assert-expr* ~expr ~hint)))))))
+
+(defmacro verify!
+  "A variant of `assert!` macro that evaluates always, independently
+  of the *assert* value."
+  [& params]
+  (binding [*assert* true]
+    `(assert! ~@params)))
 
 ;; --- Public Api
 

common/src/app/common/types/color.cljc

@@ -4,7 +4,7 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.common.spec.color
+(ns app.common.types.color
   (:require
     [app.common.data :as d]
     [app.common.spec :as us]

common/src/app/common/types/file.cljc

@@ -4,12 +4,11 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.common.spec.file
+(ns app.common.types.file
   (:require
    [app.common.spec :as us]
-   [app.common.spec.color :as color]
+   [app.common.types.color :as ctc]
-   [app.common.spec.page :as page]
+   [app.common.types.page :as ctp]
-   [app.common.spec.typography]
    [clojure.spec.alpha :as s]))
 
 (s/def :internal.media-object/name string?)
@@ -31,13 +30,13 @@
           :opt-un [:internal.media-object/path]))
 
 (s/def ::colors
-  (s/map-of uuid? ::color/color))
+  (s/map-of uuid? ::ctc/color))
 
 (s/def ::recent-colors
-  (s/coll-of ::color/recent-color :kind vector?))
+  (s/coll-of ::ctc/recent-color :kind vector?))
 
 (s/def ::typographies
-  (s/map-of uuid? :app.common.spec.typography/typography))
+  (s/map-of uuid? :ctst/typography))
 
 (s/def ::pages
   (s/coll-of uuid? :kind vector?))
@@ -46,10 +45,10 @@
   (s/map-of uuid? ::media-object))
 
 (s/def ::pages-index
-  (s/map-of uuid? ::page/page))
+  (s/map-of uuid? ::ctp/page))
 
 (s/def ::components
-  (s/map-of uuid? ::page/container))
+  (s/map-of uuid? ::ctp/container))
 
 (s/def ::data
   (s/keys :req-un [::pages-index

common/src/app/common/types/page.cljc

@@ -4,11 +4,11 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.common.spec.page
+(ns app.common.types.page
   (:require
    [app.common.data :as d]
    [app.common.spec :as us]
-   [app.common.spec.shape :as shape]
+   [app.common.types.shape :as cts]
    [clojure.spec.alpha :as s]))
 
 ;; --- Grid options
@@ -90,7 +90,7 @@
 
 (s/def ::id uuid?)
 (s/def ::name string?)
-(s/def ::objects (s/map-of uuid? ::shape/shape))
+(s/def ::objects (s/map-of uuid? ::cts/shape))
 
 (s/def ::page
   (s/keys :req-un [::id ::name ::objects ::options]))

common/src/app/common/types/shape.cljc

@@ -4,17 +4,17 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.common.spec.shape
+(ns app.common.types.shape
   (:require
    [app.common.geom.matrix :as gmt]
    [app.common.geom.point :as gpt]
    [app.common.spec :as us]
-   [app.common.spec.blur :as blur]
+   [app.common.types.color :as ctc]
-   [app.common.spec.color :as color]
+   [app.common.types.shape.blur :as ctsb]
-   [app.common.spec.export :as export]
+   [app.common.types.shape.export :as ctse]
-   [app.common.spec.interactions :as cti]
+   [app.common.types.shape.interactions :as ctsi]
-   [app.common.spec.radius :as radius]
+   [app.common.types.shape.radius :as ctsr]
-   [app.common.spec.shadow :as shadow]
+   [app.common.types.shape.shadow :as ctss]
    [clojure.set :as set]
    [clojure.spec.alpha :as s]))
 
@@ -47,11 +47,13 @@
 
 (s/def ::fill-color string?)
 (s/def ::fill-opacity ::us/safe-number)
-(s/def ::fill-color-gradient (s/nilable ::color/gradient))
+(s/def ::fill-color-gradient (s/nilable ::ctc/gradient))
 (s/def ::fill-color-ref-file (s/nilable uuid?))
 (s/def ::fill-color-ref-id (s/nilable uuid?))
 
 (s/def ::hide-fill-on-export boolean?)
+(s/def ::show-content boolean?)
+(s/def ::hide-in-viewer boolean?)
 
 (s/def ::file-thumbnail boolean?)
 (s/def ::masked-group? boolean?)
@@ -67,7 +69,7 @@
 (s/def ::proportion ::us/safe-number)
 (s/def ::proportion-lock boolean?)
 (s/def ::stroke-color string?)
-(s/def ::stroke-color-gradient (s/nilable ::color/gradient))
+(s/def ::stroke-color-gradient (s/nilable ::ctc/gradient))
 (s/def ::stroke-color-ref-file (s/nilable uuid?))
 (s/def ::stroke-color-ref-id (s/nilable uuid?))
 (s/def ::stroke-opacity ::us/safe-number)
@@ -100,7 +102,7 @@
   (s/keys :req-un [::x ::y ::x1 ::y1 ::x2 ::y2 ::width ::height]))
 
 (s/def ::exports
-  (s/coll-of ::export/export :kind vector?))
+  (s/coll-of ::ctse/export :kind vector?))
 
 (s/def ::points
   (s/every ::gpt/point :kind vector?))
@@ -185,12 +187,12 @@
                    ::constraints-h
                    ::constraints-v
                    ::fixed-scroll
-                   ::radius/rx
+                   ::ctsr/rx
-                   ::radius/ry
+                   ::ctsr/ry
-                   ::radius/r1
+                   ::ctsr/r1
-                   ::radius/r2
+                   ::ctsr/r2
-                   ::radius/r3
+                   ::ctsr/r3
-                   ::radius/r4
+                   ::ctsr/r4
                    ::x
                    ::y
                    ::exports
@@ -211,9 +213,9 @@
                    ::width
                    ::height
                    ::masked-group?
-                   ::cti/interactions
+                   ::ctsi/interactions
-                   ::shadow/shadow
+                   ::ctss/shadow
-                   ::blur/blur
+                   ::ctsb/blur
                    ::opacity
                    ::blend-mode]))
 
@@ -254,8 +256,7 @@
                    :internal.shape.text.position-data/rtl
                    :internal.shape.text.position-data/text
                    :internal.shape.text.position-data/text-decoration
-                   :internal.shape.text.position-data/text-transform]
+                   :internal.shape.text.position-data/text-transform]))
-          ))
 
 (s/def :internal.shape.text.position-data/x ::us/safe-number)
 (s/def :internal.shape.text.position-data/y ::us/safe-number)
@@ -303,7 +304,9 @@
 (defmethod shape-spec :frame [_]
   (s/and ::shape-attrs
          (s/keys :opt-un [::file-thumbnail
-                          ::hide-fill-on-export])))
+                          ::hide-fill-on-export
+                          ::show-content
+                          ::hide-in-viewer])))
 
 (s/def ::shape
   (s/and (s/multi-spec shape-spec :type)

common/src/app/common/types/shape/blur.cljc

@@ -4,7 +4,7 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.common.spec.blur
+(ns app.common.types.shape.blur
   (:require
    [app.common.spec :as us]
    [clojure.spec.alpha :as s]))

common/src/app/common/types/shape/export.cljc

@@ -4,12 +4,11 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.common.spec.export
+(ns app.common.types.shape.export
   (:require
    [app.common.spec :as us]
    [clojure.spec.alpha :as s]))
 
-
 (s/def ::suffix string?)
 (s/def ::scale ::us/safe-number)
 (s/def ::type keyword?)
@@ -19,4 +18,3 @@
                    ::suffix
                    ::scale]))
 
-

common/src/app/common/types/shape/interactions.cljc

@@ -4,7 +4,7 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.common.spec.interactions
+(ns app.common.types.shape.interactions
   (:require
    [app.common.data :as d]
    [app.common.geom.point :as gpt]

common/src/app/common/types/shape/radius.cljc

@@ -4,7 +4,7 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.common.spec.radius
+(ns app.common.types.shape.radius
   (:require
     [app.common.pages.common :refer [editable-attrs]]
     [app.common.spec :as us]

common/src/app/common/types/shape/shadow.cljc

@@ -4,10 +4,10 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.common.spec.shadow
+(ns app.common.types.shape.shadow
   (:require
    [app.common.spec :as us]
-   [app.common.spec.color :as color]
+   [app.common.types.color :as ctc]
    [clojure.spec.alpha :as s]))
 
 
@@ -24,7 +24,7 @@
 
 (s/def ::color string?)
 (s/def ::opacity ::us/safe-number)
-(s/def ::gradient (s/nilable ::color/gradient))
+(s/def ::gradient (s/nilable ::ctc/gradient))
 (s/def ::file-id (s/nilable uuid?))
 (s/def ::ref-id (s/nilable uuid?))
 

common/src/app/common/types/typography.cljc

@@ -4,7 +4,7 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.common.spec.typography
+(ns app.common.types.typography
   (:require
    [clojure.spec.alpha :as s]))
 

common/src/app/common/uuid.cljc

@@ -48,3 +48,6 @@
 
 #?(:clj
    (dm/export impl/get-word-high))
+
+#?(:clj
+   (dm/export impl/get-word-low))

common/test/app/common/spec_interactions_test.cljc

@@ -10,62 +10,62 @@
    [clojure.pprint :refer [pprint]]
    [app.common.exceptions :as ex]
    [app.common.pages.init :as cpi]
-   [app.common.spec.interactions :as csi]
+   [app.common.types.shape.interactions :as ctsi]
    [app.common.uuid :as uuid]
    [app.common.geom.point :as gpt]))
 
 (t/deftest set-event-type
-  (let [interaction csi/default-interaction
+  (let [interaction ctsi/default-interaction
         shape       (cpi/make-minimal-shape :rect)
         frame       (cpi/make-minimal-shape :frame)]
 
     (t/testing "Set event type unchanged"
       (let [new-interaction
-            (csi/set-event-type interaction :click shape)]
+            (ctsi/set-event-type interaction :click shape)]
         (t/is (= :click (:event-type new-interaction)))))
 
     (t/testing "Set event type changed"
       (let [new-interaction
-            (csi/set-event-type interaction :mouse-press shape)]
+            (ctsi/set-event-type interaction :mouse-press shape)]
           (t/is (= :mouse-press (:event-type new-interaction)))))
 
     (t/testing "Set after delay on non-frame"
       (let [result (ex/try
-                     (csi/set-event-type interaction :after-delay shape))]
+                     (ctsi/set-event-type interaction :after-delay shape))]
         (t/is (ex/exception? result))))
 
     (t/testing "Set after delay on frame"
       (let [new-interaction
-            (csi/set-event-type interaction :after-delay frame)]
+            (ctsi/set-event-type interaction :after-delay frame)]
         (t/is (= :after-delay (:event-type new-interaction)))
         (t/is (= 600 (:delay new-interaction)))))
 
     (t/testing "Set after delay with previous data"
       (let [interaction (assoc interaction :delay 300)
             new-interaction
-            (csi/set-event-type interaction :after-delay frame)]
+            (ctsi/set-event-type interaction :after-delay frame)]
         (t/is (= :after-delay (:event-type new-interaction)))
         (t/is (= 300 (:delay new-interaction)))))))
 
 
 (t/deftest set-action-type
-  (let [interaction csi/default-interaction]
+  (let [interaction ctsi/default-interaction]
 
     (t/testing "Set action type unchanged"
       (let [new-interaction
-            (csi/set-action-type interaction :navigate)]
+            (ctsi/set-action-type interaction :navigate)]
         (t/is (= :navigate (:action-type new-interaction)))))
 
     (t/testing "Set action type changed"
       (let [new-interaction
-            (csi/set-action-type interaction :prev-screen)]
+            (ctsi/set-action-type interaction :prev-screen)]
         (t/is (= :prev-screen (:action-type new-interaction)))))
 
     (t/testing "Set action type navigate"
       (let [interaction {:event-type :click
                          :action-type :prev-screen}
             new-interaction
-            (csi/set-action-type interaction :navigate)]
+            (ctsi/set-action-type interaction :navigate)]
         (t/is (= :navigate (:action-type new-interaction)))
         (t/is (nil? (:destination new-interaction)))
         (t/is (= false (:preserve-scroll new-interaction)))))
@@ -77,14 +77,14 @@
                          :destination     destination
                          :preserve-scroll true}
             new-interaction
-            (csi/set-action-type interaction :navigate)]
+            (ctsi/set-action-type interaction :navigate)]
         (t/is (= :navigate (:action-type new-interaction)))
         (t/is (= destination (:destination new-interaction)))
         (t/is (= true (:preserve-scroll new-interaction)))))
 
     (t/testing "Set action type open-overlay"
       (let [new-interaction
-            (csi/set-action-type interaction :open-overlay)]
+            (ctsi/set-action-type interaction :open-overlay)]
         (t/is (= :open-overlay (:action-type new-interaction)))
         (t/is (= :center (:overlay-pos-type new-interaction)))
         (t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))
@@ -93,14 +93,14 @@
       (let [interaction (assoc interaction :overlay-pos-type :top-left
                                            :overlay-position (gpt/point 100 200))
             new-interaction
-            (csi/set-action-type interaction :open-overlay)]
+            (ctsi/set-action-type interaction :open-overlay)]
         (t/is (= :open-overlay (:action-type new-interaction)))
         (t/is (= :top-left (:overlay-pos-type new-interaction)))
         (t/is (= (gpt/point 100 200) (:overlay-position new-interaction)))))
 
     (t/testing "Set action type toggle-overlay"
       (let [new-interaction
-            (csi/set-action-type interaction :toggle-overlay)]
+            (ctsi/set-action-type interaction :toggle-overlay)]
         (t/is (= :toggle-overlay (:action-type new-interaction)))
         (t/is (= :center (:overlay-pos-type new-interaction)))
         (t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))
@@ -109,14 +109,14 @@
       (let [interaction (assoc interaction :overlay-pos-type :top-left
                                            :overlay-position (gpt/point 100 200))
             new-interaction
-            (csi/set-action-type interaction :toggle-overlay)]
+            (ctsi/set-action-type interaction :toggle-overlay)]
         (t/is (= :toggle-overlay (:action-type new-interaction)))
         (t/is (= :top-left (:overlay-pos-type new-interaction)))
         (t/is (= (gpt/point 100 200) (:overlay-position new-interaction)))))
 
     (t/testing "Set action type close-overlay"
       (let [new-interaction
-            (csi/set-action-type interaction :close-overlay)]
+            (ctsi/set-action-type interaction :close-overlay)]
         (t/is (= :close-overlay (:action-type new-interaction)))
         (t/is (nil? (:destination new-interaction)))))
 
@@ -124,89 +124,89 @@
       (let [destination (uuid/next)
             interaction (assoc interaction :destination destination)
             new-interaction
-            (csi/set-action-type interaction :close-overlay)]
+            (ctsi/set-action-type interaction :close-overlay)]
         (t/is (= :close-overlay (:action-type new-interaction)))
         (t/is (= destination (:destination new-interaction)))))
 
     (t/testing "Set action type prev-screen"
       (let [new-interaction
-            (csi/set-action-type interaction :prev-screen)]
+            (ctsi/set-action-type interaction :prev-screen)]
         (t/is (= :prev-screen (:action-type new-interaction)))))
 
     (t/testing "Set action type open-url"
       (let [new-interaction
-            (csi/set-action-type interaction :open-url)]
+            (ctsi/set-action-type interaction :open-url)]
         (t/is (= :open-url (:action-type new-interaction)))
         (t/is (= "" (:url new-interaction)))))
 
     (t/testing "Set action type open-url with previous data"
       (let [interaction (assoc interaction :url "https://example.com")
             new-interaction
-            (csi/set-action-type interaction :open-url)]
+            (ctsi/set-action-type interaction :open-url)]
         (t/is (= :open-url (:action-type new-interaction)))
         (t/is (= "https://example.com" (:url new-interaction)))))))
 
 
 (t/deftest option-delay
   (let [frame (cpi/make-minimal-shape :frame)
-        i1    csi/default-interaction
+        i1    ctsi/default-interaction
-        i2    (csi/set-event-type i1 :after-delay frame)]
+        i2    (ctsi/set-event-type i1 :after-delay frame)]
 
   (t/testing "Has delay"
-    (t/is (not (csi/has-delay i1)))
+    (t/is (not (ctsi/has-delay i1)))
-    (t/is (csi/has-delay i2)))
+    (t/is (ctsi/has-delay i2)))
 
   (t/testing "Set delay"
-    (let [new-interaction (csi/set-delay i2 1000)]
+    (let [new-interaction (ctsi/set-delay i2 1000)]
       (t/is (= 1000 (:delay new-interaction)))))))
 
 
 (t/deftest option-destination
   (let [destination (uuid/next)
-        i1          csi/default-interaction
+        i1          ctsi/default-interaction
-        i2          (csi/set-action-type i1 :prev-screen)
+        i2          (ctsi/set-action-type i1 :prev-screen)
-        i3          (csi/set-action-type i1 :open-overlay)]
+        i3          (ctsi/set-action-type i1 :open-overlay)]
 
   (t/testing "Has destination"
-    (t/is (csi/has-destination i1))
+    (t/is (ctsi/has-destination i1))
-    (t/is (not (csi/has-destination i2))))
+    (t/is (not (ctsi/has-destination i2))))
 
   (t/testing "Set destination"
-    (let [new-interaction (csi/set-destination i1 destination)]
+    (let [new-interaction (ctsi/set-destination i1 destination)]
       (t/is (= destination (:destination new-interaction)))
       (t/is (nil? (:overlay-pos-type new-interaction)))
       (t/is (nil? (:overlay-position new-interaction)))))
 
   (t/testing "Set destination of overlay"
-    (let [new-interaction (csi/set-destination i3 destination)]
+    (let [new-interaction (ctsi/set-destination i3 destination)]
       (t/is (= destination (:destination new-interaction)))
       (t/is (= :center (:overlay-pos-type new-interaction)))
       (t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))))
 
 
 (t/deftest option-preserve-scroll
-  (let [i1 csi/default-interaction
+  (let [i1 ctsi/default-interaction
-        i2 (csi/set-action-type i1 :prev-screen)]
+        i2 (ctsi/set-action-type i1 :prev-screen)]
 
   (t/testing "Has preserve-scroll"
-    (t/is (csi/has-preserve-scroll i1))
+    (t/is (ctsi/has-preserve-scroll i1))
-    (t/is (not (csi/has-preserve-scroll i2))))
+    (t/is (not (ctsi/has-preserve-scroll i2))))
 
   (t/testing "Set preserve-scroll"
-    (let [new-interaction (csi/set-preserve-scroll i1 true)]
+    (let [new-interaction (ctsi/set-preserve-scroll i1 true)]
       (t/is (= true (:preserve-scroll new-interaction)))))))
 
 
 (t/deftest option-url
-  (let [i1 csi/default-interaction
+  (let [i1 ctsi/default-interaction
-        i2 (csi/set-action-type i1 :open-url)]
+        i2 (ctsi/set-action-type i1 :open-url)]
 
   (t/testing "Has url"
-    (t/is (not (csi/has-url i1)))
+    (t/is (not (ctsi/has-url i1)))
-    (t/is (csi/has-url i2)))
+    (t/is (ctsi/has-url i2)))
 
   (t/testing "Set url"
-    (let [new-interaction (csi/set-url i2 "https://example.com")]
+    (let [new-interaction (ctsi/set-url i2 "https://example.com")]
       (t/is (= "https://example.com" (:url new-interaction)))))))
 
 
@@ -220,35 +220,35 @@
         objects       {(:id base-frame) base-frame
                        (:id overlay-frame) overlay-frame}
 
-        i1 csi/default-interaction
+        i1 ctsi/default-interaction
-        i2 (csi/set-action-type i1 :open-overlay)
+        i2 (ctsi/set-action-type i1 :open-overlay)
         i3 (-> i1
-               (csi/set-action-type :open-overlay)
+               (ctsi/set-action-type :open-overlay)
-               (csi/set-destination (:id overlay-frame)))]
+               (ctsi/set-destination (:id overlay-frame)))]
 
   (t/testing "Has overlay options"
-    (t/is (not (csi/has-overlay-opts i1)))
+    (t/is (not (ctsi/has-overlay-opts i1)))
-    (t/is (csi/has-overlay-opts i2)))
+    (t/is (ctsi/has-overlay-opts i2)))
 
   (t/testing "Set overlay-pos-type without destination"
-    (let [new-interaction (csi/set-overlay-pos-type i2 :top-right base-frame objects)]
+    (let [new-interaction (ctsi/set-overlay-pos-type i2 :top-right base-frame objects)]
       (t/is (= :top-right (:overlay-pos-type new-interaction)))
       (t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))
 
   (t/testing "Set overlay-pos-type with destination and auto"
-    (let [new-interaction (csi/set-overlay-pos-type i3 :bottom-right base-frame objects)]
+    (let [new-interaction (ctsi/set-overlay-pos-type i3 :bottom-right base-frame objects)]
       (t/is (= :bottom-right (:overlay-pos-type new-interaction)))
       (t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))
 
   (t/testing "Set overlay-pos-type with destination and manual"
-    (let [new-interaction (csi/set-overlay-pos-type i3 :manual base-frame objects)]
+    (let [new-interaction (ctsi/set-overlay-pos-type i3 :manual base-frame objects)]
       (t/is (= :manual (:overlay-pos-type new-interaction)))
       (t/is (= (gpt/point 35 40) (:overlay-position new-interaction)))))
 
   (t/testing "Toggle overlay-pos-type"
-    (let [new-interaction (csi/toggle-overlay-pos-type i3 :center base-frame objects)
+    (let [new-interaction (ctsi/toggle-overlay-pos-type i3 :center base-frame objects)
-          new-interaction-2 (csi/toggle-overlay-pos-type new-interaction :center base-frame objects)
+          new-interaction-2 (ctsi/toggle-overlay-pos-type new-interaction :center base-frame objects)
-          new-interaction-3 (csi/toggle-overlay-pos-type new-interaction-2 :top-right base-frame objects)]
+          new-interaction-3 (ctsi/toggle-overlay-pos-type new-interaction-2 :top-right base-frame objects)]
       (t/is (= :manual (:overlay-pos-type new-interaction)))
       (t/is (= (gpt/point 35 40) (:overlay-position new-interaction)))
       (t/is (= :center (:overlay-pos-type new-interaction-2)))
@@ -257,73 +257,73 @@
       (t/is (= (gpt/point 0 0) (:overlay-position new-interaction-3)))))
 
   (t/testing "Set overlay-position"
-    (let [new-interaction (csi/set-overlay-position i3 (gpt/point 50 60))]
+    (let [new-interaction (ctsi/set-overlay-position i3 (gpt/point 50 60))]
       (t/is (= :manual (:overlay-pos-type new-interaction)))
       (t/is (= (gpt/point 50 60) (:overlay-position new-interaction)))))
 
   (t/testing "Set close-click-outside"
-    (let [new-interaction (csi/set-close-click-outside i3 true)]
+    (let [new-interaction (ctsi/set-close-click-outside i3 true)]
       (t/is (not (:close-click-outside i3)))
       (t/is (:close-click-outside new-interaction))))
 
   (t/testing "Set background-overlay"
-    (let [new-interaction (csi/set-background-overlay i3 true)]
+    (let [new-interaction (ctsi/set-background-overlay i3 true)]
       (t/is (not (:background-overlay i3)))
       (t/is (:background-overlay new-interaction))))))
 
 
 (t/deftest animation-checks
-  (let [i1 csi/default-interaction
+  (let [i1 ctsi/default-interaction
-        i2 (csi/set-action-type i1 :open-overlay)
+        i2 (ctsi/set-action-type i1 :open-overlay)
-        i3 (csi/set-action-type i1 :toggle-overlay)
+        i3 (ctsi/set-action-type i1 :toggle-overlay)
-        i4 (csi/set-action-type i1 :close-overlay)
+        i4 (ctsi/set-action-type i1 :close-overlay)
-        i5 (csi/set-action-type i1 :prev-screen)
+        i5 (ctsi/set-action-type i1 :prev-screen)
-        i6 (csi/set-action-type i1 :open-url)]
+        i6 (ctsi/set-action-type i1 :open-url)]
 
     (t/testing "Has animation?"
-      (t/is (csi/has-animation? i1))
+      (t/is (ctsi/has-animation? i1))
-      (t/is (csi/has-animation? i2))
+      (t/is (ctsi/has-animation? i2))
-      (t/is (csi/has-animation? i3))
+      (t/is (ctsi/has-animation? i3))
-      (t/is (csi/has-animation? i4))
+      (t/is (ctsi/has-animation? i4))
-      (t/is (not (csi/has-animation? i5)))
+      (t/is (not (ctsi/has-animation? i5)))
-      (t/is (not (csi/has-animation? i6))))
+      (t/is (not (ctsi/has-animation? i6))))
 
     (t/testing "Valid push?"
-      (t/is (csi/allow-push? (:action-type i1)))
+      (t/is (ctsi/allow-push? (:action-type i1)))
-      (t/is (not (csi/allow-push? (:action-type i2))))
+      (t/is (not (ctsi/allow-push? (:action-type i2))))
-      (t/is (not (csi/allow-push? (:action-type i3))))
+      (t/is (not (ctsi/allow-push? (:action-type i3))))
-      (t/is (not (csi/allow-push? (:action-type i4))))
+      (t/is (not (ctsi/allow-push? (:action-type i4))))
-      (t/is (not (csi/allow-push? (:action-type i5))))
+      (t/is (not (ctsi/allow-push? (:action-type i5))))
-      (t/is (not (csi/allow-push? (:action-type i6)))))))
+      (t/is (not (ctsi/allow-push? (:action-type i6)))))))
 
 
 (t/deftest set-animation-type
-  (let [i1 csi/default-interaction
+  (let [i1 ctsi/default-interaction
-        i2 (csi/set-animation-type i1 :dissolve)]
+        i2 (ctsi/set-animation-type i1 :dissolve)]
 
     (t/testing "Set animation type nil"
       (let [new-interaction
-            (csi/set-animation-type i1 nil)]
+            (ctsi/set-animation-type i1 nil)]
         (t/is (nil? (-> new-interaction :animation :animation-type)))))
 
     (t/testing "Set animation type unchanged"
       (let [new-interaction
-            (csi/set-animation-type i2 :dissolve)]
+            (ctsi/set-animation-type i2 :dissolve)]
         (t/is (= :dissolve (-> new-interaction :animation :animation-type)))))
 
     (t/testing "Set animation type changed"
       (let [new-interaction
-            (csi/set-animation-type i2 :slide)]
+            (ctsi/set-animation-type i2 :slide)]
         (t/is (= :slide (-> new-interaction :animation :animation-type)))))
 
     (t/testing "Set animation type reset"
       (let [new-interaction
-            (csi/set-animation-type i2 nil)]
+            (ctsi/set-animation-type i2 nil)]
         (t/is (nil? (-> new-interaction :animation)))))
 
     (t/testing "Set animation type dissolve"
       (let [new-interaction
-            (csi/set-animation-type i1 :dissolve)]
+            (ctsi/set-animation-type i1 :dissolve)]
         (t/is (= :dissolve (-> new-interaction :animation :animation-type)))
         (t/is (= 300 (-> new-interaction :animation :duration)))
         (t/is (= :linear (-> new-interaction :animation :easing)))))
@@ -336,14 +336,14 @@
                                               :direction :left
                                               :offset-effect true})
             new-interaction
-            (csi/set-animation-type interaction :dissolve)]
+            (ctsi/set-animation-type interaction :dissolve)]
         (t/is (= :dissolve (-> new-interaction :animation :animation-type)))
         (t/is (= 1000 (-> new-interaction :animation :duration)))
         (t/is (= :ease-out (-> new-interaction :animation :easing)))))
 
     (t/testing "Set animation type slide"
       (let [new-interaction
-            (csi/set-animation-type i1 :slide)]
+            (ctsi/set-animation-type i1 :slide)]
         (t/is (= :slide (-> new-interaction :animation :animation-type)))
         (t/is (= 300 (-> new-interaction :animation :duration)))
         (t/is (= :linear (-> new-interaction :animation :easing)))
@@ -359,7 +359,7 @@
                                               :direction :left
                                               :offset-effect true})
             new-interaction
-            (csi/set-animation-type interaction :slide)]
+            (ctsi/set-animation-type interaction :slide)]
         (t/is (= :slide (-> new-interaction :animation :animation-type)))
         (t/is (= 1000 (-> new-interaction :animation :duration)))
         (t/is (= :ease-out (-> new-interaction :animation :easing)))
@@ -369,7 +369,7 @@
 
     (t/testing "Set animation type push"
       (let [new-interaction
-            (csi/set-animation-type i1 :push)]
+            (ctsi/set-animation-type i1 :push)]
         (t/is (= :push (-> new-interaction :animation :animation-type)))
         (t/is (= 300 (-> new-interaction :animation :duration)))
         (t/is (= :linear (-> new-interaction :animation :easing)))
@@ -383,7 +383,7 @@
                                               :direction :left
                                               :offset-effect true})
             new-interaction
-            (csi/set-animation-type interaction :push)]
+            (ctsi/set-animation-type interaction :push)]
         (t/is (= :push (-> new-interaction :animation :animation-type)))
         (t/is (= 1000 (-> new-interaction :animation :duration)))
         (t/is (= :ease-out (-> new-interaction :animation :easing)))
@@ -391,9 +391,9 @@
 
 
 (t/deftest allowed-animation
-  (let [i1 (csi/set-action-type csi/default-interaction :open-overlay)
+  (let [i1 (ctsi/set-action-type ctsi/default-interaction :open-overlay)
-        i2 (csi/set-action-type csi/default-interaction :close-overlay)
+        i2 (ctsi/set-action-type ctsi/default-interaction :close-overlay)
-        i3 (csi/set-action-type csi/default-interaction :toggle-overlay)]
+        i3 (ctsi/set-action-type ctsi/default-interaction :toggle-overlay)]
 
     (t/testing "Cannot use animation push for an overlay action"
       (let [bad-interaction-1 (assoc i1 :animation {:animation-type :push
@@ -408,72 +408,72 @@
                                                     :duration 1000
                                                     :easing :ease-out
                                                     :direction :left})]
-        (t/is (not (csi/allowed-animation? (:action-type bad-interaction-1)
+        (t/is (not (ctsi/allowed-animation? (:action-type bad-interaction-1)
                                            (-> bad-interaction-1 :animation :animation-type))))
-        (t/is (not (csi/allowed-animation? (:action-type bad-interaction-2)
+        (t/is (not (ctsi/allowed-animation? (:action-type bad-interaction-2)
                                            (-> bad-interaction-1 :animation :animation-type))))
-        (t/is (not (csi/allowed-animation? (:action-type bad-interaction-3)
+        (t/is (not (ctsi/allowed-animation? (:action-type bad-interaction-3)
                                            (-> bad-interaction-1 :animation :animation-type))))))
 
     (t/testing "Remove animation if moving to an forbidden state"
-      (let [interaction (csi/set-animation-type csi/default-interaction :push)
+      (let [interaction (ctsi/set-animation-type ctsi/default-interaction :push)
-            new-interaction (csi/set-action-type interaction :open-overlay)]
+            new-interaction (ctsi/set-action-type interaction :open-overlay)]
         (t/is (nil? (:animation new-interaction)))))))
 
 
 (t/deftest option-duration
-  (let [i1 csi/default-interaction
+  (let [i1 ctsi/default-interaction
-        i2 (csi/set-animation-type csi/default-interaction :dissolve)]
+        i2 (ctsi/set-animation-type ctsi/default-interaction :dissolve)]
 
   (t/testing "Has duration?"
-    (t/is (not (csi/has-duration? i1)))
+    (t/is (not (ctsi/has-duration? i1)))
-    (t/is (csi/has-duration? i2)))
+    (t/is (ctsi/has-duration? i2)))
 
   (t/testing "Set duration"
-    (let [new-interaction (csi/set-duration i2 1000)]
+    (let [new-interaction (ctsi/set-duration i2 1000)]
       (t/is (= 1000 (-> new-interaction :animation :duration)))))))
 
 
 (t/deftest option-easing
-  (let [i1 csi/default-interaction
+  (let [i1 ctsi/default-interaction
-        i2 (csi/set-animation-type csi/default-interaction :dissolve)]
+        i2 (ctsi/set-animation-type ctsi/default-interaction :dissolve)]
 
   (t/testing "Has easing?"
-    (t/is (not (csi/has-easing? i1)))
+    (t/is (not (ctsi/has-easing? i1)))
-    (t/is (csi/has-easing? i2)))
+    (t/is (ctsi/has-easing? i2)))
 
   (t/testing "Set easing"
-    (let [new-interaction (csi/set-easing i2 :ease-in)]
+    (let [new-interaction (ctsi/set-easing i2 :ease-in)]
       (t/is (= :ease-in (-> new-interaction :animation :easing)))))))
 
 
 (t/deftest option-way
-  (let [i1 csi/default-interaction
+  (let [i1 ctsi/default-interaction
-        i2 (csi/set-animation-type csi/default-interaction :slide)
+        i2 (ctsi/set-animation-type ctsi/default-interaction :slide)
-        i3 (csi/set-action-type i2 :open-overlay)]
+        i3 (ctsi/set-action-type i2 :open-overlay)]
 
   (t/testing "Has way?"
-    (t/is (not (csi/has-way? i1)))
+    (t/is (not (ctsi/has-way? i1)))
-    (t/is (csi/has-way? i2))
+    (t/is (ctsi/has-way? i2))
-    (t/is (not (csi/has-way? i3)))
+    (t/is (not (ctsi/has-way? i3)))
     (t/is (some? (-> i3 :animation :way)))) ; <- it exists but is ignored
 
   (t/testing "Set way"
-    (let [new-interaction (csi/set-way i2 :out)]
+    (let [new-interaction (ctsi/set-way i2 :out)]
       (t/is (= :out (-> new-interaction :animation :way)))))))
 
 
 (t/deftest option-direction
-  (let [i1 csi/default-interaction
+  (let [i1 ctsi/default-interaction
-        i2 (csi/set-animation-type csi/default-interaction :push)
+        i2 (ctsi/set-animation-type ctsi/default-interaction :push)
-        i3 (csi/set-animation-type csi/default-interaction :dissolve)]
+        i3 (ctsi/set-animation-type ctsi/default-interaction :dissolve)]
 
   (t/testing "Has direction?"
-    (t/is (not (csi/has-direction? i1)))
+    (t/is (not (ctsi/has-direction? i1)))
-    (t/is (csi/has-direction? i2)))
+    (t/is (ctsi/has-direction? i2)))
 
   (t/testing "Set direction"
-    (let [new-interaction (csi/set-direction i2 :left)]
+    (let [new-interaction (ctsi/set-direction i2 :left)]
       (t/is (= :left (-> new-interaction :animation :direction)))))
 
   (t/testing "Invert direction"
@@ -483,12 +483,12 @@
           a-up (assoc a-right :direction :up)
           a-down (assoc a-right :direction :down)
 
-          a-nil' (csi/invert-direction nil)
+          a-nil' (ctsi/invert-direction nil)
-          a-none' (csi/invert-direction a-none)
+          a-none' (ctsi/invert-direction a-none)
-          a-right' (csi/invert-direction a-right)
+          a-right' (ctsi/invert-direction a-right)
-          a-left' (csi/invert-direction a-left)
+          a-left' (ctsi/invert-direction a-left)
-          a-up' (csi/invert-direction a-up)
+          a-up' (ctsi/invert-direction a-up)
-          a-down' (csi/invert-direction a-down)]
+          a-down' (ctsi/invert-direction a-down)]
 
       (t/is (nil? a-nil'))
       (t/is (nil? (:direction a-none')))
@@ -499,44 +499,44 @@
 
 
 (t/deftest option-offset-effect
-  (let [i1 csi/default-interaction
+  (let [i1 ctsi/default-interaction
-        i2 (csi/set-animation-type csi/default-interaction :slide)
+        i2 (ctsi/set-animation-type ctsi/default-interaction :slide)
-        i3 (csi/set-action-type i2 :open-overlay)]
+        i3 (ctsi/set-action-type i2 :open-overlay)]
 
   (t/testing "Has offset-effect"
-    (t/is (not (csi/has-offset-effect? i1)))
+    (t/is (not (ctsi/has-offset-effect? i1)))
-    (t/is (csi/has-offset-effect? i2))
+    (t/is (ctsi/has-offset-effect? i2))
-    (t/is (not (csi/has-offset-effect? i3)))
+    (t/is (not (ctsi/has-offset-effect? i3)))
     (t/is (some? (-> i3 :animation :offset-effect)))) ; <- it exists but is ignored
 
   (t/testing "Set offset-effect"
-    (let [new-interaction (csi/set-offset-effect i2 true)]
+    (let [new-interaction (ctsi/set-offset-effect i2 true)]
       (t/is (= true (-> new-interaction :animation :offset-effect)))))))
 
 
 (t/deftest modify-interactions
-  (let [i1 (csi/set-action-type csi/default-interaction :open-overlay)
+  (let [i1 (ctsi/set-action-type ctsi/default-interaction :open-overlay)
-        i2 (csi/set-action-type csi/default-interaction :close-overlay)
+        i2 (ctsi/set-action-type ctsi/default-interaction :close-overlay)
-        i3 (csi/set-action-type csi/default-interaction :prev-screen)
+        i3 (ctsi/set-action-type ctsi/default-interaction :prev-screen)
         interactions [i1 i2]]
 
     (t/testing "Add interaction to nil"
-      (let [new-interactions (csi/add-interaction nil i3)]
+      (let [new-interactions (ctsi/add-interaction nil i3)]
         (t/is (= (count new-interactions) 1))
         (t/is (= (:action-type (last new-interactions)) :prev-screen))))
 
     (t/testing "Add interaction to normal"
-      (let [new-interactions (csi/add-interaction interactions i3)]
+      (let [new-interactions (ctsi/add-interaction interactions i3)]
         (t/is (= (count new-interactions) 3))
         (t/is (= (:action-type (last new-interactions)) :prev-screen))))
 
     (t/testing "Remove interaction"
-      (let [new-interactions (csi/remove-interaction interactions 0)]
+      (let [new-interactions (ctsi/remove-interaction interactions 0)]
         (t/is (= (count new-interactions) 1))
         (t/is (= (:action-type (last new-interactions)) :close-overlay))))
 
     (t/testing "Update interaction"
-      (let [new-interactions (csi/update-interaction interactions 1 #(csi/set-action-type % :open-url))]
+      (let [new-interactions (ctsi/update-interaction interactions 1 #(ctsi/set-action-type % :open-url))]
         (t/is (= (count new-interactions) 2))
         (t/is (= (:action-type (last new-interactions)) :open-url))))))
 
@@ -556,16 +556,16 @@
         ids-map {(:id frame1) (:id frame4)
                  (:id frame2) (:id frame5)}
 
-        i1 (csi/set-destination csi/default-interaction (:id frame1))
+        i1 (ctsi/set-destination ctsi/default-interaction (:id frame1))
-        i2 (csi/set-destination csi/default-interaction (:id frame2))
+        i2 (ctsi/set-destination ctsi/default-interaction (:id frame2))
-        i3 (csi/set-destination csi/default-interaction (:id frame3))
+        i3 (ctsi/set-destination ctsi/default-interaction (:id frame3))
-        i4 (csi/set-destination csi/default-interaction nil)
+        i4 (ctsi/set-destination ctsi/default-interaction nil)
-        i5 (csi/set-destination csi/default-interaction (:id frame6))
+        i5 (ctsi/set-destination ctsi/default-interaction (:id frame6))
 
         interactions [i1 i2 i3 i4 i5]]
 
     (t/testing "Remap interactions"
-      (let [new-interactions (csi/remap-interactions interactions ids-map objects)]
+      (let [new-interactions (ctsi/remap-interactions interactions ids-map objects)]
         (t/is (= (count new-interactions) 4))
         (t/is (= (:id frame4) (:destination (get new-interactions 0))))
         (t/is (= (:id frame5) (:destination (get new-interactions 1))))

common/yarn.lock

@@ -533,10 +533,10 @@ shadow-cljs-jar@1.3.2:
   resolved "https://registry.yarnpkg.com/shadow-cljs-jar/-/shadow-cljs-jar-1.3.2.tgz#97273afe1747b6a2311917c1c88d9e243c81957b"
   integrity sha512-XmeffAZHv8z7451kzeq9oKh8fh278Ak+UIOGGrapyqrFBB773xN8vMQ3O7J7TYLnb9BUwcqadKkmgaq7q6fhZg==
 
-shadow-cljs@2.17.3:
+shadow-cljs@2.19.3:
-  version "2.17.3"
+  version "2.19.3"
-  resolved "https://registry.yarnpkg.com/shadow-cljs/-/shadow-cljs-2.17.3.tgz#748e31f67cffdc401691c0cd1bf733a1da53ab5d"
+  resolved "https://registry.yarnpkg.com/shadow-cljs/-/shadow-cljs-2.19.3.tgz#115a33917f8bca1495e0f815dca7ec3957f669af"
-  integrity sha512-GxyczUuCtACq/uEOvdTc61wT/aDOZFy8G/AGc322uTX/oUiZaeTJrwpClXe+0+e7VKG9E9RCqP/cjuG3cAG0fw==
+  integrity sha512-9TsTCRlmR8m1g2ekwblgomRUgJpbifQI99VlRrlH9NMqEzklev3zYAD1dvy4d5h8BoAhgdxOOEg7ld2d45CWTA==
   dependencies:
     node-libs-browser "^2.2.1"
     readline-sync "^1.4.7"

docker/devenv/Dockerfile

@@ -1,12 +1,12 @@
-FROM ubuntu:20.04
+FROM ubuntu:22.04
 LABEL maintainer="Andrey Antukh <niwi@niwi.nz>"
 
 ARG DEBIAN_FRONTEND=noninteractive
 
-ENV NODE_VERSION=v16.14.2 \
+ENV NODE_VERSION=v16.15.1 \
-    CLOJURE_VERSION=1.11.0.1100 \
+    CLOJURE_VERSION=1.11.1.1149 \
-    CLJKONDO_VERSION=2022.03.09 \
+    CLJKONDO_VERSION=2022.06.22 \
-    BABASHKA_VERSION=0.8.0 \
+    BABASHKA_VERSION=0.8.156 \
     LANG=en_US.UTF-8 \
     LC_ALL=en_US.UTF-8
 
@@ -44,7 +44,6 @@ RUN set -ex; \
 RUN set -ex; \
     apt-get -qq update; \
     apt-get -qqy install --no-install-recommends \
-        python \
         build-essential \
         imagemagick \
         ghostscript \
@@ -104,7 +103,7 @@ RUN set -ex; \
     rm -rf /var/lib/apt/lists/*;
 
 RUN set -ex; \
-    curl -LfsSo /tmp/openjdk.tar.gz https://github.com/adoptium/temurin18-binaries/releases/download/jdk-18%2B36/OpenJDK18U-jdk_x64_linux_hotspot_18_36.tar.gz; \
+    curl -LfsSo /tmp/openjdk.tar.gz https://github.com/adoptium/temurin18-binaries/releases/download/jdk-18.0.1%2B10/OpenJDK18U-jdk_x64_linux_hotspot_18.0.1_10.tar.gz; \
     mkdir -p /usr/lib/jvm/openjdk; \
     cd /usr/lib/jvm/openjdk; \
     tar -xf /tmp/openjdk.tar.gz --strip-components=1; \
@@ -120,7 +119,7 @@ RUN set -ex; \
 
 RUN set -ex; \
     curl https://www.postgresql.org/media/keys/ACCC4CF8.asc | sudo apt-key add -; \
-    echo "deb http://apt.postgresql.org/pub/repos/apt focal-pgdg main" >> /etc/apt/sources.list.d/postgresql.list; \
+    echo "deb http://apt.postgresql.org/pub/repos/apt jammy-pgdg main" >> /etc/apt/sources.list.d/postgresql.list; \
     apt-get -qq update; \
     apt-get -qqy install postgresql-client-13; \
     rm -rf /var/lib/apt/lists/*;
@@ -132,8 +131,8 @@ RUN set -ex; \
     tar -xf /tmp/nodejs.tar.xz --strip-components=1; \
     chown -R root /usr/local/nodejs; \
     PATH="$PATH:/usr/local/nodejs/bin"; \
-    /usr/local/nodejs/bin/npm install -g yarn; \
+    /usr/local/nodejs/bin/npm install --location=global yarn; \
-    /usr/local/nodejs/bin/npm install -g svgo; \
+    /usr/local/nodejs/bin/npm install --location=global svgo; \
     rm -rf /tmp/nodejs.tar.xz;
 
 # Install clj-kondo
@@ -143,7 +142,6 @@ RUN set -ex; \
     unzip /tmp/clj-kondo.zip; \
     rm /tmp/clj-kondo.zip;
 
-# Install babashka
 RUN set -ex; \
     cd /tmp; \
     curl -LfsSo /tmp/babashka.tar.gz https://github.com/babashka/babashka/releases/download/v$BABASHKA_VERSION/babashka-$BABASHKA_VERSION-linux-amd64.tar.gz; \
@@ -151,8 +149,10 @@ RUN set -ex; \
     tar -xf /tmp/babashka.tar.gz; \
     rm -rf /tmp/babashka.tar.gz;
 
+
+# Install minio client
 RUN set -ex; \
-    curl -LfsSo /tmp/mc https://dl.min.io/client/mc/release/linux-amd64/mc --user-agent "Mozilla/5.0 (Macintosh; Intel Mac OS X 10_15_7) AppleWebKit/605.1.15 (KHTML, like Gecko) Version/14.1.1 Safari/605.1.15"; \
+    wget -O /tmp/mc https://dl.min.io/client/mc/release/linux-amd64/mc; \
     mv /tmp/mc /usr/local/bin/; \
     chmod +x /usr/local/bin/mc;
 

docker/images/Dockerfile.backend

@@ -1,4 +1,4 @@
-FROM ubuntu:20.04
+FROM ubuntu:22.04
 LABEL maintainer="Andrey Antukh <niwi@niwi.nz>"
 
 ENV LANG='en_US.UTF-8' LC_ALL='en_US.UTF-8'
@@ -27,16 +27,16 @@ RUN set -eux; \
     ARCH="$(dpkg --print-architecture)"; \
     case "${ARCH}" in \
        aarch64|arm64) \
-         ESUM='7217a9f9be3b0c8dfc78538f95fd2deb493eb651152d975062920566492b2574'; \
+         ESUM='37ceaf232a85cce46bcccfd71839854e8b14bf3160e7ef72a676b9cae45ee8af'; \
-         BINARY_URL='https://github.com/AdoptOpenJDK/openjdk16-binaries/releases/download/jdk-16%2B36/OpenJDK16-jdk_aarch64_linux_hotspot_16_36.tar.gz'; \
+         BINARY_URL='https://github.com/adoptium/temurin18-binaries/releases/download/jdk-18.0.1%2B10/OpenJDK18U-jdk_aarch64_linux_hotspot_18.0.1_10.tar.gz'; \
          ;; \
        armhf|armv7l) \
-         ESUM='f1d32ba01a40c98889f31368c0e987d6bbda65a7c50b8c088623b48e3a90104a'; \
+         ESUM='0ddec3c165ab0b662a57a845db3fdaeb840660b493f164696b03df76aadf61c8'; \
-         BINARY_URL='https://github.com/AdoptOpenJDK/openjdk16-binaries/releases/download/jdk-16%2B36/OpenJDK16-jdk_arm_linux_hotspot_16_36.tar.gz'; \
+         BINARY_URL='https://github.com/adoptium/temurin18-binaries/releases/download/jdk-18.0.1%2B10/OpenJDK18U-jdk_arm_linux_hotspot_18.0.1_10.tar.gz'; \
          ;; \
        amd64|x86_64) \
-         ESUM='2e031cf37018161c9e59b45fa4b98ff2ce4ce9297b824c512989d579a70f8422'; \
+         ESUM='16b1d9d75f22c157af04a1fd9c664324c7f4b5163c022b382a2f2e8897c1b0a2'; \
-         BINARY_URL='https://github.com/AdoptOpenJDK/openjdk16-binaries/releases/download/jdk-16%2B36/OpenJDK16-jdk_x64_linux_hotspot_16_36.tar.gz'; \
+         BINARY_URL='https://github.com/adoptium/temurin18-binaries/releases/download/jdk-18.0.1%2B10/OpenJDK18U-jdk_x64_linux_hotspot_18.0.1_10.tar.gz'; \
          ;; \
        *) \
          echo "Unsupported arch: ${ARCH}"; \

docker/images/Dockerfile.exporter

@@ -1,11 +1,11 @@
-FROM ubuntu:20.04
+FROM ubuntu:22.04
 LABEL maintainer="Andrey Antukh <niwi@niwi.nz>"
 
 ARG DEBIAN_FRONTEND=noninteractive
 
 ENV LANG=en_US.UTF-8 \
     LC_ALL=en_US.UTF-8 \
-    NODE_VERSION=v16.14.2
+    NODE_VERSION=v16.15.1
 
 RUN set -ex; \
     mkdir -p /etc/resolvconf/resolv.conf.d; \
@@ -95,7 +95,7 @@ WORKDIR /opt/app
 ADD ./bundle-exporter/ /opt/app/
 
 RUN set -ex; \
-    yarn install; \
+    yarn; \
     npx playwright install chromium;
 
 CMD ["/usr/local/nodejs/bin/node", "app.js"]