🐛 Fix issue with password persistence

Remove frame thumbnail if the migration modifies a shape.

.github/ISSUE_TEMPLATE/bug_report.md

@@ -8,49 +8,48 @@ assignees: ''
 
 ---
 
-**Describe the bug**
-A clear and concise description of what the bug is.
-
 **To Reproduce**
+
 Steps to reproduce the behavior:
 1.  Go to '...'
 2.  Click on '....'
 3.  Scroll down to '....'
-4.  See error
 
 **Expected behavior**
+
 A clear and concise description of what you expected to happen.
 
+**Actual behavior**
+
+A clear and concise description of what happens instead; what the bug is.
+ 
 **Screenshots**
+
 If applicable, add screenshots to help explain your problem.
 
 **Desktop (please complete the following information):**
-
--   OS: (e.g. iOS)
--   Browser (e.g. chrome, safari)
--   Version (e.g. 22)
+- OS (e.g. iOS):
+- Browser & version (e.g. Chrome 89.0):
 
 **Smartphone (please complete the following information):**
-
--   Device: (e.g. iPhone6)
--   OS: (e.g. iOS8.1)
--   Browser (e.g. stock browser, safari)
--   Version (e.g. 22)
+- Device & model (e.g. iPhone 6):
+- OS & version (e.g. iOS 8.1):
+- Browser & version (e.g. stock browser 22):
 
 **Environment (please complete the following information):**
-Specify if using SAAS (https://design.penpot.app) or self-hosted instance.
+- Host (e.g. https://design.penpot.app, local instance):
 
-If self-hosted instance, add OS and runtime information to help explain your problem.
+*If self-hosted:*
+- OS Version (e.g. Ubuntu 16.04):
+- Docker / Docker-compose version (e.g. Docker version 18.03.0-ce, build 0520e24):
+- Image version (e.g. Alpine):
 
--   OS Version: (e.g. Ubuntu 16.04)
+Docker commands or docker-compose file (if possible and if proceed.x):
+```
 
-Also provide Docker commands or docker-compose file if possible and if proceed.x
-
--   Docker / Docker-compose Version: (e.g. Docker version 18.03.0-ce, build 0520e24)
--   Image (e.g. alpine)
-
-**Frontend Stack Trace (if self-hosted)**
+```
 
+Frontend Stack Trace:
 <details>
 
 ```
@@ -59,8 +58,7 @@ Also provide Docker commands or docker-compose file if possible and if proceed.x
 
 </details>
 
-**Backend Stack Trace (if self-hosted)**
-
+Backend Stack Trace:
 <details>
 
 ```
@@ -69,5 +67,6 @@ Also provide Docker commands or docker-compose file if possible and if proceed.x
 
 </details>
 
-**Additional context**
-Add any other context about the problem here.
+**Additional context:**
+
+Any other context about the problem.

.gitignore

@@ -1,6 +1,7 @@
 *-init.clj
 *.jar
 *.penpot
+*.orig
 .calva
 .clj-kondo
 .cpcache
@@ -33,13 +34,16 @@
 /exporter/.shadow-cljs
 /exporter/target
 /frontend/.shadow-cljs
+/frontend/package-lock.json
 /frontend/cypress/videos/*/
+/frontend/cypress/fixtures/validuser.json
 /frontend/dist/
 /frontend/npm-debug.log
 /frontend/out/
 /frontend/resources/fonts/experiments
 /frontend/resources/public/*
 /frontend/target/
+/frontend/cypress/videos/*/
 /media
 /telemetry/
 /vendor/**/target

CHANGES.md

@@ -1,11 +1,109 @@
 # CHANGELOG
 
-## 1.11.0-beta
+## 1.12.3-beta
+
+### :bug: Bugs fixed
+
+- Fix issue with shift+select to deselect shapes [Taiga #3154](https://tree.taiga.io/project/penpot/issue/3154)
+- Fix issue with drag-select shapes  [Taiga #3165](https://tree.taiga.io/project/penpot/issue/3165)
+- Fix issue on password persistence after registration process on private instances
+
+## 1.12.2-beta
+
+### :bug: Bugs fixed
+
+- Fix issue with guides over shape handlers [Taiga #3032](https://tree.taiga.io/project/penpot/issue/3032)
+- Fix problem with shift+ctrl+click to select [#1671](https://github.com/penpot/penpot/issues/1671)
+- Fix ellipsis in long page names [Taiga #2962](https://tree.taiga.io/project/penpot/issue/2962)
+
+## 1.12.1-beta
+
+### :bug: Bugs fixed
+
+- Fix length of names in sidebar [Taiga #2962](https://tree.taiga.io/project/penpot/issue/2962)
+- Fix issues on loki integration
+
+
+## 1.12.0-beta
 
 ### :boom: Breaking changes
 
 ### :sparkles: New features
 
+- Open feedback in a new window [Taiga #2901](https://tree.taiga.io/project/penpot/us/2901)
+- Improve usage of file menu [Taiga #2853](https://tree.taiga.io/project/penpot/us/2853)
+- Rotation to snap to 15º intervals with shift [Taiga #2437](https://tree.taiga.io/project/penpot/issue/2437)
+- Support border radius and stroke properties for images [Taiga #497](https://tree.taiga.io/project/penpot/us/497)
+- Disallow using same password as user email [Taiga #2454](https://tree.taiga.io/project/penpot/us/2454)
+- Add configurable nudge amount [Taiga #910](https://tree.taiga.io/project/penpot/us/910)
+- Add stroke properties for image shapes [Taiga #497](https://tree.taiga.io/project/penpot/us/497)
+- On user settings, hide the theme selector as long as we only have one theme [Taiga #2610](https://tree.taiga.io/project/penpot/us/2610)
+- Automatically open comments from dashboard notifications [Taiga #2605](https://tree.taiga.io/project/penpot/us/2605)
+- Enhance the behaviour of the artboards list on view mode [Taiga #2634](https://tree.taiga.io/project/penpot/us/2634)
+- Add recent used fonts in font selection widget [Taiga #1381](https://tree.taiga.io/project/penpot/us/1381)
+- Allow to align items relative to groups [Taiga #2533](https://tree.taiga.io/project/penpot/us/2533)
+- Scroll bars [Taiga #2550](https://tree.taiga.io/project/penpot/task/2550)
+- Add select layer option to context menu [Taiga #2474](https://tree.taiga.io/project/penpot/us/2474)
+- Guides [Taiga #290](https://tree.taiga.io/project/penpot/us/290)
+- Improve file menu by adding semantically groups [Github #1203](https://github.com/penpot/penpot/issues/1203)
+- Add update components in bulk option in context menu [Taiga #1975](https://tree.taiga.io/project/penpot/us/1975)
+- Create first E2E tests [Taiga #2608](https://tree.taiga.io/project/penpot/task/2608), [Taiga #2608](https://tree.taiga.io/project/penpot/task/2608)
+- Redesign of workspace toolbars [Taiga #2319](https://tree.taiga.io/project/penpot/us/2319)
+- Graphic Tablet usability improvements [Taiga #1913](https://tree.taiga.io/project/penpot/us/1913)
+- Improved mouse collision detection for groups and text shapes [Taiga #2452](https://tree.taiga.io/project/penpot/us/2452), [Taiga #2453](https://tree.taiga.io/project/penpot/us/2453)
+- Add support for alternative S3 storage providers and all aws regions [#1267](https://github.com/penpot/penpot/issues/1267)
+
+### :bug: Bugs fixed
+
+- Fixed ungroup typography when editing it [Taiga #2391](https://tree.taiga.io/project/penpot/issue/2391) 
+- Fixed error when trying to post an empty comment [Taiga #2603](https://tree.taiga.io/project/penpot/issue/2603)
+- Fixed missing translation strings [Taiga #2786](https://tree.taiga.io/project/penpot/issue/2786)
+- Fixed color palette outside viewport [Taiga #2715](https://tree.taiga.io/project/penpot/issue/2715)
+- Fixed missing translate string [Taiga #2780](https://tree.taiga.io/project/penpot/issue/2780)
+- Fixed handoff shadow type text [Taiga #2717](https://tree.taiga.io/project/penpot/issue/2717)
+- Fixed components get "dirty" marker when moved [Taiga #2764](https://tree.taiga.io/project/penpot/issue/2764)
+- Fixed cannot align objects in a group that is not part of a frame [Taiga #2762](https://tree.taiga.io/project/penpot/issue/2762)
+- Fix problem with double click on exit path editing [Taiga #2906](https://tree.taiga.io/project/penpot/issue/2906)
+- Fixed alignment of layers with children [Taiga #2862](https://tree.taiga.io/project/penpot/issue/2862)
+
+### :heart: Community contributions by (Thank you!)
+
+- Cleanup unused static images (by @rhcarvalho) [#1561](https://github.com/penpot/penpot/pull/1561)
+- Compress static images to save space (by @rhcarvalho) [#1562](https://github.com/penpot/penpot/pull/1562)
+
+## 1.11.2-beta
+
+### :bug: Bugs fixed
+
+- Fix issue on handling empty content on boolean shapes
+- Fix race condition issue on component renaming
+- Handle EOF errors on writting streamed response
+- Handle EOF errors on websocket send/ping methods
+- Disable parallel upload of file media on import (causes too much
+  contention on the rlimit subsistem that does not works as expected
+  on high load).
+
+### :sparkles: New features
+
+- Add health check endpoint on API
+- Increase default max connection pool size to 60
+- Reduce resource usage of the error reporter.
+
+## 1.11.1-beta
+
+### :bug: Bugs fixed
+
+- Fix issue related to default http host config value.
+- Fix issue on rendering frames on firefox.
+
+### :arrow_up: Deps updates
+
+- Update nodejs version to 16.13.1 on docker images.
+
+## 1.11.0-beta
+
+### :sparkles: New features
+
 - Add an option to hide artboards names on the viewport [Taiga #2034](https://tree.taiga.io/project/penpot/issue/2034)
 - Limit pasted object position to container boundaries [Taiga #2449](https://tree.taiga.io/project/penpot/us/2449)
 - Add new options for zoom widget in workspace and viewer mode [Taiga #896](https://tree.taiga.io/project/penpot/us/896)
@@ -81,7 +179,7 @@
 
 ### :arrow_up: Deps updates
 
-- Update devenv docker image dependencies.
+- Update devenv docker image dependencies
 
 ### :heart: Community contributions by (Thank you!)
 
@@ -93,13 +191,13 @@
 
 ### :sparkles: Enhacements
 
-- Allow parametrice file snapshoting interval.
+- Allow parametrice file snapshoting interval
 
 ### :bug: Bugs fixed
 
-- Fix issue on :mov-object change impl.
-- Minor fix on how file changes log is persisted.
-- Fix many issues on error reporting.
+- Fix issue on :mov-object change impl
+- Minor fix on how file changes log is persisted
+- Fix many issues on error reporting
 
 ## 1.10.3-beta
 

backend/deps.edn

@@ -1,12 +1,13 @@
 {:deps
  {penpot/common {:local/root "../common"}
+  org.clojure/clojure {:mvn/version "1.10.3"}
   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.1-1"}
+  com.github.luben/zstd-jni {:mvn/version "1.5.2-1"}
   org.clojure/data.fressian {:mvn/version "1.0.0"}
 
   io.prometheus/simpleclient {:mvn/version "0.14.1"}
@@ -25,7 +26,7 @@
 
   com.github.seancorfield/next.jdbc {:mvn/version "1.2.761"}
   metosin/reitit-ring {:mvn/version "0.5.15"}
-  org.postgresql/postgresql {:mvn/version "42.3.1"}
+  org.postgresql/postgresql {:mvn/version "42.3.2"}
   com.zaxxer/HikariCP {:mvn/version "5.0.1"}
   funcool/datoteka {:mvn/version "2.0.0"}
 
@@ -39,11 +40,11 @@
   org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
   integrant/integrant {:mvn/version "0.8.0"}
 
-  io.sentry/sentry {:mvn/version "5.5.2"}
+  io.sentry/sentry {:mvn/version "5.6.1"}
 
   ;; Pretty Print specs
   pretty-spec/pretty-spec {:mvn/version "0.1.4"}
-  software.amazon.awssdk/s3 {:mvn/version "2.17.111"}}
+  software.amazon.awssdk/s3 {:mvn/version "2.17.122"}}
 
  :paths ["src" "resources" "target/classes"]
  :aliases
@@ -59,13 +60,10 @@
    :extra-paths ["test" "dev"]}
 
   :build
-  {:extra-deps {io.github.clojure/tools.build {:git/tag "v0.7.4" :git/sha "ac442da"}}
+  {:extra-deps
+   {io.github.clojure/tools.build {:git/tag "v0.7.5" :git/sha "34727f7"}}
    :ns-default build}
 
-  :kaocha
-  {:extra-deps {lambdaisland/kaocha {:mvn/version "RELEASE"}}
-   :main-opts ["-m" "kaocha.runner"]}
-
   :test
   {:extra-paths ["test"]
    :extra-deps

backend/dev/user.clj

@@ -6,6 +6,7 @@
 
 (ns user
   (:require
+   [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.geom.matrix :as gmt]
    [app.common.perf :as perf]

backend/scripts/repl

@@ -10,6 +10,18 @@
 # export PENPOT_DATABASE_PASSWORD="penpot_pre"
 # export PENPOT_FLAGS="enable-asserts enable-audit-log $PENPOT_FLAGS"
 
+# Initialize MINIO config
+# mc alias set penpot-s3/ http://minio:9000 minioadmin minioadmin
+# mc admin user add penpot-s3 penpot-devenv penpot-devenv
+# mc admin policy set penpot-s3 readwrite user=penpot-devenv
+# 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-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="
        -A:dev \
        -J-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager \

backend/src/app/cli/manage.clj

@@ -140,7 +140,6 @@
   indicating the action the program should take and the options provided."
   [args]
   (let [{:keys [options arguments errors summary] :as opts} (parse-opts args cli-options)]
-    ;; (pp/pprint opts)
     (cond
       (:help options) ; help => exit OK with usage summary
       {:exit-message (usage summary) :ok? true}

backend/src/app/config.clj

@@ -41,9 +41,7 @@
     data))
 
 (def defaults
-  {:http-server-port 6060
-   :http-server-host "localhost"
-   :host "devenv"
+  {:host "devenv"
    :tenant "dev"
    :database-uri "postgresql://postgres/penpot"
    :database-username "penpot"
@@ -106,12 +104,21 @@
 (s/def ::file-change-snapshot-every ::us/integer)
 (s/def ::file-change-snapshot-timeout ::dt/duration)
 
+(s/def ::default-executor-parallelism ::us/integer)
+(s/def ::blocking-executor-parallelism ::us/integer)
+(s/def ::worker-executor-parallelism ::us/integer)
+
 (s/def ::secret-key ::us/string)
 (s/def ::allow-demo-users ::us/boolean)
 (s/def ::assets-path ::us/string)
+(s/def ::authenticated-cookie-domain ::us/string)
 (s/def ::database-password (s/nilable ::us/string))
 (s/def ::database-uri ::us/string)
 (s/def ::database-username (s/nilable ::us/string))
+(s/def ::database-readonly ::us/boolean)
+(s/def ::database-min-pool-size ::us/integer)
+(s/def ::database-max-pool-size ::us/integer)
+
 (s/def ::default-blob-version ::us/integer)
 (s/def ::error-report-webhook ::us/string)
 (s/def ::user-feedback-destination ::us/string)
@@ -134,6 +141,8 @@
 (s/def ::host ::us/string)
 (s/def ::http-server-port ::us/integer)
 (s/def ::http-server-host ::us/string)
+(s/def ::http-server-min-threads ::us/integer)
+(s/def ::http-server-max-threads ::us/integer)
 (s/def ::http-session-idle-max-age ::dt/duration)
 (s/def ::http-session-updater-batch-max-age ::dt/duration)
 (s/def ::http-session-updater-batch-max-size ::us/integer)
@@ -179,9 +188,11 @@
 (s/def ::storage-assets-fs-directory ::us/string)
 (s/def ::storage-assets-s3-bucket ::us/string)
 (s/def ::storage-assets-s3-region ::us/keyword)
+(s/def ::storage-assets-s3-endpoint ::us/string)
 (s/def ::storage-fdata-s3-bucket ::us/string)
 (s/def ::storage-fdata-s3-region ::us/keyword)
 (s/def ::storage-fdata-s3-prefix ::us/string)
+(s/def ::storage-fdata-s3-endpoint ::us/string)
 (s/def ::telemetry-uri ::us/string)
 (s/def ::telemetry-with-taiga ::us/boolean)
 (s/def ::tenant ::us/string)
@@ -198,11 +209,18 @@
                    ::allow-demo-users
                    ::audit-log-archive-uri
                    ::audit-log-gc-max-age
+                   ::authenticated-cookie-domain
                    ::database-password
                    ::database-uri
                    ::database-username
+                   ::database-readonly
+                   ::database-min-pool-size
+                   ::database-max-pool-size
                    ::default-blob-version
                    ::error-report-webhook
+                   ::default-executor-parallelism
+                   ::blocking-executor-parallelism
+                   ::worker-executor-parallelism
                    ::file-change-snapshot-every
                    ::file-change-snapshot-timeout
                    ::user-feedback-destination
@@ -225,6 +243,8 @@
                    ::host
                    ::http-server-host
                    ::http-server-port
+                   ::http-server-max-threads
+                   ::http-server-min-threads
                    ::http-session-idle-max-age
                    ::http-session-updater-batch-max-age
                    ::http-session-updater-batch-max-size
@@ -274,10 +294,12 @@
                    ::storage-assets-fs-directory
                    ::storage-assets-s3-bucket
                    ::storage-assets-s3-region
+                   ::storage-assets-s3-endpoint
                    ::fdata-storage-backend
                    ::storage-fdata-s3-bucket
                    ::storage-fdata-s3-region
                    ::storage-fdata-s3-prefix
+                   ::storage-fdata-s3-endpoint
                    ::telemetry-enabled
                    ::telemetry-uri
                    ::telemetry-referer

backend/src/app/db.clj

@@ -47,43 +47,63 @@
 ;; Initialization
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(declare instrument-jdbc!)
 (declare apply-migrations!)
 
-(s/def ::name keyword?)
-(s/def ::uri ::us/not-empty-string)
-(s/def ::min-pool-size ::us/integer)
-(s/def ::max-pool-size ::us/integer)
+(s/def ::connection-timeout ::us/integer)
+(s/def ::max-size ::us/integer)
+(s/def ::min-size ::us/integer)
 (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)
 
 (defmethod ig/pre-init-spec ::pool [_]
-  (s/keys :req-un [::uri ::name ::min-pool-size ::max-pool-size]
-          :opt-un [::migrations ::mtx/metrics ::read-only]))
+  (s/keys :req-un [::uri ::name
+                   ::min-size
+                   ::max-size
+                   ::connection-timeout
+                   ::validation-timeout]
+          :opt-un [::migrations
+                   ::username
+                   ::password
+                   ::mtx/metrics
+                   ::read-only]))
+
+(defmethod ig/prep-key ::pool
+  [_ cfg]
+  (merge {: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}
+         (d/without-nils cfg)))
 
 (defmethod ig/init-key ::pool
-  [_ {:keys [migrations metrics name] :as cfg}]
-  (l/info :action "initialize connection pool" :name (d/name name) :uri (:uri cfg))
-  (some-> metrics :registry instrument-jdbc!)
+  [_ {:keys [migrations name read-only] :as cfg}]
+  (l/info :hint "initialize connection pool"
+          :name (d/name name)
+          :uri (:uri cfg)
+          :read-only read-only
+          :with-credentials (and (contains? cfg :username)
+                                 (contains? cfg :password))
+          :min-size (:min-size cfg)
+          :max-size (:max-size cfg))
 
   (let [pool (create-pool cfg)]
-    (some->> (seq migrations) (apply-migrations! pool))
+    (when-not read-only
+      (some->> (seq migrations) (apply-migrations! pool)))
     pool))
 
 (defmethod ig/halt-key! ::pool
   [_ pool]
   (.close ^HikariDataSource pool))
 
-(defn- instrument-jdbc!
-  [registry]
-  (mtx/instrument-vars!
-   [#'next.jdbc/execute-one!
-    #'next.jdbc/execute!]
-   {:registry registry
-    :type :counter
-    :name "database_query_total"
-    :help "An absolute counter of database queries."}))
-
 (defn- apply-migrations!
   [pool migrations]
   (with-open [conn ^AutoCloseable (open pool)]
@@ -100,22 +120,19 @@
        "SET idle_in_transaction_session_timeout = 300000;"))
 
 (defn- create-datasource-config
-  [{:keys [metrics read-only] :or {read-only false} :as cfg}]
-  (let [dburi    (:uri cfg)
-        username (:username cfg)
-        password (:password cfg)
-        config   (HikariConfig.)]
+  [{:keys [metrics uri] :as cfg}]
+  (let [config (HikariConfig.)]
     (doto config
-      (.setJdbcUrl (str "jdbc:" dburi))
-      (.setPoolName (d/name (:name cfg)))
+      (.setJdbcUrl           (str "jdbc:" uri))
+      (.setPoolName          (d/name (:name cfg)))
       (.setAutoCommit true)
-      (.setReadOnly read-only)
-      (.setConnectionTimeout 10000)  ;; 10seg
-      (.setValidationTimeout 10000)  ;; 10seg
-      (.setIdleTimeout 120000)       ;; 2min
-      (.setMaxLifetime 1800000)      ;; 30min
-      (.setMinimumIdle (:min-pool-size cfg 0))
-      (.setMaximumPoolSize (:max-pool-size cfg 50))
+      (.setReadOnly          (:read-only cfg))
+      (.setConnectionTimeout (:connection-timeout cfg))
+      (.setValidationTimeout (:validation-timeout cfg))
+      (.setIdleTimeout       (:idle-timeout cfg))
+      (.setMaxLifetime       (:max-lifetime cfg))
+      (.setMinimumIdle       (:min-size cfg))
+      (.setMaximumPoolSize   (:max-size cfg))
       (.setConnectionInitSql initsql)
       (.setInitializationFailTimeout -1))
 
@@ -125,8 +142,8 @@
            (PrometheusMetricsTrackerFactory.)
            (.setMetricsTrackerFactory config)))
 
-    (when username (.setUsername config username))
-    (when password (.setPassword config password))
+    (some->> ^String (:username cfg) (.setUsername config))
+    (some->> ^String (:password cfg) (.setPassword config))
 
     config))
 
@@ -136,10 +153,14 @@
 
 (s/def ::pool pool?)
 
-(defn pool-closed?
+(defn closed?
   [pool]
   (.isClosed ^HikariDataSource pool))
 
+(defn read-only?
+  [pool]
+  (.isReadOnly ^HikariDataSource pool))
+
 (defn create-pool
   [cfg]
   (let [dsc (create-datasource-config cfg)]

backend/src/app/http.clj

@@ -10,6 +10,7 @@
    [app.common.exceptions :as ex]
    [app.common.logging :as l]
    [app.common.spec :as us]
+   [app.config :as cf]
    [app.http.doc :as doc]
    [app.http.errors :as errors]
    [app.http.middleware :as middleware]
@@ -24,19 +25,30 @@
 
 (declare wrap-router)
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HTTP SERVER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (s/def ::handler fn?)
 (s/def ::router some?)
 (s/def ::port ::us/integer)
 (s/def ::host ::us/string)
 (s/def ::name ::us/string)
-
-(defmethod ig/pre-init-spec ::server [_]
-  (s/keys :req-un [::port]
-          :opt-un [::name ::mtx/metrics ::router ::handler ::host]))
+(s/def ::max-threads ::cf/http-server-max-threads)
+(s/def ::min-threads ::cf/http-server-min-threads)
 
 (defmethod ig/prep-key ::server
   [_ cfg]
-  (merge {:name "http"} (d/without-nils cfg)))
+  (merge {:name "http"
+          :min-threads 4
+          :max-threads 60
+          :port 6060
+          :host "0.0.0.0"}
+         (d/without-nils cfg)))
+
+(defmethod ig/pre-init-spec ::server [_]
+  (s/keys :req-un [::port ::host ::name ::min-threads ::max-threads]
+          :opt-un [::mtx/metrics ::router ::handler]))
 
 (defn- instrument-metrics
   [^Server server metrics]
@@ -48,15 +60,22 @@
 
 (defmethod ig/init-key ::server
   [_ {:keys [handler router port name metrics host] :as opts}]
-  (l/info :msg "starting http server" :port port :host host :name name)
-  (let [options {:http/port port :http/host host}
+  (l/info :hint "starting http server"
+          :port port :host host :name name
+          :min-threads (:min-threads opts)
+          :max-threads (:max-threads opts))
+  (let [options {:http/port port
+                 :http/host host
+                 :thread-pool/max-threads (:max-threads opts)
+                 :thread-pool/min-threads (:min-threads opts)
+                 :ring/async true}
         handler (cond
                   (fn? handler)  handler
                   (some? router) (wrap-router router)
                   :else (ex/raise :type :internal
                                   :code :invalid-argument
                                   :hint "Missing `handler` or `router` option."))
-        server  (-> (yt/server handler options)
+        server  (-> (yt/server handler (d/without-nils options))
                     (cond-> metrics (instrument-metrics metrics)))]
     (assoc opts :server (yt/start! server))))
 
@@ -70,20 +89,20 @@
   (let [default (rr/routes
                  (rr/create-resource-handler {:path "/"})
                  (rr/create-default-handler))
-        options {:middleware [middleware/server-timing]}
+        options {:middleware [middleware/wrap-server-timing]
+                 :inject-match? false
+                 :inject-router? false}
         handler (rr/ring-handler router default options)]
-    (fn [request]
-      (try
-        (handler request)
-        (catch Throwable e
-          (l/with-context (errors/get-error-context request e)
-            (l/error :hint "unexpected error processing request"
-                     :query-string (:query-string request)
-                     :cause e)
-            {:status 500 :body "internal server error"}))))))
+    (fn [request respond _]
+      (handler request respond (fn [cause]
+                                 (l/error :hint "unexpected error processing request"
+                                          ::l/context (errors/get-error-context request cause)
+                                          :query-string (:query-string request)
+                                          :cause cause)
+                                 (respond {:status 500 :body "internal server error"}))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Http Router
+;; HTTP ROUTER
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (s/def ::rpc map?)
@@ -145,13 +164,12 @@
                           [middleware/multipart-params]
                           [middleware/keyword-params]
                           [middleware/format-response-body]
-                          [middleware/etag]
                           [middleware/parse-request-body]
                           [middleware/errors errors/handle]
                           [middleware/cookies]]}
 
+     ["/health" {:get (:health-check debug)}]
      ["/_doc" {:get (doc/handler rpc)}]
-
      ["/feedback" {:middleware [(:middleware session)]
                    :post feedback}]
      ["/auth/oauth/:provider" {:post (:handler oauth)}]

backend/src/app/http/assets.clj

@@ -13,9 +13,12 @@
    [app.db :as db]
    [app.metrics :as mtx]
    [app.storage :as sto]
+   [app.util.async :as async]
    [app.util.time :as dt]
+   [app.worker :as wrk]
    [clojure.spec.alpha :as s]
-   [integrant.core :as ig]))
+   [integrant.core :as ig]
+   [promesa.core :as p]))
 
 (def ^:private cache-max-age
   (dt/duration {:hours 24}))
@@ -52,10 +55,10 @@
        :body (sto/get-object-bytes storage obj)}
 
       :s3
-      (let [url (sto/get-object-url storage obj {:max-age signature-max-age})]
+      (let [{:keys [host port] :as url} (sto/get-object-url storage obj {:max-age signature-max-age})]
         {:status 307
          :headers {"location" (str url)
-                   "x-host"   (:host url)
+                   "x-host"   (cond-> host port (str ":" port))
                    "cache-control" (str "max-age=" (inst-ms cache-max-age))}
          :body ""})
 
@@ -69,29 +72,38 @@
          :body ""}))))
 
 (defn- generic-handler
-  [{:keys [storage] :as cfg} _request id]
-  (let [obj (sto/get-object storage id)]
-    (if obj
-      (serve-object cfg obj)
-      {:status 404 :body ""})))
+  [{:keys [storage executor] :as cfg} request kf]
+  (async/with-dispatch executor
+    (let [id   (get-in request [:path-params :id])
+          mobj (get-file-media-object storage id)
+          obj  (sto/get-object storage (kf mobj))]
+      (if obj
+        (serve-object cfg obj)
+        {:status 404 :body ""}))))
 
 (defn objects-handler
-  [cfg request]
-  (let [id (get-in request [:path-params :id])]
-    (generic-handler cfg request (coerce-id id))))
+  [{:keys [storage executor] :as cfg} request respond raise]
+  (-> (async/with-dispatch executor
+        (let [id (get-in request [:path-params :id])
+              id (coerce-id id)
+              obj  (sto/get-object storage id)]
+          (if obj
+            (serve-object cfg obj)
+            {:status 404 :body ""})))
+      (p/then respond)
+      (p/catch raise)))
 
 (defn file-objects-handler
-  [{:keys [storage] :as cfg} request]
-  (let [id   (get-in request [:path-params :id])
-        mobj (get-file-media-object storage id)]
-    (generic-handler cfg request (:media-id mobj))))
+  [cfg request respond raise]
+  (-> (generic-handler cfg request :media-id)
+      (p/then respond)
+      (p/catch raise)))
 
 (defn file-thumbnails-handler
-  [{:keys [storage] :as cfg} request]
-  (let [id   (get-in request [:path-params :id])
-        mobj (get-file-media-object storage id)]
-    (generic-handler cfg request (or (:thumbnail-id mobj) (:media-id mobj)))))
-
+  [cfg request respond raise]
+  (-> (generic-handler cfg request #(or (:thumbnail-id %) (:media-id %)))
+      (p/then respond)
+      (p/catch raise)))
 
 ;; --- Initialization
 
@@ -101,10 +113,16 @@
 (s/def ::signature-max-age ::dt/duration)
 
 (defmethod ig/pre-init-spec ::handlers [_]
-  (s/keys :req-un [::storage ::mtx/metrics ::assets-path ::cache-max-age ::signature-max-age]))
+  (s/keys :req-un [::storage
+                   ::wrk/executor
+                   ::mtx/metrics
+                   ::assets-path
+                   ::cache-max-age
+                   ::signature-max-age]))
 
 (defmethod ig/init-key ::handlers
   [_ cfg]
-  {:objects-handler #(objects-handler cfg %)
-   :file-objects-handler #(file-objects-handler cfg %)
-   :file-thumbnails-handler #(file-thumbnails-handler cfg %)})
+  {:objects-handler (partial objects-handler cfg)
+   :file-objects-handler (partial file-objects-handler cfg)
+   :file-thumbnails-handler (partial file-thumbnails-handler cfg)})
+

backend/src/app/http/awsns.clj

@@ -26,25 +26,30 @@
 
 (defmethod ig/init-key ::handler
   [_ cfg]
-  (fn [request]
-    (let [body  (parse-json (slurp (:body request)))
-          mtype (get body "Type")]
-      (cond
-        (= mtype "SubscriptionConfirmation")
-        (let [surl   (get body "SubscribeURL")
-              stopic (get body "TopicArn")]
-          (l/info :action "subscription received" :topic stopic :url surl)
-          (http/send! {:uri surl :method :post :timeout 10000}))
+  (fn [request respond _]
+    (try
+      (let [body  (parse-json (slurp (:body request)))
+            mtype (get body "Type")]
+        (cond
+          (= mtype "SubscriptionConfirmation")
+          (let [surl   (get body "SubscribeURL")
+                stopic (get body "TopicArn")]
+            (l/info :action "subscription received" :topic stopic :url surl)
+            (http/send! {:uri surl :method :post :timeout 10000}))
 
-        (= mtype "Notification")
-        (when-let [message (parse-json (get body "Message"))]
-          (let [notification (parse-notification cfg message)]
-            (process-report cfg notification)))
+          (= mtype "Notification")
+          (when-let [message (parse-json (get body "Message"))]
+            (let [notification (parse-notification cfg message)]
+              (process-report cfg notification)))
 
-        :else
-        (l/warn :hint "unexpected data received"
-                :report (pr-str body)))
-      {:status 200 :body ""})))
+          :else
+          (l/warn :hint "unexpected data received"
+                  :report (pr-str body))))
+      (catch Throwable cause
+        (l/error :hint "unexpected exception on awsns handler"
+                 :cause cause)))
+
+    (respond {:status 200 :body ""})))
 
 (defn- parse-bounce
   [data]

backend/src/app/http/debug.clj

@@ -14,14 +14,18 @@
    [app.db :as db]
    [app.rpc.mutations.files :as m.files]
    [app.rpc.queries.profile :as profile]
+   [app.util.async :as async]
    [app.util.blob :as blob]
    [app.util.template :as tmpl]
    [app.util.time :as dt]
+   [app.worker :as wrk]
    [clojure.java.io :as io]
-   [clojure.pprint :as ppr]
+   [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [datoteka.core :as fs]
-   [integrant.core :as ig]))
+   [fipp.edn :as fpp]
+   [integrant.core :as ig]
+   [promesa.core :as p]))
 
 ;; (selmer.parser/cache-off!)
 
@@ -147,21 +151,20 @@
              (some-> (db/get-by-id pool :server-error-report id) :content db/decode-transit-pgobject)))
 
           (render-template [report]
-            (binding [ppr/*print-right-margin* 300]
-              (let [context (dissoc report
-                                    :trace :cause :params :data :spec-problems
-                                    :spec-explain :spec-value :error :explain :hint)
-                    params  {:context (with-out-str (ppr/pprint context))
-                             :hint    (:hint report)
-                             :spec-explain  (:spec-explain report)
-                             :spec-problems (:spec-problems report)
-                             :spec-value    (:spec-value report)
-                             :data          (:data report)
-                             :trace         (or (:trace report)
-                                                (some-> report :error :trace))
-                             :params        (:params report)}]
-                (-> (io/resource "templates/error-report.tmpl")
-                    (tmpl/render params)))))
+            (let [context (dissoc report
+                                  :trace :cause :params :data :spec-problems
+                                  :spec-explain :spec-value :error :explain :hint)
+                  params  {:context (with-out-str (fpp/pprint context {:width 300}))
+                           :hint    (:hint report)
+                           :spec-explain  (:spec-explain report)
+                           :spec-problems (:spec-problems report)
+                           :spec-value    (:spec-value report)
+                           :data          (:data report)
+                           :trace         (or (:trace report)
+                                              (some-> report :error :trace))
+                           :params        (:params report)}]
+              (-> (io/resource "templates/error-report.tmpl")
+                  (tmpl/render params))))
           ]
 
     (when-not (authorized? pool request)
@@ -195,11 +198,30 @@
      :body (-> (io/resource "templates/error-list.tmpl")
                (tmpl/render {:items items}))}))
 
+(defn health-check
+  "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;"])
+    {:status 200 :body "Ok"}))
+
+(defn- wrap-async
+  [{:keys [executor] :as cfg} f]
+  (fn [request respond raise]
+    (-> (async/with-dispatch executor
+          (f cfg request))
+        (p/then respond)
+        (p/catch raise))))
+
+(defmethod ig/pre-init-spec ::handlers [_]
+  (s/keys :req-un [::db/pool ::wrk/executor]))
+
 (defmethod ig/init-key ::handlers
   [_ cfg]
-  {:index (partial index cfg)
-   :retrieve-file-data (partial retrieve-file-data cfg)
-   :retrieve-file-changes (partial retrieve-file-changes cfg)
-   :retrieve-error (partial retrieve-error cfg)
-   :retrieve-error-list (partial retrieve-error-list cfg)
-   :upload-file-data (partial upload-file-data cfg)})
+  {:index (wrap-async cfg index)
+   :health-check (wrap-async cfg health-check)
+   :retrieve-file-data (wrap-async cfg retrieve-file-data)
+   :retrieve-file-changes (wrap-async cfg retrieve-file-changes)
+   :retrieve-error (wrap-async cfg retrieve-error)
+   :retrieve-error-list (wrap-async cfg retrieve-error-list)
+   :upload-file-data (wrap-async cfg upload-file-data)})

backend/src/app/http/doc.clj

@@ -46,8 +46,9 @@
   [rpc]
   (let [context (prepare-context rpc)]
     (if (contains? cf/flags :backend-api-doc)
-      (fn [_]
-        {:status 200
-         :body (-> (io/resource "api-doc.tmpl")
-                   (tmpl/render context))})
-      (constantly {:status 404 :body ""}))))
+      (fn [_ respond _]
+        (respond {:status 200
+                  :body (-> (io/resource "api-doc.tmpl")
+                            (tmpl/render context))}))
+      (fn [_ respond _]
+        (respond {:status 404 :body ""})))))

backend/src/app/http/errors.clj

@@ -9,11 +9,9 @@
   (:require
    [app.common.exceptions :as ex]
    [app.common.logging :as l]
-   [app.common.uuid :as uuid]
-   [clojure.pprint]
+   [app.common.spec :as us]
    [clojure.spec.alpha :as s]
-   [cuerdas.core :as str]
-   [expound.alpha :as expound]))
+   [cuerdas.core :as str]))
 
 (defn- parse-client-ip
   [{:keys [headers] :as request}]
@@ -25,8 +23,7 @@
   [request error]
   (let [data (ex-data error)]
     (merge
-     {:id            (uuid/next)
-      :path          (:uri request)
+     {:path          (:uri request)
       :method        (:request-method request)
       :hint          (ex-message error)
       :params        (:params request)
@@ -36,14 +33,13 @@
       :data          (some-> data (dissoc ::s/problems ::s/value ::s/spec))
       :ip-addr       (parse-client-ip request)
       :profile-id    (:profile-id request)}
+
      (let [headers (:headers request)]
        {:user-agent (get headers "user-agent")
         :frontend-version (get headers "x-frontend-version" "unknown")})
 
      (when (and data (::s/problems data))
-       {:spec-explain (binding [s/*explain-out* expound/printer]
-                        (with-out-str
-                          (s/explain-out (update data ::s/problems #(take 10 %)))))}))))
+       {:spec-explain (us/pretty-explain data)}))))
 
 (defmulti handle-exception
   (fn [err & _rest]
@@ -62,20 +58,20 @@
 (defmethod handle-exception :validation
   [err _]
   (let [data    (ex-data err)
-        explain (binding [s/*explain-out* expound/printer]
-                  (with-out-str
-                    (s/explain-out (update data ::s/problems #(take 10 %)))))]
+        explain (us/pretty-explain data)]
     {:status 400
      :body (-> data
                (dissoc ::s/problems)
                (dissoc ::s/value)
-               (assoc :explain explain))}))
+               (cond-> explain (assoc :explain explain)))}))
 
 (defmethod handle-exception :assertion
   [error request]
   (let [edata (ex-data error)]
-    (l/with-context (get-error-context request error)
-      (l/error ::l/raw (ex-message error) :cause error))
+    (l/error ::l/raw (ex-message error)
+             ::l/context (get-error-context request error)
+             :cause error)
+
     {:status 500
      :body {:type :server-error
             :code :assertion
@@ -97,9 +93,9 @@
              (ex/exception? (:handling edata)))
       (handle-exception (:handling edata) request)
       (do
-        (l/with-context (get-error-context request error)
-          (l/error ::l/raw (ex-message error) :cause error))
-
+        (l/error ::l/raw (ex-message error)
+                 ::l/context (get-error-context request error)
+                 :cause error)
         {:status 500
          :body {:type :server-error
                 :code :unexpected
@@ -109,10 +105,9 @@
 (defmethod handle-exception org.postgresql.util.PSQLException
   [error request]
   (let [state (.getSQLState ^java.sql.SQLException error)]
-
-    (l/with-context (get-error-context request error)
-      (l/error ::l/raw (ex-message error) :cause error))
-
+    (l/error ::l/raw (ex-message error)
+             ::l/context (get-error-context request error)
+             :cause error)
     (cond
       (= state "57014")
       {:status 504

backend/src/app/http/feedback.clj

@@ -14,48 +14,55 @@
    [app.db :as db]
    [app.emails :as eml]
    [app.rpc.queries.profile :as profile]
+   [app.worker :as wrk]
    [clojure.spec.alpha :as s]
-   [integrant.core :as ig]))
+   [integrant.core :as ig]
+   [promesa.core :as p]
+   [promesa.exec :as px]))
 
-(declare send-feedback)
+(declare ^:private send-feedback)
+(declare ^:private handler)
 
 (defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::db/pool]))
+  (s/keys :req-un [::db/pool ::wrk/executor]))
 
 (defmethod ig/init-key ::handler
-  [_ {:keys [pool] :as scfg}]
-  (let [ftoken   (cf/get :feedback-token ::no-token)
-        enabled  (contains? cf/flags :user-feedback)]
-    (fn [{:keys [profile-id] :as request}]
-      (let [token  (get-in request [:headers "x-feedback-token"])
-            params (d/merge (:params request)
-                            (:body-params request))]
+  [_ {:keys [executor] :as cfg}]
+  (let [enabled? (contains? cf/flags :user-feedback)]
+    (if enabled?
+      (fn [request respond raise]
+        (-> (px/submit! executor #(handler cfg request))
+            (p/then' respond)
+            (p/catch raise)))
+      (fn [_ _ raise]
+        (raise (ex/error :type :validation
+                         :code :feedback-disabled
+                         :hint "feedback module is disabled"))))))
 
-        (when-not enabled
-          (ex/raise :type :validation
-                    :code :feedback-disabled
-                    :hint "feedback module is disabled"))
+(defn- handler
+  [{:keys [pool] :as cfg} {:keys [profile-id] :as request}]
+  (let [ftoken (cf/get :feedback-token ::no-token)
+        token  (get-in request [:headers "x-feedback-token"])
+        params (d/merge (:params request)
+                        (:body-params request))]
+    (cond
+      (uuid? profile-id)
+      (let [profile (profile/retrieve-profile-data pool profile-id)
+            params  (assoc params :from (:email profile))]
+        (send-feedback pool profile params))
 
-        (cond
-          (uuid? profile-id)
-          (let [profile (profile/retrieve-profile-data pool profile-id)
-                params  (assoc params :from (:email profile))]
-            (when-not (:is-muted profile)
-              (send-feedback pool profile params)))
+      (= token ftoken)
+      (send-feedback cfg nil params))
 
-          (= token ftoken)
-          (send-feedback scfg nil params))
-
-        {:status 204 :body ""}))))
+    {:status 204 :body ""}))
 
 (s/def ::content ::us/string)
 (s/def ::from    ::us/email)
 (s/def ::subject ::us/string)
-
 (s/def ::feedback
   (s/keys :req-un [::from ::subject ::content]))
 
-(defn send-feedback
+(defn- send-feedback
   [pool profile params]
   (let [params      (us/conform ::feedback params)
         destination (cf/get :feedback-destination)]

backend/src/app/http/middleware.clj

@@ -10,8 +10,6 @@
    [app.common.transit :as t]
    [app.config :as cf]
    [app.util.json :as json]
-   [buddy.core.codecs :as bc]
-   [buddy.core.hash :as bh]
    [ring.core.protocols :as rp]
    [ring.middleware.cookies :refer [wrap-cookies]]
    [ring.middleware.keyword-params :refer [wrap-keyword-params]]
@@ -21,13 +19,15 @@
 
 (defn wrap-server-timing
   [handler]
-  (let [seconds-from #(float (/ (- (System/nanoTime) %) 1000000000))]
-    (fn [request]
-      (let [start    (System/nanoTime)
-            response (handler request)]
-        (update response :headers
-                (fn [headers]
-                  (assoc headers "Server-Timing" (str "total;dur=" (seconds-from start)))))))))
+  (letfn [(get-age [start]
+            (float (/ (- (System/nanoTime) start) 1000000000)))
+
+          (update-headers [headers start]
+            (assoc headers "Server-Timing" (str "total;dur=" (get-age start))))]
+
+    (fn [request respond raise]
+      (let [start (System/nanoTime)]
+        (handler request #(respond (update % :headers update-headers start)) raise)))))
 
 (defn wrap-parse-request-body
   [handler]
@@ -36,32 +36,40 @@
               (t/read! reader)))
 
           (parse-json [body]
-            (json/read body))]
-    (fn [{:keys [headers body] :as request}]
+            (json/read body))
+
+          (handle-request [{:keys [headers body] :as request}]
+            (let [ctype (get headers "content-type")]
+              (case ctype
+                "application/transit+json"
+                (let [params (parse-transit body)]
+                  (-> request
+                      (assoc :body-params params)
+                      (update :params merge params)))
+
+                "application/json"
+                (let [params (parse-json body)]
+                  (-> request
+                      (assoc :body-params params)
+                      (update :params merge params)))
+
+                request)))
+
+          (handle-exception [cause]
+            (let [data {:type :validation
+                        :code :unable-to-parse-request-body
+                        :hint "malformed params"}]
+              (l/error :hint (ex-message cause) :cause cause)
+              {:status 400
+               :headers {"content-type" "application/transit+json"}
+               :body (t/encode-str data {:type :json-verbose})}))]
+
+    (fn [request respond raise]
       (try
-        (let [ctype (get headers "content-type")]
-          (handler (case ctype
-                     "application/transit+json"
-                     (let [params (parse-transit body)]
-                       (-> request
-                           (assoc :body-params params)
-                           (update :params merge params)))
-
-                     "application/json"
-                     (let [params (parse-json body)]
-                       (-> request
-                           (assoc :body-params params)
-                           (update :params merge params)))
-
-                     request)))
-        (catch Exception e
-          (let [data {:type :validation
-                      :code :unable-to-parse-request-body
-                      :hint "malformed params"}]
-            (l/error :hint (ex-message e) :cause e)
-            {:status 400
-             :headers {"content-type" "application/transit+json"}
-             :body (t/encode-str data {:type :json-verbose})}))))))
+        (let [request (handle-request request)]
+          (handler request respond raise))
+        (catch Exception cause
+          (respond (handle-exception cause)))))))
 
 (def parse-request-body
   {:name ::parse-request-body
@@ -81,45 +89,50 @@
 
 (def ^:const buffer-size (:http/output-buffer-size yt/base-defaults))
 
-(defn- transit-streamable-body
-  [data opts]
-  (reify rp/StreamableResponseBody
-    (write-body-to-stream [_ _ output-stream]
-      ;; Use the same buffer as jetty output buffer size
-      (try
-        (with-open [bos (buffered-output-stream output-stream buffer-size)]
-          (let [tw (t/writer bos opts)]
-            (t/write! tw data)))
-        (catch Throwable cause
-          (l/warn :hint "unexpected error on encoding response"
-                  :cause cause))))))
-
-(defn- impl-format-response-body
-  [response {:keys [query-params] :as request}]
-  (let [body   (:body response)
-        opts   {:type (if (contains? query-params "transit_verbose") :json-verbose :json)}]
-
-    (cond
-      (:ws response)
-      response
-
-      (coll? body)
-      (-> response
-          (update :headers assoc "content-type" "application/transit+json")
-          (assoc :body (transit-streamable-body body opts)))
-
-      (nil? body)
-      (assoc response :status 204 :body "")
-
-      :else
-      response)))
-
-(defn- wrap-format-response-body
+(defn wrap-format-response-body
   [handler]
-  (fn [request]
-    (let [response (handler request)]
-      (cond-> response
-        (map? response) (impl-format-response-body request)))))
+  (letfn [(transit-streamable-body [data opts]
+            (reify rp/StreamableResponseBody
+              (write-body-to-stream [_ _ output-stream]
+                ;; Use the same buffer as jetty output buffer size
+                (try
+                  (with-open [bos (buffered-output-stream output-stream buffer-size)]
+                    (let [tw (t/writer bos opts)]
+                      (t/write! tw data)))
+                  (catch org.eclipse.jetty.io.EofException _cause
+                    ;; Do nothing, EOF means client closes connection abruptly
+                    nil)
+                  (catch Throwable cause
+                    (l/warn :hint "unexpected error on encoding response"
+                            :cause cause))))))
+
+          (impl-format-response-body [response {:keys [query-params] :as request}]
+            (let [body   (:body response)
+                  opts   {:type (if (contains? query-params "transit_verbose") :json-verbose :json)}]
+              (cond
+                (:ws response)
+                response
+
+                (coll? body)
+                (-> response
+                    (update :headers assoc "content-type" "application/transit+json")
+                    (assoc :body (transit-streamable-body body opts)))
+
+                (nil? body)
+                (assoc response :status 204 :body "")
+
+                :else
+                response)))
+
+          (handle-response [response request]
+            (cond-> response
+              (map? response) (impl-format-response-body request)))]
+
+    (fn [request respond raise]
+      (handler request
+               (fn [response]
+                 (respond (handle-response response request)))
+               raise))))
 
 (def format-response-body
   {:name ::format-response-body
@@ -127,11 +140,9 @@
 
 (defn wrap-errors
   [handler on-error]
-  (fn [request]
-    (try
-      (handler request)
-      (catch Throwable e
-        (on-error e request)))))
+  (fn [request respond _]
+    (handler request respond (fn [cause]
+                               (-> cause (on-error request) respond)))))
 
 (def errors
   {:name ::errors
@@ -157,41 +168,7 @@
   {:name ::server-timing
    :compile (constantly wrap-server-timing)})
 
-(defn wrap-etag
-  [handler]
-  (letfn [(encode [data]
-            (when (string? data)
-              (str "W/\"" (-> data bh/blake2b-128 bc/bytes->hex) "\"")))]
-    (fn [{method :request-method headers :headers :as request}]
-      (cond-> (handler request)
-        (= :get method)
-        (as-> $ (if-let [etag (-> $ :body meta :etag encode)]
-                  (cond-> (update $ :headers assoc "etag" etag)
-                    (= etag (get headers "if-none-match"))
-                    (-> (assoc :body "")
-                        (assoc :status 304)))
-                  $))))))
-
-(def etag
-  {:name ::etag
-   :compile (constantly wrap-etag)})
-
-(defn activity-logger
-  [handler]
-  (let [logger "penpot.profile-activity"]
-    (fn [{:keys [headers] :as request}]
-      (let [ip-addr    (get headers "x-forwarded-for")
-            profile-id (:profile-id request)
-            qstring    (:query-string request)]
-        (l/info ::l/async true
-                ::l/logger logger
-                :ip-addr ip-addr
-                :profile-id profile-id
-                :uri (str (:uri request) (when qstring (str "?" qstring)))
-                :method (name (:request-method request)))
-        (handler request)))))
-
-(defn- wrap-cors
+(defn wrap-cors
   [handler]
   (if-not (contains? cf/flags :cors)
     handler
@@ -206,12 +183,15 @@
                          (assoc "access-control-allow-credentials" "true")
                          (assoc "access-control-expose-headers" "x-requested-with, content-type, cookie")
                          (assoc "access-control-allow-headers" "x-frontend-version, content-type, accept, x-requested-width"))))))]
-      (fn [request]
+      (fn [request respond raise]
         (if (= (:request-method request) :options)
           (-> {:status 200 :body ""}
-              (add-cors-headers request))
-          (let [response (handler request)]
-            (add-cors-headers response request)))))))
+              (add-cors-headers request)
+              (respond))
+          (handler request
+                   (fn [response]
+                     (respond (add-cors-headers response request)))
+                   raise))))))
 
 (def cors
   {:name ::cors

backend/src/app/http/oauth.clj

@@ -21,7 +21,10 @@
    [clojure.set :as set]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
-   [integrant.core :as ig]))
+   [integrant.core :as ig]
+   [promesa.exec :as px]))
+
+;; TODO: make it fully async (?)
 
 (defn- build-redirect-uri
   [{:keys [provider] :as cfg}]
@@ -213,28 +216,35 @@
       (redirect-response uri))))
 
 (defn- auth-handler
-  [{:keys [tokens] :as cfg} {:keys [params] :as request}]
-  (let [invitation (:invitation-token params)
-        props      (extract-utm-props params)
-        state      (tokens :generate
-                           {:iss :oauth
-                            :invitation-token invitation
-                            :props props
-                            :exp (dt/in-future "15m")})
-        uri        (build-auth-uri cfg state)]
-    {:status 200
-     :body {:redirect-uri uri}}))
+  [{:keys [tokens executor] :as cfg} {:keys [params] :as request} respond _]
+  (px/run!
+   executor
+   (fn []
+     (let [invitation (:invitation-token params)
+           props      (extract-utm-props params)
+           state      (tokens :generate
+                              {:iss :oauth
+                               :invitation-token invitation
+                               :props props
+                               :exp (dt/in-future "15m")})
+           uri        (build-auth-uri cfg state)]
+
+       (respond
+        {:status 200
+         :body {:redirect-uri uri}})))))
 
 (defn- callback-handler
-  [cfg request]
-  (try
-    (let [info     (retrieve-info cfg request)
-          profile  (retrieve-profile cfg info)]
-      (generate-redirect cfg request info profile))
-    (catch Exception e
-      (l/warn :hint "error on oauth process"
-              :cause e)
-      (generate-error-redirect cfg e))))
+  [{:keys [executor] :as cfg} request respond _]
+  (px/run!
+   executor
+   (fn []
+     (try
+       (let [info     (retrieve-info cfg request)
+             profile  (retrieve-profile cfg info)]
+         (respond (generate-redirect cfg request info profile)))
+       (catch Exception cause
+         (l/warn :hint "error on oauth process" :cause cause)
+         (respond (generate-error-redirect cfg cause)))))))
 
 ;; --- INIT
 
@@ -250,15 +260,19 @@
 
 (defn wrap-handler
   [cfg handler]
-  (fn [request]
+  (fn [request respond raise]
     (let [provider (get-in request [:path-params :provider])
           provider (get-in @cfg [:providers provider])]
-      (when-not provider
-        (ex/raise :type :not-found
-                  :context {:provider provider}
-                  :hint "provider not configured"))
-      (-> (assoc @cfg :provider provider)
-          (handler request)))))
+      (if provider
+        (handler (assoc @cfg :provider provider)
+                 request
+                 respond
+                 raise)
+        (raise
+         (ex/error
+          :type :not-found
+          :provider provider
+          :hint "provider not configured"))))))
 
 (defmethod ig/init-key ::handler
   [_ cfg]

backend/src/app/http/session.clj

@@ -11,95 +11,167 @@
    [app.common.logging :as l]
    [app.config :as cfg]
    [app.db :as db]
+   [app.db.sql :as sql]
    [app.metrics :as mtx]
    [app.util.async :as aa]
    [app.util.time :as dt]
    [app.worker :as wrk]
    [clojure.core.async :as a]
    [clojure.spec.alpha :as s]
-   [integrant.core :as ig]))
+   [integrant.core :as ig]
+   [ring.middleware.session.store :as rss]))
 
-;; A default cookie name for storing the session. We don't allow
-;; configure it.
-(def cookie-name "auth-token")
+;; A default cookie name for storing the session. We don't allow to configure it.
+(def token-cookie-name "auth-token")
+
+;; A cookie that we can use to check from other sites of the same domain if a user
+;; is registered. Is not intended for on premise installations, although nothing
+;; prevents using it if some one wants to.
+(def authenticated-cookie-name "authenticated")
+
+(deftype DatabaseStore [pool tokens]
+  rss/SessionStore
+  (read-session [_ token]
+    (db/exec-one! pool (sql/select :http-session {:id token})))
+
+  (write-session [_ _ data]
+    (let [profile-id (:profile-id data)
+          user-agent (:user-agent data)
+          token      (tokens :generate {:iss "authentication"
+                                        :iat (dt/now)
+                                        :uid profile-id})
+
+          now        (dt/now)
+          params     {:user-agent user-agent
+                      :profile-id profile-id
+                      :created-at now
+                      :updated-at now
+                      :id token}]
+      (db/insert! pool :http-session params)
+      token))
+
+  (delete-session [_ token]
+    (db/delete! pool :http-session {:id token})
+    nil))
+
+(deftype MemoryStore [cache tokens]
+  rss/SessionStore
+  (read-session [_ token]
+    (get @cache token))
+
+  (write-session [_ _ data]
+    (let [profile-id (:profile-id data)
+          user-agent (:user-agent data)
+          token      (tokens :generate {:iss "authentication"
+                                        :iat (dt/now)
+                                        :uid profile-id})
+          params     {:user-agent user-agent
+                      :profile-id profile-id
+                      :id token}]
+
+      (swap! cache assoc token params)
+      token))
+
+  (delete-session [_ token]
+    (swap! cache dissoc token)
+    nil))
 
 ;; --- IMPL
 
 (defn- create-session
-  [{:keys [conn tokens] :as cfg} {:keys [profile-id headers] :as request}]
-  (let [token  (tokens :generate {:iss "authentication"
-                                  :iat (dt/now)
-                                  :uid profile-id})
-        params {:user-agent (get headers "user-agent")
-                :profile-id profile-id
-                :id token}]
-    (db/insert! conn :http-session params)))
+  [store request profile-id]
+  (let [params {:user-agent (get-in request [:headers "user-agent"])
+                :profile-id profile-id}]
+    (rss/write-session store nil params)))
 
 (defn- delete-session
-  [{:keys [conn] :as cfg} {:keys [cookies] :as request}]
-  (when-let [token (get-in cookies [cookie-name :value])]
-    (db/delete! conn :http-session {:id token}))
-  nil)
+  [store {:keys [cookies] :as request}]
+  (when-let [token (get-in cookies [token-cookie-name :value])]
+    (rss/delete-session store token)))
 
 (defn- retrieve-session
-  [{:keys [conn] :as cfg} id]
-  (when id
-    (db/exec-one! conn ["select id, profile_id from http_session where id = ?" id])))
+  [store token]
+  (when token
+    (rss/read-session store token)))
 
 (defn- retrieve-from-request
-  [cfg {:keys [cookies] :as request}]
-  (->> (get-in cookies [cookie-name :value])
-       (retrieve-session cfg)))
+  [store {:keys [cookies] :as request}]
+  (->> (get-in cookies [token-cookie-name :value])
+       (retrieve-session store)))
 
 (defn- add-cookies
-  [response {:keys [id] :as session}]
+  [response token]
   (let [cors?   (contains? cfg/flags :cors)
-        secure? (contains? cfg/flags :secure-session-cookies)]
-    (assoc response :cookies {cookie-name {:path "/"
-                                           :http-only true
-                                           :value id
-                                           :same-site (if cors? :none :lax)
-                                           :secure secure?}})))
+        secure? (contains? cfg/flags :secure-session-cookies)
+        authenticated-cookie-domain (cfg/get :authenticated-cookie-domain)]
+    (update response :cookies
+            (fn [cookies]
+              (cond-> cookies
+                :always
+                (assoc token-cookie-name {:path "/"
+                                          :http-only true
+                                          :value token
+                                          :same-site (if cors? :none :lax)
+                                          :secure secure?})
+
+                (some? authenticated-cookie-domain)
+                (assoc authenticated-cookie-name {:domain authenticated-cookie-domain
+                                                  :path "/"
+                                                  :value true
+                                                  :same-site :strict
+                                                  :secure secure?}))))))
 
 (defn- clear-cookies
   [response]
-  (assoc response :cookies {cookie-name {:value "" :max-age -1}}))
+  (let [authenticated-cookie-domain (cfg/get :authenticated-cookie-domain)]
+    (assoc response :cookies {token-cookie-name {:path "/"
+                                                 :value ""
+                                                 :max-age -1}
+                              authenticated-cookie-name {:domain authenticated-cookie-domain
+                                                         :path "/"
+                                                         :value ""
+                                                         :max-age -1}})))
 
 (defn- middleware
-  [cfg handler]
-  (fn [request]
-    (if-let [{:keys [id profile-id] :as session} (retrieve-from-request cfg request)]
+  [events-ch store handler]
+  (fn [request respond raise]
+    (if-let [{:keys [id profile-id] :as session} (retrieve-from-request store request)]
       (do
-        (a/>!! (::events-ch cfg) id)
+        (a/>!! events-ch id)
         (l/set-context! {:profile-id profile-id})
-        (handler (assoc request :profile-id profile-id :session-id id)))
-      (handler request))))
+        (handler (assoc request :profile-id profile-id :session-id id) respond raise))
+      (handler request respond raise))))
 
 ;; --- STATE INIT: SESSION
 
+(s/def ::tokens fn?)
 (defmethod ig/pre-init-spec ::session [_]
-  (s/keys :req-un [::db/pool]))
+  (s/keys :req-un [::db/pool ::tokens]))
 
 (defmethod ig/prep-key ::session
   [_ cfg]
-  (d/merge {:buffer-size 64}
+  (d/merge {:buffer-size 128}
            (d/without-nils cfg)))
 
 (defmethod ig/init-key ::session
-  [_ {:keys [pool] :as cfg}]
-  (let [events (a/chan (a/dropping-buffer (:buffer-size cfg)))
-        cfg    (-> cfg
-                   (assoc :conn pool)
-                   (assoc ::events-ch events))]
+  [_ {:keys [pool tokens] :as cfg}]
+  (let [events-ch (a/chan (a/dropping-buffer (:buffer-size cfg)))
+        store     (if (db/read-only? pool)
+                    (->MemoryStore (atom {}) tokens)
+                    (->DatabaseStore pool tokens))]
+
+    (when (db/read-only? pool)
+      (l/warn :hint "sessions module initialized with in-memory store"))
+
     (-> cfg
-        (assoc :middleware #(middleware cfg %))
+        (assoc ::events-ch events-ch)
+        (assoc :middleware (partial middleware events-ch store))
         (assoc :create (fn [profile-id]
                          (fn [request response]
-                           (let [request (assoc request :profile-id profile-id)
-                                 session (create-session cfg request)]
-                             (add-cookies response session)))))
+                           (let [token (create-session store request profile-id)]
+                             (add-cookies response token)))))
         (assoc :delete (fn [request response]
-                         (delete-session cfg request)
+                         (delete-session store request)
                          (-> response
                              (assoc :status 204)
                              (assoc :body "")
@@ -136,16 +208,11 @@
           :max-batch-size (str (:max-batch-size cfg)))
   (let [input (aa/batch (::events-ch session)
                         {:max-batch-size (:max-batch-size cfg)
-                         :max-batch-age (inst-ms (:max-batch-age cfg))})
-        mcnt  (mtx/create
-               {:name "http_session_update_total"
-                :help "A counter of session update batch events."
-                :registry (:registry metrics)
-                :type :counter})]
+                         :max-batch-age (inst-ms (:max-batch-age cfg))})]
     (a/go-loop []
       (when-let [[reason batch] (a/<! input)]
         (let [result (a/<! (update-sessions cfg batch))]
-          (mcnt :inc)
+          (mtx/run! metrics {:id :session-update-total :inc 1})
           (cond
             (ex/exception? result)
             (l/error :task "updater"
@@ -154,9 +221,10 @@
 
             (= :size reason)
             (l/debug :task "updater"
-                     :action "update sessions"
+                     :hint "update sessions"
                      :reason (name reason)
                      :count result))
+
           (recur))))))
 
 (defn- update-sessions
@@ -183,17 +251,20 @@
 
 (defmethod ig/init-key ::gc-task
   [_ {:keys [pool max-age] :as cfg}]
+  (l/debug :hint "initializing session gc task" :max-age max-age)
   (fn [_]
     (db/with-atomic [conn pool]
       (let [interval (db/interval max-age)
-            result   (db/exec-one! conn [sql:delete-expired interval])
+            result   (db/exec-one! conn [sql:delete-expired interval interval])
             result   (:next.jdbc/update-count result)]
         (l/debug :task "gc"
-                 :action "clean http sessions"
-                 :count result)
+                 :hint "clean http sessions"
+                 :deleted result)
         result))))
 
 (def ^:private
   sql:delete-expired
   "delete from http_session
-    where updated_at < now() - ?::interval")
+    where updated_at < now() - ?::interval
+       or (updated_at is null and
+           created_at < now() - ?::interval)")

backend/src/app/http/websocket.clj

@@ -13,7 +13,6 @@
    [app.db :as db]
    [app.metrics :as mtx]
    [app.util.websocket :as ws]
-   [app.worker :as wrk]
    [clojure.core.async :as a]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]
@@ -100,36 +99,36 @@
   (s/keys :req-un [::file-id ::session-id]))
 
 (defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::msgbus ::db/pool ::mtx/metrics ::wrk/executor]))
+  (s/keys :req-un [::msgbus ::db/pool ::mtx/metrics]))
 
 (defmethod ig/init-key ::handler
-  [_ {:keys [metrics pool] :as cfg}]
-  (let [metrics {:connections (get-in metrics [:definitions :websocket-active-connections])
-                 :messages    (get-in metrics [:definitions :websocket-messages-total])
-                 :sessions    (get-in metrics [:definitions :websocket-session-timing])}]
-    (fn [{:keys [profile-id params] :as req}]
-      (let [params (us/conform ::handler-params params)
-            file   (retrieve-file pool (:file-id params))
-            cfg    (-> (merge cfg params)
-                       (assoc :profile-id profile-id)
-                       (assoc :team-id (:team-id file))
-                       (assoc ::ws/metrics metrics))]
+  [_ {:keys [pool] :as cfg}]
+  (fn [{:keys [profile-id params] :as req} respond raise]
+    (let [params (us/conform ::handler-params params)
+          file   (retrieve-file pool (:file-id params))
+          cfg    (-> (merge cfg params)
+                     (assoc :profile-id profile-id)
+                     (assoc :team-id (:team-id file)))]
 
-        (when-not profile-id
-          (ex/raise :type :authentication
-                    :hint "Authentication required."))
+      (cond
+        (not profile-id)
+        (raise (ex/error :type :authentication
+                         :hint "Authentication required."))
 
-        (when-not file
-          (ex/raise :type :not-found
-                    :code :object-not-found))
+        (not file)
+        (raise (ex/error :type :not-found
+                         :code :object-not-found))
 
-        (when-not (yws/upgrade-request? req)
-          (ex/raise :type :validation
-                    :code :websocket-request-expected
-                    :hint "this endpoint only accepts websocket connections"))
 
+        (not (yws/upgrade-request? req))
+        (raise (ex/error :type :validation
+                         :code :websocket-request-expected
+                         :hint "this endpoint only accepts websocket connections"))
+
+        :else
         (->> (ws/handler handle-message cfg)
-             (yws/upgrade req))))))
+             (yws/upgrade req)
+             (respond))))))
 
 (def ^:private
   sql:retrieve-file

backend/src/app/loggers/audit.clj

@@ -24,6 +24,7 @@
    [cuerdas.core :as str]
    [integrant.core :as ig]
    [lambdaisland.uri :as u]
+   [promesa.core :as p]
    [promesa.exec :as px]))
 
 (defn parse-client-ip
@@ -41,33 +42,26 @@
 
 (defn clean-props
   [{:keys [profile-id] :as event}]
-  (letfn [(clean-common [props]
-            (-> props
-                (dissoc :session-id)
-                (dissoc :password)
-                (dissoc :old-password)
-                (dissoc :token)))
+  (let [invalid-keys #{:session-id
+                       :password
+                       :old-password
+                       :token}
+        xform (comp
+               (remove (fn [kv]
+                         (qualified-keyword? (first kv))))
+               (remove (fn [kv]
+                         (contains? invalid-keys (first kv))))
+               (remove (fn [[k v]]
+                         (and (= k :profile-id)
+                              (= v profile-id))))
+               (filter (fn [[_ v]]
+                         (or (string? v)
+                             (keyword? v)
+                             (uuid? v)
+                             (boolean? v)
+                             (number? v)))))]
 
-          (clean-profile-id [props]
-            (cond-> props
-              (= profile-id (:profile-id props))
-              (dissoc :profile-id)))
-
-          (clean-complex-data [props]
-            (reduce-kv (fn [props k v]
-                         (cond-> props
-                           (or (string? v)
-                               (uuid? v)
-                               (boolean? v)
-                               (number? v))
-                           (assoc k v)
-
-                           (keyword? v)
-                           (assoc k (name v))))
-                       {}
-                       props))]
-
-    (update event :props #(-> % clean-common clean-profile-id clean-complex-data))))
+    (update event :props #(into {} xform %))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; HTTP Handler
@@ -82,52 +76,62 @@
 (s/def ::timestamp dt/instant?)
 (s/def ::context (s/map-of ::us/keyword any?))
 
-(s/def ::event
+(s/def ::frontend-event
   (s/keys :req-un [::type ::name ::props ::timestamp ::profile-id]
           :opt-un [::context]))
 
-(s/def ::events (s/every ::event))
+(s/def ::frontend-events (s/every ::frontend-event))
 
 (defmethod ig/init-key ::http-handler
-  [_  {:keys [executor] :as cfg}]
-  (fn [{:keys [params profile-id] :as request}]
-    (when (contains? cf/flags :audit-log)
-      (let [events  (->> (:events params)
-                         (remove #(not= profile-id (:profile-id %)))
-                         (us/conform ::events))
-            ip-addr (parse-client-ip request)
-            cfg     (-> cfg
-                        (assoc :source "frontend")
-                        (assoc :events events)
-                        (assoc :ip-addr ip-addr))]
-        (px/run! executor #(persist-http-events cfg))))
-    {:status 204 :body ""}))
+  [_  {:keys [executor pool] :as cfg}]
+  (if (or (db/read-only? pool) (not (contains? cf/flags :audit-log)))
+    (do
+      (l/warn :hint "audit log http handler disabled or db is read-only")
+      (fn [_ respond _]
+        (respond {:status 204 :body ""})))
+
+
+    (letfn [(handler [{:keys [params profile-id] :as request}]
+              (let [events  (->> (:events params)
+                                 (remove #(not= profile-id (:profile-id %)))
+                                 (us/conform ::frontend-events))
+
+                    ip-addr (parse-client-ip request)
+                    cfg     (-> cfg
+                                (assoc :source "frontend")
+                                (assoc :events events)
+                                (assoc :ip-addr ip-addr))]
+                (persist-http-events cfg)))
+
+            (handle-error [cause]
+              (let [xdata (ex-data cause)]
+                (if (= :spec-validation (:code xdata))
+                  (l/error ::l/raw (str "spec validation on persist-events:\n" (us/pretty-explain xdata)))
+                  (l/error :hint "error on persist-events" :cause cause))))]
+
+      (fn [request respond _]
+        ;; Fire and forget, log error in case of errro
+        (-> (px/submit! executor #(handler request))
+            (p/catch handle-error))
+
+        (respond {:status 204 :body ""})))))
 
 (defn- persist-http-events
   [{:keys [pool events ip-addr source] :as cfg}]
-  (try
-    (let [columns    [:id :name :source :type :tracked-at :profile-id :ip-addr :props :context]
-          prepare-xf (map (fn [event]
-                            [(uuid/next)
-                             (:name event)
-                             source
-                             (:type event)
-                             (:timestamp event)
-                             (:profile-id event)
-                             (db/inet ip-addr)
-                             (db/tjson (:props event))
-                             (db/tjson (d/without-nils (:context event)))]))
-          events     (us/conform ::events events)]
-      (when (seq events)
-        (->> (into [] prepare-xf events)
-             (db/insert-multi! pool :audit-log columns))))
-    (catch Throwable e
-      (let [xdata (ex-data e)]
-        (if (= :spec-validation (:code xdata))
-          (l/error ::l/raw (str "spec validation on persist-events:\n"
-                                (:explain xdata)))
-          (l/error :hint "error on persist-events"
-                   :cause e))))))
+  (let [columns    [:id :name :source :type :tracked-at :profile-id :ip-addr :props :context]
+        prepare-xf (map (fn [event]
+                          [(uuid/next)
+                           (:name event)
+                           source
+                           (:type event)
+                           (:timestamp event)
+                           (:profile-id event)
+                           (db/inet ip-addr)
+                           (db/tjson (:props event))
+                           (db/tjson (d/without-nils (:context event)))]))]
+    (when (seq events)
+      (->> (into [] prepare-xf events)
+           (db/insert-multi! pool :audit-log columns)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Collector
@@ -142,36 +146,53 @@
 (defmethod ig/pre-init-spec ::collector [_]
   (s/keys :req-un [::db/pool ::wrk/executor]))
 
-(def event-xform
+(s/def ::ip-addr string?)
+(s/def ::backend-event
+  (s/keys :req-un [::type ::name ::profile-id]
+          :opt-un [::ip-addr ::props]))
+
+(def ^:private backend-event-xform
   (comp
-   (filter :profile-id)
+   (filter #(us/valid? ::backend-event %))
    (map clean-props)))
 
 (defmethod ig/init-key ::collector
-  [_ cfg]
-  (when (contains? cf/flags :audit-log)
-    (l/info :msg "initializing audit log collector")
-    (let [input  (a/chan 512 event-xform)
+  [_ {:keys [pool] :as cfg}]
+  (cond
+    (not (contains? cf/flags :audit-log))
+    (do
+      (l/info :hint "audit log collection disabled")
+      (constantly nil))
+
+    (db/read-only? pool)
+    (do
+      (l/warn :hint "audit log collection disabled, db is read-only")
+      (constantly nil))
+
+    :else
+    (let [input  (a/chan 512 backend-event-xform)
           buffer (aa/batch input {:max-batch-size 100
                                   :max-batch-age (* 10 1000) ; 10s
                                   :init []})]
+      (l/info :hint "audit log collector initialized")
       (a/go-loop []
         (when-let [[_type events] (a/<! buffer)]
           (let [res (a/<! (persist-events cfg events))]
             (when (ex/exception? res)
-              (l/error :hint "error on persisting events"
-                       :cause res)))
-          (recur)))
+              (l/error :hint "error on persisting events" :cause res))
+            (recur))))
 
       (fn [& {:keys [cmd] :as params}]
-        (let [params (-> params
-                         (dissoc :cmd)
-                         (assoc :tracked-at (dt/now)))]
-          (case cmd
-            :stop   (a/close! input)
-            :submit (when-not (a/offer! input params)
-                      (l/warn :msg "activity channel is full"))))))))
+        (case cmd
+          :stop
+          (a/close! input)
 
+          :submit
+          (let [params (-> params
+                           (dissoc :cmd)
+                           (assoc :tracked-at (dt/now)))]
+            (when-not (a/offer! input params)
+              (l/warn :hint "activity channel is full"))))))))
 
 (defn- persist-events
   [{:keys [pool executor] :as cfg} events]
@@ -189,7 +210,7 @@
         (db/with-atomic [conn pool]
           (db/insert-multi! conn :audit-log
                             [:id :name :type :profile-id :tracked-at :ip-addr :props :source]
-                            (sequence (map event->row) events)))))))
+                            (sequence (keep event->row) events)))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Archive Task
@@ -216,6 +237,7 @@
                       (:enabled props false))
           uri     (or uri (:uri props))
           cfg     (assoc cfg :uri uri)]
+
       (when (and enabled (not uri))
         (ex/raise :type :internal
                   :code :task-not-configured

backend/src/app/loggers/database.clj

@@ -28,9 +28,8 @@
 
 (defn- persist-on-database!
   [{:keys [pool] :as cfg} {:keys [id] :as event}]
-  (db/with-atomic [conn pool]
-    (db/insert! conn :server-error-report
-                {:id id :content (db/tjson event)})))
+  (when-not (db/read-only? pool)
+    (db/insert! pool :server-error-report {:id id :content (db/tjson event)})))
 
 (defn- parse-event-data
   [event]
@@ -51,7 +50,7 @@
       (assoc :host (cf/get :host))
       (assoc :public-uri (cf/get :public-uri))
       (assoc :version (:full cf/version))
-      (update :id (fn [id] (or id (uuid/next))))))
+      (update :id #(or % (uuid/next)))))
 
 (defn handle-event
   [{:keys [executor] :as cfg} event]
@@ -59,22 +58,25 @@
     (try
       (let [event (parse-event event)
             uri   (cf/get :public-uri)]
+
         (l/debug :hint "registering error on database" :id (:id event)
                  :uri (str uri "/dbg/error/" (:id event)))
+
         (persist-on-database! cfg event))
-      (catch Exception e
-        (l/warn :hint "unexpected exception on database error logger"
-                :cause e)))))
+      (catch Exception cause
+        (l/warn :hint "unexpected exception on database error logger" :cause cause)))))
 
 (defmethod ig/pre-init-spec ::reporter [_]
   (s/keys :req-un [::wrk/executor ::db/pool ::receiver]))
 
+(defn error-event?
+  [event]
+  (= "error" (:logger/level event)))
+
 (defmethod ig/init-key ::reporter
   [_ {:keys [receiver] :as cfg}]
   (l/info :msg "initializing database error persistence")
-  (let [output (a/chan (a/sliding-buffer 128)
-                       (filter (fn [event]
-                                 (= (:logger/level event) "error"))))]
+  (let [output (a/chan (a/sliding-buffer 5) (filter error-event?))]
     (receiver :sub output)
     (a/go-loop []
       (let [msg (a/<! output)]

backend/src/app/loggers/loki.clj

@@ -52,14 +52,14 @@
   (let [labels {:host    (cfg/get :host)
                 :tenant  (cfg/get :tenant)
                 :version (:full cfg/version)
-                :logger  (:logger event)
-                :level   (:level event)}]
+                :logger  (:logger/name event)
+                :level   (:logger/level event)}]
     {:streams
      [{:stream labels
        :values [[(str (* (inst-ms (:created-at event)) 1000000))
                  (str (:message event)
-                      (when-let [error (:error event)]
-                        (str "\n" (:trace error))))]]}]}))
+                      (when-let [error (:trace event)]
+                        (str "\n" error)))]]}]}))
 
 (defn- send-log
   [uri payload i]

backend/src/app/loggers/sentry.clj

@@ -120,8 +120,6 @@
               (.captureMessage ^IHub shub msg)
               ))
           ]
-    ;; (clojure.pprint/pprint event)
-
     (when @enabled
       (.withScope ^IHub shub (reify ScopeCallback
                                (run [_ scope]

backend/src/app/main.clj

@@ -17,11 +17,37 @@
    {:uri        (cf/get :database-uri)
     :username   (cf/get :database-username)
     :password   (cf/get :database-password)
+    :read-only  (cf/get :database-readonly false)
     :metrics    (ig/ref :app.metrics/metrics)
     :migrations (ig/ref :app.migrations/all)
     :name :main
-    :min-pool-size 0
-    :max-pool-size 30}
+    :min-size (cf/get :database-min-pool-size 0)
+    :max-size (cf/get :database-max-pool-size 30)}
+
+   ;; Default thread pool for IO operations
+   [::default :app.worker/executor]
+   {:parallelism (cf/get :default-executor-parallelism 60)
+    :prefix :default}
+
+   ;; Constrained thread pool. Should only be used from high demand
+   ;; RPC methods.
+   [::blocking :app.worker/executor]
+   {:parallelism (cf/get :blocking-executor-parallelism 20)
+    :prefix :blocking}
+
+   ;; Dedicated thread pool for backround tasks execution.
+   [::worker :app.worker/executor]
+   {:parallelism (cf/get :worker-executor-parallelism 10)
+    :prefix :worker}
+
+   :app.worker/executors
+   {:default  (ig/ref [::default :app.worker/executor])
+    :worker   (ig/ref [::worker :app.worker/executor])
+    :blocking (ig/ref [::blocking :app.worker/executor])}
+
+   :app.worker/executors-monitor
+   {:metrics   (ig/ref :app.metrics/metrics)
+    :executors (ig/ref :app.worker/executors)}
 
    :app.migrations/migrations
    {}
@@ -32,7 +58,6 @@
    :app.migrations/all
    {:main (ig/ref :app.migrations/migrations)}
 
-
    :app.msgbus/msgbus
    {:backend   (cf/get :msgbus-backend :redis)
     :redis-uri (cf/get :redis-uri)}
@@ -48,13 +73,9 @@
    :app.storage/gc-touched-task
    {:pool     (ig/ref :app.db/pool)}
 
-   :app.storage/recheck-task
-   {:pool     (ig/ref :app.db/pool)
-    :storage  (ig/ref :app.storage/storage)}
-
    :app.http.session/session
-   {:pool   (ig/ref :app.db/pool)
-    :tokens (ig/ref :app.tokens/tokens)}
+   {:pool     (ig/ref :app.db/pool)
+    :tokens   (ig/ref :app.tokens/tokens)}
 
    :app.http.session/gc-task
    {:pool        (ig/ref :app.db/pool)
@@ -63,7 +84,7 @@
    :app.http.session/updater
    {:pool           (ig/ref :app.db/pool)
     :metrics        (ig/ref :app.metrics/metrics)
-    :executor       (ig/ref :app.worker/executor)
+    :executor       (ig/ref [::worker :app.worker/executor])
     :session        (ig/ref :app.http.session/session)
     :max-batch-age  (cf/get :http-session-updater-batch-max-age)
     :max-batch-size (cf/get :http-session-updater-batch-max-size)}
@@ -73,10 +94,13 @@
     :pool    (ig/ref :app.db/pool)}
 
    :app.http/server
-   {:port    (cf/get :http-server-port)
-    :host    (cf/get :http-server-host)
-    :router  (ig/ref :app.http/router)
-    :metrics (ig/ref :app.metrics/metrics)}
+   {:port        (cf/get :http-server-port)
+    :host        (cf/get :http-server-host)
+    :router      (ig/ref :app.http/router)
+    :metrics     (ig/ref :app.metrics/metrics)
+
+    :max-threads (cf/get :http-server-max-threads)
+    :min-threads (cf/get :http-server-min-threads)}
 
    :app.http/router
    {:assets               (ig/ref :app.http.assets/handlers)
@@ -94,11 +118,11 @@
     :rpc                  (ig/ref :app.rpc/rpc)}
 
    :app.http.debug/handlers
-   {:pool (ig/ref :app.db/pool)}
+   {:pool (ig/ref :app.db/pool)
+    :executor (ig/ref [::default :app.worker/executor])}
 
    :app.http.websocket/handler
    {:pool     (ig/ref :app.db/pool)
-    :executor (ig/ref :app.worker/executor)
     :metrics  (ig/ref :app.metrics/metrics)
     :msgbus   (ig/ref :app.msgbus/msgbus)}
 
@@ -106,11 +130,13 @@
    {:metrics           (ig/ref :app.metrics/metrics)
     :assets-path       (cf/get :assets-path)
     :storage           (ig/ref :app.storage/storage)
+    :executor          (ig/ref [::default :app.worker/executor])
     :cache-max-age     (dt/duration {:hours 24})
     :signature-max-age (dt/duration {:hours 24 :minutes 5})}
 
    :app.http.feedback/handler
-   {:pool (ig/ref :app.db/pool)}
+   {:pool     (ig/ref :app.db/pool)
+    :executor (ig/ref [::default :app.worker/executor])}
 
    :app.http.oauth/handler
    {:rpc        (ig/ref :app.rpc/rpc)
@@ -118,6 +144,7 @@
     :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])
     :public-uri (cf/get :public-uri)}
 
    :app.rpc/rpc
@@ -128,22 +155,17 @@
     :storage    (ig/ref :app.storage/storage)
     :msgbus     (ig/ref :app.msgbus/msgbus)
     :public-uri (cf/get :public-uri)
-    :audit      (ig/ref :app.loggers.audit/collector)}
-
-   :app.worker/executor
-   {:min-threads 0
-    :max-threads 256
-    :idle-timeout 60000
-    :name :worker}
+    :audit      (ig/ref :app.loggers.audit/collector)
+    :executors  (ig/ref :app.worker/executors)}
 
    :app.worker/worker
-   {:executor (ig/ref :app.worker/executor)
+   {:executor (ig/ref [::worker :app.worker/executor])
     :tasks    (ig/ref :app.worker/registry)
     :metrics  (ig/ref :app.metrics/metrics)
     :pool     (ig/ref :app.db/pool)}
 
    :app.worker/scheduler
-   {:executor   (ig/ref :app.worker/executor)
+   {:executor   (ig/ref [::worker :app.worker/executor])
     :tasks      (ig/ref :app.worker/registry)
     :pool       (ig/ref :app.db/pool)
     :schedule
@@ -162,9 +184,6 @@
      {:cron #app/cron "0 0 0 * * ?"  ;; daily
       :task :session-gc}
 
-     {:cron #app/cron "0 0 * * * ?"  ;; hourly
-      :task :storage-recheck}
-
      {:cron #app/cron "0 0 0 * * ?"  ;; daily
       :task :objects-gc}
 
@@ -176,7 +195,7 @@
         :task :file-offload})
 
      (when (contains? cf/flags :audit-log-archive)
-       {:cron #app/cron "0 */3 * * * ?" ;; every 3m
+       {:cron #app/cron "0 */5 * * * ?" ;; every 5m
         :task :audit-log-archive})
 
      (when (contains? cf/flags :audit-log-gc)
@@ -185,7 +204,7 @@
 
      (when (or (contains? cf/flags :telemetry)
                (cf/get :telemetry-enabled))
-       {:cron #app/cron "0 0 */6 * * ?" ;; every 6h
+       {:cron #app/cron "0 30 */3,23 * * ?"
         :task :telemetry})]}
 
    :app.worker/registry
@@ -197,7 +216,6 @@
      :file-xlog-gc       (ig/ref :app.tasks.file-xlog-gc/handler)
      :storage-deleted-gc (ig/ref :app.storage/gc-deleted-task)
      :storage-touched-gc (ig/ref :app.storage/gc-touched-task)
-     :storage-recheck    (ig/ref :app.storage/recheck-task)
      :tasks-gc           (ig/ref :app.tasks.tasks-gc/handler)
      :telemetry          (ig/ref :app.tasks.telemetry/handler)
      :session-gc         (ig/ref :app.http.session/gc-task)
@@ -261,11 +279,11 @@
 
    :app.loggers.audit/http-handler
    {:pool     (ig/ref :app.db/pool)
-    :executor (ig/ref :app.worker/executor)}
+    :executor (ig/ref [::worker :app.worker/executor])}
 
    :app.loggers.audit/collector
    {:pool     (ig/ref :app.db/pool)
-    :executor (ig/ref :app.worker/executor)}
+    :executor (ig/ref [::worker :app.worker/executor])}
 
    :app.loggers.audit/archive-task
    {:uri      (cf/get :audit-log-archive-uri)
@@ -279,51 +297,43 @@
    :app.loggers.loki/reporter
    {:uri      (cf/get :loggers-loki-uri)
     :receiver (ig/ref :app.loggers.zmq/receiver)
-    :executor (ig/ref :app.worker/executor)}
+    :executor (ig/ref [::worker :app.worker/executor])}
 
    :app.loggers.mattermost/reporter
    {:uri      (cf/get :error-report-webhook)
     :receiver (ig/ref :app.loggers.zmq/receiver)
     :pool     (ig/ref :app.db/pool)
-    :executor (ig/ref :app.worker/executor)}
+    :executor (ig/ref [::worker :app.worker/executor])}
 
    :app.loggers.database/reporter
    {:receiver (ig/ref :app.loggers.zmq/receiver)
     :pool     (ig/ref :app.db/pool)
-    :executor (ig/ref :app.worker/executor)}
-
-   :app.loggers.sentry/reporter
-   {:dsn                (cf/get :sentry-dsn)
-    :trace-sample-rate  (cf/get :sentry-trace-sample-rate 1.0)
-    :attach-stack-trace (cf/get :sentry-attach-stack-trace false)
-    :debug              (cf/get :sentry-debug false)
-    :receiver (ig/ref :app.loggers.zmq/receiver)
-    :pool     (ig/ref :app.db/pool)
-    :executor (ig/ref :app.worker/executor)}
+    :executor (ig/ref [::worker :app.worker/executor])}
 
    :app.storage/storage
    {:pool     (ig/ref :app.db/pool)
-    :executor (ig/ref :app.worker/executor)
+    :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])
 
-    :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])
+     :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])}}
+     ;; 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)
-    :prefix (cf/get :storage-fdata-s3-prefix)}
+   {: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)}
 
    [::assets :app.storage.s3/backend]
-   {:region (cf/get :storage-assets-s3-region)
-    :bucket (cf/get :storage-assets-s3-bucket)}
+   {:region   (cf/get :storage-assets-s3-region)
+    :endpoint (cf/get :storage-assets-s3-endpoint)
+    :bucket   (cf/get :storage-assets-s3-bucket)}
 
    [::assets :app.storage.fs/backend]
    {:directory (cf/get :storage-assets-fs-directory)}

backend/src/app/media.clj

@@ -326,8 +326,10 @@
 (defn configure-assets-storage
   "Given storage map, returns a storage configured with the appropriate
   backend for assets."
-  [storage conn]
-  (-> storage
-      (assoc :conn conn)
-      (assoc :backend (cf/get :assets-storage-backend :assets-fs))))
+  ([storage]
+   (assoc storage :backend (cf/get :assets-storage-backend :assets-fs)))
+  ([storage conn]
+   (-> storage
+       (assoc :conn conn)
+       (assoc :backend (cf/get :assets-storage-backend :assets-fs)))))
 

backend/src/app/metrics.clj

@@ -5,46 +5,40 @@
 ;; Copyright (c) UXBOX Labs SL
 
 (ns app.metrics
+  (:refer-clojure :exclude [run!])
   (:require
-   [app.common.exceptions :as ex]
    [app.common.logging :as l]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig])
   (:import
    io.prometheus.client.CollectorRegistry
    io.prometheus.client.Counter
+   io.prometheus.client.Counter$Child
    io.prometheus.client.Gauge
+   io.prometheus.client.Gauge$Child
    io.prometheus.client.Summary
+   io.prometheus.client.Summary$Child
+   io.prometheus.client.Summary$Builder
    io.prometheus.client.Histogram
+   io.prometheus.client.Histogram$Child
    io.prometheus.client.exporter.common.TextFormat
    io.prometheus.client.hotspot.DefaultExports
    io.prometheus.client.jetty.JettyStatisticsCollector
    org.eclipse.jetty.server.handler.StatisticsHandler
    java.io.StringWriter))
 
-(declare instrument-vars!)
-(declare instrument)
+(set! *warn-on-reflection* true)
+
 (declare create-registry)
 (declare create)
 (declare handler)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Defaults
+;; METRICS SERVICE PROVIDER
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-
 (def default-metrics
-  {:profile-register
-   {:name "actions_profile_register_count"
-    :help "A global counter of user registrations."
-    :type :counter}
-
-   :profile-activation
-   {:name "actions_profile_activation_count"
-    :help "A global counter of profile activations"
-    :type :counter}
-
-   :update-file-changes
+  {:update-file-changes
    {:name "rpc_update_file_changes_total"
     :help "A total number of changes submitted to update-file."
     :type :counter}
@@ -54,6 +48,18 @@
     :help "A total number of bytes processed by update-file."
     :type :counter}
 
+   :rpc-mutation-timing
+   {:name "rpc_mutation_timing"
+    :help "RPC mutation method call timming."
+    :labels ["name"]
+    :type :histogram}
+
+   :rpc-query-timing
+   {:name "rpc_query_timing"
+    :help "RPC query method call timing."
+    :labels ["name"]
+    :type :histogram}
+
    :websocket-active-connections
    {:name "websocket_active_connections"
     :help "Active websocket connections gauge"
@@ -68,12 +74,60 @@
    :websocket-session-timing
    {:name "websocket_session_timing"
     :help "Websocket session timing (seconds)."
-    :quantiles []
-    :type :summary}})
+    :type :summary}
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Entry Point
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+   :session-update-total
+   {:name "http_session_update_total"
+    :help "A counter of session update batch events."
+    :type :counter}
+
+   :tasks-timing
+   {:name "penpot_tasks_timing"
+    :help "Background tasks timing (milliseconds)."
+    :labels ["name"]
+    :type :summary}
+
+   :rlimit-queued-submissions
+   {:name "penpot_rlimit_queued_submissions"
+    :help "Current number of queued submissions on RLIMIT."
+    :labels ["name"]
+    :type :gauge}
+
+   :rlimit-used-permits
+   {:name "penpot_rlimit_used_permits"
+    :help "Current number of used permits on RLIMIT."
+    :labels ["name"]
+    :type :gauge}
+
+   :rlimit-acquires-total
+   {:name "penpot_rlimit_acquires_total"
+    :help "Total number of acquire operations on RLIMIT."
+    :labels ["name"]
+    :type :counter}
+
+   :executors-active-threads
+   {:name "penpot_executors_active_threads"
+    :help "Current number of threads available in the executor service."
+    :labels ["name"]
+    :type :gauge}
+
+   :executors-completed-tasks
+   {:name "penpot_executors_completed_tasks_total"
+    :help "Aproximate number of completed tasks by the executor."
+    :labels ["name"]
+    :type :counter}
+
+   :executors-running-threads
+   {:name "penpot_executors_running_threads"
+    :help "Current number of threads with state RUNNING."
+    :labels ["name"]
+    :type :gauge}
+
+   :executors-queued-submissions
+   {:name "penpot_executors_queued_submissions"
+    :help "Current number of queued submissions."
+    :labels ["name"]
+    :type :gauge}})
 
 (defmethod ig/init-key ::metrics
   [_ _]
@@ -95,31 +149,44 @@
   (s/keys :req-un [::registry ::handler]))
 
 (defn- handler
-  [registry _request]
+  [registry _ respond _]
   (let [samples  (.metricFamilySamples ^CollectorRegistry registry)
         writer   (StringWriter.)]
     (TextFormat/write004 writer samples)
-    {:headers {"content-type" TextFormat/CONTENT_TYPE_004}
-     :body (.toString writer)}))
+    (respond {:headers {"content-type" TextFormat/CONTENT_TYPE_004}
+              :body (.toString writer)})))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Implementation
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(def default-empty-labels (into-array String []))
+
+(def default-quantiles
+  [[0.5  0.01]
+   [0.90 0.01]
+   [0.99 0.001]])
+
+(def default-histogram-buckets
+  [1 5 10 25 50 75 100 250 500 750 1000 2500 5000 7500])
+
+(defn run!
+  [{:keys [definitions]} {:keys [id] :as params}]
+  (when-let [mobj (get definitions id)]
+    ((::fn mobj) params)
+    true))
+
 (defn create-registry
   []
   (let [registry (CollectorRegistry.)]
     (DefaultExports/register registry)
     registry))
 
-(defmacro with-measure
-  [& {:keys [expr cb]}]
-  `(let [start# (System/nanoTime)
-         tdown# ~cb]
-     (try
-       ~expr
-       (finally
-         (tdown# (/ (- (System/nanoTime) start#) 1000000))))))
+(defn- is-array?
+  [o]
+  (let [oc (class o)]
+    (and (.isArray ^Class oc)
+         (= (.getComponentType oc) String))))
 
 (defn make-counter
   [{:keys [name help registry reg labels] :as props}]
@@ -132,12 +199,9 @@
         instance (.register instance registry)]
 
     {::instance instance
-     ::fn (fn [{:keys [by labels] :or {by 1}}]
-            (if labels
-              (.. ^Counter instance
-                  (labels (into-array String labels))
-                  (inc by))
-              (.inc ^Counter instance by)))}))
+     ::fn (fn [{:keys [inc labels] :or {inc 1 labels default-empty-labels}}]
+            (let [instance (.labels instance (if (is-array? labels) labels (into-array String labels)))]
+              (.inc ^Counter$Child instance (double inc))))}))
 
 (defn make-gauge
   [{:keys [name help registry reg labels] :as props}]
@@ -148,48 +212,33 @@
         _        (when (seq labels)
                    (.labelNames instance (into-array String labels)))
         instance (.register instance registry)]
-
     {::instance instance
-     ::fn (fn [{:keys [cmd by labels] :or {by 1}}]
-            (if labels
-              (let [labels (into-array String [labels])]
-                (case cmd
-                  :inc (.. ^Gauge instance (labels labels) (inc by))
-                  :dec (.. ^Gauge instance (labels labels) (dec by))))
-              (case cmd
-                :inc (.inc ^Gauge instance by)
-                :dec (.dec ^Gauge instance by))))}))
-
-(def default-quantiles
-  [[0.75 0.02]
-   [0.99 0.001]])
+     ::fn (fn [{:keys [inc dec labels val] :or {labels default-empty-labels}}]
+            (let [instance (.labels ^Gauge instance (if (is-array? labels) labels (into-array String labels)))]
+              (cond (number? inc) (.inc ^Gauge$Child instance (double inc))
+                    (number? dec) (.dec ^Gauge$Child instance (double dec))
+                    (number? val) (.set ^Gauge$Child instance (double val)))))}))
 
 (defn make-summary
   [{:keys [name help registry reg labels max-age quantiles buckets]
-    :or {max-age 3600 buckets 6 quantiles default-quantiles} :as props}]
+    :or {max-age 3600 buckets 12 quantiles default-quantiles} :as props}]
   (let [registry (or registry reg)
-        instance (doto (Summary/build)
+        builder  (doto (Summary/build)
                    (.name name)
                    (.help help))
         _        (when (seq quantiles)
-                   (.maxAgeSeconds ^Summary instance max-age)
-                   (.ageBuckets ^Summary instance buckets))
+                   (.maxAgeSeconds ^Summary$Builder builder ^long max-age)
+                   (.ageBuckets ^Summary$Builder builder buckets))
         _        (doseq [[q e] quantiles]
-                   (.quantile ^Summary instance q e))
+                   (.quantile ^Summary$Builder builder q e))
         _        (when (seq labels)
-                   (.labelNames instance (into-array String labels)))
-        instance (.register instance registry)]
+                   (.labelNames ^Summary$Builder builder (into-array String labels)))
+        instance (.register ^Summary$Builder builder registry)]
 
     {::instance instance
-     ::fn (fn [{:keys [val labels]}]
-            (if labels
-              (.. ^Summary instance
-                  (labels (into-array String labels))
-                  (observe val))
-              (.observe ^Summary instance val)))}))
-
-(def default-histogram-buckets
-  [1 5 10 25 50 75 100 250 500 750 1000 2500 5000 7500])
+     ::fn (fn [{:keys [val labels] :or {labels default-empty-labels}}]
+            (let [instance (.labels ^Summary instance (if (is-array? labels) labels (into-array String labels)))]
+              (.observe ^Summary$Child instance val)))}))
 
 (defn make-histogram
   [{:keys [name help registry reg labels buckets]
@@ -204,12 +253,9 @@
         instance (.register instance registry)]
 
     {::instance instance
-     ::fn (fn [{:keys [val labels]}]
-            (if labels
-              (.. ^Histogram instance
-                  (labels (into-array String labels))
-                  (observe val))
-              (.observe ^Histogram instance val)))}))
+     ::fn (fn [{:keys [val labels] :or {labels default-empty-labels}}]
+            (let [instance (.labels ^Histogram instance (if (is-array? labels) labels (into-array String labels)))]
+              (.observe ^Histogram$Child instance val)))}))
 
 (defn create
   [{:keys [type] :as props}]
@@ -219,114 +265,6 @@
     :summary (make-summary props)
     :histogram (make-histogram props)))
 
-(defn wrap-counter
-  ([rootf mobj]
-   (let [mdata (meta rootf)
-         origf (::original mdata rootf)]
-     (with-meta
-       (fn
-         ([a]
-          ((::fn mobj) nil)
-          (origf a))
-         ([a b]
-          ((::fn mobj) nil)
-          (origf a b))
-         ([a b c]
-          ((::fn mobj) nil)
-          (origf a b c))
-         ([a b c d]
-          ((::fn mobj) nil)
-          (origf a b c d))
-         ([a b c d & more]
-          ((::fn mobj) nil)
-          (apply origf a b c d more)))
-       (assoc mdata ::original origf))))
-  ([rootf mobj labels]
-   (let [mdata  (meta rootf)
-         origf  (::original mdata rootf)]
-     (with-meta
-       (fn
-         ([a]
-          ((::fn mobj) {:labels labels})
-          (origf a))
-         ([a b]
-          ((::fn mobj) {:labels labels})
-          (origf a b))
-         ([a b & more]
-          ((::fn mobj) {:labels labels})
-          (apply origf a b more)))
-       (assoc mdata ::original origf)))))
-
-(defn wrap-summary
-  ([rootf mobj]
-   (let [mdata  (meta rootf)
-         origf  (::original mdata rootf)]
-     (with-meta
-       (fn
-         ([a]
-         (with-measure
-           :expr (origf a)
-           :cb   #((::fn mobj) {:val %})))
-         ([a b]
-          (with-measure
-            :expr (origf a b)
-            :cb   #((::fn mobj) {:val %})))
-         ([a b & more]
-          (with-measure
-            :expr (apply origf a b more)
-            :cb   #((::fn mobj) {:val %}))))
-       (assoc mdata ::original origf))))
-
-  ([rootf mobj labels]
-   (let [mdata  (meta rootf)
-         origf  (::original mdata rootf)]
-     (with-meta
-       (fn
-         ([a]
-         (with-measure
-           :expr (origf a)
-           :cb   #((::fn mobj) {:val % :labels labels})))
-         ([a b]
-          (with-measure
-            :expr (origf a b)
-            :cb   #((::fn mobj) {:val % :labels labels})))
-         ([a b & more]
-          (with-measure
-            :expr (apply origf a b more)
-            :cb   #((::fn mobj) {:val % :labels labels}))))
-       (assoc mdata ::original origf)))))
-
-(defn instrument-vars!
-  [vars {:keys [wrap] :as props}]
-  (let [obj (create props)]
-    (cond
-      (instance? Counter (::instance obj))
-      (doseq [var vars]
-        (alter-var-root var (or wrap wrap-counter) obj))
-
-      (instance? Summary (::instance obj))
-      (doseq [var vars]
-        (alter-var-root var (or wrap wrap-summary) obj))
-
-      :else
-      (ex/raise :type :not-implemented))))
-
-(defn instrument
-  [f {:keys [wrap] :as props}]
-  (let [obj (create props)]
-    (cond
-      (instance? Counter (::instance obj))
-      ((or wrap wrap-counter) f obj)
-
-      (instance? Summary (::instance obj))
-      ((or wrap wrap-summary) f obj)
-
-      (instance? Histogram (::instance obj))
-      ((or wrap wrap-summary) f obj)
-
-      :else
-      (ex/raise :type :not-implemented))))
-
 (defn instrument-jetty!
   [^CollectorRegistry registry ^StatisticsHandler handler]
   (doto (JettyStatisticsCollector. handler)

backend/src/app/migrations.clj

@@ -205,6 +205,9 @@
 
    {:name "0065-add-trivial-spelling-fixes"
     :fn (mg/resource "app/migrations/sql/0065-add-trivial-spelling-fixes.sql")}
+   
+   {:name "0066-add-frame-thumbnail-table"
+    :fn (mg/resource "app/migrations/sql/0066-add-frame-thumbnail-table.sql")}
    ])
 
 

backend/src/app/migrations/sql/0066-add-frame-thumbnail-table.sql

@@ -0,0 +1,10 @@
+CREATE TABLE file_frame_thumbnail (
+  file_id uuid NOT NULL REFERENCES file(id) ON DELETE CASCADE,
+  frame_id uuid NOT NULL,
+  created_at timestamptz NOT NULL DEFAULT now(),
+  updated_at timestamptz NOT NULL DEFAULT clock_timestamp(),
+
+  data text NULL,
+
+  PRIMARY KEY(file_id, frame_id)
+);

backend/src/app/msgbus.clj

@@ -18,7 +18,6 @@
    [integrant.core :as ig]
    [promesa.core :as p])
   (:import
-   java.time.Duration
    io.lettuce.core.RedisClient
    io.lettuce.core.RedisURI
    io.lettuce.core.api.StatefulConnection
@@ -29,7 +28,10 @@
    io.lettuce.core.codec.StringCodec
    io.lettuce.core.pubsub.RedisPubSubListener
    io.lettuce.core.pubsub.StatefulRedisPubSubConnection
-   io.lettuce.core.pubsub.api.async.RedisPubSubAsyncCommands))
+   io.lettuce.core.pubsub.api.async.RedisPubSubAsyncCommands
+   io.lettuce.core.resource.ClientResources
+   io.lettuce.core.resource.DefaultClientResources
+   java.time.Duration))
 
 (def ^:private prefix (cfg/get :tenant))
 
@@ -136,27 +138,35 @@
 (declare impl-redis-sub)
 (declare impl-redis-unsub)
 
+
 (defmethod init-backend :redis
   [{:keys [redis-uri] :as cfg}]
   (let [codec    (RedisCodec/of StringCodec/UTF8 ByteArrayCodec/INSTANCE)
 
-        uri      (RedisURI/create redis-uri)
-        rclient  (RedisClient/create ^RedisURI uri)
+        resources (.. (DefaultClientResources/builder)
+                      (ioThreadPoolSize 4)
+                      (computationThreadPoolSize 4)
+                      (build))
 
-        pub-conn (.connect ^RedisClient rclient ^RedisCodec codec)
-        sub-conn (.connectPubSub ^RedisClient rclient ^RedisCodec codec)]
+        uri       (RedisURI/create redis-uri)
+        rclient   (RedisClient/create ^ClientResources resources ^RedisURI uri)
+
+        pub-conn  (.connect ^RedisClient rclient ^RedisCodec codec)
+        sub-conn  (.connectPubSub ^RedisClient rclient ^RedisCodec codec)]
 
     (.setTimeout ^StatefulRedisConnection pub-conn ^Duration (dt/duration {:seconds 10}))
     (.setTimeout ^StatefulRedisPubSubConnection sub-conn ^Duration (dt/duration {:seconds 10}))
 
     (-> cfg
+        (assoc ::resources resources)
         (assoc ::pub-conn pub-conn)
         (assoc ::sub-conn sub-conn))))
 
 (defmethod stop-backend :redis
-  [{:keys [::pub-conn ::sub-conn] :as cfg}]
+  [{:keys [::pub-conn ::sub-conn ::resources] :as cfg}]
   (.close ^StatefulRedisConnection pub-conn)
-  (.close ^StatefulRedisPubSubConnection sub-conn))
+  (.close ^StatefulRedisPubSubConnection sub-conn)
+  (.shutdown ^ClientResources resources))
 
 (defmethod init-pub-loop :redis
   [{:keys [::pub-conn ::pub-ch]}]

backend/src/app/rpc.clj

@@ -13,125 +13,182 @@
    [app.db :as db]
    [app.loggers.audit :as audit]
    [app.metrics :as mtx]
-   [app.util.retry :as retry]
-   [app.util.rlimit :as rlimit]
+   [app.rpc.retry :as retry]
+   [app.rpc.rlimit :as rlimit]
+   [app.util.async :as async]
    [app.util.services :as sv]
+   [app.worker :as wrk]
    [clojure.spec.alpha :as s]
-   [integrant.core :as ig]))
+   [integrant.core :as ig]
+   [promesa.core :as p]
+   [promesa.exec :as px]))
 
 (defn- default-handler
   [_]
-  (ex/raise :type :not-found))
+  (p/rejected (ex/error :type :not-found)))
 
-(defn- run-hook
-  [hook-fn response]
-  (ex/ignoring (hook-fn))
+(defn- handle-response-transformation
+  [response request mdata]
+  (if-let [transform-fn (:transform-response mdata)]
+    (transform-fn request response)
+    response))
+
+(defn- handle-before-comple-hook
+  [response mdata]
+  (when-let [hook-fn (:before-complete mdata)]
+    (ex/ignoring (hook-fn)))
   response)
 
 (defn- rpc-query-handler
-  [methods {:keys [profile-id session-id] :as request}]
-  (let [type   (keyword (get-in request [:path-params :type]))
+  "Ring handler that dispatches query requests and convert between
+  internal async flow into ring async flow."
+  [methods {:keys [profile-id session-id] :as request} respond raise]
+  (letfn [(handle-response [result]
+            (let [mdata (meta result)]
+              (-> {:status 200 :body result}
+                  (handle-response-transformation request mdata))))]
 
-        data   (merge (:params request)
-                      (:body-params request)
-                      (:uploads request)
-                      {::request request})
+    (let [type   (keyword (get-in request [:path-params :type]))
+          data   (merge (:params request)
+                        (:body-params request)
+                        (:uploads request)
+                        {::request request})
 
-        data   (if profile-id
-                 (assoc data :profile-id profile-id ::session-id session-id)
-                 (dissoc data :profile-id))
+          data   (if profile-id
+                   (assoc data :profile-id profile-id ::session-id session-id)
+                   (dissoc data :profile-id))
 
-        result ((get methods type default-handler) data)
-        mdata  (meta result)]
+          ;; Get the method from methods registry and if method does
+          ;; not exists asigns it to the default handler.
+          method (get methods type default-handler)]
 
-    (cond->> {:status 200 :body result}
-      (fn? (:transform-response mdata))
-      ((:transform-response mdata) request))))
+      (-> (method data)
+          (p/then #(respond (handle-response %)))
+          (p/catch raise)))))
 
 (defn- rpc-mutation-handler
-  [methods {:keys [profile-id session-id] :as request}]
-  (let [type   (keyword (get-in request [:path-params :type]))
-        data   (merge (:params request)
-                      (:body-params request)
-                      (:uploads request)
-                      {::request request})
+  "Ring handler that dispatches mutation requests and convert between
+  internal async flow into ring async flow."
+  [methods {:keys [profile-id session-id] :as request} respond raise]
+  (letfn [(handle-response [result]
+            (let [mdata (meta result)]
+              (-> {:status 200 :body result}
+                  (handle-response-transformation request mdata)
+                  (handle-before-comple-hook mdata))))]
 
-        data   (if profile-id
-                 (assoc data :profile-id profile-id ::session-id session-id)
-                 (dissoc data :profile-id))
+    (let [type   (keyword (get-in request [:path-params :type]))
+          data   (merge (:params request)
+                        (:body-params request)
+                        (:uploads request)
+                        {::request request})
 
-        result ((get methods type default-handler) data)
-        mdata  (meta result)]
-    (cond->> {:status 200 :body result}
-      (fn? (:transform-response mdata))
-      ((:transform-response mdata) request)
+          data   (if profile-id
+                   (assoc data :profile-id profile-id ::session-id session-id)
+                   (dissoc data :profile-id))
 
-      (fn? (:before-complete mdata))
-      (run-hook (:before-complete mdata)))))
+          method (get methods type default-handler)]
 
-(defn- wrap-with-metrics
-  [cfg f mdata]
-  (mtx/wrap-summary f (::mobj cfg) [(::sv/name mdata)]))
+      (-> (method data)
+          (p/then #(respond (handle-response %)))
+          (p/catch raise)))))
 
-(defn- wrap-impl
+(defn- wrap-metrics
+  "Wrap service method with metrics measurement."
+  [{:keys [metrics ::metrics-id]} f mdata]
+  (let [labels (into-array String [(::sv/name mdata)])]
+    (fn [cfg params]
+      (let [start (System/nanoTime)]
+        (p/finally
+          (f cfg params)
+          (fn [_ _]
+            (mtx/run! metrics
+                      {:id metrics-id
+                       :val (/ (- (System/nanoTime) start) 1000000)
+                       :labels labels})))))))
+
+(defn- wrap-dispatch
+  "Wraps service method into async flow, with the ability to dispatching
+  it to a preconfigured executor service."
+  [{:keys [executors] :as cfg} f mdata]
+  (let [dname (::async/dispatch mdata :none)]
+    (if (= :none dname)
+      (with-meta
+        (fn [cfg params]
+          (p/do! (f cfg params)))
+        mdata)
+
+      (let [executor (get executors dname)]
+        (when-not executor
+          (ex/raise :type :internal
+                    :code :executor-not-configured
+                    :hint (format "executor %s not configured" dname)))
+        (with-meta
+          (fn [cfg params]
+            (-> (px/submit! executor #(f cfg params))
+                (p/bind p/wrap)))
+          mdata)))))
+
+(defn- wrap-audit
   [{:keys [audit] :as cfg} f mdata]
+  (if audit
+    (with-meta
+      (fn [cfg {:keys [::request] :as params}]
+        (p/finally (f cfg params)
+                   (fn [result _]
+                     (when result
+                       (let [resultm    (meta result)
+                             profile-id (or (:profile-id params)
+                                            (:profile-id result)
+                                            (::audit/profile-id resultm))
+                             props      (d/merge params (::audit/props resultm))]
+                         (audit :cmd :submit
+                                :type (or (::audit/type resultm)
+                                          (::type cfg))
+                                :name (or (::audit/name resultm)
+                                          (::sv/name mdata))
+                                :profile-id profile-id
+                                :ip-addr (audit/parse-client-ip request)
+                                :props (dissoc props ::request)))))))
+      mdata)
+    f))
+
+(defn- wrap
+  [cfg f mdata]
   (let [f     (as-> f $
+                (wrap-dispatch cfg $ mdata)
                 (rlimit/wrap-rlimit cfg $ mdata)
                 (retry/wrap-retry cfg $ mdata)
-                (wrap-with-metrics cfg $ mdata))
+                (wrap-audit cfg $ mdata)
+                (wrap-metrics cfg $ mdata)
+                )
 
         spec  (or (::sv/spec mdata) (s/spec any?))
         auth? (:auth mdata true)]
 
     (l/trace :action "register" :name (::sv/name mdata))
     (with-meta
-      (fn [params]
+      (fn [{:keys [::request] :as params}]
         ;; Raise authentication error when rpc method requires auth but
         ;; no profile-id is found in the request.
-        (when (and auth? (not (uuid? (:profile-id params))))
-          (ex/raise :type :authentication
-                    :code :authentication-required
-                    :hint "authentication required for this endpoint"))
+        (p/do!
+         (if (and auth? (not (uuid? (:profile-id params))))
+           (ex/raise :type :authentication
+                     :code :authentication-required
+                     :hint "authentication required for this endpoint")
+           (let [params (us/conform spec (dissoc params ::request))]
+             (f cfg (assoc params ::request request))))))
 
-        (let [params' (dissoc params ::request)
-              params' (us/conform spec params')
-              result  (f cfg params')]
-
-          ;; When audit log is enabled (default false).
-          (when (fn? audit)
-            (let [resultm    (meta result)
-                  request    (::request params)
-                  profile-id (or (:profile-id params')
-                                 (:profile-id result)
-                                 (::audit/profile-id resultm))
-                  props      (d/merge params' (::audit/props resultm))]
-              (audit :cmd :submit
-                     :type (or (::audit/type resultm)
-                               (::type cfg))
-                     :name (or (::audit/name resultm)
-                               (::sv/name mdata))
-                     :profile-id profile-id
-                     :ip-addr (audit/parse-client-ip request)
-                     :props props)))
-
-          result))
       mdata)))
 
 (defn- process-method
   [cfg vfn]
   (let [mdata (meta vfn)]
     [(keyword (::sv/name mdata))
-     (wrap-impl cfg (deref vfn) mdata)]))
+     (wrap cfg (deref vfn) mdata)]))
 
 (defn- resolve-query-methods
   [cfg]
-  (let [mobj (mtx/create
-              {:name "rpc_query_timing"
-               :labels ["name"]
-               :registry (get-in cfg [:metrics :registry])
-               :type :histogram
-               :help "Timing of query services."})
-        cfg  (assoc cfg ::mobj mobj ::type "query")]
+  (let [cfg (assoc cfg ::type "query" ::metrics-id :rpc-query-timing)]
     (->> (sv/scan-ns 'app.rpc.queries.projects
                      'app.rpc.queries.files
                      'app.rpc.queries.teams
@@ -144,13 +201,7 @@
 
 (defn- resolve-mutation-methods
   [cfg]
-  (let [mobj (mtx/create
-              {:name "rpc_mutation_timing"
-               :labels ["name"]
-               :registry (get-in cfg [:metrics :registry])
-               :type :histogram
-               :help "Timing of mutation services."})
-        cfg  (assoc cfg ::mobj mobj ::type "mutation")]
+  (let [cfg (assoc cfg ::type "mutation" ::metrics-id :rpc-mutation-timing)]
     (->> (sv/scan-ns 'app.rpc.mutations.demo
                      'app.rpc.mutations.media
                      'app.rpc.mutations.profile
@@ -170,15 +221,16 @@
 (s/def ::session map?)
 (s/def ::tokens fn?)
 (s/def ::audit (s/nilable fn?))
+(s/def ::executors (s/map-of keyword? ::wrk/executor))
 
 (defmethod ig/pre-init-spec ::rpc [_]
   (s/keys :req-un [::storage ::session ::tokens ::audit
-                   ::mtx/metrics ::db/pool]))
+                   ::executors ::mtx/metrics ::db/pool]))
 
 (defmethod ig/init-key ::rpc
   [_ cfg]
   (let [mq (resolve-query-methods cfg)
         mm (resolve-mutation-methods cfg)]
     {:methods {:query mq :mutation mm}
-     :query-handler #(rpc-query-handler mq %)
-     :mutation-handler #(rpc-mutation-handler mm %)}))
+     :query-handler (partial rpc-query-handler mq)
+     :mutation-handler (partial rpc-mutation-handler mm)}))

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

@@ -7,12 +7,13 @@
 (ns app.rpc.mutations.comments
   (:require
    [app.common.exceptions :as ex]
+   [app.common.geom.point :as gpt]
    [app.common.spec :as us]
    [app.db :as db]
    [app.rpc.queries.comments :as comments]
    [app.rpc.queries.files :as files]
+   [app.rpc.retry :as retry]
    [app.util.blob :as blob]
-   [app.util.retry :as retry]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]))
@@ -26,15 +27,14 @@
 (s/def ::page-id ::us/uuid)
 (s/def ::file-id ::us/uuid)
 (s/def ::profile-id ::us/uuid)
-(s/def ::position ::us/point)
+(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]))
 
 (sv/defmethod ::create-comment-thread
-  {::retry/enabled true
-   ::retry/max-retries 3
+  {::retry/max-retries 3
    ::retry/matches retry/conflict-db-insert?}
   [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
   (db/with-atomic [conn pool]

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

@@ -18,6 +18,7 @@
    [app.rpc.queries.files :as files]
    [app.rpc.queries.projects :as proj]
    [app.storage.impl :as simpl]
+   [app.util.async :as async]
    [app.util.blob :as blob]
    [app.util.services :as sv]
    [app.util.time :as dt]
@@ -27,6 +28,8 @@
 
 ;; --- Helpers & Specs
 
+(s/def ::frame-id ::us/uuid)
+(s/def ::file-id ::us/uuid)
 (s/def ::id ::us/uuid)
 (s/def ::name ::us/string)
 (s/def ::profile-id ::us/uuid)
@@ -270,6 +273,7 @@
          (contains? o :changes-with-metadata)))))
 
 (sv/defmethod ::update-file
+  {::async/dispatch :blocking}
   [{:keys [pool] :as cfg} {:keys [id profile-id] :as params}]
   (db/with-atomic [conn pool]
     (db/xact-lock! conn id)
@@ -305,24 +309,21 @@
               :context {:incoming-revn (:revn params)
                         :stored-revn (:revn file)}))
 
-  (let [mtx1    (get-in metrics [:definitions :update-file-changes])
-        mtx2    (get-in metrics [:definitions :update-file-bytes-processed])
-
-        changes (if changes-with-metadata
+  (let [changes (if changes-with-metadata
                   (mapcat :changes changes-with-metadata)
                   changes)
 
         changes (vec changes)
 
         ;; Trace the number of changes processed
-        _       ((::mtx/fn mtx1) {:by (count changes)})
+        _       (mtx/run! metrics {:id :update-file-changes :inc (count changes)})
 
         ts      (dt/now)
         file    (-> (files/retrieve-data cfg file)
                     (update :revn inc)
                     (update :data (fn [data]
                                     ;; Trace the length of bytes of processed data
-                                    ((::mtx/fn mtx2) {:by (alength data)})
+                                    (mtx/run! metrics {:id :update-file-bytes-processed :inc (alength data)})
                                     (-> data
                                         (blob/decode)
                                         (assoc :id (:id file))
@@ -472,3 +473,25 @@
                       {:id id})))
 
       nil)))
+
+
+;; --- Mutation: Upsert frame thumbnail
+
+(def sql:upsert-frame-thumbnail
+  "insert into file_frame_thumbnail(file_id, frame_id, data)
+   values (?, ?, ?)
+       on conflict(file_id, frame_id) do
+          update set data = ?;")
+
+(s/def ::data ::us/string)
+(s/def ::upsert-frame-thumbnail
+  (s/keys :req-un [::profile-id ::file-id ::frame-id ::data]))
+
+(sv/defmethod ::upsert-frame-thumbnail
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id frame-id data]}]
+  (db/with-atomic [conn pool]
+    (files/check-edition-permissions! conn profile-id file-id)
+    (db/exec-one! conn [sql:upsert-frame-thumbnail file-id frame-id data data])
+    nil))
+
+

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

@@ -9,12 +9,10 @@
    [app.common.exceptions :as ex]
    [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.teams :as teams]
    [app.storage :as sto]
-   [app.util.rlimit :as rlimit]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]))
@@ -39,52 +37,57 @@
                    ::font-id ::font-family ::font-weight ::font-style]))
 
 (sv/defmethod ::create-font-variant
-  {::rlimit/permits (cf/get :rlimit-font)}
   [{:keys [pool] :as cfg} {:keys [team-id profile-id] :as params}]
-  (db/with-atomic [conn pool]
-    (let [cfg (assoc cfg :conn conn)]
-      (teams/check-edition-permissions! conn profile-id team-id)
-      (create-font-variant cfg params))))
+  (teams/check-edition-permissions! pool profile-id team-id)
+  (create-font-variant cfg params))
 
 (defn create-font-variant
-  [{:keys [conn storage] :as cfg} {:keys [data] :as params}]
+  [{:keys [storage pool] :as cfg} {:keys [data] :as params}]
   (let [data    (media/run {:cmd :generate-fonts :input data})
-        storage (media/configure-assets-storage storage conn)
+        storage (media/configure-assets-storage storage)]
 
-        otf     (when-let [fdata (get data "font/otf")]
-                  (sto/put-object storage {:content (sto/content fdata)
-                                           :content-type "font/otf"}))
-
-        ttf     (when-let [fdata (get data "font/ttf")]
-                  (sto/put-object storage {:content (sto/content fdata)
-                                           :content-type "font/ttf"}))
-
-        woff1   (when-let [fdata (get data "font/woff")]
-                  (sto/put-object storage {:content (sto/content fdata)
-                                           :content-type "font/woff"}))
-
-        woff2   (when-let [fdata (get data "font/woff2")]
-                  (sto/put-object storage {:content (sto/content fdata)
-                                           :content-type "font/woff2"}))]
-
-    (when (and (nil? otf)
-               (nil? ttf)
-               (nil? woff1)
-               (nil? woff2))
+    (when (and (not (contains? data "font/otf"))
+               (not (contains? data "font/ttf"))
+               (not (contains? data "font/woff"))
+               (not (contains? data "font/woff2")))
       (ex/raise :type :validation
                 :code :invalid-font-upload))
 
-    (db/insert! conn :team-font-variant
-                {:id (uuid/next)
-                 :team-id (:team-id params)
-                 :font-id (:font-id params)
-                 :font-family (:font-family params)
-                 :font-weight (:font-weight params)
-                 :font-style (:font-style params)
-                 :woff1-file-id (:id woff1)
-                 :woff2-file-id (:id woff2)
-                 :otf-file-id (:id otf)
-                 :ttf-file-id (:id ttf)})))
+    (let [otf   (when-let [fdata (get data "font/otf")]
+                  (sto/put-object storage {:content (sto/content fdata)
+                                           :content-type "font/otf"
+                                           :reference :team-font-variant
+                                           :touched-at (dt/now)}))
+
+          ttf   (when-let [fdata (get data "font/ttf")]
+                  (sto/put-object storage {:content (sto/content fdata)
+                                           :content-type "font/ttf"
+                                           :touched-at (dt/now)
+                                           :reference :team-font-variant}))
+
+          woff1 (when-let [fdata (get data "font/woff")]
+                  (sto/put-object storage {:content (sto/content fdata)
+                                           :content-type "font/woff"
+                                           :touched-at (dt/now)
+                                           :reference :team-font-variant}))
+
+          woff2 (when-let [fdata (get data "font/woff2")]
+                  (sto/put-object storage {:content (sto/content fdata)
+                                           :content-type "font/woff2"
+                                           :touched-at (dt/now)
+                                           :reference :team-font-variant}))]
+
+      (db/insert! pool :team-font-variant
+                  {:id (uuid/next)
+                   :team-id (:team-id params)
+                   :font-id (:font-id params)
+                   :font-family (:font-family params)
+                   :font-weight (:font-weight params)
+                   :font-style (:font-style params)
+                   :woff1-file-id (:id woff1)
+                   :woff2-file-id (:id woff2)
+                   :otf-file-id (:id otf)
+                   :ttf-file-id (:id ttf)}))))
 
 ;; --- UPDATE FONT FAMILY
 

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

@@ -56,7 +56,7 @@
   (s/keys :req-un [::email ::password]
           :opt-un [::invitation-token]))
 
-(sv/defmethod ::login-with-ldap {:auth false :rlimit :password}
+(sv/defmethod ::login-with-ldap {:auth false}
   [{:keys [pool session tokens] :as cfg} params]
   (db/with-atomic [conn pool]
     (let [info (authenticate params)

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

@@ -14,9 +14,10 @@
    [app.db :as db]
    [app.media :as media]
    [app.rpc.queries.teams :as teams]
+   [app.rpc.rlimit :as rlimit]
    [app.storage :as sto]
+   [app.util.async :as async]
    [app.util.http :as http]
-   [app.util.rlimit :as rlimit]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
@@ -49,13 +50,12 @@
           :opt-un [::id]))
 
 (sv/defmethod ::upload-file-media-object
-  {::rlimit/permits (cf/get :rlimit-image)}
+  {::rlimit/permits (cf/get :rlimit-image)
+   ::async/dispatch :default}
   [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
-  (db/with-atomic [conn pool]
-    (let [file (select-file conn file-id)]
-      (teams/check-edition-permissions! conn profile-id (:team-id file))
-      (-> (assoc cfg :conn conn)
-          (create-file-media-object params)))))
+  (let [file (select-file pool file-id)]
+    (teams/check-edition-permissions! pool profile-id (:team-id file))
+    (create-file-media-object cfg params)))
 
 (defn- big-enough-for-thumbnail?
   "Checks if the provided image info is big enough for
@@ -77,6 +77,9 @@
                 :code :unable-to-access-to-url
                 :cause e))))
 
+;; TODO: we need to check the size before fetch resource, if not we
+;; can start downloading very big object and cause OOM errors.
+
 (defn- download-media
   [{:keys [storage] :as cfg} url]
   (let [result (fetch-url url)
@@ -90,6 +93,7 @@
     (-> (assoc storage :backend :tmp)
         (sto/put-object {:content (sto/content data)
                          :content-type mtype
+                         :reference :file-media-object
                          :expired-at (dt/in-future {:minutes 30})}))))
 
 ;; NOTE: we use the `on conflict do update` instead of `do nothing`
@@ -102,13 +106,27 @@
        on conflict (id) do update set created_at=file_media_object.created_at
        returning *")
 
+;; NOTE: the following function executes without a transaction, this
+;; means that if something fails in the middle of this function, it
+;; will probably leave leaked/unreferenced objects in the database and
+;; probably in the storage layer. For handle possible object leakage,
+;; we create all media objects marked as touched, this ensures that if
+;; something fails, all leaked (already created storage objects) will
+;; be eventually marked as deleted by the touched-gc task.
+;;
+;; The touched-gc task, performs periodic analisis of all touched
+;; storage objects and check references of it. This is the reason why
+;; `reference` metadata exists: it indicates the name of the table
+;; witch holds the reference to storage object (it some kind of
+;; inverse, soft referential integrity).
+
 (defn create-file-media-object
-  [{:keys [conn storage] :as cfg} {:keys [id file-id is-local name content] :as params}]
+  [{:keys [storage pool] :as cfg} {:keys [id file-id is-local name content] :as params}]
   (media/validate-media-type (:content-type content))
-  (let [storage      (media/configure-assets-storage storage conn)
-        source-path  (fs/path (:tempfile content))
+  (let [source-path  (fs/path (:tempfile content))
         source-mtype (:content-type content)
         source-info  (media/run {:cmd :info :input {:path source-path :mtype source-mtype}})
+        storage      (media/configure-assets-storage storage)
 
         thumb        (when (and (not (svg-image? source-info))
                                 (big-enough-for-thumbnail? source-info))
@@ -119,16 +137,25 @@
 
         image        (if (= (:mtype source-info) "image/svg+xml")
                        (let [data (slurp source-path)]
-                         (sto/put-object storage {:content (sto/content data)
-                                                  :content-type (:mtype source-info)}))
-                       (sto/put-object storage {:content (sto/content source-path)
-                                                :content-type (:mtype source-info)}))
+                         (sto/put-object storage
+                                         {:content (sto/content data)
+                                          :content-type (:mtype source-info)
+                                          :reference :file-media-object
+                                          :touched-at (dt/now)}))
+                       (sto/put-object storage
+                                       {:content (sto/content source-path)
+                                        :content-type (:mtype source-info)
+                                        :reference :file-media-object
+                                        :touched-at (dt/now)}))
 
         thumb        (when thumb
-                       (sto/put-object storage {:content (sto/content (:data thumb) (:size thumb))
-                                                :content-type (:mtype thumb)}))]
+                       (sto/put-object storage
+                                       {:content (sto/content (:data thumb) (:size thumb))
+                                        :content-type (:mtype thumb)
+                                        :reference :file-media-object
+                                        :touched-at (dt/now)}))]
 
-    (db/exec-one! conn [sql:create-file-media-object
+    (db/exec-one! pool [sql:create-file-media-object
                         (or id (uuid/next))
                         file-id is-local name
                         (:id image)
@@ -144,20 +171,19 @@
           :opt-un [::id ::name]))
 
 (sv/defmethod ::create-file-media-object-from-url
+  {::rlimit/permits (cf/get :rlimit-image)
+   ::async/dispatch :default}
   [{:keys [pool storage] :as cfg} {:keys [profile-id file-id url name] :as params}]
-  (db/with-atomic [conn pool]
-    (let [file (select-file conn file-id)]
-      (teams/check-edition-permissions! conn profile-id (:team-id file))
-      (let [mobj    (download-media cfg url)
-            content {:filename "tempfile"
-                     :size (:size mobj)
-                     :tempfile (sto/get-object-path storage mobj)
-                     :content-type (:content-type (meta mobj))}
-            params' (merge params {:content content
-                                   :name (or name (:filename content))})]
-        (-> (assoc cfg :conn conn)
-            (create-file-media-object params'))))))
+  (let [file (select-file pool file-id)]
+    (teams/check-edition-permissions! pool profile-id (:team-id file))
+    (let [mobj    (download-media cfg url)
+          content {:filename "tempfile"
+                   :size (:size mobj)
+                   :tempfile (sto/get-object-path storage mobj)
+                   :content-type (:content-type (meta mobj))}]
 
+      (->> (merge params {:content content :name (or name (:filename content))})
+           (create-file-media-object cfg)))))
 
 ;; --- Clone File Media object (Upload and create from url)
 
@@ -189,7 +215,6 @@
                  :height (:height mobj)
                  :mtype  (:mtype mobj)})))
 
-
 ;; --- HELPERS
 
 (def ^:private

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

@@ -6,6 +6,7 @@
 
 (ns app.rpc.mutations.profile
   (:require
+   [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
@@ -15,11 +16,11 @@
    [app.http.oauth :refer [extract-utm-props]]
    [app.loggers.audit :as audit]
    [app.media :as media]
-   [app.metrics :as mtx]
    [app.rpc.mutations.teams :as teams]
    [app.rpc.queries.profile :as profile]
+   [app.rpc.rlimit :as rlimit]
    [app.storage :as sto]
-   [app.util.rlimit :as rlimit]
+   [app.util.async :as async]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [buddy.hashers :as hashers]
@@ -38,7 +39,6 @@
 (s/def ::theme ::us/string)
 (s/def ::invitation-token ::us/not-empty-string)
 
-(declare annotate-profile-register)
 (declare check-profile-existence!)
 (declare create-profile)
 (declare create-profile-relations)
@@ -102,6 +102,7 @@
   (when-not (contains? cf/flags :registration)
     (ex/raise :type :restriction
               :code :registration-disabled))
+
   (when-let [domains (cf/get :registration-domain-whitelist)]
     (when-not (email-domain-in-whitelist? domains (:email params))
       (ex/raise :type :validation
@@ -116,10 +117,18 @@
 
   (check-profile-existence! pool params)
 
-  (let [params (assoc params
-                      :backend "penpot"
-                      :iss :prepared-register
-                      :exp (dt/in-future "48h"))
+  (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)]
     {:token token}))
 
@@ -136,43 +145,32 @@
     (-> (assoc cfg :conn conn)
         (register-profile params))))
 
-(defn- annotate-profile-register
-  "A helper for properly increase the profile-register metric once the
-  transaction is completed."
-  [metrics]
-  (fn []
-    (let [mobj (get-in metrics [:definitions :profile-register])]
-      ((::mtx/fn mobj) {:by 1}))))
-
 (defn register-profile
-  [{:keys [conn tokens session metrics] :as cfg} {:keys [token] :as params}]
+  [{: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}))]
 
-    (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))]
       (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).
-        (some? (:invitation-token params))
-        (let [token (:invitation-token params)
-              claims (tokens :verify {:token token :iss :team-invitation})
-              claims (assoc claims
-                            :member-id  (:id profile)
-                            :member-email (:email profile))
+        ;; 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))
-             :before-complete (annotate-profile-register metrics)
              ::audit/props (audit/profile->props profile)
              ::audit/profile-id (:id profile)}))
 
@@ -182,7 +180,6 @@
         (not= "penpot" (:auth-backend profile))
         (with-meta (profile/strip-private-attrs profile)
           {:transform-response ((:create session) (:id profile))
-           :before-complete (annotate-profile-register metrics)
            ::audit/props (audit/profile->props profile)
            ::audit/profile-id (:id profile)})
 
@@ -191,7 +188,6 @@
         (true? is-active)
         (with-meta (profile/strip-private-attrs profile)
           {:transform-response ((:create session) (:id profile))
-           :before-complete (annotate-profile-register metrics)
            ::audit/props (audit/profile->props profile)
            ::audit/profile-id (:id profile)})
 
@@ -214,8 +210,7 @@
                       :extra-data ptoken})
 
           (with-meta profile
-            {:before-complete (annotate-profile-register metrics)
-             ::audit/props (audit/profile->props profile)
+            {::audit/props (audit/profile->props profile)
              ::audit/profile-id (:id profile)}))))))
 
 (defn create-profile
@@ -284,7 +279,9 @@
           :opt-un [::scope ::invitation-token]))
 
 (sv/defmethod ::login
-  {:auth false ::rlimit/permits (cf/get :rlimit-password)}
+  {:auth false
+   ::async/dispatch :default
+   ::rlimit/permits (cf/get :rlimit-password)}
   [{:keys [pool session tokens] :as cfg} {:keys [email password] :as params}]
   (letfn [(check-password [profile password]
             (when (= (:password profile) "!")
@@ -305,32 +302,26 @@
             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))]
-        (if-let [token (:invitation-token params)]
-          ;; If the request comes with an invitation token, this means
-          ;; that user wants to accept it with different user. A very
-          ;; strange case but still can happen. In this case, we
-          ;; proceed in the same way as in register: regenerate the
-          ;; invitation token and return it to the user for proper
-          ;; invitation acceptation.
-          (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 (audit/profile->props profile)
-               ::audit/profile-id (:id profile)}))
+      (let [profile    (->> (profile/retrieve-profile-data-by-email conn email)
+                            (validate-profile)
+                            (profile/strip-private-attrs)
+                            (profile/populate-additional-data conn)
+                            (decode-profile-row))
 
-          (with-meta profile
-            {:transform-response ((:create session) (:id profile))
-             ::audit/props (audit/profile->props profile)
-             ::audit/profile-id (:id profile)}))))))
+            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
 
@@ -381,6 +372,11 @@
   (db/with-atomic [conn pool]
     (let [profile    (validate-password! conn params)
           session-id (:app.rpc/session-id params)]
+      (when (= (str/lower (:email profile))
+               (str/lower (:password params)))
+        (ex/raise :type :validation
+                  :code :email-as-password
+                  :hint "you can't use your email as password"))
       (update-profile-password! conn (assoc profile :password password))
       (invalidate-profile-session! conn (:id profile) session-id)
       nil)))
@@ -606,7 +602,8 @@
       (db/update! conn :profile
                   {:props (db/tjson props)}
                   {:id profile-id})
-      nil)))
+
+      (profile/filter-profile-props props))))
 
 
 ;; --- MUTATION: Delete Profile

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

@@ -18,8 +18,8 @@
    [app.rpc.permissions :as perms]
    [app.rpc.queries.profile :as profile]
    [app.rpc.queries.teams :as teams]
+   [app.rpc.rlimit :as rlimit]
    [app.storage :as sto]
-   [app.util.rlimit :as rlimit]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
@@ -379,8 +379,7 @@
                 :code :member-is-muted
                 :hint "looks like the profile has reported repeatedly as spam or has permanent bounces"))
 
-    ;; Secondly check if the invited member email is part of the
-    ;; global spam/bounce report.
+    ;; Secondly check if the invited member email is part of the global spam/bounce report.
     (when (eml/has-bounce-reports? conn email)
       (ex/raise :type :validation
                 :code :email-has-permanent-bounces
@@ -403,13 +402,21 @@
   (s/and ::create-team (s/keys :req-un [::emails ::role])))
 
 (sv/defmethod ::create-team-and-invite-members
-  [{:keys [pool] :as cfg} {:keys [profile-id emails role] :as params}]
+  [{:keys [pool audit] :as cfg} {:keys [profile-id emails role] :as params}]
   (db/with-atomic [conn pool]
     (let [team    (create-team conn params)
           profile (db/get-by-id conn :profile profile-id)]
 
       ;; Create invitations for all provided emails.
       (doseq [email emails]
+        (audit :cmd :submit
+               :type "mutation"
+               :name "create-team-invitation"
+               :profile-id profile-id
+               :props {:email email
+                       :role role
+                       :profile-id profile-id})
+
         (create-team-invitation
          (assoc cfg
                 :conn conn

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

@@ -10,7 +10,6 @@
    [app.common.spec :as us]
    [app.db :as db]
    [app.loggers.audit :as audit]
-   [app.metrics :as mtx]
    [app.rpc.mutations.teams :as teams]
    [app.rpc.queries.profile :as profile]
    [app.util.services :as sv]
@@ -44,16 +43,8 @@
      ::audit/props {:email email}
      ::audit/profile-id profile-id}))
 
-(defn- annotate-profile-activation
-  "A helper for properly increase the profile-activation metric once the
-  transaction is completed."
-  [metrics]
-  (fn []
-    (let [mobj (get-in metrics [:definitions :profile-activation])]
-      ((::mtx/fn mobj) {:by 1}))))
-
 (defmethod process-token :verify-email
-  [{:keys [conn session metrics] :as cfg} _ {:keys [profile-id] :as claims}]
+  [{:keys [conn session] :as cfg} _ {:keys [profile-id] :as claims}]
   (let [profile (profile/retrieve-profile conn profile-id)
         claims  (assoc claims :profile profile)]
 
@@ -69,7 +60,6 @@
 
     (with-meta claims
       {:transform-response ((:create session) profile-id)
-       :before-complete (annotate-profile-activation metrics)
        ::audit/name "verify-profile-email"
        ::audit/props (audit/profile->props profile)
        ::audit/profile-id (:id profile)})))
@@ -118,77 +108,39 @@
     (assoc member :is-active true)))
 
 (defmethod process-token :team-invitation
-  [{:keys [session] :as cfg} {:keys [profile-id token]} {:keys [member-id] :as claims}]
+  [cfg {:keys [profile-id token]} {:keys [member-id] :as claims}]
   (us/assert ::team-invitation-claims claims)
   (cond
     ;; This happens when token is filled with member-id and current
-    ;; user is already logged in with some account.
-    (and (uuid? profile-id)
-         (uuid? member-id))
+    ;; user is already logged in with exactly invited account.
+    (and (uuid? profile-id) (uuid? member-id) (= member-id profile-id))
     (let [profile (accept-invitation cfg claims)]
-      (if (= member-id profile-id)
-        ;; If the current session is already matches the invited
-        ;; member, then just return the token and leave the frontend
-        ;; app redirect to correct team.
-        (assoc claims :state :created)
-
-        ;; If the session does not matches the invited member, replace
-        ;; the session with a new one matching the invited member.
-        ;; This technique should be considered secure because the
-        ;; user clicking the link he already has access to the email
-        ;; account.
-        (with-meta
-          (assoc claims :state :created)
-          {:transform-response ((:create session) member-id)
-           ::audit/name "accept-team-invitation"
-           ::audit/props (merge
-                          (audit/profile->props profile)
-                          {:team-id (:team-id claims)
-                           :role (:role claims)})
-           ::audit/profile-id profile-id})))
-
-    ;; This happens when member-id is not filled in the invitation but
-    ;; the user already has an account (probably with other mail) and
-    ;; is already logged-in.
-    (and (uuid? profile-id)
-         (nil? member-id))
-    (let [profile (accept-invitation cfg (assoc claims :member-id profile-id))]
       (with-meta
         (assoc claims :state :created)
         {::audit/name "accept-team-invitation"
-         ::audit/props (merge
-                        (audit/profile->props profile)
-                        {:team-id (:team-id claims)
-                         :role (:role claims)})
-         ::audit/profile-id profile-id}))
-
-    ;; This happens when member-id is filled but the accessing user is
-    ;; not logged-in. In this case we proceed to accept invitation and
-    ;; leave the user logged-in.
-    (and (nil? profile-id)
-         (uuid? member-id))
-    (let [profile (accept-invitation cfg claims)]
-      (with-meta
-        (assoc claims :state :created)
-        {:transform-response ((:create session) member-id)
-         ::audit/name "accept-team-invitation"
          ::audit/props (merge
                         (audit/profile->props profile)
                         {:team-id (:team-id claims)
                          :role (:role claims)})
          ::audit/profile-id member-id}))
 
-    ;; In this case, we wait until frontend app redirect user to
-    ;; registration page, the user is correctly registered and the
-    ;; register mutation call us again with the same token to finally
-    ;; create the corresponding team-profile relation from the first
-    ;; condition of this if.
+    ;; This case means that invitation token does not match with
+    ;; registred user, so we need to indicate to frontend to redirect
+    ;; it to register page.
+    (nil? member-id)
+    {:invitation-token token
+     :iss :team-invitation
+     :redirect-to :auth-register
+     :state :pending}
+
+    ;; In all other cases, just tell to fontend to redirect the user
+    ;; to the login page.
     :else
     {:invitation-token token
      :iss :team-invitation
+     :redirect-to :auth-login
      :state :pending}))
 
-
 ;; --- Default
 
 (defmethod process-token :default

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

@@ -7,7 +7,7 @@
 (ns app.rpc.queries.files
   (:require
    [app.common.data :as d]
-   [app.common.pages :as cp]
+   [app.common.pages.helpers :as cph]
    [app.common.pages.migrations :as pmg]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
@@ -26,6 +26,7 @@
 
 ;; --- Helpers & Specs
 
+(s/def ::frame-id ::us/uuid)
 (s/def ::id ::us/uuid)
 (s/def ::name ::us/string)
 (s/def ::project-id ::us/uuid)
@@ -242,13 +243,10 @@
 (defn- trim-file-data
   [file {:keys [page-id object-id]}]
   (let [page    (get-in file [:data :pages-index page-id])
-        objects (->> (:objects page)
-                     (cp/get-object-with-children object-id)
-                     (map #(dissoc % :thumbnail)))
-
-        objects (d/index-by :id objects)
+        objects (->> (cph/get-children-with-self (:objects page) object-id)
+                     (map #(dissoc % :thumbnail))
+                     (d/index-by :id))
         page    (assoc page :objects objects)]
-
     (-> file
         (update :data assoc :pages-index {page-id page})
         (update :data assoc :pages [page-id]))))
@@ -395,6 +393,7 @@
    )
    select * from recent_files where row_num <= 10;")
 
+
 (s/def ::team-recent-files
   (s/keys :req-un [::profile-id ::team-id]))
 
@@ -404,6 +403,25 @@
     (teams/check-read-permissions! conn profile-id team-id)
     (db/exec! conn [sql:team-recent-files team-id])))
 
+
+;; --- QUERY: get the thumbnail for an frame
+
+(def ^:private sql:file-frame-thumbnail
+  "select data
+     from file_frame_thumbnail
+    where file_id = ?
+      and frame_id = ?")
+
+(s/def ::file-frame-thumbnail
+  (s/keys :req-un [::profile-id ::file-id ::frame-id]))
+
+(sv/defmethod ::file-frame-thumbnail
+  [{:keys [pool]} {:keys [profile-id file-id frame-id]}]
+  (with-open [conn (db/open pool)]
+    (check-read-permissions! conn profile-id file-id)
+    (db/exec-one! conn [sql:file-frame-thumbnail file-id frame-id])))
+
+
 ;; --- Helpers
 
 (defn decode-row

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

@@ -35,7 +35,8 @@
 (s/def ::profile
   (s/keys :opt-un [::profile-id]))
 
-(sv/defmethod ::profile {:auth false}
+(sv/defmethod ::profile
+  {:auth false}
   [{:keys [pool] :as cfg} {:keys [profile-id] :as params}]
   ;; We need to return the anonymous profile object in two cases, when
   ;; no profile-id is in session, and when db call raises not found. In all other
@@ -74,7 +75,7 @@
   [conn profile]
   (merge profile (retrieve-additional-data conn (:id profile))))
 
-(defn- filter-profile-props
+(defn filter-profile-props
   [props]
   (into {} (filter (fn [[k _]] (simple-ident? k))) props))
 

backend/src/app/rpc/retry.clj

@@ -0,0 +1,45 @@
+;; 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.retry
+  "A fault tolerance helpers. Allow retry some operations that we know
+  we can retry."
+  (:require
+   [app.common.logging :as l]
+   [app.util.services :as sv]
+   [promesa.core :as p]))
+
+(defn conflict-db-insert?
+  "Check if exception matches a insertion conflict on postgresql."
+  [e]
+  (and (instance? org.postgresql.util.PSQLException e)
+       (= "23505" (.getSQLState e))))
+
+(defn wrap-retry
+  [_ f {:keys [::matches ::sv/name]
+        :or {matches (constantly false)}
+        :as mdata}]
+
+  (when (::enabled mdata)
+    (l/debug :hint "wrapping retry" :name name))
+
+  (if-let [max-retries (::max-retries mdata)]
+    (fn [cfg params]
+      (letfn [(run [retry]
+                (-> (f cfg params)
+                    (p/catch (partial handle-error retry))))
+
+              (handle-error [retry cause]
+                (if (matches cause)
+                  (let [current-retry (inc retry)]
+                    (l/trace :hint "running retry algorithm" :retry current-retry)
+                    (if (<= current-retry max-retries)
+                      (run current-retry)
+                      (throw cause)))
+                  (throw cause)))]
+        (run 0)))
+    f))
+

backend/src/app/rpc/rlimit.clj

@@ -0,0 +1,67 @@
+;; 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.rlimit
+  "Resource usage limits (in other words: semaphores)."
+  (:require
+   [app.common.data :as d]
+   [app.common.logging :as l]
+   [app.metrics :as mtx]
+   [app.util.services :as sv]
+   [promesa.core :as p]))
+
+(defprotocol IAsyncSemaphore
+  (acquire! [_])
+  (release! [_]))
+
+(defn semaphore
+  [{:keys [permits metrics name]}]
+  (let [name   (d/name name)
+        used   (volatile! 0)
+        queue  (volatile! (d/queue))
+        labels (into-array String [name])]
+    (reify IAsyncSemaphore
+      (acquire! [this]
+        (let [d (p/deferred)]
+          (locking this
+            (if (< @used permits)
+              (do
+                (vswap! used inc)
+                (p/resolve! d))
+              (vswap! queue conj d)))
+
+          (mtx/run! metrics {:id :rlimit-used-permits :val @used :labels labels })
+          (mtx/run! metrics {:id :rlimit-queued-submissions :val (count @queue) :labels labels})
+          (mtx/run! metrics {:id :rlimit-acquires-total :inc 1 :labels labels})
+          d))
+
+      (release! [this]
+        (locking this
+          (if-let [item (peek @queue)]
+            (do
+              (vswap! queue pop)
+              (p/resolve! item))
+            (when (pos? @used)
+              (vswap! used dec))))
+
+        (mtx/run! metrics {:id :rlimit-used-permits :val @used :labels labels})
+        (mtx/run! metrics {:id :rlimit-queued-submissions :val (count @queue) :labels labels})
+        ))))
+
+(defn wrap-rlimit
+  [{:keys [metrics] :as cfg} f mdata]
+  (if-let [permits (::permits mdata)]
+    (let [sem (semaphore {:permits permits
+                          :metrics metrics
+                          :name (::sv/name mdata)})]
+      (l/debug :hint "wrapping rlimit" :handler (::sv/name mdata) :permits permits)
+      (fn [cfg params]
+        (-> (acquire! sem)
+            (p/then (fn [_] (f cfg params)))
+            (p/finally (fn [_ _] (release! sem))))))
+    f))
+
+

backend/src/app/setup.clj

@@ -7,6 +7,7 @@
 (ns app.setup
   "Initial data setup of instance."
   (:require
+   [app.common.logging :as l]
    [app.common.uuid :as uuid]
    [app.db :as db]
    [buddy.core.codecs :as bc]
@@ -14,55 +15,49 @@
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]))
 
-(declare initialize-instance-id!)
-(declare initialize-secret-key!)
-(declare retrieve-all)
+(defn- generate-random-key
+  []
+  (-> (bn/random-bytes 64)
+      (bc/bytes->b64u)
+      (bc/bytes->str)))
+
+(defn- retrieve-all
+  [conn]
+  (->> (db/query conn :server-prop {:preload true})
+       (filter #(not= "secret-key" (:id %)))
+       (map (fn [row]
+              [(keyword (:id row))
+               (db/decode-transit-pgobject (:content row))]))
+       (into {})))
+
+(defn- handle-instance-id
+  [instance-id conn read-only?]
+  (or instance-id
+      (let [instance-id (uuid/random)]
+        (when-not read-only?
+          (try
+            (db/insert! conn :server-prop
+                        {:id "instance-id"
+                         :preload true
+                         :content (db/tjson instance-id)})
+            (catch Throwable cause
+              (l/warn :hint "unable to persist instance-id"
+                      :instance-id instance-id
+                      :cause cause))))
+        instance-id)))
 
 (defmethod ig/pre-init-spec ::props [_]
   (s/keys :req-un [::db/pool]))
 
 (defmethod ig/init-key ::props
-  [_ {:keys [pool] :as cfg}]
+  [_ {:keys [pool key] :as cfg}]
   (db/with-atomic [conn pool]
-    (let [cfg (assoc cfg :conn conn)]
-      (initialize-secret-key! cfg)
-      (initialize-instance-id! cfg)
-      (retrieve-all cfg))))
+    (db/xact-lock! conn 0)
+    (when-not key
+      (l/warn :hint (str "using autogenerated secret-key, it will change on each restart and will invalidate "
+                         "all sessions on each restart, it is hightly recommeded setting up the "
+                         "PENPOT_SECRET_KEY environment variable")))
 
-(def sql:upsert-secret-key
-  "insert into server_prop (id, preload, content)
-   values ('secret-key', true, ?::jsonb)
-   on conflict (id) do update set content = ?::jsonb")
-
-(def sql:insert-secret-key
-  "insert into server_prop (id, preload, content)
-   values ('secret-key', true, ?::jsonb)
-   on conflict (id) do nothing")
-
-(defn- initialize-secret-key!
-  [{:keys [conn key] :as cfg}]
-  (if key
-    (let [key (db/tjson key)]
-      (db/exec-one! conn [sql:upsert-secret-key key key]))
-    (let [key (-> (bn/random-bytes 64)
-                  (bc/bytes->b64u)
-                  (bc/bytes->str))
-          key (db/tjson key)]
-      (db/exec-one! conn [sql:insert-secret-key key]))))
-
-(defn- initialize-instance-id!
-  [{:keys [conn] :as cfg}]
-  (let [iid (uuid/random)]
-
-    (db/insert! conn :server-prop
-                {:id "instance-id"
-                 :preload true
-                 :content (db/tjson iid)}
-                {:on-conflict-do-nothing true})))
-
-(defn- retrieve-all
-  [{:keys [conn] :as cfg}]
-  (reduce (fn [acc row]
-            (assoc acc (keyword (:id row)) (db/decode-transit-pgobject (:content row))))
-          {}
-          (db/query conn :server-prop {:preload true})))
+    (let [stored (-> (retrieve-all conn)
+                     (assoc :secret-key (or key (generate-random-key))))]
+      (update stored :instance-id handle-instance-id conn (db/read-only? pool)))))

backend/src/app/srepl/main.clj

@@ -7,7 +7,7 @@
    [app.common.logging :as l]
    [app.common.pages :as cp]
    [app.common.pages.migrations :as pmg]
-   [app.common.pages.spec :as spec]
+   [app.common.spec.file :as spec.file]
    [app.common.uuid :as uuid]
    [app.config :as cfg]
    [app.db :as db]
@@ -17,7 +17,7 @@
    [app.srepl.dev :as dev]
    [app.util.blob :as blob]
    [app.util.time :as dt]
-   [clojure.pprint :refer [pprint]]
+   [fipp.edn :refer [pprint]]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [expound.alpha :as expound]))
@@ -86,7 +86,7 @@
 
           (validate-item [{:keys [id data modified-at] :as file}]
             (let [data   (blob/decode data)
-                  valid? (s/valid? ::spec/data data)]
+                  valid? (s/valid? ::spec.file/data data)]
 
               (l/debug :hint "validated file"
                        :file-id id
@@ -98,7 +98,7 @@
                        :valid valid?)
 
               (when (and (not valid?) verbose?)
-                (let [edata (-> (s/explain-data ::spec/data data)
+                (let [edata (-> (s/explain-data ::spec.file/data data)
                                 (update ::s/problems #(take 5 %)))]
                   (binding [s/*explain-out* expound/printer]
                     (l/warn ::l/raw (with-out-str (s/explain-out edata))))))

backend/src/app/storage.clj

@@ -18,11 +18,9 @@
    [app.storage.impl :as impl]
    [app.storage.s3 :as ss3]
    [app.util.time :as dt]
-   [app.worker :as wrk]
    [clojure.spec.alpha :as s]
    [datoteka.core :as fs]
-   [integrant.core :as ig]
-   [promesa.exec :as px]))
+   [integrant.core :as ig]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Storage Module State
@@ -40,7 +38,7 @@
                    :db ::sdb/backend))))
 
 (defmethod ig/pre-init-spec ::storage [_]
-  (s/keys :req-un [::wrk/executor ::db/pool ::backends]))
+  (s/keys :req-un [::db/pool ::backends]))
 
 (defmethod ig/prep-key ::storage
   [_ {:keys [backends] :as cfg}]
@@ -53,78 +51,74 @@
       (assoc :backends (d/without-nils backends))))
 
 (s/def ::storage
-  (s/keys :req-un [::backends ::wrk/executor ::db/pool]))
+  (s/keys :req-un [::backends ::db/pool]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Database Objects
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defrecord StorageObject [id size created-at expired-at backend])
+(defrecord StorageObject [id size created-at expired-at touched-at backend])
 
 (defn storage-object?
   [v]
   (instance? StorageObject v))
 
-(def ^:private
-  sql:insert-storage-object
-  "insert into storage_object (id, size, backend, metadata)
-   values (?, ?, ?, ?::jsonb)
-   returning *")
+(s/def ::storage-object storage-object?)
+(s/def ::storage-content impl/content?)
 
-(def ^:private
-  sql:insert-storage-object-with-expiration
-  "insert into storage_object (id, size, backend, metadata, deleted_at)
-   values (?, ?, ?, ?::jsonb, ?)
-   returning *")
 
-(defn- insert-object
-  [conn id size backend mdata expiration]
-  (if expiration
-    (db/exec-one! conn [sql:insert-storage-object-with-expiration id size backend mdata expiration])
-    (db/exec-one! conn [sql:insert-storage-object id size backend mdata])))
+(defn- clone-database-object
+  ;; If we in this condition branch, this means we come from the
+  ;; clone-object, so we just need to clone it with a new backend.
+  [{:keys [conn backend]} object]
+  (let [id     (uuid/random)
+        mdata  (meta object)
+        result (db/insert! conn :storage-object
+                           {:id id
+                            :size (:size object)
+                            :backend (name backend)
+                            :metadata (db/tjson mdata)
+                            :deleted-at (:expired-at object)
+                            :touched-at (:touched-at object)})]
+    (assoc object
+           :id (:id result)
+           :backend backend
+           :created-at (:created-at result)
+           :touched-at (:touched-at result))))
 
 (defn- create-database-object
   [{:keys [conn backend]} {:keys [content] :as object}]
-  (if (instance? StorageObject object)
-    ;; If we in this condition branch, this means we come from the
-    ;; clone-object, so we just need to clone it with a new backend.
-    (let [id     (uuid/random)
-          mdata  (meta object)
-          result (insert-object conn
-                                id
-                                (:size object)
-                                (name backend)
-                                (db/tjson mdata)
-                                (:expired-at object))]
-      (assoc object
-             :id (:id result)
-             :backend backend
-             :created-at (:created-at result)))
-    (let [id     (uuid/random)
-          mdata  (dissoc object :content :expired-at)
-          result (insert-object conn
-                                id
-                                (count content)
-                                (name backend)
-                                (db/tjson mdata)
-                                (:expired-at object))]
-      (StorageObject. (:id result)
-                      (:size result)
-                      (:created-at result)
-                      (:deleted-at result)
-                      backend
-                      mdata
-                      nil))))
+  (us/assert ::storage-content content)
+  (let [id     (uuid/random)
+        mdata  (dissoc object :content :expired-at :touched-at)
+
+        result (db/insert! conn :storage-object
+                           {:id id
+                            :size (count content)
+                            :backend (name backend)
+                            :metadata (db/tjson mdata)
+                            :deleted-at (:expired-at object)
+                            :touched-at (:touched-at object)})]
+
+    (StorageObject. (:id result)
+                    (:size result)
+                    (:created-at result)
+                    (:deleted-at result)
+                    (:touched-at result)
+                    backend
+                    mdata
+                    nil)))
 
 (def ^:private sql:retrieve-storage-object
   "select * from storage_object where id = ? and (deleted_at is null or deleted_at > now())")
 
 (defn row->storage-object [res]
-  (let [mdata (some-> (:metadata res) (db/decode-transit-pgobject))]
+  (let [mdata (or (some-> (:metadata res) (db/decode-transit-pgobject)) {})]
     (StorageObject. (:id res)
                     (:size res)
                     (:created-at res)
                     (:deleted-at res)
+                    (:touched-at res)
                     (keyword (:backend res))
                     mdata
                     nil)))
@@ -142,10 +136,6 @@
   (let [result (db/exec-one! conn [sql:delete-storage-object id])]
     (pos? (:next.jdbc/update-count result))))
 
-(defn- register-recheck
-  [{:keys [pool] :as storage} backend id]
-  (db/insert! pool :storage-pending {:id id :backend (name backend)}))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; API
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -170,17 +160,13 @@
 
 (defn put-object
   "Creates a new object with the provided content."
-  [{:keys [pool conn backend executor] :as storage} {:keys [content] :as params}]
+  [{:keys [pool conn backend] :as storage} {:keys [content] :as params}]
   (us/assert ::storage storage)
-  (us/assert impl/content? content)
+  (us/assert ::storage-content content)
+  (us/assert ::us/keyword backend)
   (let [storage (assoc storage :conn (or conn pool))
         object  (create-database-object storage params)]
 
-    ;; Schedule to execute in background; in an other transaction and
-    ;; register the currently created storage object id for a later
-    ;; recheck.
-    (px/run! executor #(register-recheck storage backend (:id object)))
-
     ;; Store the data finally on the underlying storage subsystem.
     (-> (impl/resolve-backend storage backend)
         (impl/put-object object content))
@@ -190,10 +176,12 @@
 (defn clone-object
   "Creates a clone of the provided object using backend based efficient
   method. Always clones objects to the configured default."
-  [{:keys [pool conn] :as storage} object]
+  [{:keys [pool conn backend] :as storage} object]
   (us/assert ::storage storage)
+  (us/assert ::storage-object object)
+  (us/assert ::us/keyword backend)
   (let [storage (assoc storage :conn (or conn pool))
-        object* (create-database-object storage object)]
+        object* (clone-database-object storage object)]
     (if (= (:backend object) (:backend storage))
       ;; if the source and destination backends are the same, we
       ;; proceed to use the fast path with specific copy
@@ -269,7 +257,7 @@
 ;; A task responsible to permanently delete already marked as deleted
 ;; storage files.
 
-(declare sql:retrieve-deleted-objects)
+(declare sql:retrieve-deleted-objects-chunk)
 
 (s/def ::min-age ::dt/duration)
 
@@ -278,44 +266,46 @@
 
 (defmethod ig/init-key ::gc-deleted-task
   [_ {:keys [pool storage min-age] :as cfg}]
-  (letfn [(group-by-backend [rows]
-            (let [conj (fnil conj [])]
-              [(reduce (fn [acc {:keys [id backend]}]
-                         (update acc (keyword backend) conj id))
-                       {}
-                       rows)
-               (count rows)]))
+  (letfn [(retrieve-deleted-objects-chunk [conn cursor]
+            (let [min-age (db/interval min-age)
+                  rows    (db/exec! conn [sql:retrieve-deleted-objects-chunk min-age cursor])]
+              [(some-> rows peek :created-at)
+               (some->> (seq rows) (d/group-by' #(-> % :backend keyword) :id) seq)]))
 
           (retrieve-deleted-objects [conn]
-            (let [min-age (db/interval min-age)
-                  rows    (db/exec! conn [sql:retrieve-deleted-objects min-age])]
-              (some-> (seq rows) (group-by-backend))))
+            (->> (d/iteration (fn [cursor]
+                                (retrieve-deleted-objects-chunk conn cursor))
+                              :initk (dt/now)
+                              :vf second
+                              :kf first)
+                 (sequence cat)))
 
-          (delete-in-bulk [conn [backend ids]]
+          (delete-in-bulk [conn backend ids]
             (let [backend (impl/resolve-backend storage backend)
                   backend (assoc backend :conn conn)]
               (impl/del-objects-in-bulk backend ids)))]
 
     (fn [_]
       (db/with-atomic [conn pool]
-        (loop [n 0]
-          (if-let [[groups total] (retrieve-deleted-objects conn)]
+        (loop [total  0
+               groups (retrieve-deleted-objects conn)]
+          (if-let [[backend ids] (first groups)]
             (do
-              (run! (partial delete-in-bulk conn) groups)
-              (recur (+ n ^long total)))
+              (delete-in-bulk conn backend ids)
+              (recur (+ total (count ids))
+                     (rest groups)))
             (do
-              (l/info :task "gc-deleted"
-                      :action "permanently delete items"
-                      :count n)
-              {:deleted n})))))))
+              (l/info :task "gc-deleted" :count total)
+              {:deleted total})))))))
 
-(def sql:retrieve-deleted-objects
+(def sql:retrieve-deleted-objects-chunk
   "with items_part as (
      select s.id
        from storage_object as s
       where s.deleted_at is not null
         and s.deleted_at < (now() - ?::interval)
-      order by s.deleted_at
+        and s.created_at < ?
+      order by s.created_at desc
       limit 100
    )
    delete from storage_object
@@ -326,157 +316,105 @@
 ;; Garbage Collection: Analyze touched objects
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-;; This task is part of the garbage collection of storage objects and
-;; is responsible on analyzing the touched objects and mark them for deletion
-;; if corresponds.
+;; This task is part of the garbage collection of storage objects and is responsible on analyzing the touched
+;; objects and mark them for deletion if corresponds.
 ;;
-;; When file_media_object is deleted, the depending storage_object are
-;; marked as touched. This means that some files that depend on a
-;; concrete storage_object are no longer exists and maybe this
-;; storage_object is no longer necessary and can be eligible for
-;; elimination. This task periodically analyzes touched objects and
-;; mark them as freeze (means that has other references and the object
-;; is still valid) or deleted (no more references to this object so is
-;; ready to be deleted).
+;; For example: when file_media_object is deleted, the depending storage_object are marked as touched. This
+;; means that some files that depend on a concrete storage_object are no longer exists and maybe this
+;; storage_object is no longer necessary and can be eligible for elimination. This task periodically analyzes
+;; touched objects and mark them as freeze (means that has other references and the object is still valid) or
+;; deleted (no more references to this object so is ready to be deleted).
 
-(declare sql:retrieve-touched-objects)
+(declare sql:retrieve-touched-objects-chunk)
+(declare sql:retrieve-file-media-object-nrefs)
+(declare sql:retrieve-team-font-variant-nrefs)
 
 (defmethod ig/pre-init-spec ::gc-touched-task [_]
   (s/keys :req-un [::db/pool]))
 
 (defmethod ig/init-key ::gc-touched-task
   [_ {:keys [pool] :as cfg}]
-  (letfn [(group-results [rows]
-            (let [conj (fnil conj [])]
-              (reduce (fn [acc {:keys [id nrefs]}]
-                        (if (pos? nrefs)
-                          (update acc :to-freeze conj id)
-                          (update acc :to-delete conj id)))
-                      {}
-                      rows)))
+  (letfn [(has-team-font-variant-nrefs? [conn id]
+            (-> (db/exec-one! conn [sql:retrieve-team-font-variant-nrefs id id id id]) :nrefs pos?))
 
-          (retrieve-touched [conn]
-            (let [rows (db/exec! conn [sql:retrieve-touched-objects])]
-              (some-> (seq rows) (group-results))))
-
-          (mark-delete-in-bulk [conn ids]
-            (db/exec-one! conn ["update storage_object set deleted_at=now(), touched_at=null where id = ANY(?)"
-                                (db/create-array conn "uuid" (into-array java.util.UUID ids))]))
+          (has-file-media-object-nrefs? [conn id]
+            (-> (db/exec-one! conn [sql:retrieve-file-media-object-nrefs id id]) :nrefs pos?))
 
           (mark-freeze-in-bulk [conn ids]
             (db/exec-one! conn ["update storage_object set touched_at=null where id = ANY(?)"
-                                (db/create-array conn "uuid" (into-array java.util.UUID ids))]))]
+                                (db/create-array conn "uuid" ids)]))
+
+          (mark-delete-in-bulk [conn ids]
+            (db/exec-one! conn ["update storage_object set deleted_at=now(), touched_at=null where id = ANY(?)"
+                                (db/create-array conn "uuid" ids)]))
+
+          (retrieve-touched-chunk [conn cursor]
+            (let [rows (->> (db/exec! conn [sql:retrieve-touched-objects-chunk cursor])
+                            (mapv #(d/update-when % :metadata db/decode-transit-pgobject)))
+                  kw   (fn [o] (if (keyword? o) o (keyword o)))]
+              (when (seq rows)
+                [(-> rows peek :created-at)
+                 ;; NOTE: we use the :file-media-object as default value for backward compatibility because when we
+                 ;; deploy it we can have old backend instances running in the same time as the new one and we can
+                 ;; still have storage-objects created without reference value.  And we know that if it does not
+                 ;; have value, it means :file-media-object.
+                 (d/group-by' #(or (some-> % :metadata :reference kw) :file-media-object) :id rows)])))
+
+          (retrieve-touched [conn]
+            (->> (d/iteration (fn [cursor]
+                                (retrieve-touched-chunk conn cursor))
+                              :initk (dt/now)
+                              :vf second
+                              :kf first)
+                 (sequence cat)))
+
+          (process-objects! [conn pred-fn ids]
+            (loop [to-freeze #{}
+                   to-delete #{}
+                   ids       (seq ids)]
+              (if-let [id (first ids)]
+                (if (pred-fn conn id)
+                  (recur (conj to-freeze id) to-delete (rest ids))
+                  (recur to-freeze (conj to-delete id) (rest ids)))
+
+                (do
+                  (some->> (seq to-freeze) (mark-freeze-in-bulk conn))
+                  (some->> (seq to-delete) (mark-delete-in-bulk conn))
+                  [(count to-freeze) (count to-delete)]))))
+          ]
 
     (fn [_]
       (db/with-atomic [conn pool]
-        (loop [cntf 0
-               cntd 0]
-          (if-let [{:keys [to-delete to-freeze]} (retrieve-touched conn)]
+        (loop [to-freeze 0
+               to-delete 0
+               groups    (retrieve-touched conn)]
+          (if-let [[reference ids] (first groups)]
+            (let [[f d] (case reference
+                          :file-media-object (process-objects! conn has-file-media-object-nrefs? ids)
+                          :team-font-variant (process-objects! conn has-team-font-variant-nrefs? ids)
+                          (ex/raise :type :internal
+                                    :code :unexpected-unknown-reference
+                                    :hint (format "unknown reference %s" (pr-str reference))))]
+              (recur (+ to-freeze f)
+                     (+ to-delete d)
+                     (rest groups)))
             (do
-              (when (seq to-delete) (mark-delete-in-bulk conn to-delete))
-              (when (seq to-freeze) (mark-freeze-in-bulk conn to-freeze))
-              (recur (+ cntf (count to-freeze))
-                     (+ cntd (count to-delete))))
-            (do
-              (l/info :task "gc-touched"
-                      :action "mark freeze"
-                      :count cntf)
-              (l/info :task "gc-touched"
-                      :action "mark for deletion"
-                      :count cntd)
-              {:freeze cntf :delete cntd})))))))
+              (l/info :task "gc-touched" :to-freeze to-freeze :to-delete to-delete)
+              {:freeze to-freeze :delete to-delete})))))))
 
-(def sql:retrieve-touched-objects
-  "select so.id,
-          ((select count(*) from file_media_object where media_id = so.id) +
-           (select count(*) from file_media_object where thumbnail_id = so.id)) as nrefs
-     from storage_object as so
+(def sql:retrieve-touched-objects-chunk
+  "select so.* from storage_object as so
     where so.touched_at is not null
-    order by so.touched_at
-    limit 100;")
+      and so.created_at < ?
+    order by so.created_at desc
+    limit 500;")
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Recheck Stalled Task
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(def sql:retrieve-file-media-object-nrefs
+  "select ((select count(*) from file_media_object where media_id = ?) +
+           (select count(*) from file_media_object where thumbnail_id = ?)) as nrefs")
 
-;; Because the physical storage (filesystem, s3, ... except db) is not
-;; transactional, in some situations we can found physical object
-;; leakage. That situations happens when the transaction that writes
-;; the file aborts, leaving the file written to the underlying storage
-;; but the reference on the database is lost with the rollback.
-;;
-;; For this situations we need to write a "log" of inserted files that
-;; are checked in some time in future. If physical file exists but the
-;; database refence does not exists means that leaked file is found
-;; and is immediately deleted. The responsibility of this task is
-;; check that write log for possible leaked files.
-
-(def recheck-min-age (dt/duration {:hours 1}))
-
-(declare sql:retrieve-pending-to-recheck)
-(declare sql:exists-storage-object)
-
-(defmethod ig/pre-init-spec ::recheck-task [_]
-  (s/keys :req-un [::storage ::db/pool]))
-
-(defmethod ig/init-key ::recheck-task
-  [_ {:keys [pool storage] :as cfg}]
-  (letfn [(group-results [rows]
-            (let [conj (fnil conj [])]
-              (reduce (fn [acc {:keys [id exist] :as row}]
-                        (cond-> (update acc :all conj id)
-                          (false? exist)
-                          (update :to-delete conj (dissoc row :exist))))
-                      {}
-                      rows)))
-
-          (group-by-backend [rows]
-            (let [conj (fnil conj [])]
-              (reduce (fn [acc {:keys [id backend]}]
-                        (update acc (keyword backend) conj id))
-                      {}
-                      rows)))
-
-          (retrieve-pending [conn]
-            (let [rows (db/exec! conn [sql:retrieve-pending-to-recheck (db/interval recheck-min-age)])]
-              (some-> (seq rows) (group-results))))
-
-          (delete-group [conn [backend ids]]
-            (let [backend (impl/resolve-backend storage backend)
-                  backend (assoc backend :conn conn)]
-              (impl/del-objects-in-bulk backend ids)))
-
-          (delete-all [conn ids]
-            (let [ids (db/create-array conn "uuid" (into-array java.util.UUID ids))]
-              (db/exec-one! conn ["delete from storage_pending where id = ANY(?)" ids])))]
-
-    (fn [_]
-      (db/with-atomic [conn pool]
-        (loop [n 0 d 0]
-          (if-let [{:keys [all to-delete]} (retrieve-pending conn)]
-            (let [groups (group-by-backend to-delete)]
-              (run! (partial delete-group conn) groups)
-              (delete-all conn all)
-              (recur (+ n (count all))
-                     (+ d (count to-delete))))
-            (do
-              (l/info :task "recheck"
-                      :action "recheck items"
-                      :processed n
-                      :deleted n)
-              {:processed n :deleted d})))))))
-
-(def sql:retrieve-pending-to-recheck
-  "select sp.id,
-          sp.backend,
-          sp.created_at,
-          (case when count(so.id) > 0 then true
-                else false
-            end) as exist
-     from storage_pending as sp
-     left join storage_object as so
-            on (so.id = sp.id)
-    where sp.created_at < now() - ?::interval
-    group by 1,2,3
-    order by sp.created_at asc
-    limit 100")
+(def sql:retrieve-team-font-variant-nrefs
+  "select ((select count(*) from team_font_variant where woff1_file_id = ?) +
+           (select count(*) from team_font_variant where woff2_file_id = ?) +
+           (select count(*) from team_font_variant where otf_file_id = ?) +
+           (select count(*) from team_font_variant where ttf_file_id = ?)) as nrefs")

backend/src/app/storage/s3.clj

@@ -33,6 +33,7 @@
    software.amazon.awssdk.services.s3.model.GetObjectRequest
    software.amazon.awssdk.services.s3.model.ObjectIdentifier
    software.amazon.awssdk.services.s3.model.PutObjectRequest
+   software.amazon.awssdk.services.s3.model.S3Error
    ;; software.amazon.awssdk.services.s3.model.GetObjectResponse
    software.amazon.awssdk.services.s3.presigner.S3Presigner
    software.amazon.awssdk.services.s3.presigner.model.GetObjectPresignRequest
@@ -55,9 +56,10 @@
 (s/def ::region #{:eu-central-1})
 (s/def ::bucket ::us/string)
 (s/def ::prefix ::us/string)
+(s/def ::endpoint ::us/string)
 
 (defmethod ig/pre-init-spec ::backend [_]
-  (s/keys :opt-un [::region ::bucket ::prefix]))
+  (s/keys :opt-un [::region ::bucket ::prefix ::endpoint]))
 
 (defmethod ig/prep-key ::backend
   [_ {:keys [prefix] :as cfg}]
@@ -118,20 +120,31 @@
 
 (defn- ^Region lookup-region
   [region]
-  (case region
-    :eu-central-1 Region/EU_CENTRAL_1))
+  (Region/of (name region)))
 
 (defn build-s3-client
-  [{:keys [region]}]
-  (.. (S3Client/builder)
-      (region (lookup-region region))
-      (build)))
+  [{:keys [region endpoint]}]
+  (if (string? endpoint)
+    (let [uri (java.net.URI. endpoint)]
+      (.. (S3Client/builder)
+          (endpointOverride uri)
+          (region (lookup-region region))
+          (build)))
+    (.. (S3Client/builder)
+        (region (lookup-region region))
+        (build))))
 
 (defn build-s3-presigner
-  [{:keys [region]}]
-  (.. (S3Presigner/builder)
-      (region (lookup-region region))
-      (build)))
+  [{:keys [region endpoint]}]
+  (if (string? endpoint)
+    (let [uri (java.net.URI. endpoint)]
+      (.. (S3Presigner/builder)
+          (endpointOverride uri)
+          (region (lookup-region region))
+          (build)))
+    (.. (S3Presigner/builder)
+        (region (lookup-region region))
+        (build))))
 
 (defn put-object
   [{:keys [client bucket prefix]} {:keys [id] :as object} content]
@@ -231,6 +244,9 @@
                              ^DeleteObjectsRequest dor)]
     (when (.hasErrors ^DeleteObjectsResponse dres)
       (let [errors (seq (.errors ^DeleteObjectsResponse dres))]
-        (ex/raise :type :s3-error
-                  :code :error-on-bulk-delete
-                  :context errors)))))
+        (ex/raise :type :internal
+                  :code :error-on-s3-bulk-delete
+                  :s3-errors (mapv (fn [^S3Error error]
+                                     {:key (.key error)
+                                      :msg (.message error)})
+                                   errors))))))

backend/src/app/tasks/file_media_gc.clj

@@ -10,6 +10,7 @@
   after some period of inactivity (the default threshold is 72h)."
   (:require
    [app.common.logging :as l]
+   [app.common.pages.helpers :as cph]
    [app.common.pages.migrations :as pmg]
    [app.db :as db]
    [app.util.blob :as blob]
@@ -52,6 +53,7 @@
     limit 10
     for update skip locked")
 
+
 (defn- retrieve-candidates
   [{:keys [conn max-age] :as cfg}]
   (let [interval (db/interval max-age)]
@@ -64,12 +66,11 @@
   (comp
    (map :objects)
    (mapcat vals)
-   (map (fn [{:keys [type] :as obj}]
-          (case type
-            :path (get-in obj [:fill-image :id])
-            :image (get-in obj [:metadata :id])
-            nil)))
-   (filter uuid?)))
+   (keep (fn [{:keys [type] :as obj}]
+           (case type
+             :path (get-in obj [:fill-image :id])
+             :image (get-in obj [:metadata :id])
+             nil)))))
 
 (defn- collect-used-media
   [data]
@@ -80,37 +81,59 @@
       (into collect-media-xf pages)
       (into (keys (:media data))))))
 
+(def ^:private
+  collect-frames-xf
+  (comp
+   (map :objects)
+   (mapcat vals)
+   (filter cph/frame-shape?)
+   (keep :id)))
+
+(defn- collect-frames
+  [data]
+  (let [pages (concat
+               (vals (:pages-index data))
+               (vals (:components data)))]
+    (into #{} collect-frames-xf pages)))
+
 (defn- process-file
   [{:keys [conn] :as cfg} {:keys [id data age] :as file}]
-  (let [data   (-> (blob/decode data)
-                   (assoc :id id)
-                   (pmg/migrate-data))
+  (let [data (-> (blob/decode data)
+                 (assoc :id id)
+                 (pmg/migrate-data))]
 
-        used   (collect-used-media data)
-        unused (->> (db/query conn :file-media-object {:file-id id})
-                    (remove #(contains? used (:id %))))]
+    (let [used   (collect-used-media data)
+          unused (->> (db/query conn :file-media-object {:file-id id})
+                      (remove #(contains? used (:id %))))]
 
-    (l/debug :action "processing file"
-             :id id
-             :age age
-             :to-delete (count unused))
+      (l/debug :hint "processing file"
+               :id id
+               :age age
+               :to-delete (count unused))
 
-    ;; Mark file as trimmed
-    (db/update! conn :file
-                {:has-media-trimmed true}
-                {:id id})
+      ;; Mark file as trimmed
+      (db/update! conn :file
+                  {:has-media-trimmed true}
+                  {:id id})
 
-    (doseq [mobj unused]
-      (l/debug :action "deleting media object"
-               :id (:id mobj)
-               :media-id (:media-id mobj)
-               :thumbnail-id (:thumbnail-id mobj))
+      (doseq [mobj unused]
+        (l/debug :hint "deleting media object"
+                 :id (:id mobj)
+                 :media-id (:media-id mobj)
+                 :thumbnail-id (:thumbnail-id mobj))
 
-      ;; NOTE: deleting the file-media-object in the database
-      ;; automatically marks as touched the referenced storage
-      ;; objects. The touch mechanism is needed because many files can
-      ;; point to the same storage objects and we can't just delete
-      ;; them.
-      (db/delete! conn :file-media-object {:id (:id mobj)}))
+        ;; NOTE: deleting the file-media-object in the database
+        ;; automatically marks as touched the referenced storage
+        ;; objects. The touch mechanism is needed because many files can
+        ;; point to the same storage objects and we can't just delete
+        ;; them.
+        (db/delete! conn :file-media-object {:id (:id mobj)})))
+
+    (let [sql (str "delete from file_frame_thumbnail "
+                   " where file_id = ? and not (frame_id = ANY(?))")
+          ids (->> (collect-frames data)
+                   (db/create-array conn "uuid"))]
+      ;; delete the unused frame thumbnails
+      (db/exec! conn [sql (:id file) ids]))
 
     nil))

backend/src/app/tasks/file_offload.clj

@@ -29,7 +29,7 @@
 
 (defn- offload-candidate
   [{:keys [storage conn backend] :as cfg} {:keys [id data] :as file}]
-  (l/debug :action "offload file data" :id id)
+  (l/debug :hint "offload file data" :id id)
   (let [backend (simpl/resolve-backend storage backend)]
     (->> (simpl/content data)
          (simpl/put-object backend file))

backend/src/app/tasks/file_xlog_gc.clj

@@ -28,7 +28,8 @@
       (let [interval (db/interval max-age)
             result   (db/exec-one! conn [sql:delete-files-xlog interval])
             result   (:next.jdbc/update-count result)]
-        (l/debug :removed result :hint "remove old file changes")
+        (l/info :hint "remove old file changes"
+                :removed result)
         result))))
 
 (def ^:private

backend/src/app/tasks/objects_gc.clj

@@ -48,7 +48,7 @@
         result  (db/exec! conn [sql max-age])]
 
     (doseq [{:keys [id] :as item} result]
-      (l/trace :action "delete object" :table table :id id))
+      (l/trace :hint "delete object" :table table :id id))
 
     (count result)))
 
@@ -63,7 +63,7 @@
         backend (simpl/resolve-backend storage (cf/get :fdata-storage-backend))]
 
     (doseq [{:keys [id] :as item} result]
-      (l/trace :action "delete object" :table table :id id)
+      (l/trace :hint "delete object" :table table :id id)
       (when backend
         (simpl/del-object backend item)))
 
@@ -78,7 +78,7 @@
         fonts   (db/exec! conn [sql max-age])
         storage (assoc storage :conn conn)]
     (doseq [{:keys [id] :as font} fonts]
-      (l/trace :action "delete object" :table table :id id)
+      (l/trace :hint "delete object" :table table :id id)
       (some->> (:woff1-file-id font) (sto/del-object storage))
       (some->> (:woff2-file-id font) (sto/del-object storage))
       (some->> (:otf-file-id font)   (sto/del-object storage))
@@ -95,7 +95,7 @@
         storage (assoc storage :conn conn)]
 
     (doseq [{:keys [id] :as team} teams]
-      (l/trace :action "delete object" :table table :id id)
+      (l/trace :hint "delete object" :table table :id id)
       (some->> (:photo-id team) (sto/del-object storage)))
 
     (count teams)))
@@ -127,7 +127,7 @@
         storage  (assoc storage :conn conn)]
 
     (doseq [{:keys [id] :as profile} profiles]
-      (l/trace :action "delete object" :table table :id id)
+      (l/trace :hint "delete object" :table table :id id)
 
       ;; Mark the owned teams as deleted; this enables them to be processed
       ;; in the same transaction in the "team" table step.

backend/src/app/tasks/tasks_gc.clj

@@ -28,7 +28,7 @@
       (let [interval (db/interval max-age)
             result   (db/exec-one! conn [sql:delete-completed-tasks interval])
             result   (:next.jdbc/update-count result)]
-        (l/debug :action "trim completed tasks table" :removed result)
+        (l/debug :hint "trim completed tasks table" :removed result)
         result))))
 
 (def ^:private

backend/src/app/tasks/telemetry.clj

@@ -14,12 +14,17 @@
    [app.common.spec :as us]
    [app.config :as cfg]
    [app.db :as db]
+   [app.util.async :refer [thread-sleep]]
    [app.util.http :as http]
    [app.util.json :as json]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]))
 
-(declare retrieve-stats)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; TASK ENTRY POINT
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare get-stats)
 (declare send!)
 
 (s/def ::version ::us/string)
@@ -33,11 +38,21 @@
 
 (defmethod ig/init-key ::handler
   [_ {:keys [pool sprops version] :as cfg}]
-  (fn [_]
-    (let [instance-id (:instance-id sprops)]
-      (-> (retrieve-stats pool version)
-          (assoc :instance-id instance-id)
-          (send! cfg)))))
+  (fn [{:keys [send?] :or {send? true}}]
+    ;; Sleep randomly between 0 to 10s
+    (when send?
+      (thread-sleep (rand-int 10000)))
+
+    (let [instance-id (:instance-id sprops)
+          stats       (-> (get-stats pool version)
+                          (assoc :instance-id instance-id))]
+      (when send?
+        (send! stats cfg))
+      stats)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; IMPL
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defn- send!
   [data cfg]
@@ -63,6 +78,20 @@
   [conn]
   (-> (db/exec-one! conn ["select count(*) as count from file;"]) :count))
 
+(defn- retrieve-num-file-changes
+  [conn]
+  (let [sql (str "select count(*) as count "
+                 "  from file_change "
+                 " where date_trunc('day', created_at) = date_trunc('day', now())")]
+    (-> (db/exec-one! conn [sql]) :count)))
+
+(defn- retrieve-num-touched-files
+  [conn]
+  (let [sql (str "select count(distinct file_id) as count "
+                 "  from file_change "
+                 " where date_trunc('day', created_at) = date_trunc('day', now())")]
+    (-> (db/exec-one! conn [sql]) :count)))
+
 (defn- retrieve-num-users
   [conn]
   (-> (db/exec-one! conn ["select count(*) as count from profile;"]) :count))
@@ -111,14 +140,30 @@
   (->> [sql:team-averages]
        (db/exec-one! conn)))
 
+(defn- retrieve-enabled-auth-providers
+  [conn]
+  (let [sql  (str "select auth_backend as backend, count(*) as total "
+                 "  from profile group by 1")
+        rows (db/exec! conn [sql])]
+    (->> rows
+         (map (fn [{:keys [backend total]}]
+                (let [backend (or backend "penpot")]
+                  [(keyword (str "auth-backend-" backend))
+                   total])))
+         (into {}))))
+
 (defn- retrieve-jvm-stats
   []
   (let [^Runtime runtime (Runtime/getRuntime)]
     {:jvm-heap-current (.totalMemory runtime)
      :jvm-heap-max     (.maxMemory runtime)
-     :jvm-cpus         (.availableProcessors runtime)}))
+     :jvm-cpus         (.availableProcessors runtime)
+     :os-arch          (System/getProperty "os.arch")
+     :os-name          (System/getProperty "os.name")
+     :os-version       (System/getProperty "os.version")
+     :user-tz          (System/getProperty "user.timezone")}))
 
-(defn retrieve-stats
+(defn get-stats
   [conn version]
   (let [referer (if (cfg/get :telemetry-with-taiga)
                   "taiga"
@@ -130,9 +175,12 @@
          :total-files    (retrieve-num-files conn)
          :total-users    (retrieve-num-users conn)
          :total-fonts    (retrieve-num-fonts conn)
-         :total-comments (retrieve-num-comments conn)}
+         :total-comments (retrieve-num-comments conn)
+         :total-file-changes  (retrieve-num-file-changes conn)
+         :total-touched-files (retrieve-num-touched-files conn)}
         (d/merge
          (retrieve-team-averages conn)
-         (retrieve-jvm-stats))
+         (retrieve-jvm-stats)
+         (retrieve-enabled-auth-providers conn))
         (d/without-nils))))
 

backend/src/app/tokens.clj

@@ -7,6 +7,7 @@
 (ns app.tokens
   "Tokens generation service."
   (:require
+   [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.common.transit :as t]
@@ -17,7 +18,7 @@
 
 (defn- generate
   [cfg claims]
-  (let [payload (t/encode claims)]
+  (let [payload (-> claims d/without-nils t/encode)]
     (jwe/encrypt payload (::secret cfg) {:alg :a256kw :enc :a256gcm})))
 
 (defn- verify

backend/src/app/util/async.clj

@@ -7,7 +7,8 @@
 (ns app.util.async
   (:require
    [clojure.core.async :as a]
-   [clojure.spec.alpha :as s])
+   [clojure.spec.alpha :as s]
+   [promesa.exec :as px])
   (:import
    java.util.concurrent.Executor))
 
@@ -54,13 +55,16 @@
         (a/close! c)
         c))))
 
-
 (defmacro with-thread
   [executor & body]
   (if (= executor ::default)
     `(a/thread-call (^:once fn* [] (try ~@body (catch Exception e# e#))))
     `(thread-call ~executor (^:once fn* [] ~@body))))
 
+(defmacro with-dispatch
+  [executor & body]
+  `(px/submit! ~executor (^:once fn* [] ~@body)))
+
 (defn batch
   [in {:keys [max-batch-size
               max-batch-age

backend/src/app/util/retry.clj

@@ -1,43 +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.util.retry
-  "A fault tolerance helpers. Allow retry some operations that we know
-  we can retry."
-  (:require
-   [app.common.exceptions :as ex]
-   [app.common.logging :as l]
-   [app.util.async :as aa]
-   [app.util.services :as sv]))
-
-(defn conflict-db-insert?
-  "Check if exception matches a insertion conflict on postgresql."
-  [e]
-  (and (instance? org.postgresql.util.PSQLException e)
-       (= "23505" (.getSQLState e))))
-
-(defn wrap-retry
-  [_ f {:keys [::max-retries ::matches ::sv/name]
-        :or {max-retries 3
-             matches (constantly false)}
-        :as mdata}]
-  (when (::enabled mdata)
-    (l/debug :hint "wrapping retry" :name name))
-  (if (::enabled mdata)
-    (fn [cfg params]
-      (loop [retry 1]
-        (when (> retry 1)
-          (l/debug :hint "retrying controlled function" :retry retry :name name))
-        (let [res (ex/try (f cfg params))]
-          (if (ex/exception? res)
-            (if (and (matches res) (< retry max-retries))
-              (do
-                (aa/thread-sleep (* 100 retry))
-                (recur (inc retry)))
-              (throw res))
-            res))))
-    f))
-

backend/src/app/util/rlimit.clj

@@ -1,36 +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.util.rlimit
-  "Resource usage limits (in other words: semaphores)."
-  (:require
-   [app.common.logging :as l]
-   [app.util.services :as sv])
-  (:import
-   java.util.concurrent.Semaphore))
-
-(defn acquire!
-  [sem]
-  (.acquire ^Semaphore sem))
-
-(defn release!
-  [sem]
-  (.release ^Semaphore sem))
-
-(defn wrap-rlimit
-  [_cfg f mdata]
-  (if-let [permits (::permits mdata)]
-    (let [sem (Semaphore. permits)]
-      (l/debug :hint "wrapping rlimit" :handler (::sv/name mdata) :permits permits)
-      (fn [cfg params]
-        (try
-          (acquire! sem)
-          (f cfg params)
-          (finally
-            (release! sem)))))
-    f))
-
-

backend/src/app/util/time.clj

@@ -8,7 +8,8 @@
   (:require
    [app.common.exceptions :as ex]
    [clojure.spec.alpha :as s]
-   [cuerdas.core :as str])
+   [cuerdas.core :as str]
+   [fipp.ednize :as fez])
   (:import
    java.time.Duration
    java.time.Instant
@@ -111,6 +112,11 @@
 (defmethod print-dup Duration [o w]
   (print-method o w))
 
+(extend-protocol fez/IEdn
+  Duration
+  (-edn [o] (pr-str o)))
+
+
 ;; --- INSTANT
 
 (defn instant
@@ -175,6 +181,10 @@
 (defmethod print-dup Instant [o w]
   (print-method o w))
 
+(extend-protocol fez/IEdn
+  Instant
+  (-edn [o] (pr-str o)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Cron Expression
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -285,6 +295,11 @@
   (s/assert cron? cron)
   (.toInstant (.getNextValidTimeAfter cron (Date/from now))))
 
+(defn get-next
+  [cron tnow]
+  (let [nt (next-valid-instant-from cron tnow)]
+    (cons nt (lazy-seq (get-next cron nt)))))
+
 (defmethod print-method CronExpression
   [mv ^java.io.Writer writer]
   (.write writer (str "#app/cron \"" (.toString ^CronExpression mv) "\"")))
@@ -292,3 +307,8 @@
 (defmethod print-dup CronExpression
   [o w]
   (print-ctor o (fn [o w] (print-dup (.toString ^CronExpression o) w)) w))
+
+(extend-protocol fez/IEdn
+  CronExpression
+  (-edn [o] (pr-str o)))
+

backend/src/app/util/websocket.clj

@@ -15,7 +15,9 @@
    [clojure.core.async :as a]
    [yetti.websocket :as yws])
   (:import
-   java.nio.ByteBuffer))
+   java.nio.ByteBuffer
+   org.eclipse.jetty.io.EofException))
+
 
 (declare decode-beat)
 (declare encode-beat)
@@ -25,11 +27,6 @@
 (declare ws-ping!)
 (declare ws-send!)
 
-(defmacro call-mtx
-  [definitions name & args]
-  `(when-let [mtx-fn# (some-> ~definitions ~name ::mtx/fn)]
-     (mtx-fn# ~@args)))
-
 (def noop (constantly nil))
 
 (defn handler
@@ -47,7 +44,7 @@
   ([handle-message {:keys [::input-buff-size
                            ::output-buff-size
                            ::idle-timeout
-                           ::metrics]
+                           metrics]
                     :or {input-buff-size 64
                          output-buff-size 64
                          idle-timeout 30000}
@@ -69,8 +66,8 @@
            on-terminate
            (fn [& _args]
              (when (compare-and-set! terminated false true)
-               (call-mtx metrics :connections {:cmd :dec :by 1})
-               (call-mtx metrics :sessions {:val (/ (inst-ms (dt/diff created-at (dt/now))) 1000.0)})
+               (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)})
 
                (a/close! close-ch)
                (a/close! pong-ch)
@@ -86,7 +83,7 @@
 
            on-connect
            (fn [conn]
-             (call-mtx metrics :connections {:cmd :inc :by 1})
+             (mtx/run! metrics {:id :websocket-active-connections :inc 1})
 
              (let [wsp (atom (assoc options ::conn conn))]
                ;; Handle heartbeat
@@ -100,7 +97,7 @@
                ;; connection
                (a/go-loop []
                  (when-let [val (a/<! output-ch)]
-                   (call-mtx metrics :messages {:labels ["send"]})
+                   (mtx/run! metrics {:id :websocket-messages-total :labels ["send"] :inc 1})
                    (a/<! (ws-send! conn (t/encode-str val)))
                    (recur)))
 
@@ -109,7 +106,7 @@
 
            on-message
            (fn [_ message]
-             (call-mtx metrics :messages {:labels ["recv"]})
+             (mtx/run! metrics {:id :websocket-messages-total :labels ["recv"] :inc 1})
              (try
                (let [message (t/decode-str message)]
                  (a/offer! input-ch message))
@@ -132,17 +129,25 @@
 (defn- ws-send!
   [conn s]
   (let [ch (a/chan 1)]
-    (yws/send! conn s (fn [e]
-                        (when e (a/offer! ch e))
-                        (a/close! ch)))
+    (try
+      (yws/send! conn s (fn [e]
+                          (when e (a/offer! ch e))
+                          (a/close! ch)))
+      (catch EofException cause
+        (a/offer! ch cause)
+        (a/close! ch)))
     ch))
 
 (defn- ws-ping!
   [conn s]
   (let [ch (a/chan 1)]
-    (yws/ping! conn s (fn [e]
-                        (when e (a/offer! ch e))
-                        (a/close! ch)))
+    (try
+      (yws/ping! conn s (fn [e]
+                          (when e (a/offer! ch e))
+                          (a/close! ch)))
+      (catch EofException cause
+        (a/offer! ch cause)
+        (a/close! ch)))
     ch))
 
 (defn- encode-beat

backend/src/app/worker.clj

@@ -22,44 +22,100 @@
    [integrant.core :as ig]
    [promesa.exec :as px])
   (:import
-   org.eclipse.jetty.util.thread.QueuedThreadPool
    java.util.concurrent.ExecutorService
-   java.util.concurrent.Executors
-   java.util.concurrent.Executor))
+   java.util.concurrent.ForkJoinPool
+   java.util.concurrent.ForkJoinWorkerThread
+   java.util.concurrent.ForkJoinPool$ForkJoinWorkerThreadFactory
+   java.util.concurrent.atomic.AtomicLong
+   java.util.concurrent.Executors))
 
-(s/def ::executor #(instance? Executor %))
+(set! *warn-on-reflection* true)
+
+(s/def ::executor #(instance? ExecutorService %))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Executor
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(s/def ::name keyword?)
+(s/def ::prefix keyword?)
+(s/def ::parallelism ::us/integer)
 (s/def ::min-threads ::us/integer)
 (s/def ::max-threads ::us/integer)
 (s/def ::idle-timeout ::us/integer)
 
 (defmethod ig/pre-init-spec ::executor [_]
-  (s/keys :req-un [::min-threads ::max-threads ::idle-timeout ::name]))
+  (s/keys :req-un [::prefix ::parallelism]))
+
+(defn- get-thread-factory
+  ^ForkJoinPool$ForkJoinWorkerThreadFactory
+  [prefix counter]
+  (reify ForkJoinPool$ForkJoinWorkerThreadFactory
+    (newThread [_ pool]
+      (let [^ForkJoinWorkerThread thread (.newThread ForkJoinPool/defaultForkJoinWorkerThreadFactory pool)
+            ^String thread-name (str (name prefix) "-" (.getAndIncrement ^AtomicLong counter))]
+        (.setName thread thread-name)
+        thread))))
 
 (defmethod ig/init-key ::executor
-  [_ {:keys [min-threads max-threads idle-timeout name]}]
-  (doto (QueuedThreadPool. (int max-threads)
-                           (int min-threads)
-                           (int idle-timeout))
-    (.setStopTimeout 500)
-    (.setName (d/name name))
-    (.start)))
+  [_ {:keys [parallelism prefix]}]
+  (let [counter (AtomicLong. 0)]
+    (ForkJoinPool. (int parallelism) (get-thread-factory prefix counter) nil false)))
 
 (defmethod ig/halt-key! ::executor
   [_ instance]
-  (.stop ^QueuedThreadPool instance))
+  (.shutdown ^ForkJoinPool instance))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Executor Monitor
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(s/def ::executors (s/map-of keyword? ::executor))
+
+(defmethod ig/pre-init-spec ::executors-monitor [_]
+  (s/keys :req-un [::executors ::mtx/metrics]))
+
+(defmethod ig/init-key ::executors-monitor
+  [_ {:keys [executors metrics interval] :or {interval 3000}}]
+  (letfn [(log-stats [scheduler state]
+            (doseq [[key ^ForkJoinPool executor] executors]
+              (let [labels  (into-array String [(name key)])
+                    running (.getRunningThreadCount executor)
+                    queued  (.getQueuedSubmissionCount executor)
+                    active  (.getPoolSize executor)
+                    steals  (.getStealCount executor)
+                    steals-increment (- steals (or (get-in @state [key :steals]) 0))
+                    steals-increment (if (neg? steals-increment) 0 steals-increment)]
+
+                (mtx/run! metrics {:id :executors-active-threads :labels labels :val active})
+                (mtx/run! metrics {:id :executors-running-threads :labels labels :val running})
+                (mtx/run! metrics {:id :executors-queued-submissions :labels labels :val queued})
+                (mtx/run! metrics {:id :executors-completed-tasks :labels labels :inc steals-increment})
+
+                (swap! state update key assoc
+                       :running running
+                       :active active
+                       :queued queued
+                       :steals steals)))
+
+            (when-not (.isShutdown scheduler)
+              (px/schedule! scheduler interval (partial log-stats scheduler state))))]
+
+    (let [scheduler (px/scheduled-pool 1)
+          state     (atom {})]
+      (px/schedule! scheduler interval (partial log-stats scheduler state))
+      {::scheduler scheduler
+       ::state state})))
+
+(defmethod ig/halt-key! ::executors-monitor
+  [_ {:keys [::scheduler]}]
+  (.shutdown ^ExecutorService scheduler))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Worker
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (declare event-loop-fn)
-(declare instrument-tasks)
+(declare event-loop)
 
 (s/def ::queue keyword?)
 (s/def ::parallelism ::us/integer)
@@ -85,13 +141,10 @@
             :queue :default}
            (d/without-nils cfg)))
 
-(defmethod ig/init-key ::worker
-  [_ {:keys [pool poll-interval name queue] :as cfg}]
-  (l/info :action "start worker"
-          :name (d/name name)
-          :queue (d/name queue))
-  (let [close-ch (a/chan 1)
-        poll-ms  (inst-ms poll-interval)]
+(defn- event-loop
+  "Main, worker eventloop"
+  [{:keys [pool poll-interval close-ch] :as cfg}]
+  (let [poll-ms (inst-ms poll-interval)]
     (a/go-loop []
       (let [[val port] (a/alts! [close-ch (event-loop-fn cfg)] :priority true)]
         (cond
@@ -100,7 +153,7 @@
           (or (= port close-ch) (nil? val))
           (l/debug :hint "stop condition found")
 
-          (db/pool-closed? pool)
+          (db/closed? pool)
           (do
             (l/debug :hint "eventloop aborted because pool is closed")
             (a/close! close-ch))
@@ -108,7 +161,7 @@
           (and (instance? java.sql.SQLException val)
                (contains? #{"08003" "08006" "08001" "08004"} (.getSQLState ^java.sql.SQLException val)))
           (do
-            (l/error :hint "connection error, trying resume in some instants")
+            (l/warn :hint "connection error, trying resume in some instants")
             (a/<! (a/timeout poll-interval))
             (recur))
 
@@ -121,8 +174,8 @@
 
           (instance? Exception val)
           (do
-            (l/error :cause val
-                     :hint "unexpected error ocurried on polling the database (will resume in some instants)")
+            (l/warn :cause val
+                    :hint "unexpected error ocurried on polling the database (will resume in some instants)")
             (a/<! (a/timeout poll-ms))
             (recur))
 
@@ -132,14 +185,27 @@
           (= ::empty val)
           (do
             (a/<! (a/timeout poll-ms))
-            (recur)))))
+            (recur)))))))
+
+(defmethod ig/init-key ::worker
+  [_ {:keys [pool name queue] :as cfg}]
+  (let [close-ch (a/chan 1)
+        cfg      (assoc cfg :close-ch close-ch)]
+    (if (db/read-only? pool)
+      (l/warn :hint "worker not started, db is read-only"
+              :name (d/name name)
+              :queue (d/name queue))
+      (do
+        (l/info :hint "worker started"
+                :name (d/name name)
+                :queue (d/name queue))
+        (event-loop cfg)))
 
     (reify
       java.lang.AutoCloseable
       (close [_]
         (a/close! close-ch)))))
 
-
 (defmethod ig/halt-key! ::worker
   [_ instance]
   (.close ^java.lang.AutoCloseable instance))
@@ -249,10 +315,15 @@
 
 (defn get-error-context
   [error item]
-  (let [edata (ex-data error)]
-    {:id      (uuid/next)
-     :data    edata
-     :params  item}))
+  (let [data (ex-data error)]
+    (merge
+     {:hint          (ex-message error)
+      :spec-problems (some->> data ::s/problems (take 10) seq vec)
+      :spec-value    (some->> data ::s/value)
+      :data          (some-> data (dissoc ::s/problems ::s/value ::s/spec))
+      :params        item}
+     (when (and data (::s/problems data))
+       {:spec-explain (us/pretty-explain data)}))))
 
 (defn- handle-exception
   [error item]
@@ -266,8 +337,10 @@
 
         (= ::noop (:strategy edata))
         (assoc :inc-by 0))
-      (l/with-context (get-error-context error item)
-        (l/error :cause error :hint "unhandled exception on task")
+      (do
+        (l/error :hint "unhandled exception on task"
+                 ::l/context (get-error-context error item)
+                 :cause error)
         (if (>= (:retry-num item) (:max-retries item))
           {:status :failed :task item :error error}
           {:status :retry :task item :error error})))))
@@ -343,31 +416,35 @@
   (s/keys :req-un [::executor ::db/pool ::schedule ::tasks]))
 
 (defmethod ig/init-key ::scheduler
-  [_ {:keys [schedule tasks] :as cfg}]
-  (let [scheduler (Executors/newScheduledThreadPool (int 1))
-        schedule  (->> schedule
-                       (filter some?)
-                       ;; If id is not defined, use the task as id.
-                       (map (fn [{:keys [id task] :as item}]
-                              (if (some? id)
-                                (assoc item :id (d/name id))
-                                (assoc item :id (d/name task)))))
-                       (map (fn [{:keys [task] :as item}]
-                              (let [f (get tasks task)]
-                                (when-not f
-                                  (ex/raise :type :internal
-                                            :code :task-not-found
-                                            :hint (str/fmt "task %s not configured" task)))
-                                (-> item
-                                    (dissoc :task)
-                                    (assoc :fn f))))))
-        cfg       (assoc cfg
-                         :scheduler scheduler
-                         :schedule schedule)]
+  [_ {:keys [schedule tasks pool] :as cfg}]
+  (let [scheduler (Executors/newScheduledThreadPool (int 1))]
+    (if (db/read-only? pool)
+      (l/warn :hint "scheduler not started, db is read-only")
+      (let [schedule  (->> schedule
+                           (filter some?)
+                           ;; If id is not defined, use the task as id.
+                           (map (fn [{:keys [id task] :as item}]
+                                  (if (some? id)
+                                    (assoc item :id (d/name id))
+                                    (assoc item :id (d/name task)))))
+                           (map (fn [{:keys [task] :as item}]
+                                  (let [f (get tasks task)]
+                                    (when-not f
+                                      (ex/raise :type :internal
+                                                :code :task-not-found
+                                                :hint (str/fmt "task %s not configured" task)))
+                                    (-> item
+                                        (dissoc :task)
+                                        (assoc :fn f))))))
+            cfg       (assoc cfg
+                             :scheduler scheduler
+                             :schedule schedule)]
+        (l/info :hint "scheduler started"
+                :registred-tasks (count schedule))
 
-    (synchronize-schedule cfg)
-    (run! (partial schedule-task cfg)
-          (filter some? schedule))
+        (synchronize-schedule cfg)
+        (run! (partial schedule-task cfg)
+              (filter some? schedule))))
 
     (reify
       java.lang.AutoCloseable
@@ -398,29 +475,22 @@
 (def sql:lock-scheduled-task
   "select id from scheduled_task where id=? for update skip locked")
 
-(defn exception->string
-  [error]
-  (with-out-str
-    (.printStackTrace ^Throwable error (java.io.PrintWriter. *out*))))
-
 (defn- execute-scheduled-task
   [{:keys [executor pool] :as cfg} {:keys [id] :as task}]
   (letfn [(run-task [conn]
-            (try
-              (when (db/exec-one! conn [sql:lock-scheduled-task (d/name id)])
-                (l/debug :action "execute scheduled task" :id id)
-                ((:fn task) task))
-              (catch Throwable e
-                e)))
+            (when (db/exec-one! conn [sql:lock-scheduled-task (d/name id)])
+              (l/debug :action "execute scheduled task" :id id)
+              ((:fn task) task)))
 
           (handle-task []
-            (db/with-atomic [conn pool]
-              (let [result (run-task conn)]
-                (when (ex/exception? result)
-                  (l/error :cause result
-                           :hint "unhandled exception on scheduled task"
-                           :id id)))))]
-
+            (try
+              (db/with-atomic [conn pool]
+                (run-task conn))
+              (catch Throwable cause
+                (l/error :hint "unhandled exception on scheduled task"
+                         ::l/context (get-error-context cause task)
+                         :task-id id
+                         :cause cause))))]
     (try
       (px/run! executor handle-task)
       (finally
@@ -440,59 +510,27 @@
 
 ;; --- INSTRUMENTATION
 
-(defn instrument!
-  [registry]
-  (mtx/instrument-vars!
-   [#'submit!]
-   {:registry registry
-    :type :counter
-    :labels ["name"]
-    :name "tasks_submit_total"
-    :help "A counter of task submissions."
-    :wrap (fn [rootf mobj]
-            (let [mdata (meta rootf)
-                  origf (::original mdata rootf)]
-              (with-meta
-                (fn [conn params]
-                  (let [tname (:name params)]
-                    (mobj :inc [tname])
-                    (origf conn params)))
-                {::original origf})))})
-
-  (mtx/instrument-vars!
-   [#'app.worker/run-task]
-   {:registry registry
-    :type :summary
-    :quantiles []
-    :name "tasks_checkout_timing"
-    :help "Latency measured between scheduled_at and execution time."
-    :wrap (fn [rootf mobj]
-            (let [mdata (meta rootf)
-                  origf (::original mdata rootf)]
-              (with-meta
-                (fn [tasks item]
-                  (let [now (inst-ms (dt/now))
-                        sat (inst-ms (:scheduled-at item))]
-                    (mobj :observe (- now sat))
-                    (origf tasks item)))
-                {::original origf})))}))
-
+(defn- wrap-task-handler
+  [metrics tname f]
+  (let [labels (into-array String [tname])]
+    (fn [params]
+      (let [start (System/nanoTime)]
+        (try
+          (f params)
+          (finally
+            (mtx/run! metrics
+                      {:id :tasks-timing
+                       :val (/ (- (System/nanoTime) start) 1000000)
+                       :labels labels})))))))
 
 (defmethod ig/pre-init-spec ::registry [_]
   (s/keys :req-un [::mtx/metrics ::tasks]))
 
 (defmethod ig/init-key ::registry
   [_ {:keys [metrics tasks]}]
-  (let [mobj (mtx/create
-              {:registry (:registry metrics)
-               :type :summary
-               :labels ["name"]
-               :quantiles []
-               :name "tasks_timing"
-               :help "Background task execution timing."})]
-    (reduce-kv (fn [res k v]
-                 (let [tname (name k)]
-                   (l/debug :action "register task" :name tname)
-                   (assoc res k (mtx/wrap-summary v mobj [tname]))))
-               {}
-               tasks)))
+  (reduce-kv (fn [res k v]
+               (let [tname (name k)]
+                 (l/debug :hint "register task" :name tname)
+                 (assoc res k (wrap-task-handler metrics tname v))))
+             {}
+             tasks))

backend/test/app/services_files_test.clj

@@ -174,6 +174,14 @@
                             :type :image
                             :metadata {:id (:id fmo1)}}}]})]
 
+
+
+      ;; If we launch gc-touched-task, we should have 4 items to freeze.
+      (let [task (:app.storage/gc-touched-task th/*system*)
+            res  (task {})]
+        (t/is (= 4 (:freeze res)))
+        (t/is (= 0 (:delete res))))
+
       ;; run the task immediately
       (let [task  (:app.tasks.file-media-gc/handler th/*system*)
             res   (task {})]
@@ -202,16 +210,22 @@
       (t/is (some? (sto/get-object storage (:media-id fmo1))))
       (t/is (some? (sto/get-object storage (:thumbnail-id fmo1))))
 
-      ;; but if we pass the touched gc task two of them should disappear
+      ;; now, we have deleted the unused file-media-object, if we
+      ;; execute the touched-gc task, we should see that two of them
+      ;; are marked to be deleted.
       (let [task (:app.storage/gc-touched-task th/*system*)
             res  (task {})]
         (t/is (= 0 (:freeze res)))
-        (t/is (= 2 (:delete res)))
+        (t/is (= 2 (:delete res))))
 
-        (t/is (nil? (sto/get-object storage (:media-id fmo2))))
-        (t/is (nil? (sto/get-object storage (:thumbnail-id fmo2))))
-        (t/is (some? (sto/get-object storage (:media-id fmo1))))
-        (t/is (some? (sto/get-object storage (:thumbnail-id fmo1)))))
+
+      ;; Finally, check that some of the objects that are marked as
+      ;; deleted we are unable to retrieve them using standard storage
+      ;; public api.
+      (t/is (nil? (sto/get-object storage (:media-id fmo2))))
+      (t/is (nil? (sto/get-object storage (:thumbnail-id fmo2))))
+      (t/is (some? (sto/get-object storage (:media-id fmo1))))
+      (t/is (some? (sto/get-object storage (:thumbnail-id fmo1))))
 
       )))
 
@@ -389,3 +403,73 @@
         (t/is (th/ex-info? error))
         (t/is (= (:type error-data) :not-found))))
     ))
+
+(t/deftest query-frame-thumbnails
+  (let [prof  (th/create-profile* 1 {:is-active true})
+        file  (th/create-file* 1 {:profile-id (:id prof)
+                                  :project-id (:default-project-id prof)
+                                  :is-shared false})
+        data {::th/type :file-frame-thumbnail
+              :profile-id (:id prof)
+              :file-id (:id file)
+              :frame-id (uuid/next)}]
+
+    ;;insert an entry on the database with a test value for the thumbnail of this frame
+    (db/exec-one! th/*pool*
+                  ["insert into file_frame_thumbnail(file_id, frame_id, data) values (?, ?, ?)"
+                   (:file-id data) (:frame-id data) "testvalue"])
+
+    (let [out (th/query! data)]
+      (t/is (nil? (:error out)))
+      (let [result (:result out)]
+        (t/is (= 1 (count result)))
+        (t/is (= "testvalue" (:data result)))))))
+
+(t/deftest insert-frame-thumbnails
+  (let [prof    (th/create-profile* 1 {:is-active true})
+        file    (th/create-file* 1 {:profile-id (:id prof)
+                                    :project-id (:default-project-id prof)
+                                    :is-shared false})
+        data {::th/type :upsert-frame-thumbnail
+              :profile-id (:id prof)
+              :file-id (:id file)
+              :frame-id (uuid/next)
+              :data "test insert new value"}
+        out  (th/mutation! data)]
+
+        (t/is (nil? (:error out)))
+        (t/is (nil? (:result out)))
+
+        ;;retrieve the value from the database and check its content
+        (let [result (db/exec-one!
+                      th/*pool*
+                      ["select data from file_frame_thumbnail where file_id = ? and frame_id = ?"
+                       (:file-id data) (:frame-id data)])]
+          (t/is (= "test insert new value" (:data result))))))
+
+(t/deftest frame-thumbnails
+  (let [prof (th/create-profile* 1 {:is-active true})
+        file (th/create-file* 1 {:profile-id (:id prof)
+                                 :project-id (:default-project-id prof)
+                                 :is-shared false})
+        data {::th/type :upsert-frame-thumbnail
+              :profile-id (:id prof)
+              :file-id (:id file)
+              :frame-id (uuid/next)
+              :data "updated value"}]
+
+    ;;insert an entry on the database with and old value for the thumbnail of this frame
+    (db/exec-one! th/*pool*
+                  ["insert into file_frame_thumbnail(file_id, frame_id, data) values (?, ?, ?)"
+                   (:file-id data) (:frame-id data) "old value"])
+
+    (let [out (th/mutation! data)]
+      (t/is (nil? (:error out)))
+      (t/is (nil? (:result out)))
+
+      ;;retrieve the value from the database and check its content
+      (let [result (db/exec-one!
+                    th/*pool*
+                    ["select data from file_frame_thumbnail where file_id = ? and frame_id = ?"
+                     (:file-id data) (:frame-id data)])]
+        (t/is (= "updated value" (:data result)))))))

backend/test/app/services_management_test.clj

@@ -11,6 +11,7 @@
    [app.http :as http]
    [app.storage :as sto]
    [app.test-helpers :as th]
+   [app.storage-test :refer [configure-storage-backend]]
    [clojure.test :as t]
    [buddy.core.bytes :as b]
    [datoteka.core :as fs]))
@@ -19,7 +20,9 @@
 (t/use-fixtures :each th/database-reset)
 
 (t/deftest duplicate-file
-  (let [storage (:app.storage/storage th/*system*)
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
+
         sobject (sto/put-object storage {:content (sto/content "content")
                                          :content-type "text/plain"
                                          :other "data"})
@@ -90,7 +93,8 @@
         ))))
 
 (t/deftest duplicate-file-with-deleted-rels
-  (let [storage (:app.storage/storage th/*system*)
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
         sobject (sto/put-object storage {:content (sto/content "content")
                                          :content-type "text/plain"
                                          :other "data"})
@@ -151,7 +155,9 @@
         ))))
 
 (t/deftest duplicate-project
-  (let [storage (:app.storage/storage th/*system*)
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
+
         sobject (sto/put-object storage {:content (sto/content "content")
                                          :content-type "text/plain"
                                          :other "data"})
@@ -221,7 +227,8 @@
           )))))
 
 (t/deftest duplicate-project-with-deleted-files
-  (let [storage (:app.storage/storage th/*system*)
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
         sobject (sto/put-object storage {:content (sto/content "content")
                                          :content-type "text/plain"
                                          :other "data"})

backend/test/app/services_profile_test.clj

@@ -240,6 +240,16 @@
       (t/is (nil? error))
       (t/is (string? (:token result))))))
 
+(t/deftest test-register-profile-with-email-as-password
+  (let [data  {::th/type :prepare-register-profile
+               :email "user@example.com"
+               :password "USER@example.com"}]
+
+    (let [{:keys [result error] :as out} (th/mutation! data)]
+      (t/is (th/ex-info? error))
+      (t/is (th/ex-of-type? error :validation))
+      (t/is (th/ex-of-code? error :email-as-password)))))
+
 (t/deftest test-email-change-request
   (with-mocks [email-send-mock {:target 'app.emails/send! :return nil}
                cfg-get-mock    {:target 'app.config/get
@@ -345,3 +355,39 @@
         (t/is (th/ex-of-code? error :email-has-permanent-bounces)))
 
       )))
+
+
+(t/deftest update-profile-password
+  (let [profile (th/create-profile* 1)
+        data  {::th/type :update-profile-password
+               :profile-id (:id profile)
+               :old-password "123123"
+               :password "foobarfoobar"}
+        out   (th/mutation! data)]
+    (t/is (nil? (:error out)))
+    (t/is (nil? (:result out)))
+  ))
+
+
+(t/deftest update-profile-password-bad-old-password
+  (let [profile (th/create-profile* 1)
+        data  {::th/type :update-profile-password
+               :profile-id (:id profile)
+               :old-password "badpassword"
+               :password "foobarfoobar"}
+        {:keys [result error] :as out} (th/mutation! data)]
+    (t/is (th/ex-info? error))
+    (t/is (th/ex-of-type? error :validation))
+    (t/is (th/ex-of-code? error :old-password-not-match))))
+
+
+(t/deftest update-profile-password-email-as-password
+  (let [profile (th/create-profile* 1)
+        data  {::th/type :update-profile-password
+               :profile-id (:id profile)
+               :old-password "123123"
+               :password "profile1.test@nodomain.com"}
+        {:keys [result error] :as out} (th/mutation! data)]
+    (t/is (th/ex-info? error))
+    (t/is (th/ex-of-type? error :validation))
+    (t/is (th/ex-of-code? error :email-as-password))))

backend/test/app/storage_test.clj

@@ -7,6 +7,7 @@
 (ns app.storage-test
   (:require
    [app.common.exceptions :as ex]
+   [app.common.uuid :as uuid]
    [app.db :as db]
    [app.storage :as sto]
    [app.test-helpers :as th]
@@ -22,9 +23,19 @@
                        th/database-reset
                        th/clean-storage))
 
+(defn configure-storage-backend
+  "Given storage map, returns a storage configured with the appropriate
+  backend for assets."
+  ([storage]
+   (assoc storage :backend :tmp))
+  ([storage conn]
+   (-> storage
+       (assoc :conn conn)
+       (assoc :backend :tmp))))
 
 (t/deftest put-and-retrieve-object
-  (let [storage (:app.storage/storage th/*system*)
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
         content (sto/content "content")
         object  (sto/put-object storage {:content content
                                          :content-type "text/plain"
@@ -39,9 +50,9 @@
     (t/is (= "content" (slurp (sto/get-object-path storage object))))
     ))
 
-
 (t/deftest put-and-retrieve-expired-object
-  (let [storage (:app.storage/storage th/*system*)
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
         content (sto/content "content")
         object  (sto/put-object storage {:content content
                                          :content-type "text/plain"
@@ -59,7 +70,8 @@
     ))
 
 (t/deftest put-and-delete-object
-  (let [storage (:app.storage/storage th/*system*)
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
         content (sto/content "content")
         object  (sto/put-object storage {:content content
                                          :content-type "text/plain"
@@ -79,7 +91,8 @@
     ))
 
 (t/deftest test-deleted-gc-task
-  (let [storage (:app.storage/storage th/*system*)
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
         content (sto/content "content")
         object1 (sto/put-object storage {:content content
                                          :content-type "text/plain"
@@ -96,14 +109,17 @@
     (let [res (db/exec-one! th/*pool* ["select count(*) from storage_object;"])]
       (t/is (= 1 (:count res))))))
 
-(t/deftest test-touched-gc-task
-  (let [storage (:app.storage/storage th/*system*)
+(t/deftest test-touched-gc-task-1
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
         prof    (th/create-profile* 1)
         proj    (th/create-project* 1 {:profile-id (:id prof)
                                        :team-id (:default-team-id prof)})
+
         file    (th/create-file* 1 {:profile-id (:id prof)
                                     :project-id (:default-project-id prof)
                                     :is-shared false})
+
         mfile   {:filename "sample.jpg"
                  :tempfile (th/tempfile "app/test_files/sample.jpg")
                  :content-type "image/jpeg"
@@ -140,12 +156,12 @@
 
       ;; now check if the storage objects are touched
       (let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where touched_at is not null"])]
-        (t/is (= 2 (:count res))))
+        (t/is (= 4 (:count res))))
 
       ;; run the touched gc task
       (let [task (:app.storage/gc-touched-task th/*system*)
             res  (task {})]
-        (t/is (= 0 (:freeze res)))
+        (t/is (= 2 (:freeze res)))
         (t/is (= 2 (:delete res))))
 
       ;; now check that there are no touched objects
@@ -157,8 +173,85 @@
         (t/is (= 2 (:count res))))
     )))
 
+
+(t/deftest test-touched-gc-task-2
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
+        prof    (th/create-profile* 1 {:is-active true})
+        team-id (:default-team-id prof)
+        proj-id (:default-project-id prof)
+        font-id (uuid/custom 10 1)
+
+        proj    (th/create-project* 1 {:profile-id (:id prof)
+                                       :team-id team-id})
+
+        file    (th/create-file* 1 {:profile-id (:id prof)
+                                    :project-id proj-id
+                                    :is-shared false})
+
+        ttfdata (-> (io/resource "app/test_files/font-1.ttf")
+                    (fs/slurp-bytes))
+
+        mfile   {:filename "sample.jpg"
+                 :tempfile (th/tempfile "app/test_files/sample.jpg")
+                 :content-type "image/jpeg"
+                 :size 312043}
+
+        params1 {::th/type :upload-file-media-object
+                 :profile-id (:id prof)
+                 :file-id (:id file)
+                 :is-local true
+                 :name "testfile"
+                 :content mfile}
+
+        params2 {::th/type :create-font-variant
+                 :profile-id (:id prof)
+                 :team-id team-id
+                 :font-id font-id
+                 :font-family "somefont"
+                 :font-weight 400
+                 :font-style "normal"
+                 :data {"font/ttf" ttfdata}}
+
+        out1     (th/mutation! params1)
+        out2     (th/mutation! params2)]
+
+    ;; (th/print-result! out)
+
+    (t/is (nil? (:error out1)))
+    (t/is (nil? (:error out2)))
+
+    ;; run the touched gc task
+    (let [task (:app.storage/gc-touched-task th/*system*)
+          res  (task {})]
+      (t/is (= 6 (:freeze res)))
+      (t/is (= 0 (:delete res)))
+
+      (let [result-1 (:result out1)
+            result-2 (:result out2)]
+
+        ;; now we proceed to manually delete one team-font-variant
+        (db/exec-one! th/*pool* ["delete from team_font_variant where id = ?" (:id result-2)])
+
+        ;; revert touched state to all storage objects
+        (db/exec-one! th/*pool* ["update storage_object set touched_at=now()"])
+
+        ;; Run the task again
+        (let [res  (task {})]
+          (t/is (= 2 (:freeze res)))
+          (t/is (= 4 (:delete res))))
+
+        ;; now check that there are no touched objects
+        (let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where touched_at is not null"])]
+          (t/is (= 0 (:count res))))
+
+        ;; now check that all objects are marked to be deleted
+        (let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where deleted_at is not null"])]
+          (t/is (= 4 (:count res))))))))
+
 (t/deftest test-touched-gc-task-without-delete
-  (let [storage (:app.storage/storage th/*system*)
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
         prof    (th/create-profile* 1)
         proj    (th/create-project* 1 {:profile-id (:id prof)
                                        :team-id (:default-team-id prof)})
@@ -198,72 +291,3 @@
       ;; check that we have all object in the db
       (let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where deleted_at is null"])]
         (t/is (= 4 (:count res)))))))
-
-
-;; Recheck is the mechanism for delete leaked resources on
-;; transaction failure.
-
-(t/deftest test-recheck
-  (let [storage (:app.storage/storage th/*system*)
-        content (sto/content "content")
-        object  (sto/put-object storage {:content content
-                                         :content-type "text/plain"})]
-    ;; Sleep fo 50ms
-    (th/sleep 50)
-
-    (let [rows (db/exec! th/*pool* ["select * from storage_pending"])]
-      (t/is (= 1 (count rows)))
-      (t/is (= (:id object) (:id (first rows)))))
-
-    ;; Artificially make all storage_pending object 1 hour older.
-    (db/exec-one! th/*pool* ["update storage_pending set created_at = created_at - '1 hour'::interval"])
-
-    ;; Sleep fo 50ms
-    (th/sleep 50)
-
-    ;; Run recheck task
-    (let [task (:app.storage/recheck-task th/*system*)
-          res  (task {})]
-      (t/is (= 1 (:processed res)))
-      (t/is (= 0 (:deleted res))))
-
-    ;; After recheck task, storage-pending table should be empty
-    (let [rows (db/exec! th/*pool* ["select * from storage_pending"])]
-      (t/is (= 0 (count rows))))))
-
-(t/deftest test-recheck-with-rollback
-  (let [storage (:app.storage/storage th/*system*)
-        content (sto/content "content")]
-
-    ;; check with aborted transaction
-    (ex/ignoring
-     (db/with-atomic [conn th/*pool*]
-       (let [storage (assoc storage :conn conn)] ; make participate storage in the transaction
-         (sto/put-object storage {:content content
-                                  :content-type "text/plain"})
-         (throw (ex-info "expected" {})))))
-
-    ;; let a 200ms window for recheck registration thread
-    ;; completion before proceed.
-    (th/sleep 200)
-
-    ;; storage_pending table should have the object
-    ;; registered independently of the aborted transaction.
-    (let [rows (db/exec! th/*pool* ["select * from storage_pending"])]
-      (t/is (= 1 (count rows))))
-
-    ;; Artificially make all storage_pending object 1 hour older.
-    (db/exec-one! th/*pool* ["update storage_pending set created_at = created_at - '1 hour'::interval"])
-
-    ;; Sleep fo 50ms
-    (th/sleep 50)
-
-    ;; Run recheck task
-    (let [task (:app.storage/recheck-task th/*system*)
-          res  (task {})]
-      (t/is (= 1 (:processed res)))
-      (t/is (= 1 (:deleted res))))
-
-    ;; After recheck task, storage-pending table should be empty
-    (let [rows (db/exec! th/*pool* ["select * from storage_pending"])]
-      (t/is (= 0 (count rows))))))

backend/test/app/test_helpers.clj

@@ -52,7 +52,6 @@
                    (assoc-in [:app.db/pool :uri] (:database-uri config))
                    (assoc-in [:app.db/pool :username] (:database-username config))
                    (assoc-in [:app.db/pool :password] (:database-password config))
-                   (assoc-in [[:app.main/main :app.storage.fs/backend] :directory] "/tmp/app/storage")
                    (dissoc :app.srepl/server
                            :app.http/server
                            :app.http/router
@@ -65,8 +64,7 @@
                            :app.worker/scheduler
                            :app.worker/worker)
                    (d/deep-merge
-                    {:app.storage/storage {:backend :tmp}
-                     :app.tasks.file-media-gc/handler {:max-age (dt/duration 300)}}))
+                    {:app.tasks.file-media-gc/handler {:max-age (dt/duration 300)}}))
         _      (ig/load-namespaces config)
         system (-> (ig/prep config)
                    (ig/init))]
@@ -250,7 +248,7 @@
   [expr]
   `(try
      {:error nil
-      :result ~expr}
+      :result (deref ~expr)}
      (catch Exception e#
        {:error (handle-error e#)
         :result nil})))

common/deps.edn

@@ -13,7 +13,7 @@
   org.apache.logging.log4j/log4j-slf4j18-impl {:mvn/version "2.17.1"}
   org.slf4j/slf4j-api {:mvn/version "2.0.0-alpha1"}
 
-  selmer/selmer {:mvn/version "1.12.49"}
+  selmer/selmer {:mvn/version "1.12.50"}
   criterium/criterium {:mvn/version "0.4.6"}
 
   expound/expound {:mvn/version "0.9.0"}
@@ -21,10 +21,10 @@
   com.cognitect/transit-cljs {:mvn/version "0.8.269"}
   java-http-clj/java-http-clj {:mvn/version "0.4.3"}
 
-  funcool/promesa {:mvn/version "6.0.2"}
+  funcool/promesa {:mvn/version "7.0.444"}
   funcool/cuerdas {:mvn/version "2022.01.14-391"}
 
-  lambdaisland/uri {:mvn/version "1.12.89"
+  lambdaisland/uri {:mvn/version "1.13.95"
                     :exclusions [org.clojure/data.json]}
 
   frankiesardo/linked {:mvn/version "1.3.0"}
@@ -42,9 +42,8 @@
   {:extra-deps
    {org.clojure/tools.namespace {:mvn/version "RELEASE"}
     org.clojure/test.check {:mvn/version "RELEASE"}
-    org.clojure/tools.deps.alpha {:mvn/version "RELEASE"}
+    thheller/shadow-cljs {:mvn/version "2.17.3"}
     com.bhauman/rebel-readline {:mvn/version "RELEASE"}
-    thheller/shadow-cljs {:mvn/version "2.16.12"}
     criterium/criterium {:mvn/version "RELEASE"}
     mockery/mockery {:mvn/version "RELEASE"}}
    :extra-paths ["test" "dev"]}

common/package.json

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

common/src/app/common/colors.cljc

@@ -15,4 +15,5 @@
 (def info "#59B9E2")
 (def test "#fabada")
 (def white "#FFFFFF")
+(def primary "#31EFB8")
 

common/src/app/common/data.cljc

@@ -6,7 +6,7 @@
 
 (ns app.common.data
   "Data manipulation and query helper functions."
-  (:refer-clojure :exclude [read-string hash-map merge name parse-double])
+  (:refer-clojure :exclude [read-string hash-map merge name parse-double group-by iteration])
   #?(:cljs
      (:require-macros [app.common.data]))
   (:require
@@ -37,6 +37,22 @@
   #?(:cljs (instance? lks/LinkedSet o)
      :clj (instance? LinkedSet o)))
 
+#?(:clj
+   (defmethod print-method clojure.lang.PersistentQueue [q, w]
+     ;; Overload the printer for queues so they look like fish
+     (print-method '<- w)
+     (print-method (seq q) w)
+     (print-method '-< w)))
+
+(defn queue
+  ([] #?(:clj clojure.lang.PersistentQueue/EMPTY :cljs #queue []))
+  ([a] (into (queue) [a]))
+  ([a & more] (into (queue) (cons a more))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data Structures Manipulation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (defn deep-merge
   ([a b]
    (if (map? a)
@@ -45,10 +61,6 @@
   ([a b & rest]
    (reduce deep-merge a (cons b rest))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data Structures Manipulation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
 (defn dissoc-in
   [m [k & ks]]
   (if ks
@@ -151,7 +163,11 @@
   "Given a map, return a map removing key-value
   pairs when value is `nil`."
   [data]
-  (into {} (remove (comp nil? second) data)))
+  (into {} (remove (comp nil? second)) data))
+
+(defn without-qualified
+  [data]
+  (into {} (remove (comp qualified-keyword? first)) data))
 
 (defn without-keys
   "Return a map without the keys provided
@@ -609,3 +625,81 @@
           (if (or (keyword? k) (string? k))
             [(keyword (str/kebab (name k))) v]
             [k v])))))
+
+
+(defn group-by
+  ([kf coll] (group-by kf identity coll))
+  ([kf vf coll]
+   (let [conj (fnil conj [])]
+     (reduce (fn [result item]
+               (update result (kf item) conj (vf item)))
+             {}
+             coll))))
+
+(defn group-by'
+  "A variant of group-by that uses a set for collecting results."
+  ([kf coll] (group-by kf identity coll))
+  ([kf vf coll]
+   (let [conj (fnil conj #{})]
+     (reduce (fn [result item]
+               (update result (kf item) conj (vf item)))
+             {}
+             coll))))
+
+;; TEMPORAL COPY of clojure-1.11 iteration function, should be
+;; replaced with the builtin on when stable version is released.
+
+#?(:clj
+   (defn iteration
+     "Creates a seqable/reducible via repeated calls to step,
+     a function of some (continuation token) 'k'. The first call to step
+     will be passed initk, returning 'ret'. Iff (somef ret) is true,
+     (vf ret) will be included in the iteration, else iteration will
+     terminate and vf/kf will not be called. If (kf ret) is non-nil it
+     will be passed to the next step call, else iteration will terminate.
+     This can be used e.g. to consume APIs that return paginated or batched data.
+      step - (possibly impure) fn of 'k' -> 'ret'
+      :somef - fn of 'ret' -> logical true/false, default 'some?'
+      :vf - fn of 'ret' -> 'v', a value produced by the iteration, default 'identity'
+      :kf - fn of 'ret' -> 'next-k' or nil (signaling 'do not continue'), default 'identity'
+      :initk - the first value passed to step, default 'nil'
+     It is presumed that step with non-initk is unreproducible/non-idempotent.
+     If step with initk is unreproducible it is on the consumer to not consume twice."
+     {:added "1.11"}
+     [step & {:keys [somef vf kf initk]
+              :or {vf identity
+                   kf identity
+                   somef some?
+                   initk nil}}]
+     (reify
+       clojure.lang.Seqable
+       (seq [_]
+         ((fn next [ret]
+            (when (somef ret)
+              (cons (vf ret)
+                    (when-some [k (kf ret)]
+                      (lazy-seq (next (step k)))))))
+          (step initk)))
+       clojure.lang.IReduceInit
+       (reduce [_ rf init]
+         (loop [acc init
+                ret (step initk)]
+           (if (somef ret)
+             (let [acc (rf acc (vf ret))]
+               (if (reduced? acc)
+                 @acc
+                 (if-some [k (kf ret)]
+                   (recur acc (step k))
+                   acc)))
+             acc))))))
+
+(defn toggle-selection
+  ([set value]
+   (toggle-selection set value false))
+
+  ([set value toggle?]
+   (if-not toggle?
+     (conj (ordered-set) value)
+     (if (contains? set value)
+       (disj set value)
+       (conj set value)))))

common/src/app/common/file_builder.cljc

@@ -13,6 +13,7 @@
    [app.common.pages.changes :as ch]
    [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]))
 
@@ -38,9 +39,9 @@
                          :frame-id (:current-frame-id file)))]
 
      (when fail-on-spec?
-       (us/verify :app.common.pages.spec/change change))
+       (us/verify ::spec.change/change change))
 
-     (let [valid? (us/valid? :app.common.pages.spec/change change)]
+     (let [valid? (us/valid? ::spec.change/change change)]
        #?(:cljs
           (when-not valid? (.warn js/console "Invalid shape" (clj->js change))))
 
@@ -568,4 +569,78 @@
         (dissoc :current-component-id)
         (update :parent-stack pop))))
 
+(defn delete-object
+  [file id]
+  (let [page-id (:current-page-id file)]
+    (commit-change
+     file
+     {:type :del-obj
+      :page-id page-id
+      :id id})))
 
+(defn update-object
+  [file old-obj new-obj]
+  (let [page-id (:current-page-id file)
+        new-obj (setup-selrect new-obj)
+        attrs (d/concat-set (keys old-obj) (keys new-obj))
+        generate-operation
+        (fn [changes attr]
+          (let [old-val (get old-obj attr)
+                new-val (get new-obj attr)]
+            (if (= old-val new-val)
+              changes
+              (conj changes {:type :set :attr attr :val new-val}))))]
+    (-> file
+        (commit-change
+         {:type :mod-obj
+          :operations (reduce generate-operation [] attrs)
+          :page-id page-id
+          :id (:id old-obj)}))))
+
+(defn get-current-page
+  [file]
+  (let [page-id (:current-page-id file)]
+    (-> file (get-in [:data :pages-index page-id]))))
+
+(defn add-guide
+  [file guide]
+
+  (let [guide (cond-> guide
+                (nil? (:id guide))
+                (assoc :id (uuid/next)))
+        page-id (:current-page-id file)
+        old-guides (or (get-in file [:data :pages-index page-id :options :guides]) {})
+        new-guides (assoc old-guides (:id guide) guide)]
+    (-> file
+        (commit-change
+         {:type :set-option
+          :page-id page-id
+          :option :guides
+          :value new-guides})
+        (assoc :last-id (:id guide)))))
+
+(defn delete-guide
+  [file id]
+
+  (let [page-id (:current-page-id file)
+        old-guides (or (get-in file [:data :pages-index page-id :options :guides]) {})
+        new-guides (dissoc old-guides id)]
+    (-> file
+        (commit-change
+         {:type :set-option
+          :page-id page-id
+          :option :guides
+          :value new-guides}))))
+
+(defn update-guide
+  [file guide]
+
+  (let [page-id (:current-page-id file)
+        old-guides (or (get-in file [:data :pages-index page-id :options :guides]) {})
+        new-guides (assoc old-guides (:id guide) guide)]
+    (-> file
+        (commit-change
+         {:type :set-option
+          :page-id page-id
+          :option :guides
+          :value new-guides}))))

common/src/app/common/geom/align.cljc

@@ -6,7 +6,6 @@
 
 (ns app.common.geom.align
   (:require
-   [app.common.data :as d]
    [app.common.geom.shapes :as gsh]
    [app.common.pages.helpers :refer [get-children]]
    [clojure.spec.alpha :as s]))
@@ -20,8 +19,7 @@
 (defn- recursive-move
   "Move the shape and all its recursive children."
   [shape dpoint objects]
-  (->> (get-children (:id shape) objects)
-       (map (d/getf objects))
+  (->> (get-children objects (:id shape))
        (cons shape)
        (map #(gsh/move % dpoint))))
 

common/src/app/common/geom/matrix.cljc

@@ -10,7 +10,9 @@
       :clj  [clojure.pprint :as pp])
    [app.common.data :as d]
    [app.common.geom.point :as gpt]
-   [app.common.math :as mth]))
+   [app.common.math :as mth]
+   [app.common.spec :as us]
+   [clojure.spec.alpha :as s]))
 
 ;; --- Matrix Impl
 
@@ -24,6 +26,21 @@
   (toString [_]
     (str "matrix(" a "," b "," c "," d "," e "," f ")")))
 
+(defn ^boolean matrix?
+  "Return true if `v` is Matrix instance."
+  [v]
+  (instance? Matrix v))
+
+(s/def ::a ::us/safe-number)
+(s/def ::b ::us/safe-number)
+(s/def ::c ::us/safe-number)
+(s/def ::d ::us/safe-number)
+(s/def ::e ::us/safe-number)
+(s/def ::f ::us/safe-number)
+
+(s/def ::matrix
+  (s/and (s/keys :req-un [::a ::b ::c ::d ::e ::f]) matrix?))
+
 (defn matrix
   "Create a new matrix instance."
   ([]
@@ -84,11 +101,6 @@
    (- m1a m2a) (- m1b m2b) (- m1c m2c)
    (- m1d m2d) (- m1e m2e) (- m1f m2f)))
 
-(defn ^boolean matrix?
-  "Return true if `v` is Matrix instance."
-  [v]
-  (instance? Matrix v))
-
 (def base (matrix))
 
 (defn base?

common/src/app/common/geom/point.cljc

@@ -11,7 +11,9 @@
       :clj  [clojure.pprint :as pp])
    #?(:cljs [cljs.core :as c]
       :clj [clojure.core :as c])
-   [app.common.math :as mth]))
+   [app.common.math :as mth]
+   [app.common.spec :as us]
+   [clojure.spec.alpha :as s]))
 
 ;; --- Point Impl
 
@@ -25,6 +27,13 @@
   (or (instance? Point v)
       (and (map? v) (contains? v :x) (contains? v :y))))
 
+(s/def ::x ::us/safe-number)
+(s/def ::y ::us/safe-number)
+
+(s/def ::point
+  (s/and (s/keys :req-un [::x ::y]) point?))
+
+
 (defn ^boolean point-like?
   [{:keys [x y] :as v}]
   (and (map? v)

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

@@ -185,3 +185,7 @@
 ;; Bool
 (d/export gsb/update-bool-selrect)
 (d/export gsb/calc-bool-content)
+
+;; Constraints
+(d/export gct/default-constraints-h)
+(d/export gct/default-constraints-v)

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

@@ -11,7 +11,7 @@
    [app.common.geom.shapes.common :as gco]
    [app.common.geom.shapes.transforms :as gtr]
    [app.common.math :as mth]
-   [app.common.pages.spec :as spec]))
+   [app.common.uuid :as uuid]))
 
 ;; Auxiliary methods to work in an specifica axis
 (defn get-delta-start [axis rect tr-rect]
@@ -117,7 +117,7 @@
              (not (mth/close? (:y resize-vector-2) 1)))
         (assoc :resize-origin (:resize-origin-2 modifiers)
                :resize-vector (gpt/point 1 (:y resize-vector-2)))
-        
+
         (some? displacement)
         (assoc :displacement
                (get-displacement axis (-> (gpt/point 0 0)
@@ -138,16 +138,32 @@
    :center :center
    :scale :scale})
 
+(defn default-constraints-h
+  [shape]
+  (if (= (:parent-id shape) uuid/zero)
+    nil
+    (if (= (:parent-id shape) (:frame-id shape))
+      :left
+      :scale)))
+
+(defn default-constraints-v
+  [shape]
+  (if (= (:parent-id shape) uuid/zero)
+    nil
+    (if (= (:parent-id shape) (:frame-id shape))
+      :top
+      :scale)))
+
 (defn calc-child-modifiers
   [parent child modifiers ignore-constraints transformed-parent-rect]
   (let [constraints-h
         (if-not ignore-constraints
-          (:constraints-h child (spec/default-constraints-h child))
+          (:constraints-h child (default-constraints-h child))
           :scale)
 
         constraints-v
         (if-not ignore-constraints
-          (:constraints-v child (spec/default-constraints-v child))
+          (:constraints-v child (default-constraints-v child))
           :scale)
 
         modifiers-h (constraint-modifier (constraints-h const->type+axis) :x parent child modifiers transformed-parent-rect)

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

@@ -545,7 +545,6 @@
 
 (defn transform-selrect
   [selrect {:keys [displacement resize-transform-inverse resize-vector resize-origin resize-vector-2 resize-origin-2]}]
- 
   ;; FIXME: Improve Performance
   (let [resize-transform-inverse (or resize-transform-inverse (gmt/matrix))
 

common/src/app/common/logging.cljc

@@ -7,8 +7,10 @@
 (ns app.common.logging
   (:require
    [app.common.exceptions :as ex]
+   [app.common.uuid :as uuid]
    [clojure.pprint :refer [pprint]]
    [cuerdas.core :as str]
+   [fipp.edn :as fpp]
    #?(:clj [io.aviso.exception :as ie])
    #?(:cljs [goog.log :as glog]))
   #?(:cljs (:require-macros [app.common.logging])
@@ -34,12 +36,12 @@
        (reduce-kv #(.with ^MapMessage %1 (name %2) %3) message m))))
 
 #?(:clj
-  (def logger-context
-    (LogManager/getContext false)))
+   (def logger-context
+     (LogManager/getContext false)))
 
 #?(:clj
-  (def logging-agent
-    (agent nil :error-mode :continue)))
+   (def logging-agent
+     (agent nil :error-mode :continue)))
 
 (defn- simple-prune
   ([s] (simple-prune s (* 1024 1024)))
@@ -52,22 +54,16 @@
    (defn stringify-data
      [val]
      (cond
-       (instance? clojure.lang.Named val)
-       (name val)
-
-       (instance? Throwable val)
-       (binding [ie/*app-frame-names* [#"app.*"]
-                 ie/*fonts* nil
-                 ie/*traditional* true]
-         (ie/format-exception val nil))
-
        (string? val)
        val
 
+       (instance? clojure.lang.Named val)
+       (name val)
+
        (coll? val)
-       (binding [clojure.pprint/*print-right-margin* 200]
-         (-> (with-out-str (pprint val))
-             (simple-prune (* 1024 1024 3))))
+       (binding [*print-level* 8
+                 *print-length* 25]
+         (with-out-str (fpp/pprint val {:width 200})))
 
        :else
        (str val))))
@@ -163,13 +159,13 @@
      (.isEnabled ^Logger logger ^Level level)))
 
 (defmacro log
-  [& {:keys [level cause ::logger ::async ::raw] :or {async true} :as props}]
+  [& {:keys [level cause ::logger ::async ::raw ::context] :or {async true} :as props}]
   (if (:ns &env) ; CLJS
     `(write-log! ~(or logger (str *ns*))
                  ~level
                  ~cause
-                 (or ~raw ~(dissoc props :level :cause ::logger ::raw)))
-    (let [props      (dissoc props :level :cause ::logger ::async ::raw)
+                 (or ~raw ~(dissoc props :level :cause ::logger ::raw ::context)))
+    (let [props      (dissoc props :level :cause ::logger ::async ::raw ::context)
           logger     (or logger (str *ns*))
           logger-sym (gensym "log")
           level-sym  (gensym "log")]
@@ -180,7 +176,7 @@
               `(->> (ThreadContext/getImmutableContext)
                     (send-off logging-agent
                               (fn [_# cdata#]
-                                (with-context (into {} cdata#)
+                                (with-context (-> {:id (uuid/next)} (into cdata#) (into ~context))
                                   (->> (or ~raw (build-map-message ~props))
                                        (write-log! ~logger-sym ~level-sym ~cause))))))
 

common/src/app/common/math.cljc

@@ -6,6 +6,7 @@
 
 (ns app.common.math
   "A collection of math utils."
+  (:refer-clojure :exclude [abs])
   #?(:cljs
      (:require [goog.math :as math])))
 

common/src/app/common/pages.cljc

@@ -10,11 +10,8 @@
    [app.common.data :as d]
    [app.common.pages.changes :as changes]
    [app.common.pages.common :as common]
-   [app.common.pages.helpers :as helpers]
    [app.common.pages.indices :as indices]
-   [app.common.pages.init :as init]
-   [app.common.pages.spec :as spec]
-   [clojure.spec.alpha :as s]))
+   [app.common.pages.init :as init]))
 
 ;; Common
 (d/export common/root)
@@ -22,55 +19,6 @@
 (d/export common/default-color)
 (d/export common/component-sync-attrs)
 
-;; Helpers
-
-(d/export helpers/walk-pages)
-(d/export helpers/select-objects)
-(d/export helpers/update-object-list)
-(d/export helpers/get-component-shape)
-(d/export helpers/get-root-shape)
-(d/export helpers/make-container)
-(d/export helpers/page?)
-(d/export helpers/component?)
-(d/export helpers/get-container)
-(d/export helpers/get-shape)
-(d/export helpers/get-component)
-(d/export helpers/is-main-of)
-(d/export helpers/get-component-root)
-(d/export helpers/get-children)
-(d/export helpers/get-children-objects)
-(d/export helpers/get-object-with-children)
-(d/export helpers/select-children)
-(d/export helpers/is-shape-grouped)
-(d/export helpers/get-parent)
-(d/export helpers/get-parents)
-(d/export helpers/get-frame)
-(d/export helpers/clean-loops)
-(d/export helpers/calculate-invalid-targets)
-(d/export helpers/valid-frame-target)
-(d/export helpers/position-on-parent)
-(d/export helpers/insert-at-index)
-(d/export helpers/append-at-the-end)
-(d/export helpers/select-toplevel-shapes)
-(d/export helpers/select-frames)
-(d/export helpers/clone-object)
-(d/export helpers/indexed-shapes)
-(d/export helpers/expand-region-selection)
-(d/export helpers/frame-id-by-position)
-(d/export helpers/set-touched-group)
-(d/export helpers/touched-group?)
-(d/export helpers/get-base-shape)
-(d/export helpers/is-parent?)
-(d/export helpers/get-index-in-parent)
-(d/export helpers/split-path)
-(d/export helpers/join-path)
-(d/export helpers/parse-path-name)
-(d/export helpers/merge-path-item)
-(d/export helpers/compact-path)
-(d/export helpers/compact-name)
-(d/export helpers/unframed-shape?)
-(d/export helpers/children-seq)
-
 ;; Indices
 (d/export indices/calculate-z-index)
 (d/export indices/update-z-index)
@@ -88,15 +36,3 @@
 (d/export init/make-minimal-shape)
 (d/export init/make-minimal-group)
 (d/export init/empty-file-data)
-
-;; Specs
-
-(s/def ::changes ::spec/changes)
-(s/def ::color ::spec/color)
-(s/def ::data ::spec/data)
-(s/def ::media-object ::spec/media-object)
-(s/def ::page ::spec/page)
-(s/def ::recent-color ::spec/recent-color)
-(s/def ::shape-attrs ::spec/shape-attrs)
-(s/def ::typography ::spec/typography)
-

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

@@ -5,6 +5,7 @@
 ;; Copyright (c) UXBOX Labs SL
 
 (ns app.common.pages.changes
+  #_:clj-kondo/ignore
   (:require
    [app.common.data :as d]
    [app.common.exceptions :as ex]
@@ -13,9 +14,9 @@
    [app.common.pages.common :refer [component-sync-attrs]]
    [app.common.pages.helpers :as cph]
    [app.common.pages.init :as init]
-   [app.common.pages.spec :as spec]
-   [app.common.spec :as us]))
-
+   [app.common.spec :as us]
+   [app.common.spec.change :as spec.change]
+   [app.common.spec.shape :as spec.shape]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Specific helpers
@@ -47,7 +48,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/changes items))
+     (us/assert ::spec.change/changes items))
 
    (let [result (reduce #(or (process-change %1 %2) %1) data items)]
      ;; Validate result shapes (only on the backend)
@@ -57,7 +58,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))))))
+                (us/verify ::spec.shape/shape shape))))))
 
      result)))
 
@@ -159,10 +160,8 @@
             (let [lookup    (d/getf objects)
                   update-fn #(d/update-when %1 %2 update-group %1)
                   xform     (comp
-                             (mapcat #(cons % (cph/get-parents % objects)))
-                             (map lookup)
-                             (filter #(contains? #{:group :bool} (:type %)))
-                             (map :id)
+                             (mapcat #(cons % (cph/get-parent-ids objects %)))
+                             (filter #(contains? #{:group :bool} (-> % lookup :type)))
                              (distinct))]
 
               (->> (sequence xform shapes)
@@ -203,11 +202,16 @@
 
 (defmethod process-change :mov-objects
   [data {:keys [parent-id shapes index page-id component-id ignore-touched]}]
-  (letfn [(is-valid-move? [objects shape-id]
-            (let [invalid-targets (cph/calculate-invalid-targets shape-id objects)]
+  (letfn [(calculate-invalid-targets [objects shape-id]
+            (let [reduce-fn #(into %1 (calculate-invalid-targets objects %2))]
+              (->> (get-in objects [shape-id :shapes])
+                   (reduce reduce-fn #{shape-id}))))
+
+          (is-valid-move? [objects shape-id]
+            (let [invalid-targets (calculate-invalid-targets objects shape-id)]
               (and (contains? objects shape-id)
                    (not (invalid-targets parent-id))
-                   (cph/valid-frame-target shape-id parent-id objects))))
+                   (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_builder.cljc

@@ -7,18 +7,26 @@
 (ns app.common.pages.changes-builder
   (:require
    [app.common.data :as d]
-   [app.common.pages :as cp]
-   [app.common.pages.helpers :as h]))
+   [app.common.pages.helpers :as cph]))
 
 ;; Auxiliary functions to help create a set of changes (undo + redo)
 
 (defn empty-changes
-  [origin page-id]
-  (let [changes {:redo-changes []
-                 :undo-changes []
-                 :origin origin}]
-    (with-meta changes
-      {::page-id page-id})))
+  ([origin page-id]
+   (let [changes (empty-changes origin)]
+     (with-meta changes
+       {::page-id page-id})))
+
+  ([origin]
+   {:redo-changes []
+    :undo-changes []
+    :origin origin}))
+
+(defn with-page [changes page]
+  (vary-meta changes assoc
+             ::page page
+             ::page-id (:id page)
+             ::objects (:objects page)))
 
 (defn with-objects [changes objects]
   (vary-meta changes assoc ::objects objects))
@@ -69,7 +77,7 @@
               :page-id (::page-id (meta changes))
               :parent-id (:parent-id shape)
               :shapes [(:id shape)]
-              :index (cp/position-on-parent (:id shape) objects)}))]
+              :index (cph/get-position-on-parent objects (:id shape))}))]
 
      (-> changes
          (update :redo-changes conj set-parent-change)
@@ -162,7 +170,7 @@
               :page-id page-id
               :parent-id (:parent-id shape)
               :shapes [id]
-              :index (h/position-on-parent id objects)
+              :index (cph/get-position-on-parent objects id)
               :ignore-touched true})))]
 
     (-> changes
@@ -171,10 +179,25 @@
                                  (reduce add-undo-change-parent $ ids)
                                  (reduce add-undo-change-shape $ ids))))))
 
-
 (defn move-page
   [chdata index prev-index]
   (let [page-id (::page-id (meta chdata))]
     (-> chdata
         (update :redo-changes conj {:type :mov-page :id page-id :index index})
         (update :undo-changes conj {:type :mov-page :id page-id :index prev-index}))))
+
+(defn set-page-option
+  [chdata option-key option-val]
+  (let [page-id (::page-id (meta chdata))
+        page (::page (meta chdata))
+        old-val (get-in page [:options option-key])]
+
+    (-> chdata
+        (update :redo-changes conj {:type :set-option
+                                    :page-id page-id
+                                    :option option-key
+                                    :value option-val})
+        (update :undo-changes conj {:type :set-option
+                                    :page-id page-id
+                                    :option option-key
+                                    :value old-val}))))

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

@@ -9,7 +9,7 @@
    [app.common.colors :as clr]
    [app.common.uuid :as uuid]))
 
-(def file-version 12)
+(def file-version 14)
 (def default-color clr/gray-20)
 (def root uuid/zero)
 

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

@@ -0,0 +1,170 @@
+;; 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.pages.diff
+  "Given a page in its old version and the new will retrieve a map with
+  the differences that will have an impact in the snap data"
+  (:require
+   [app.common.data :as d]
+   [clojure.set :as set]))
+
+(defn calculate-page-diff
+  [old-page page check-attrs]
+
+  (let [old-objects (get old-page :objects)
+        old-guides (or (get-in old-page [:options :guides]) [])
+
+        new-objects (get page :objects)
+        new-guides (or (get-in page [:options :guides]) [])
+
+        changed-object?
+        (fn [id]
+          (let [oldv (get old-objects id)
+                newv (get new-objects id)]
+            ;; Check first without select-keys because is faster if they are
+            ;; the same reference
+            (and (not= oldv newv)
+                 (not= (select-keys oldv check-attrs)
+                       (select-keys newv check-attrs)))))
+
+        frame?
+        (fn [id]
+          (or (= :frame (get-in new-objects [id :type]))
+              (= :frame (get-in old-objects [id :type]))))
+
+        changed-guide?
+        (fn [id]
+          (not= (get old-guides id)
+                (get new-guides id)))
+
+        deleted-object?
+        #(and (contains? old-objects %)
+              (not (contains? new-objects %)))
+
+        deleted-guide?
+        #(and (contains? old-guides %)
+              (not (contains? new-guides %)))
+
+        new-object?
+        #(and (not (contains? old-objects %))
+              (contains? new-objects %))
+
+        new-guide?
+        #(and (not (contains? old-guides %))
+              (contains? new-guides %))
+
+        changed-frame-object?
+        #(and (contains? new-objects %)
+              (contains? old-objects %)
+              (not= (get-in old-objects [% :frame-id])
+                    (get-in new-objects [% :frame-id])))
+
+        changed-frame-guide?
+        #(and (contains? new-guides %)
+              (contains? old-guides %)
+              (not= (get-in old-objects [% :frame-id])
+                    (get-in new-objects [% :frame-id])))
+
+        changed-attrs-object?
+        #(and (contains? new-objects %)
+              (contains? old-objects %)
+              (= (get-in old-objects [% :frame-id])
+                 (get-in new-objects [% :frame-id])))
+
+        changed-attrs-guide?
+        #(and (contains? new-guides %)
+              (contains? old-guides %)
+              (= (get-in old-objects [% :frame-id])
+                 (get-in new-objects [% :frame-id])))
+
+        changed-object-ids
+        (into #{}
+              (filter changed-object?)
+              (set/union (set (keys old-objects))
+                         (set (keys new-objects))))
+
+        changed-guides-ids
+        (into #{}
+              (filter changed-guide?)
+              (set/union (set (keys old-guides))
+                         (set (keys new-guides))))
+
+        get-diff-object (fn [id] [(get old-objects id) (get new-objects id)])
+        get-diff-guide  (fn [id] [(get old-guides id) (get new-guides id)])
+
+        ;; Shapes with different frame owner
+        change-frame-shapes
+        (->> changed-object-ids
+             (into [] (comp (filter changed-frame-object?)
+                            (map get-diff-object))))
+
+        ;; Guides that changed frames
+        change-frame-guides
+        (->> changed-guides-ids
+             (into [] (comp (filter changed-frame-guide?)
+                            (map get-diff-guide))))
+
+        removed-frames
+        (->> changed-object-ids
+             (into [] (comp (filter frame?)
+                            (filter deleted-object?)
+                            (map (d/getf old-objects)))))
+
+        removed-shapes
+        (->> changed-object-ids
+             (into [] (comp (remove frame?)
+                            (filter deleted-object?)
+                            (map (d/getf old-objects)))))
+
+        removed-guides
+        (->> changed-guides-ids
+             (into [] (comp (filter deleted-guide?)
+                            (map (d/getf old-guides)))))
+
+        updated-frames
+        (->> changed-object-ids
+             (into [] (comp (filter frame?)
+                            (filter changed-attrs-object?)
+                            (map get-diff-object))))
+
+        updated-shapes
+        (->> changed-object-ids
+             (into [] (comp (remove frame?)
+                            (filter changed-attrs-object?)
+                            (map get-diff-object))))
+
+        updated-guides
+        (->> changed-guides-ids
+             (into [] (comp (filter changed-attrs-guide?)
+                            (map get-diff-guide))))
+
+        new-frames
+        (->> changed-object-ids
+             (into [] (comp (filter frame?)
+                            (filter new-object?)
+                            (map (d/getf new-objects)))))
+
+        new-shapes
+        (->> changed-object-ids
+             (into [] (comp (remove frame?)
+                            (filter new-object?)
+                            (map (d/getf new-objects)))))
+
+        new-guides
+        (->> changed-guides-ids
+             (into [] (comp (filter new-guide?)
+                            (map (d/getf new-guides)))))]
+    {:change-frame-shapes change-frame-shapes
+     :change-frame-guides change-frame-guides
+     :removed-frames      removed-frames
+     :removed-shapes      removed-shapes
+     :removed-guides      removed-guides
+     :updated-frames      updated-frames
+     :updated-shapes      updated-shapes
+     :updated-guides      updated-guides
+     :new-frames          new-frames
+     :new-shapes          new-shapes
+     :new-guides          new-guides}))

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

@@ -9,87 +9,211 @@
    [app.common.data :as d]
    [app.common.geom.shapes :as gsh]
    [app.common.spec :as us]
-   [app.common.types.interactions :as cti]
+   [app.common.spec.page :as spec.page]
    [app.common.uuid :as uuid]
    [cuerdas.core :as str]))
 
-(defn walk-pages
-  "Go through all pages of a file and apply a function to each one"
-  ;; The function receives two parameters (page-id and page), and
-  ;; returns the updated page.
-  [f data]
-  (update data :pages-index #(d/mapm f %)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; GENERIC SHAPE SELECTORS AND PREDICATES
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defn select-objects
-  "Get a list of all objects in a container (a page or a component) that
-  satisfy a condition"
-  [f container]
-  (filter f (vals (get container :objects))))
+(defn ^boolean root-frame?
+  [{:keys [id type]}]
+  (and (= type :frame)
+       (= id uuid/zero)))
 
-(defn update-object-list
-  "Update multiple objects in a page at once"
-  [page objects-list]
-  (update page :objects
-          #(into % (d/index-by :id objects-list))))
+(defn ^boolean frame-shape?
+  [{:keys [type]}]
+  (= type :frame))
 
-(defn get-component-shape
-  "Get the parent shape linked to a component for this shape, if any"
-  [shape objects]
-  (if-not (:shape-ref shape)
-    nil
-    (if (:component-id shape)
-      shape
-      (if-let [parent-id (:parent-id shape)]
-        (get-component-shape (get objects parent-id) objects)
-        nil))))
+(defn ^boolean group-shape?
+  [{:keys [type]}]
+  (= type :group))
 
-(defn get-root-shape
-  "Get the root shape linked to a component for this shape, if any"
-  [shape objects]
+(defn ^boolean text-shape?
+  [{:keys [type]}]
+  (= type :text))
 
-  (cond
-    (some? (:component-root? shape))
-    shape
-
-    (some? (:shape-ref shape))
-    (recur (get objects (:parent-id shape))
-           objects)))
-
-(defn make-container
-  [page-or-component type]
-  (assoc page-or-component
-         :type type))
-
-(defn page?
-  [container]
-  (us/assert some? (:type container))
-  (= (:type container) :page))
-
-(defn component?
-  [container]
-  (= (:type container) :component))
-
-(defn get-container
-  [id type local-file]
-  (assert (some? type))
-  (-> (if (= type :page)
-        (get-in local-file [:pages-index id])
-        (get-in local-file [:components id]))
-      (assoc :type type)))
+(defn ^boolean unframed-shape?
+  "Checks if it's a non-frame shape in the top level."
+  [shape]
+  (and (not (frame-shape? shape))
+       (= (:frame-id shape) uuid/zero)))
 
 (defn get-shape
   [container shape-id]
-  (get-in container [:objects shape-id]))
+  (us/assert ::spec.page/container container)
+  (us/assert ::us/uuid shape-id)
+  (-> container
+      (get :objects)
+      (get shape-id)))
+
+(defn get-children-ids
+  [objects id]
+  (if-let [shapes (-> (get objects id) :shapes (some-> vec))]
+    (into shapes (mapcat #(get-children-ids objects %)) shapes)
+    []))
+
+(defn get-children
+  [objects id]
+  (mapv (d/getf objects) (get-children-ids objects id)))
+
+(defn get-children-with-self
+  [objects id]
+  (let [lookup (d/getf objects)]
+    (into [(lookup id)] (map lookup) (get-children-ids objects id))))
+
+(defn get-parent
+  "Retrieve the id of the parent for the shape-id (if exists)"
+  [objects id]
+  (let [lookup (d/getf objects)]
+    (-> id lookup :parent-id lookup)))
+
+(defn get-parent-id
+  "Retrieve the id of the parent for the shape-id (if exists)"
+  [objects id]
+  (-> objects (get id) :parent-id))
+
+(defn get-parent-ids
+  "Returns a vector of parents of the specified shape."
+  [objects shape-id]
+  (loop [result [] id shape-id]
+    (if-let [parent-id (->> id (get objects) :parent-id)]
+      (recur (conj result parent-id) parent-id)
+      result)))
+
+(defn get-frame
+  "Get the frame that contains the shape. If the shape is already a
+  frame, get itself. If no shape is provided, returns the root frame."
+  ([objects]
+   (get objects uuid/zero))
+  ([objects shape-or-id]
+   (cond
+     (map? shape-or-id)
+     (if (frame-shape? shape-or-id)
+       shape-or-id
+       (get objects (:frame-id shape-or-id)))
+
+     (= uuid/zero shape-or-id)
+     (get objects uuid/zero)
+
+     :else
+     (some->> shape-or-id
+              (get objects)
+              (get-frame objects)))))
+
+(defn valid-frame-target?
+  [objects parent-id shape-id]
+  (let [shape (get objects shape-id)]
+    (or (not (frame-shape? shape))
+        (= parent-id uuid/zero))))
+
+(defn get-position-on-parent
+  [objects id]
+  (let [obj (get objects id)
+        pid (:parent-id obj)
+        prt (get objects pid)]
+    (d/index-of (:shapes prt) id)))
+
+(defn get-immediate-children
+  "Retrieve resolved shape objects that are immediate children
+   of the specified shape-id"
+  ([objects] (get-immediate-children objects uuid/zero))
+  ([objects shape-id]
+   (let [lookup (d/getf objects)]
+     (->> (lookup shape-id)
+          (:shapes)
+          (keep lookup)))))
+
+(defn get-frames
+  "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?))]
+    (->> (:shapes (lookup uuid/zero))
+         (into [] xform))))
+
+(defn frame-id-by-position
+  [objects position]
+  (let [frames (get-frames objects)]
+    (or
+     (->> frames
+          (reverse)
+          (d/seek #(and position (gsh/has-point? % position)))
+          :id)
+     uuid/zero)))
+
+(declare indexed-shapes)
+
+(defn get-base-shape
+  "Selects the shape that will be the base to add the shapes over"
+  [objects selected]
+  (let [;; Gets the tree-index for all the shapes
+        indexed-shapes (indexed-shapes objects)
+
+        ;; Filters the selected and retrieve a list of ids
+        sorted-ids (->> indexed-shapes
+                        (filter (comp selected second))
+                        (map second))]
+
+    ;; The first id will be the top-most
+    (get objects (first sorted-ids))))
+
+(defn is-parent?
+  "Check if `parent-candidate` is parent of `shape-id`"
+  [objects shape-id parent-candidate]
+
+  (loop [current (get objects parent-candidate)
+         done #{}
+         pending (:shapes current)]
+
+    (cond
+      (contains? done (:id current))
+      (recur (get objects (first pending))
+             done
+             (rest pending))
+
+      (empty? pending) false
+      (and current (contains? (set (:shapes current)) shape-id)) true
+
+      :else
+      (recur (get objects (first pending))
+             (conj done (:id current))
+             (concat (rest pending) (:shapes current))))))
+
+(defn get-index-in-parent
+  "Retrieves the index in the parent"
+  [objects shape-id]
+  (let [shape (get objects shape-id)
+        parent (get objects (:parent-id shape))
+        [parent-idx _] (d/seek (fn [[_idx child-id]] (= child-id shape-id))
+                               (d/enumerate (:shapes parent)))]
+    parent-idx))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; COMPONENTS HELPERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn set-touched-group
+  [touched group]
+  (conj (or touched #{}) group))
+
+(defn touched-group?
+  [shape group]
+  ((or (:touched shape) #{}) group))
 
 (defn get-component
-  [component-id library-id local-library libraries]
-  (assert (some? (:id local-library)))
-  (let [file (if (= library-id (:id local-library))
-               local-library
-               (get-in libraries [library-id :data]))]
-    (get-in file [:components component-id])))
+  "Retrieve a component from libraries, if no library-id is provided, we
+  iterate over all libraries and find the component on it."
+  ([libraries component-id]
+   (some #(-> % :data :components (get component-id)) (vals libraries)))
+  ([libraries library-id component-id]
+   (get-in libraries [library-id :data :components component-id])))
 
-(defn is-main-of
+(defn ^boolean is-main-of?
   [shape-main shape-inst]
   (and (:shape-ref shape-inst)
        (or (= (:shape-ref shape-inst) (:id shape-main))
@@ -99,92 +223,67 @@
   [component]
   (get-in component [:objects (:id component)]))
 
-(defn get-children [id objects]
-  (if-let [shapes (-> (get objects id) :shapes (some-> vec))]
-    (into shapes (mapcat #(get-children % objects)) shapes)
-    []))
+(defn get-component-shape
+  "Get the parent shape linked to a component for this shape, if any"
+  [objects shape]
+  (if-not (:shape-ref shape)
+    nil
+    (if (:component-id shape)
+      shape
+      (if-let [parent-id (:parent-id shape)]
+        (get-component-shape objects (get objects parent-id))
+        nil))))
 
-(defn get-children-objects
-  "Retrieve all children objects recursively for a given object"
-  [id objects]
-  (mapv #(get objects %) (get-children id objects)))
+(defn get-root-shape
+  "Get the root shape linked to a component for this shape, if any."
+  [objects shape]
 
-(defn get-object-with-children
-  "Retrieve a vector with an object and all of its children"
-  [id objects]
-  (mapv #(get objects %) (cons id (get-children id objects))))
-
-(defn select-children [id objects]
-  (->> (get-children id objects)
-       (select-keys objects)))
-
-(defn is-shape-grouped
-  "Checks if a shape is inside a group"
-  [shape-id objects]
-  (let [contains-shape-fn (fn [{:keys [shapes]}] ((set shapes) shape-id))
-        shapes (remove #(= (:type %) :frame) (vals objects))]
-    (some contains-shape-fn shapes)))
-
-(defn get-top-frame
-  [objects]
-  (get objects uuid/zero))
-
-(defn get-parent
-  "Retrieve the id of the parent for the shape-id (if exists)"
-  [shape-id objects]
-  (let [obj (get objects shape-id)]
-    (:parent-id obj)))
-
-(defn get-parents
-  [shape-id objects]
-  (let [{:keys [parent-id]} (get objects shape-id)]
-    (when parent-id
-      (lazy-seq (cons parent-id (get-parents parent-id objects))))))
-
-(defn get-frame
-  "Get the frame that contains the shape. If the shape is already a frame, get itself."
-  [shape objects]
-  (if (= (:type shape) :frame)
+  (cond
+    (some? (:component-root? shape))
     shape
-    (get objects (:frame-id shape))))
 
-(defn clean-loops
-  "Clean a list of ids from circular references."
-  [objects ids]
+    (some? (:shape-ref shape))
+    (recur objects (get objects (:parent-id shape)))))
 
-  (let [parent-selected?
-        (fn [id]
-          (let [parents (get-parents id objects)]
-            (some ids parents)))
+(defn make-container
+  [page-or-component type]
+  (assoc page-or-component :type type))
 
-        add-element
-        (fn [result id]
-          (cond-> result
-            (not (parent-selected? id))
-            (conj id)))]
+(defn page?
+  [container]
+  (= (:type container) :page))
 
-    (reduce add-element (d/ordered-set) ids)))
+(defn component?
+  [container]
+  (= (:type container) :component))
 
-(defn calculate-invalid-targets
-  [shape-id objects]
-  (let [result #{shape-id}
-        children (get-in objects [shape-id :shapes])
-        reduce-fn (fn [result child-id]
-                    (into result (calculate-invalid-targets child-id objects)))]
-    (reduce reduce-fn result children)))
+(defn get-container
+  [file type id]
+  (us/assert map? file)
+  (us/assert keyword? type)
+  (us/assert uuid? id)
 
-(defn valid-frame-target
-  [shape-id parent-id objects]
-  (let [shape (get objects shape-id)]
-    (or (not= (:type shape) :frame)
-        (= parent-id uuid/zero))))
+  (-> (if (= type :page)
+        (get-in file [:pages-index id])
+        (get-in file [:components id]))
+      (assoc :type type)))
 
-(defn position-on-parent
-  [id objects]
-  (let [obj (get objects id)
-        pid (:parent-id obj)
-        prt (get objects pid)]
-    (d/index-of (:shapes prt) id)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ALGORITHMS & TRANSFORMATIONS FOR SHAPES
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn walk-pages
+  "Go through all pages of a file and apply a function to each one"
+  ;; The function receives two parameters (page-id and page), and
+  ;; returns the updated page.
+  [f data]
+  (update data :pages-index #(d/mapm f %)))
+
+(defn update-object-list
+  "Update multiple objects in a page at once"
+  [page objects-list]
+  (update page :objects
+          #(into % (d/index-by :id objects-list))))
 
 (defn insert-at-index
   [objects index ids]
@@ -204,41 +303,22 @@
           (vec prev-ids)
           ids))
 
-(defn select-toplevel-shapes
-  ([objects] (select-toplevel-shapes objects nil))
-  ([objects {:keys [include-frames? include-frame-children?]
-             :or {include-frames? false
-                  include-frame-children? true}}]
+(defn clean-loops
+  "Clean a list of ids from circular references."
+  [objects ids]
 
-   (let [lookup        #(get objects %)
-         root          (lookup uuid/zero)
-         root-children (:shapes root)
+  (let [parent-selected?
+        (fn [id]
+          (let [parents (get-parent-ids objects id)]
+            (some ids parents)))
 
-         lookup-shapes
-         (fn [result id]
-           (if (nil? id)
-             result
-             (let [obj      (lookup id)
-                   typ      (:type obj)
-                   children (:shapes obj)]
+        add-element
+        (fn [result id]
+          (cond-> result
+            (not (parent-selected? id))
+            (conj id)))]
 
-               (cond-> result
-                 (or (not= :frame typ) include-frames?)
-                 (conj obj)
-
-                 (and (= :frame typ) include-frame-children?)
-                 (into (map lookup) children)))))]
-
-     (reduce lookup-shapes [] root-children))))
-
-(defn select-frames
-  [objects]
-  (let [lookup #(get objects %)
-        frame? #(= :frame (:type %))
-        xform  (comp (map lookup)
-                     (filter frame?))]
-    (->> (:shapes (lookup uuid/zero))
-         (into [] xform))))
+    (reduce add-element (d/ordered-set) ids)))
 
 (defn clone-object
   "Gets a copy of the object and all its children, with new ids
@@ -305,8 +385,6 @@
               (reduce red-fn cur-idx (reverse (:shapes object)))))]
     (into {} (rec-index '() uuid/zero))))
 
-
-
 (defn expand-region-selection
   "Given a selection selects all the shapes between the first and last in
    an indexed manner (shift selection)"
@@ -323,67 +401,9 @@
          (map second)
          (into #{}))))
 
-(defn frame-id-by-position [objects position]
-  (let [frames (select-frames objects)]
-    (or
-     (->> frames
-          (reverse)
-          (d/seek #(and position (gsh/has-point? % position)))
-          :id)
-     uuid/zero)))
-
-(defn set-touched-group
-  [touched group]
-  (conj (or touched #{}) group))
-
-(defn touched-group?
-  [shape group]
-  ((or (:touched shape) #{}) group))
-
-(defn get-base-shape
-  "Selects the shape that will be the base to add the shapes over"
-  [objects selected]
-  (let [;; Gets the tree-index for all the shapes
-        indexed-shapes (indexed-shapes objects)
-
-        ;; Filters the selected and retrieve a list of ids
-        sorted-ids (->> indexed-shapes
-                        (filter (comp selected second))
-                        (map second))]
-
-    ;; The first id will be the top-most
-    (get objects (first sorted-ids))))
-
-(defn is-parent?
-  "Check if `parent-candidate` is parent of `shape-id`"
-  [objects shape-id parent-candidate]
-
-  (loop [current (get objects parent-candidate)
-         done #{}
-         pending (:shapes current)]
-
-    (cond
-      (contains? done (:id current))
-      (recur (get objects (first pending))
-             done
-             (rest pending))
-
-      (empty? pending) false
-      (and current (contains? (set (:shapes current)) shape-id)) true
-
-      :else
-      (recur (get objects (first pending))
-             (conj done (:id current))
-             (concat (rest pending) (:shapes current))))))
-
-(defn get-index-in-parent
-  "Retrieves the index in the parent"
-  [objects shape-id]
-  (let [shape (get objects shape-id)
-        parent (get objects (:parent-id shape))
-        [parent-idx _] (d/seek (fn [[_idx child-id]] (= child-id shape-id))
-                               (d/enumerate (:shapes parent)))]
-    parent-idx))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SHAPES ORGANIZATION (PATH MANAGEMENT)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defn split-path
   "Decompose a string in the form 'one / two / three' into
@@ -443,25 +463,3 @@
   [path name]
   (let [path-split (split-path path)]
     (merge-path-item (first path-split) name)))
-
-(defn connected-frame?
-  "Check if some frame is origin or destination of any navigate interaction
-  in the page"
-  [frame-id objects]
-  (let [children (get-object-with-children frame-id objects)]
-    (or (some cti/flow-origin? (map :interactions children))
-        (some #(cti/flow-to? % frame-id) (map :interactions (vals objects))))))
-
-(defn unframed-shape?
-  "Checks if it's a non-frame shape in the top level."
-  [shape]
-  (and (not= (:type shape) :frame)
-       (= (:frame-id shape) uuid/zero)))
-
-(defn children-seq
-  "Creates a sequence of shapes through the objects tree"
-  [shape objects]
-  (let [getter (partial get objects)]
-    (tree-seq #(d/not-empty? (get shape :shapes))
-              #(->> (get % :shapes) (map getter))
-              shape)))

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

@@ -7,7 +7,7 @@
 (ns app.common.pages.indices
   (:require
    [app.common.data :as d]
-   [app.common.pages.helpers :as helpers]
+   [app.common.pages.helpers :as cph]
    [app.common.uuid :as uuid]
    [clojure.set :as set]))
 
@@ -45,7 +45,7 @@
   means is displayed over other shapes with less index."
   [objects]
 
-  (let [frames (helpers/select-frames objects)
+  (let [frames  (cph/get-frames objects)
         z-index (calculate-frame-z-index {} uuid/zero objects)]
     (->> frames
          (map :id)
@@ -61,7 +61,7 @@
 
         changed-frames (set/union old-frames new-frames)
 
-        frames (->> (helpers/select-frames new-objects)
+        frames (->> (cph/get-frames new-objects)
                     (map :id)
                     (filter #(contains? changed-frames %)))
 
@@ -84,13 +84,10 @@
    (generate-child-all-parents-index objects (vals objects)))
 
   ([objects shapes]
-   (let [shape->parents
-         (fn [shape]
-           (->> (helpers/get-parents (:id shape) objects)
-                (into [])))]
-     (->> shapes
-          (map #(vector (:id %) (shape->parents %)))
-          (into {})))))
+   (let [xf-parents (comp
+                     (map :id)
+                     (map #(vector % (cph/get-parent-ids objects %))))]
+     (into {} xf-parents shapes))))
 
 (defn create-clip-index
   "Retrieves the mask information for an object"

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

@@ -51,7 +51,9 @@
     :rx 0
     :ry 0}
 
-   {:type :image}
+   {:type :image
+    :rx 0
+    :ry 0}
 
    {:type :circle
     :name "Circle-1"

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

@@ -12,7 +12,8 @@
    [app.common.geom.shapes.path :as gsp]
    [app.common.math :as mth]
    [app.common.pages :as cp]
-   [app.common.uuid :as uuid]))
+   [app.common.uuid :as uuid]
+   [cuerdas.core :as str]))
 
 ;; TODO: revisit this and rename to file-migrations
 
@@ -281,3 +282,51 @@
             (d/update-in-when page [:options :saved-grids] #(d/mapm update-grid %)))]
 
     (update data :pages-index #(d/mapm update-page %))))
+
+;; Add rx and ry to images
+(defmethod migrate 13
+  [data]
+  (letfn [(fix-radius [shape]
+            (if-not (or (contains? shape :rx) (contains? shape :r1))
+              (-> shape
+                  (assoc :rx 0)
+                  (assoc :ry 0))
+              shape))
+          (update-object [_ object]
+            (cond-> object
+              (= :image (:type object))
+              (fix-radius)))
+
+          (update-page [_ page]
+            (update page :objects #(d/mapm update-object %)))]
+
+    (update data :pages-index #(d/mapm update-page %))))
+
+(defmethod migrate 14
+  [data]
+  (letfn [(process-shape [shape]
+            (let [fill-color   (str/upper (:fill-color shape))
+                  fill-opacity (:fill-opacity shape)]
+              (cond-> shape
+                (and (= 1 fill-opacity)
+                     (or (= "#B1B2B5" fill-color)
+                         (= "#7B7D85" fill-color)))
+                (dissoc :fill-color :fill-opacity))))
+
+          (update-container [_ {:keys [objects] :as container}]
+            (loop [objects objects
+                   shapes  (->> (vals objects)
+                                (filter #(= :image (:type %))))]
+              (if-let [shape (first shapes)]
+                (let [{:keys [id frame-id] :as shape'} (process-shape shape)]
+                  (if (identical? shape shape')
+                    (recur objects (rest shapes))
+                    (recur (-> objects
+                               (assoc id shape')
+                               (d/update-when frame-id dissoc :thumbnail))
+                           (rest shapes))))
+                (assoc container :objects objects))))]
+
+    (-> data
+        (update :pages-index #(d/mapm update-container %))
+        (update :components #(d/mapm update-container %)))))

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

@@ -1,623 +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.common.pages.spec
-  (:require
-   [app.common.geom.matrix :as gmt]
-   [app.common.geom.point :as gpt]
-   [app.common.spec :as us]
-   [app.common.types.interactions :as cti]
-   [app.common.types.page-options :as cto]
-   [app.common.types.radius :as ctr]
-   [app.common.uuid :as uuid]
-   [clojure.set :as set]
-   [clojure.spec.alpha :as s]))
-
-;; --- Specs
-
-(s/def ::frame-id uuid?)
-(s/def ::id uuid?)
-(s/def ::name string?)
-(s/def ::path (s/nilable string?))
-(s/def ::page-id uuid?)
-(s/def ::parent-id uuid?)
-(s/def ::string string?)
-(s/def ::type keyword?)
-(s/def ::uuid uuid?)
-
-(s/def ::component-id uuid?)
-(s/def ::component-file uuid?)
-(s/def ::component-root? boolean?)
-(s/def ::shape-ref uuid?)
-
-(s/def :internal.matrix/a ::us/safe-number)
-(s/def :internal.matrix/b ::us/safe-number)
-(s/def :internal.matrix/c ::us/safe-number)
-(s/def :internal.matrix/d ::us/safe-number)
-(s/def :internal.matrix/e ::us/safe-number)
-(s/def :internal.matrix/f ::us/safe-number)
-
-(s/def ::matrix
-  (s/and (s/keys :req-un [:internal.matrix/a
-                          :internal.matrix/b
-                          :internal.matrix/c
-                          :internal.matrix/d
-                          :internal.matrix/e
-                          :internal.matrix/f])
-         gmt/matrix?))
-
-
-(s/def :internal.point/x ::us/safe-number)
-(s/def :internal.point/y ::us/safe-number)
-
-(s/def ::point
-  (s/and (s/keys :req-un [:internal.point/x
-                          :internal.point/y])
-         gpt/point?))
-
-;; GRADIENTS
-
-(s/def :internal.gradient.stop/color ::string)
-(s/def :internal.gradient.stop/opacity ::us/safe-number)
-(s/def :internal.gradient.stop/offset ::us/safe-number)
-
-(s/def :internal.gradient/type #{:linear :radial})
-(s/def :internal.gradient/start-x ::us/safe-number)
-(s/def :internal.gradient/start-y ::us/safe-number)
-(s/def :internal.gradient/end-x ::us/safe-number)
-(s/def :internal.gradient/end-y ::us/safe-number)
-(s/def :internal.gradient/width ::us/safe-number)
-
-(s/def :internal.gradient/stop
-  (s/keys :req-un [:internal.gradient.stop/color
-                   :internal.gradient.stop/opacity
-                   :internal.gradient.stop/offset]))
-
-(s/def :internal.gradient/stops
-  (s/coll-of :internal.gradient/stop :kind vector?))
-
-(s/def ::gradient
-  (s/keys :req-un [:internal.gradient/type
-                   :internal.gradient/start-x
-                   :internal.gradient/start-y
-                   :internal.gradient/end-x
-                   :internal.gradient/end-y
-                   :internal.gradient/width
-                   :internal.gradient/stops]))
-
-
-;;; COLORS
-
-(s/def :internal.color/name ::string)
-(s/def :internal.color/path (s/nilable ::string))
-(s/def :internal.color/value (s/nilable ::string))
-(s/def :internal.color/color (s/nilable ::string))
-(s/def :internal.color/opacity (s/nilable ::us/safe-number))
-(s/def :internal.color/gradient (s/nilable ::gradient))
-
-(s/def ::color
-  (s/keys :opt-un [::id
-                   :internal.color/name
-                   :internal.color/path
-                   :internal.color/value
-                   :internal.color/color
-                   :internal.color/opacity
-                   :internal.color/gradient]))
-
-
-;;; SHADOW EFFECT
-
-(s/def :internal.shadow/id uuid?)
-(s/def :internal.shadow/style #{:drop-shadow :inner-shadow})
-(s/def :internal.shadow/color ::color)
-(s/def :internal.shadow/offset-x ::us/safe-number)
-(s/def :internal.shadow/offset-y ::us/safe-number)
-(s/def :internal.shadow/blur ::us/safe-number)
-(s/def :internal.shadow/spread ::us/safe-number)
-(s/def :internal.shadow/hidden boolean?)
-
-(s/def :internal.shadow/shadow
-  (s/keys :req-un [:internal.shadow/id
-                   :internal.shadow/style
-                   :internal.shadow/color
-                   :internal.shadow/offset-x
-                   :internal.shadow/offset-y
-                   :internal.shadow/blur
-                   :internal.shadow/spread
-                   :internal.shadow/hidden]))
-
-(s/def ::shadow
-  (s/coll-of :internal.shadow/shadow :kind vector?))
-
-
-;;; BLUR EFFECT
-
-(s/def :internal.blur/id uuid?)
-(s/def :internal.blur/type #{:layer-blur})
-(s/def :internal.blur/value ::us/safe-number)
-(s/def :internal.blur/hidden boolean?)
-
-(s/def ::blur
-  (s/keys :req-un [:internal.blur/id
-                   :internal.blur/type
-                   :internal.blur/value
-                   :internal.blur/hidden]))
-
-;; Size constraints
-
-(s/def :internal.shape/constraints-h #{:left :right :leftright :center :scale})
-(s/def :internal.shape/constraints-v #{:top :bottom :topbottom :center :scale})
-(s/def :internal.shape/fixed-scroll boolean?)
-
-; Shapes in the top frame have no constraints. Shapes directly below some
-; frame are left-top constrained. Else (shapes in a group) are scaled.
-(defn default-constraints-h
-  [shape]
-  (if (= (:parent-id shape) uuid/zero)
-    nil
-    (if (= (:parent-id shape) (:frame-id shape))
-      :left
-      :scale)))
-
-(defn default-constraints-v
-  [shape]
-  (if (= (:parent-id shape) uuid/zero)
-    nil
-    (if (= (:parent-id shape) (:frame-id shape))
-      :top
-      :scale)))
-
-;; Page Data related
-(s/def :internal.shape/blocked boolean?)
-(s/def :internal.shape/collapsed boolean?)
-
-(s/def :internal.shape/fill-color string?)
-(s/def :internal.shape/fill-opacity ::us/safe-number)
-(s/def :internal.shape/fill-color-gradient (s/nilable ::gradient))
-(s/def :internal.shape/fill-color-ref-file (s/nilable uuid?))
-(s/def :internal.shape/fill-color-ref-id (s/nilable uuid?))
-(s/def :internal.shape/hide-fill-on-export boolean?)
-
-(s/def :internal.shape/font-family string?)
-(s/def :internal.shape/font-size ::us/safe-integer)
-(s/def :internal.shape/font-style string?)
-(s/def :internal.shape/font-weight string?)
-(s/def :internal.shape/hidden boolean?)
-(s/def :internal.shape/letter-spacing ::us/safe-number)
-(s/def :internal.shape/line-height ::us/safe-number)
-(s/def :internal.shape/locked boolean?)
-(s/def :internal.shape/page-id uuid?)
-(s/def :internal.shape/proportion ::us/safe-number)
-(s/def :internal.shape/proportion-lock boolean?)
-(s/def :internal.shape/stroke-color string?)
-(s/def :internal.shape/stroke-color-gradient (s/nilable ::gradient))
-(s/def :internal.shape/stroke-color-ref-file (s/nilable uuid?))
-(s/def :internal.shape/stroke-color-ref-id (s/nilable uuid?))
-(s/def :internal.shape/stroke-opacity ::us/safe-number)
-(s/def :internal.shape/stroke-style #{:solid :dotted :dashed :mixed :none :svg})
-
-(def stroke-caps-line #{:round :square})
-(def stroke-caps-marker #{:line-arrow :triangle-arrow :square-marker :circle-marker :diamond-marker})
-(def stroke-caps (set/union stroke-caps-line stroke-caps-marker))
-(s/def :internal.shape/stroke-cap-start stroke-caps)
-(s/def :internal.shape/stroke-cap-end stroke-caps)
-
-(defn has-caps?
-  [shape]
-  (= (:type shape) :path))
-
-(s/def :internal.shape/stroke-width ::us/safe-number)
-(s/def :internal.shape/stroke-alignment #{:center :inner :outer})
-(s/def :internal.shape/text-align #{"left" "right" "center" "justify"})
-(s/def :internal.shape/x ::us/safe-number)
-(s/def :internal.shape/y ::us/safe-number)
-(s/def :internal.shape/cx ::us/safe-number)
-(s/def :internal.shape/cy ::us/safe-number)
-(s/def :internal.shape/width ::us/safe-number)
-(s/def :internal.shape/height ::us/safe-number)
-(s/def :internal.shape/index integer?)
-(s/def :internal.shape/shadow ::shadow)
-(s/def :internal.shape/blur ::blur)
-
-(s/def :internal.shape/x1 ::us/safe-number)
-(s/def :internal.shape/y1 ::us/safe-number)
-(s/def :internal.shape/x2 ::us/safe-number)
-(s/def :internal.shape/y2 ::us/safe-number)
-
-(s/def :internal.shape.export/suffix string?)
-(s/def :internal.shape.export/scale ::us/safe-number)
-(s/def :internal.shape/export
-  (s/keys :req-un [::type
-                   :internal.shape.export/suffix
-                   :internal.shape.export/scale]))
-
-(s/def :internal.shape/exports
-  (s/coll-of :internal.shape/export :kind vector?))
-
-(s/def :internal.shape/selrect
-  (s/keys :req-un [:internal.shape/x
-                   :internal.shape/y
-                   :internal.shape/x1
-                   :internal.shape/y1
-                   :internal.shape/x2
-                   :internal.shape/y2
-                   :internal.shape/width
-                   :internal.shape/height]))
-
-(s/def :internal.shape/points
-  (s/every ::point :kind vector?))
-
-(s/def :internal.shape/shapes
-  (s/every uuid? :kind vector?))
-
-(s/def :internal.shape/transform ::matrix)
-(s/def :internal.shape/transform-inverse ::matrix)
-
-(s/def :internal.shape/opacity ::us/safe-number)
-(s/def :internal.shape/blend-mode
-  #{:normal
-    :darken
-    :multiply
-    :color-burn
-    :lighten
-    :screen
-    :color-dodge
-    :overlay
-    :soft-light
-    :hard-light
-    :difference
-    :exclusion
-    :hue
-    :saturation
-    :color
-    :luminosity})
-
-(s/def ::shape-attrs
-  (s/keys :opt-un [::id
-                   ::type
-                   ::name
-                   ::component-id
-                   ::component-file
-                   ::component-root?
-                   ::shape-ref
-                   :internal.shape/selrect
-                   :internal.shape/points
-                   :internal.shape/blocked
-                   :internal.shape/collapsed
-                   :internal.shape/fill-color
-                   :internal.shape/fill-opacity
-                   :internal.shape/fill-color-gradient
-                   :internal.shape/fill-color-ref-file
-                   :internal.shape/fill-color-ref-id
-                   :internal.shape/font-family
-                   :internal.shape/font-size
-                   :internal.shape/font-style
-                   :internal.shape/font-weight
-                   :internal.shape/hidden
-                   :internal.shape/letter-spacing
-                   :internal.shape/line-height
-                   :internal.shape/locked
-                   :internal.shape/proportion
-                   :internal.shape/proportion-lock
-                   :internal.shape/constraints-h
-                   :internal.shape/constraints-v
-                   :internal.shape/fixed-scroll
-                   ::ctr/rx
-                   ::ctr/ry
-                   ::ctr/r1
-                   ::ctr/r2
-                   ::ctr/r3
-                   ::ctr/r4
-                   :internal.shape/x
-                   :internal.shape/y
-                   :internal.shape/exports
-                   :internal.shape/shapes
-                   :internal.shape/stroke-color
-                   :internal.shape/stroke-color-ref-file
-                   :internal.shape/stroke-color-ref-id
-                   :internal.shape/stroke-opacity
-                   :internal.shape/stroke-style
-                   :internal.shape/stroke-width
-                   :internal.shape/stroke-alignment
-                   :internal.shape/stroke-cap-start
-                   :internal.shape/stroke-cap-end
-                   :internal.shape/text-align
-                   :internal.shape/transform
-                   :internal.shape/transform-inverse
-                   :internal.shape/width
-                   :internal.shape/height
-                   ::cti/interactions
-                   :internal.shape/masked-group?
-                   :internal.shape/shadow
-                   :internal.shape/blur
-                   :internal.shape/opacity
-                   :internal.shape/blend-mode]))
-
-(s/def :internal.shape.text/type #{"root" "paragraph-set" "paragraph"})
-(s/def :internal.shape.text/children
-  (s/coll-of :internal.shape.text/content
-             :kind vector?
-             :min-count 1))
-
-(s/def :internal.shape.text/text string?)
-(s/def :internal.shape.text/key string?)
-
-(s/def :internal.shape.text/content
-  (s/nilable
-   (s/or :text-container
-         (s/keys :req-un [:internal.shape.text/type
-                          :internal.shape.text/children]
-                 :opt-un [:internal.shape.text/key])
-         :text-content
-         (s/keys :req-un [:internal.shape.text/text]))))
-
-(s/def :internal.shape.path/command keyword?)
-(s/def :internal.shape.path/params
-  (s/nilable (s/map-of keyword? any?)))
-
-(s/def :internal.shape.path/command-item
-  (s/keys :req-un [:internal.shape.path/command]
-          :opt-un [:internal.shape.path/params]))
-
-(s/def :internal.shape.path/content
-  (s/coll-of :internal.shape.path/command-item :kind vector?))
-
-(defmulti shape-spec :type)
-
-(defmethod shape-spec :default [_]
-  (s/spec ::shape-attrs))
-
-(defmethod shape-spec :text [_]
-  (s/and ::shape-attrs
-         (s/keys :opt-un [:internal.shape.text/content])))
-
-(defmethod shape-spec :path [_]
-  (s/and ::shape-attrs
-         (s/keys :opt-un [:internal.shape.path/content])))
-
-(defmethod shape-spec :frame [_]
-  (s/and ::shape-attrs
-         (s/keys :opt-un [:internal.shape/hide-fill-on-export])))
-
-(s/def ::shape
-  (s/and (s/multi-spec shape-spec :type)
-         #(contains? % :name)
-         #(contains? % :type)))
-
-(s/def :internal.page/objects (s/map-of uuid? ::shape))
-
-(s/def ::page
-  (s/keys :req-un [::id
-                   ::name
-                   ::cto/options
-                   :internal.page/objects]))
-
-(s/def ::recent-color
-  (s/keys :opt-un [:internal.color/value
-                   :internal.color/color
-                   :internal.color/opacity
-                   :internal.color/gradient]))
-
-(s/def :internal.media-object/name ::string)
-(s/def :internal.media-object/width ::us/safe-integer)
-(s/def :internal.media-object/height ::us/safe-integer)
-(s/def :internal.media-object/mtype ::string)
-
-(s/def ::media-object
-  (s/keys :req-un [::id
-                   ::name
-                   :internal.media-object/width
-                   :internal.media-object/height
-                   :internal.media-object/mtype]))
-
-(s/def ::media-object-update
-  (s/keys :req-un [::id]
-          :opt-un [::name
-                   :internal.media-object/width
-                   :internal.media-object/height
-                   :internal.media-object/mtype]))
-
-(s/def :internal.file/colors
-  (s/map-of ::uuid ::color))
-
-(s/def :internal.file/recent-colors
-  (s/coll-of ::recent-color :kind vector?))
-
-(s/def :internal.typography/id ::id)
-(s/def :internal.typography/name ::string)
-(s/def :internal.typography/path (s/nilable ::string))
-(s/def :internal.typography/font-id ::string)
-(s/def :internal.typography/font-family ::string)
-(s/def :internal.typography/font-variant-id ::string)
-(s/def :internal.typography/font-size ::string)
-(s/def :internal.typography/font-weight ::string)
-(s/def :internal.typography/font-style ::string)
-(s/def :internal.typography/line-height ::string)
-(s/def :internal.typography/letter-spacing ::string)
-(s/def :internal.typography/text-transform ::string)
-
-(s/def ::typography
-  (s/keys :req-un [:internal.typography/id
-                   :internal.typography/name
-                   :internal.typography/font-id
-                   :internal.typography/font-family
-                   :internal.typography/font-variant-id
-                   :internal.typography/font-size
-                   :internal.typography/font-weight
-                   :internal.typography/font-style
-                   :internal.typography/line-height
-                   :internal.typography/letter-spacing
-                   :internal.typography/text-transform]
-          :opt-un [:internal.typography/path]))
-
-(s/def :internal.file/pages
-  (s/coll-of ::uuid :kind vector?))
-
-(s/def :internal.file/media
-  (s/map-of ::uuid ::media-object))
-
-(s/def :internal.file/pages-index
-  (s/map-of ::uuid ::page))
-
-(s/def ::data
-  (s/keys :req-un [:internal.file/pages-index
-                   :internal.file/pages]
-          :opt-un [:internal.file/colors
-                   :internal.file/recent-colors
-                   :internal.file/media]))
-
-(s/def :internal.container/type #{:page :component})
-
-(s/def ::container
-  (s/keys :req-un [:internal.container/type
-                   ::id
-                   ::name
-                   :internal.page/objects]))
-
-(defmulti operation-spec :type)
-
-(s/def :internal.operations.set/attr keyword?)
-(s/def :internal.operations.set/val any?)
-(s/def :internal.operations.set/touched
-  (s/nilable (s/every keyword? :kind set?)))
-(s/def :internal.operations.set/remote-synced?
-  (s/nilable boolean?))
-
-(defmethod operation-spec :set [_]
-  (s/keys :req-un [:internal.operations.set/attr
-                   :internal.operations.set/val]))
-
-(defmethod operation-spec :set-touched [_]
-  (s/keys :req-un [:internal.operations.set/touched]))
-
-(defmethod operation-spec :set-remote-synced [_]
-  (s/keys :req-un [:internal.operations.set/remote-synced?]))
-
-(defmulti change-spec :type)
-
-(s/def :internal.changes.set-option/option any?)
-(s/def :internal.changes.set-option/value any?)
-
-(defmethod change-spec :set-option [_]
-  (s/keys :req-un [:internal.changes.set-option/option
-                   :internal.changes.set-option/value]))
-
-(s/def :internal.changes.add-obj/obj ::shape)
-
-(defn- valid-container-id-frame?
-  [o]
-  (or (and (contains? o :page-id)
-           (not (contains? o :component-id))
-           (some? (:frame-id o)))
-      (and (contains? o :component-id)
-           (not (contains? o :page-id))
-           (nil? (:frame-id o)))))
-
-(defn- valid-container-id?
-  [o]
-  (or (and (contains? o :page-id)
-           (not (contains? o :component-id)))
-      (and (contains? o :component-id)
-           (not (contains? o :page-id)))))
-
-(defmethod change-spec :add-obj [_]
-  (s/and (s/keys :req-un [::id :internal.changes.add-obj/obj]
-                 :opt-un [::page-id ::component-id ::parent-id ::frame-id])
-         valid-container-id-frame?))
-
-(s/def ::operation (s/multi-spec operation-spec :type))
-(s/def ::operations (s/coll-of ::operation))
-
-(defmethod change-spec :mod-obj [_]
-  (s/and (s/keys :req-un [::id ::operations]
-                 :opt-un [::page-id ::component-id])
-         valid-container-id?))
-
-(defmethod change-spec :del-obj [_]
-  (s/and (s/keys :req-un [::id]
-                 :opt-un [::page-id ::component-id])
-         valid-container-id?))
-
-(s/def :internal.changes.reg-objects/shapes
-  (s/coll-of uuid? :kind vector?))
-
-(defmethod change-spec :reg-objects [_]
-  (s/and (s/keys :req-un [:internal.changes.reg-objects/shapes]
-                 :opt-un [::page-id ::component-id])
-         valid-container-id?))
-
-(defmethod change-spec :mov-objects [_]
-  (s/and (s/keys :req-un [::parent-id :internal.shape/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])))
-
-(defmethod change-spec :mod-page [_]
-  (s/keys :req-un [::id ::name]))
-
-(defmethod change-spec :del-page [_]
-  (s/keys :req-un [::id]))
-
-(defmethod change-spec :mov-page [_]
-  (s/keys :req-un [::id ::index]))
-
-(defmethod change-spec :add-color [_]
-  (s/keys :req-un [::color]))
-
-(defmethod change-spec :mod-color [_]
-  (s/keys :req-un [::color]))
-
-(defmethod change-spec :del-color [_]
-  (s/keys :req-un [::id]))
-
-(s/def :internal.changes.add-recent-color/color ::recent-color)
-
-(defmethod change-spec :add-recent-color [_]
-  (s/keys :req-un [:internal.changes.add-recent-color/color]))
-
-(s/def :internal.changes.media/object ::media-object)
-
-(defmethod change-spec :add-media [_]
-  (s/keys :req-un [:internal.changes.media/object]))
-
-(s/def :internal.changes.media.mod/object ::media-object-update)
-
-(defmethod change-spec :mod-media [_]
-  (s/keys :req-un [:internal.changes.media.mod/object]))
-
-(defmethod change-spec :del-media [_]
-  (s/keys :req-un [::id]))
-
-(s/def :internal.changes.add-component/shapes
-  (s/coll-of ::shape))
-
-(defmethod change-spec :add-component [_]
-  (s/keys :req-un [::id ::name :internal.changes.add-component/shapes]
-          :opt-un [::path]))
-
-(defmethod change-spec :mod-component [_]
-  (s/keys :req-un [::id]
-          :opt-un [::name :internal.changes.add-component/shapes]))
-
-(defmethod change-spec :del-component [_]
-  (s/keys :req-un [::id]))
-
-(s/def :internal.changes.typography/typography ::typography)
-
-(defmethod change-spec :add-typography [_]
-  (s/keys :req-un [:internal.changes.typography/typography]))
-
-(defmethod change-spec :mod-typography [_]
-  (s/keys :req-un [:internal.changes.typography/typography]))
-
-(defmethod change-spec :del-typography [_]
-  (s/keys :req-un [:internal.typography/id]))
-
-(s/def ::change (s/multi-spec change-spec :type))
-(s/def ::changes (s/coll-of ::change))

common/src/app/common/path/bool.cljc

@@ -326,6 +326,9 @@
   [bool-type contents]
   ;; We apply the boolean operation in to each pair and the result to the next
   ;; element
-  (->> contents
-       (reduce (partial content-bool-pair bool-type))
-       (into [])))
+  (if (seq contents)
+    (->> contents
+         (reduce (partial content-bool-pair bool-type))
+         (into []))
+    []))
+

common/src/app/common/spec.cljc

@@ -16,10 +16,9 @@
    ;; because of some strange interaction with cljs.spec.alpha and
    ;; modules splitting.
    [app.common.exceptions :as ex]
-   [app.common.geom.point :as gpt]
    [app.common.uuid :as uuid]
    [cuerdas.core :as str]
-   [expound.alpha]))
+   [expound.alpha :as expound]))
 
 (s/check-asserts true)
 
@@ -110,7 +109,6 @@
 (s/def ::not-empty-string (s/and string? #(not (str/empty? %))))
 (s/def ::url string?)
 (s/def ::fn fn?)
-(s/def ::point gpt/point?)
 (s/def ::id ::uuid)
 
 (defn bytes?
@@ -270,3 +268,12 @@
                       (spec-assert* ~spec params# ~message mdata#)
                       (apply origf# params#)))))))
 
+(defn pretty-explain
+  ([data] (pretty-explain data nil))
+  ([data {:keys [max-problems] :or {max-problems 10}}]
+   (when (and (::s/problems data)
+              (::s/value data)
+              (::s/spec data))
+     (binding [s/*explain-out* expound/printer]
+       (with-out-str
+         (s/explain-out (update data ::s/problems #(take max-problems %))))))))

common/src/app/common/spec/blur.cljc

@@ -0,0 +1,19 @@
+;; 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.spec.blur
+  (:require
+   [app.common.spec :as us]
+   [clojure.spec.alpha :as s]))
+
+(s/def ::id uuid?)
+(s/def ::type #{:layer-blur})
+(s/def ::value ::us/safe-number)
+(s/def ::hidden boolean?)
+
+(s/def ::blur
+  (s/keys :req-un [::id ::type ::value ::hidden]))
+

common/src/app/common/spec/change.cljc

@@ -0,0 +1,175 @@
+;; 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.spec.change
+  (:require
+   [app.common.spec :as us]
+   [app.common.spec.color :as color]
+   [app.common.spec.file :as file]
+   [app.common.spec.page :as page]
+   [app.common.spec.shape :as shape]
+   [app.common.spec.typography :as typg]
+   [clojure.spec.alpha :as s]))
+
+(s/def ::index integer?)
+(s/def ::id uuid?)
+(s/def ::parent-id uuid?)
+(s/def ::frame-id uuid?)
+(s/def ::page-id uuid?)
+(s/def ::component-id uuid?)
+(s/def ::name string?)
+
+(defmulti operation-spec :type)
+
+(s/def :internal.operations.set/attr keyword?)
+(s/def :internal.operations.set/val any?)
+
+(s/def :internal.operations.set/touched
+  (s/nilable (s/every keyword? :kind set?)))
+
+(s/def :internal.operations.set/remote-synced?
+  (s/nilable boolean?))
+
+(defmethod operation-spec :set [_]
+  (s/keys :req-un [:internal.operations.set/attr
+                   :internal.operations.set/val]))
+
+(defmethod operation-spec :set-touched [_]
+  (s/keys :req-un [:internal.operations.set/touched]))
+
+(defmethod operation-spec :set-remote-synced [_]
+  (s/keys :req-un [:internal.operations.set/remote-synced?]))
+
+(defmulti change-spec :type)
+
+(s/def :internal.changes.set-option/option any?)
+(s/def :internal.changes.set-option/value any?)
+
+(defmethod change-spec :set-option [_]
+  (s/keys :req-un [:internal.changes.set-option/option
+                   :internal.changes.set-option/value]))
+
+(s/def :internal.changes.add-obj/obj ::shape/shape)
+
+(defn- valid-container-id-frame?
+  [o]
+  (or (and (contains? o :page-id)
+           (not (contains? o :component-id))
+           (some? (:frame-id o)))
+      (and (contains? o :component-id)
+           (not (contains? o :page-id))
+           (nil? (:frame-id o)))))
+
+(defn- valid-container-id?
+  [o]
+  (or (and (contains? o :page-id)
+           (not (contains? o :component-id)))
+      (and (contains? o :component-id)
+           (not (contains? o :page-id)))))
+
+(defmethod change-spec :add-obj [_]
+  (s/and (s/keys :req-un [::id :internal.changes.add-obj/obj]
+                 :opt-un [::page-id ::component-id ::parent-id ::frame-id])
+         valid-container-id-frame?))
+
+(s/def ::operation (s/multi-spec operation-spec :type))
+(s/def ::operations (s/coll-of ::operation))
+
+(defmethod change-spec :mod-obj [_]
+  (s/and (s/keys :req-un [::id ::operations]
+                 :opt-un [::page-id ::component-id])
+         valid-container-id?))
+
+(defmethod change-spec :del-obj [_]
+  (s/and (s/keys :req-un [::id]
+                 :opt-un [::page-id ::component-id])
+         valid-container-id?))
+
+(defmethod change-spec :reg-objects [_]
+  (s/and (s/keys :req-un [::shape/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]
+                 :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])))
+
+(defmethod change-spec :mod-page [_]
+  (s/keys :req-un [::id ::name]))
+
+(defmethod change-spec :del-page [_]
+  (s/keys :req-un [::id]))
+
+(defmethod change-spec :mov-page [_]
+  (s/keys :req-un [::id ::index]))
+
+(defmethod change-spec :add-color [_]
+  (s/keys :req-un [::color/color]))
+
+(defmethod change-spec :mod-color [_]
+  (s/keys :req-un [::color/color]))
+
+(defmethod change-spec :del-color [_]
+  (s/keys :req-un [::id]))
+
+(s/def :internal.changes.add-recent-color/color ::color/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)
+(defmethod change-spec :add-media [_]
+  (s/keys :req-un [:internal.changes.add-media/object]))
+
+
+(s/def :internal.changes.mod-media/width ::us/safe-integer)
+(s/def :internal.changes.mod-media/height ::us/safe-integer)
+(s/def :internal.changes.mod-media/path (s/nilable string?))
+(s/def :internal.changes.mod-media/mtype string?)
+(s/def :internal.changes.mod-media/object
+  (s/keys :req-un [::id]
+          :opt-un [:internal.changes.mod-media/width
+                   :internal.changes.mod-media/height
+                   :internal.changes.mod-media/path
+                   :internal.changes.mod-media/mtype]))
+
+(defmethod change-spec :mod-media [_]
+  (s/keys :req-un [:internal.changes.mod-media/object]))
+
+(defmethod change-spec :del-media [_]
+  (s/keys :req-un [::id]))
+
+(s/def :internal.changes.add-component/shapes
+  (s/coll-of ::shape/shape))
+
+(defmethod change-spec :add-component [_]
+  (s/keys :req-un [::id ::name :internal.changes.add-component/shapes]
+          :opt-un [::path]))
+
+(defmethod change-spec :mod-component [_]
+  (s/keys :req-un [::id]
+          :opt-un [::name :internal.changes.add-component/shapes]))
+
+(defmethod change-spec :del-component [_]
+  (s/keys :req-un [::id]))
+
+(defmethod change-spec :add-typography [_]
+  (s/keys :req-un [::typg/typography]))
+
+(defmethod change-spec :mod-typography [_]
+  (s/keys :req-un [::typg/typography]))
+
+(defmethod change-spec :del-typography [_]
+  (s/keys :req-un [::typg/id]))
+
+(s/def ::change (s/multi-spec change-spec :type))
+(s/def ::changes (s/coll-of ::change))

common/src/app/common/spec/color.cljc

@@ -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.common.spec.color
+  (:require
+   [app.common.spec :as us]
+   [clojure.spec.alpha :as s]))
+
+;; TODO: waiting clojure 1.11 to rename this all :internal.stuff to a
+;; more consistent name.
+
+;; TODO: maybe define ::color-hex-string with proper hex color spec?
+
+;; --- GRADIENTS
+
+(s/def ::id uuid?)
+
+(s/def :internal.gradient.stop/color string?)
+(s/def :internal.gradient.stop/opacity ::us/safe-number)
+(s/def :internal.gradient.stop/offset ::us/safe-number)
+
+(s/def :internal.gradient/type #{:linear :radial})
+(s/def :internal.gradient/start-x ::us/safe-number)
+(s/def :internal.gradient/start-y ::us/safe-number)
+(s/def :internal.gradient/end-x ::us/safe-number)
+(s/def :internal.gradient/end-y ::us/safe-number)
+(s/def :internal.gradient/width ::us/safe-number)
+
+(s/def :internal.gradient/stop
+  (s/keys :req-un [:internal.gradient.stop/color
+                   :internal.gradient.stop/opacity
+                   :internal.gradient.stop/offset]))
+
+(s/def :internal.gradient/stops
+  (s/coll-of :internal.gradient/stop :kind vector?))
+
+(s/def ::gradient
+  (s/keys :req-un [:internal.gradient/type
+                   :internal.gradient/start-x
+                   :internal.gradient/start-y
+                   :internal.gradient/end-x
+                   :internal.gradient/end-y
+                   :internal.gradient/width
+                   :internal.gradient/stops]))
+
+;;; --- COLORS
+
+(s/def :internal.color/name string?)
+(s/def :internal.color/path (s/nilable string?))
+(s/def :internal.color/value (s/nilable string?))
+(s/def :internal.color/color (s/nilable string?))
+(s/def :internal.color/opacity (s/nilable ::us/safe-number))
+(s/def :internal.color/gradient (s/nilable ::gradient))
+
+(s/def ::color
+  (s/keys :opt-un [::id
+                   :internal.color/name
+                   :internal.color/path
+                   :internal.color/value
+                   :internal.color/color
+                   :internal.color/opacity
+                   :internal.color/gradient]))
+
+(s/def ::recent-color
+  (s/keys :opt-un [:internal.color/value
+                   :internal.color/color
+                   :internal.color/opacity
+                   :internal.color/gradient]))
+
+
+
+

common/src/app/common/spec/export.cljc

@@ -0,0 +1,22 @@
+;; 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.spec.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?)
+
+(s/def ::export
+  (s/keys :req-un [::type
+                   ::suffix
+                   ::scale]))
+
+

common/src/app/common/spec/file.cljc

@@ -0,0 +1,60 @@
+;; 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.spec.file
+  (:require
+   [app.common.spec :as us]
+   [app.common.spec.color :as color]
+   [app.common.spec.page :as page]
+   [app.common.spec.typography]
+   [clojure.spec.alpha :as s]))
+
+(s/def :internal.media-object/name string?)
+(s/def :internal.media-object/width ::us/safe-integer)
+(s/def :internal.media-object/height ::us/safe-integer)
+(s/def :internal.media-object/mtype string?)
+
+;; NOTE: This is marked as nilable for backward compatibility, but
+;; right now is just exists or not exists. We can thin in a gradual
+;; migration and then mark it as not nilable.
+(s/def :internal.media-object/path (s/nilable string?))
+
+(s/def ::media-object
+  (s/keys :req-un [::id
+                   ::name
+                   :internal.media-object/width
+                   :internal.media-object/height
+                   :internal.media-object/mtype]
+          :opt-un [:internal.media-object/path]))
+
+(s/def ::colors
+  (s/map-of uuid? ::color/color))
+
+(s/def ::recent-colors
+  (s/coll-of ::color/recent-color :kind vector?))
+
+(s/def ::typographies
+  (s/map-of uuid? :app.common.spec.typography/typography))
+
+(s/def ::pages
+  (s/coll-of uuid? :kind vector?))
+
+(s/def ::media
+  (s/map-of uuid? ::media-object))
+
+(s/def ::pages-index
+  (s/map-of uuid? ::page/page))
+
+(s/def ::components
+  (s/map-of uuid? ::page/container))
+
+(s/def ::data
+  (s/keys :req-un [::pages-index
+                   ::pages]
+          :opt-un [::colors
+                   ::recent-colors
+                   ::typographies
+                   ::media]))

common/src/app/common/spec/interactions.cljc

@@ -4,7 +4,7 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.common.types.interactions
+(ns app.common.spec.interactions
   (:require
    [app.common.data :as d]
    [app.common.geom.point :as gpt]
@@ -100,7 +100,7 @@
                             :bottom-left
                             :bottom-right
                             :bottom-center})
-(s/def ::overlay-position ::us/point)
+(s/def ::overlay-position ::gpt/point)
 (s/def ::url ::us/string)
 (s/def ::close-click-outside ::us/boolean)
 (s/def ::background-overlay ::us/boolean)

common/src/app/common/spec/page.cljc

@@ -0,0 +1,128 @@
+;; 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.spec.page
+  (:require
+   [app.common.data :as d]
+   [app.common.spec :as us]
+   [app.common.spec.shape :as shape]
+   [clojure.spec.alpha :as s]))
+
+;; --- Grid options
+
+(s/def :internal.grid.color/color string?)
+(s/def :internal.grid.color/opacity ::us/safe-number)
+
+(s/def :internal.grid/size (s/nilable ::us/safe-integer))
+(s/def :internal.grid/item-length (s/nilable ::us/safe-number))
+
+(s/def :internal.grid/color (s/keys :req-un [:internal.grid.color/color
+                                             :internal.grid.color/opacity]))
+(s/def :internal.grid/type #{:stretch :left :center :right})
+(s/def :internal.grid/gutter (s/nilable ::us/safe-integer))
+(s/def :internal.grid/margin (s/nilable ::us/safe-integer))
+
+(s/def :internal.grid/square
+  (s/keys :req-un [:internal.grid/size
+                   :internal.grid/color]))
+
+(s/def :internal.grid/column
+  (s/keys :req-un [:internal.grid/color]
+          :opt-un [:internal.grid/size
+                   :internal.grid/type
+                   :internal.grid/item-length
+                   :internal.grid/margin
+                   :internal.grid/gutter]))
+
+(s/def :internal.grid/row :internal.grid/column)
+
+(s/def ::saved-grids
+  (s/keys :opt-un [:internal.grid/square
+                   :internal.grid/row
+                   :internal.grid/column]))
+
+;; --- Background options
+
+(s/def ::background string?)
+
+;; --- Flow options
+
+(s/def :internal.flow/id uuid?)
+(s/def :internal.flow/name string?)
+(s/def :internal.flow/starting-frame uuid?)
+
+(s/def ::flow
+  (s/keys :req-un [:internal.flow/id
+                   :internal.flow/name
+                   :internal.flow/starting-frame]))
+
+(s/def ::flows
+  (s/coll-of ::flow :kind vector?))
+
+;; --- Guides
+
+(s/def :internal.guides/id uuid?)
+(s/def :internal.guides/axis #{:x :y})
+(s/def :internal.guides/position ::us/safe-number)
+(s/def :internal.guides/frame-id (s/nilable uuid?))
+
+(s/def ::guide
+  (s/keys :req-un [:internal.guides/id
+                   :internal.guides/axis
+                   :internal.guides/position]
+          :opt-un [:internal.guides/frame-id]))
+
+(s/def ::guides
+  (s/map-of uuid? ::guide))
+
+;; --- Page Options
+
+(s/def ::options
+  (s/keys :opt-un [::background
+                   ::saved-grids
+                   ::flows
+                   ::guides]))
+
+;; --- Page
+
+(s/def ::id uuid?)
+(s/def ::name string?)
+(s/def ::objects (s/map-of uuid? ::shape/shape))
+
+(s/def ::page
+  (s/keys :req-un [::id ::name ::objects ::options]))
+
+(s/def ::type #{:page :component})
+(s/def ::path (s/nilable string?))
+(s/def ::container
+  (s/keys :req-un [::id ::name ::objects]
+          :opt-un [::type ::path]))
+
+;; --- Helpers for flow
+
+(defn rename-flow
+  [flow name]
+  (assoc flow :name name))
+
+(defn add-flow
+  [flows flow]
+  (conj (or flows []) flow))
+
+(defn remove-flow
+  [flows flow-id]
+  (d/removev #(= (:id %) flow-id) flows))
+
+(defn update-flow
+  [flows flow-id update-fn]
+  (let [index (d/index-of-pred flows #(= (:id %) flow-id))]
+    (update flows index update-fn)))
+
+(defn get-frame-flow
+  [flows frame-id]
+  (d/seek #(= (:starting-frame %) frame-id) flows))
+
+
+

common/src/app/common/spec/radius.cljc

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

common/src/app/common/spec/shadow.cljc

@@ -0,0 +1,37 @@
+;; 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.spec.shadow
+  (:require
+   [app.common.spec :as us]
+   [app.common.spec.color :as color]
+   [clojure.spec.alpha :as s]))
+
+
+;;; SHADOW EFFECT
+
+(s/def ::id uuid?)
+(s/def ::style #{:drop-shadow :inner-shadow})
+(s/def ::color ::color/color)
+(s/def ::offset-x ::us/safe-number)
+(s/def ::offset-y ::us/safe-number)
+(s/def ::blur ::us/safe-number)
+(s/def ::spread ::us/safe-number)
+(s/def ::hidden boolean?)
+
+(s/def ::shadow-props
+  (s/keys :req-un [:internal.shadow/id
+                   :internal.shadow/style
+                   :internal.shadow/color
+                   :internal.shadow/offset-x
+                   :internal.shadow/offset-y
+                   :internal.shadow/blur
+                   :internal.shadow/spread
+                   :internal.shadow/hidden]))
+
+(s/def ::shadow
+  (s/coll-of ::shadow-props :kind vector?))
+

common/src/app/common/spec/shape.cljc

@@ -0,0 +1,242 @@
+;; 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.spec.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.spec.color :as color]
+   [app.common.spec.export :as export]
+   [app.common.spec.interactions :as cti]
+   [app.common.spec.radius :as radius]
+   [app.common.spec.shadow :as shadow]
+   [clojure.set :as set]
+   [clojure.spec.alpha :as s]))
+
+;; --- Specs
+
+(s/def ::frame-id uuid?)
+(s/def ::id uuid?)
+(s/def ::name string?)
+(s/def ::path (s/nilable string?))
+(s/def ::page-id uuid?)
+(s/def ::parent-id uuid?)
+(s/def ::string string?)
+(s/def ::type keyword?)
+(s/def ::uuid uuid?)
+
+(s/def ::component-id uuid?)
+(s/def ::component-file uuid?)
+(s/def ::component-root? boolean?)
+(s/def ::shape-ref uuid?)
+
+;; Size constraints
+
+(s/def ::constraints-h #{:left :right :leftright :center :scale})
+(s/def ::constraints-v #{:top :bottom :topbottom :center :scale})
+(s/def ::fixed-scroll boolean?)
+
+;; Page Data related
+(s/def ::blocked boolean?)
+(s/def ::collapsed boolean?)
+
+(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-ref-file (s/nilable uuid?))
+(s/def ::fill-color-ref-id (s/nilable uuid?))
+
+(s/def ::hide-fill-on-export boolean?)
+
+(s/def ::masked-group? boolean?)
+(s/def ::font-family string?)
+(s/def ::font-size ::us/safe-integer)
+(s/def ::font-style string?)
+(s/def ::font-weight string?)
+(s/def ::hidden boolean?)
+(s/def ::letter-spacing ::us/safe-number)
+(s/def ::line-height ::us/safe-number)
+(s/def ::locked boolean?)
+(s/def ::page-id uuid?)
+(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-ref-file (s/nilable uuid?))
+(s/def ::stroke-color-ref-id (s/nilable uuid?))
+(s/def ::stroke-opacity ::us/safe-number)
+(s/def ::stroke-style #{:solid :dotted :dashed :mixed :none :svg})
+
+(def stroke-caps-line #{:round :square})
+(def stroke-caps-marker #{:line-arrow :triangle-arrow :square-marker :circle-marker :diamond-marker})
+(def stroke-caps (set/union stroke-caps-line stroke-caps-marker))
+
+(s/def ::stroke-cap-start stroke-caps)
+(s/def ::stroke-cap-end stroke-caps)
+
+(s/def ::stroke-width ::us/safe-number)
+(s/def ::stroke-alignment #{:center :inner :outer})
+(s/def ::text-align #{"left" "right" "center" "justify"})
+(s/def ::x ::us/safe-number)
+(s/def ::y ::us/safe-number)
+(s/def ::cx ::us/safe-number)
+(s/def ::cy ::us/safe-number)
+(s/def ::width ::us/safe-number)
+(s/def ::height ::us/safe-number)
+(s/def ::index integer?)
+
+(s/def ::x1 ::us/safe-number)
+(s/def ::y1 ::us/safe-number)
+(s/def ::x2 ::us/safe-number)
+(s/def ::y2 ::us/safe-number)
+
+(s/def ::selrect
+  (s/keys :req-un [::x ::y ::x1 ::y1 ::x2 ::y2 ::width ::height]))
+
+(s/def ::exports
+  (s/coll-of ::export/export :kind vector?))
+
+(s/def ::points
+  (s/every ::gpt/point :kind vector?))
+
+(s/def ::shapes
+  (s/every uuid? :kind vector?))
+
+(s/def ::transform ::gmt/matrix)
+(s/def ::transform-inverse ::gmt/matrix)
+(s/def ::opacity ::us/safe-number)
+(s/def ::blend-mode
+  #{:normal
+    :darken
+    :multiply
+    :color-burn
+    :lighten
+    :screen
+    :color-dodge
+    :overlay
+    :soft-light
+    :hard-light
+    :difference
+    :exclusion
+    :hue
+    :saturation
+    :color
+    :luminosity})
+
+(s/def ::shape-attrs
+  (s/keys :opt-un [::id
+                   ::type
+                   ::name
+                   ::component-id
+                   ::component-file
+                   ::component-root?
+                   ::shape-ref
+                   ::selrect
+                   ::points
+                   ::blocked
+                   ::collapsed
+                   ::fill-color
+                   ::fill-opacity
+                   ::fill-color-gradient
+                   ::fill-color-ref-file
+                   ::fill-color-ref-id
+                   ::hide-fill-on-export
+                   ::font-family
+                   ::font-size
+                   ::font-style
+                   ::font-weight
+                   ::hidden
+                   ::letter-spacing
+                   ::line-height
+                   ::locked
+                   ::proportion
+                   ::proportion-lock
+                   ::constraints-h
+                   ::constraints-v
+                   ::fixed-scroll
+                   ::radius/rx
+                   ::radius/ry
+                   ::radius/r1
+                   ::radius/r2
+                   ::radius/r3
+                   ::radius/r4
+                   ::x
+                   ::y
+                   ::exports
+                   ::shapes
+                   ::stroke-color
+                   ::stroke-color-ref-file
+                   ::stroke-color-ref-id
+                   ::stroke-opacity
+                   ::stroke-style
+                   ::stroke-width
+                   ::stroke-alignment
+                   ::stroke-cap-start
+                   ::stroke-cap-end
+                   ::text-align
+                   ::transform
+                   ::transform-inverse
+                   ::width
+                   ::height
+                   ::masked-group?
+                   ::cti/interactions
+                   ::shadow/shadow
+                   ::blur/blur
+                   ::opacity
+                   ::blend-mode]))
+
+(s/def :internal.shape.text/type #{"root" "paragraph-set" "paragraph"})
+(s/def :internal.shape.text/children
+  (s/coll-of :internal.shape.text/content
+             :kind vector?
+             :min-count 1))
+
+(s/def :internal.shape.text/text string?)
+(s/def :internal.shape.text/key string?)
+
+(s/def :internal.shape.text/content
+  (s/nilable
+   (s/or :text-container
+         (s/keys :req-un [:internal.shape.text/type
+                          :internal.shape.text/children]
+                 :opt-un [:internal.shape.text/key])
+         :text-content
+         (s/keys :req-un [:internal.shape.text/text]))))
+
+(s/def :internal.shape.path/command keyword?)
+(s/def :internal.shape.path/params
+  (s/nilable (s/map-of keyword? any?)))
+
+(s/def :internal.shape.path/command-item
+  (s/keys :req-un [:internal.shape.path/command]
+          :opt-un [:internal.shape.path/params]))
+
+(s/def :internal.shape.path/content
+  (s/coll-of :internal.shape.path/command-item :kind vector?))
+
+(defmulti shape-spec :type)
+
+(defmethod shape-spec :default [_]
+  (s/spec ::shape-attrs))
+
+(defmethod shape-spec :text [_]
+  (s/and ::shape-attrs
+         (s/keys :opt-un [:internal.shape.text/content])))
+
+(defmethod shape-spec :path [_]
+  (s/and ::shape-attrs
+         (s/keys :opt-un [:internal.shape.path/content])))
+
+(defmethod shape-spec :frame [_]
+  (s/and ::shape-attrs
+         (s/keys :opt-un [::hide-fill-on-export])))
+
+(s/def ::shape
+  (s/and (s/multi-spec shape-spec :type)
+         #(contains? % :type)
+         #(contains? % :name)))