⬆️ Update version 1.13.2-beta

⚡ Improved frame generation performance

.circleci/config.yml

@@ -2,20 +2,13 @@ version: 2
 jobs:
   build:
     docker:
-      # specify the version you desire here
       - image: penpotapp/devenv:latest
-
-      # Specify service dependencies here if necessary
-      # CircleCI maintains a library of pre-built images
-      # documented at https://circleci.com/docs/2.0/circleci-images/
-      # - image: circleci/postgres:9.4
-      - image: circleci/postgres:13.3-ram
+      - image: cimg/postgres:13.5
         environment:
           POSTGRES_USER: penpot_test
           POSTGRES_PASSWORD: penpot_test
           POSTGRES_DB: penpot_test
-
-      - image: circleci/redis:6.0.8
+      - image: cimg/redis:6.2.6
 
     working_directory: ~/repo
 

.clj-kondo/config.edn

@@ -1,14 +1,18 @@
 {:lint-as
  {promesa.core/let clojure.core/let
+  promesa.core/->> clojure.core/->>
+  promesa.core/-> clojure.core/->
   rumext.alpha/defc clojure.core/defn
   rumext.alpha/fnc clojure.core/fn
   app.common.data/export clojure.core/def
   app.db/with-atomic clojure.core/with-open
+  app.common.data.macros/get-in clojure.core/get-in
+  app.common.data.macros/select-keys clojure.core/select-keys
   app.common.logging/with-context clojure.core/do}
 
  :hooks
  {:analyze-call
-  {app.common.data/export hooks.export/export
+  {app.common.data.macros/export hooks.export/export
    potok.core/reify hooks.export/potok-reify
    app.util.services/defmethod hooks.export/service-defmethod
    }}

CHANGES.md

@@ -1,5 +1,165 @@
 # CHANGELOG
 
+## :rocket: Next
+
+### :boom: Breaking changes
+### :sparkles: New features
+### :bug: Bugs fixed
+### :arrow_up: Deps updates
+### :heart: Community contributions by (Thank you!)
+
+## 1.13.2-beta
+
+### :bug: Bugs fixed
+
+- Improved performance when out of focus mode
+- Improved performance for thumbnail generation
+- Fix problem with out of sync thumbnails
+
+## 1.13.1-beta
+
+### :bug: Bugs fixed
+
+- Fix problem with text positioning
+- Fix issue with thumbnail generation before fonts loading
+- Fix unable to hide artboards
+- Fix problem with fonts cache causing hanging in certain pages
+
+## 1.13.0-beta
+
+### :boom: Breaking changes
+
+- We've changed the behaviour of the border-radius so it works as CSS that [has some limits](https://www.w3.org/TR/css-backgrounds-3/#corner-overlap).
+- Now exported text are SVG's native `text` tag instead of paths. This could break when opening the file depending on your engine. Some SVG's may require fonts to be installed at system level.
+
+### :sparkles: New features
+
+- Search and filter layers [Taiga #2564](https://tree.taiga.io/project/penpot/us/2564)
+- Exporting big files flow [Taiga #2218](https://tree.taiga.io/project/penpot/us/2218)
+- Multiexport from main menu [Taiga #520](https://tree.taiga.io/project/penpot/us/28541)
+- Multiexport assets (aka bulk export) [Taiga #520](https://tree.taiga.io/project/penpot/us/520)
+- Set the artboard layer fixed at the top side of the layers [Taiga #2636](https://tree.taiga.io/project/penpot/us/2636)
+- Set an artboard as the file thumbnail [Taiga #1526](https://tree.taiga.io/project/penpot/us/1526)
+- Social login redesign [Taiga #2974](https://tree.taiga.io/project/penpot/task/2974)
+- Add border radius to artboards [Taiga #2056](https://tree.taiga.io/project/penpot/us/2056)
+- Allow send multiple team invitations at once [Taiga #2798](https://tree.taiga.io/project/penpot/us/2798)
+- Persist color palette and color picker across refresh [Taiga #1660](https://tree.taiga.io/project/penpot/issue/1660)
+- Ability to add multiple strokes to a shape [Taiga #2778](https://tree.taiga.io/project/penpot/us/2778)
+- Scroll to selected size in font size selector [Taiga #2825](https://tree.taiga.io/project/penpot/us/2825)
+- Add new invitations section [Taiga #2797](https://tree.taiga.io/project/penpot/us/2797)
+- Ability to add multiple fills to a shape [Taiga #1394](https://tree.taiga.io/project/penpot/us/1394)
+- Team members redesign [Taiga #2283](https://tree.taiga.io/project/penpot/us/2283)
+- New focus mode in workspace [Taiga #2748](https://tree.taiga.io/project/penpot/us/2748)
+- Changed text shapes to be displayed as natives SVG text elements [Taiga #2759](https://tree.taiga.io/project/penpot/us/2759)
+- Texts now can have strokes, multiple fills and can be used as masks
+- Add the ability to specify the attribute for retrieve the email on OIDC integration [#1460](https://github.com/penpot/penpot/issues/1460)
+- Allow registration with invitation token when registration is disabled
+- Add the ability to disable standard, password login [Taiga #2999](https://tree.taiga.io/project/penpot/us/2999)
+- Don't stop SVG import when an image cannot be imported [#1531](https://github.com/penpot/penpot/issues/1531)
+- Show Penpot color in Safari tab bar [#1803](https://github.com/penpot/penpot/issues/1803)
+- Added option to disable snap to pixel and improved behaviour for sub-pixel drawing [#2552](https://tree.taiga.io/project/penpot/us/2552)
+- Delete guides while supr on hover [#2823](https://tree.taiga.io/project/penpot/us/2823)
+- Opt-in subscription on on-premise instances [#2772](https://tree.taiga.io/project/penpot/us/2772)
+- Optimizations in frame thumbnails [#3147](https://tree.taiga.io/project/penpot/us/3147)
+
+### :bug: Bugs fixed
+
+- Fix typo in viewer comment section [Taiga #3401](https://tree.taiga.io/project/penpot/issue/3401)
+- Do not show team-up modal for users already on a team [Taiga #3311](https://tree.taiga.io/project/penpot/issue/3311)
+- Constraints are not well assigned when default and multiselection [Taiga #3069](https://tree.taiga.io/project/penpot/issue/3069)
+- Duplicate artboards create new flows if needed [Taiga #2221](https://tree.taiga.io/project/penpot/issue/2221)
+- Round the size values on handoff to two decimals [Taiga #3227](https://tree.taiga.io/project/penpot/issue/3227)
+- Fix paste shapes while editing text [Taiga #2396](https://tree.taiga.io/project/penpot/issue/2396)
+- Fix blend modes ignored in component updates [Taiga #2626](https://tree.taiga.io/project/penpot/issue/2626)
+- Fix internal error when hoverin over shape [Taiga #3237](https://tree.taiga.io/project/penpot/issue/3237)
+- Fix mouse leave in handoff close overlay animation breaks [Taiga #3173](https://tree.taiga.io/project/penpot/issue/3173)
+- Fix different behaviour during image drag [Taiga #2279](https://tree.taiga.io/project/penpot/issue/2279)
+- Fix hidden file name on import [Taiga #3172](https://tree.taiga.io/project/penpot/issue/3172)
+- Fix unneccessary scrollbars at the color list [Taiga #3211](https://tree.taiga.io/project/penpot/issue/3211)
+- "Show in exports" is showing in multiselections [Taiga #3194](https://tree.taiga.io/project/penpot/issue/3194)
+- Edit file name navigates to the file workspace [Taiga #3183](https://tree.taiga.io/project/penpot/issue/3183)
+- Fix scroll into view behind fixed element [Taiga #3170](https://tree.taiga.io/project/penpot/issue/3170)
+- Fix sidebar icon in viewer mode [Taiga #3184](https://tree.taiga.io/project/penpot/issue/3184)
+- Fix send to back several shapes at a time [Taiga #3077](https://tree.taiga.io/project/penpot/issue/3077)
+- Fix duplicate multi selected elements [Taiga #3155](https://tree.taiga.io/project/penpot/issue/3155)
+- Fix add fills to artboard modify children [Taiga #3151](https://tree.taiga.io/project/penpot/issue/3151)
+- Avoid numeric inputs to allow big numbers [Taiga #2858](https://tree.taiga.io/project/penpot/issue/2858)
+- Fix component contex menu size [Taiga #2480](https://tree.taiga.io/project/penpot/issue/2480)
+- Add shadow to artboard make it lose the fill [Taiga #3139](https://tree.taiga.io/project/penpot/issue/3139)
+- Avoid numeric inputs to change its value without focusing them [Taiga #3140](https://tree.taiga.io/project/penpot/issue/3140)
+- Fix comments modal when changing pages [Taiga #2597](https://tree.taiga.io/project/penpot/issue/2508)
+- Copy paste inside a text layer leaves pasted text transparent [Taiga #3096](https://tree.taiga.io/project/penpot/issue/3096)
+- On dashboard enter on empty search refresh the page [Taiga #2597](https://tree.taiga.io/project/penpot/issue/2597)
+- Pencil cursor changes when activated [Taiga #2276](https://tree.taiga.io/project/penpot/issue/2276)
+- Fix icon placement in Mixed message [Taiga #3037](https://tree.taiga.io/project/penpot/issue/3037)
+- Fix scroll in comment section [Taiga #3068](https://tree.taiga.io/project/penpot/issue/3068)
+- Remove a decimal sets value to 0 [Taiga #3059](https://tree.taiga.io/project/penpot/issue/3054)
+- Go to style library file to edit in a new tab [Taiga #2639](https://tree.taiga.io/project/penpot/issue/2639)
+- Inner shadow with border not working properly [Taiga #2883](https://tree.taiga.io/project/penpot/issue/2883)
+- Fix ellipsis in long page names [Taiga #2962](https://tree.taiga.io/project/penpot/issue/2962)
+- Fix color palette animation [Taiga #2852](https://tree.taiga.io/project/penpot/issue/2852)
+- Fix display code icon on preview hover [Taiga #2838](https://tree.taiga.io/project/penpot/us/2838)
+- Fix crash on iOS when displaying viewer [#1522](https://github.com/penpot/penpot/issues/1522)
+- Fix problem when importing a SVG with text [#1532](https://github.com/penpot/penpot/issues/1532)
+- Fix problem when adding shadows to imported text [#Taiga 3057](https://tree.taiga.io/project/penpot/issue/3057)
+- Fix problem when importing SVG's with uses with overriding properties [#Taiga 2884](https://tree.taiga.io/project/penpot/issue/2884)
+- Fix inconsistency with radius in SVG an CSS [#1587](https://github.com/penpot/penpot/issues/1587)
+- Fix clickable area in layers [#1680](https://github.com/penpot/penpot/issues/1680)
+- Fix problems with trackpad zoom and scroll in MacOS [#1161](https://github.com/penpot/penpot/issues/1161)
+- Fix problem with copy/paste in Safari [#1209](https://github.com/penpot/penpot/issues/1209)
+- Fix paste ordering for frames not being respected [Taiga #3097](https://tree.taiga.io/project/penpot/issue/3097)
+- Improved command support for MacOS [Taiga #2789](https://tree.taiga.io/project/penpot/issue/2789)
+- Fix shift+2 shortcut in MacOS with non-english keyboards [Taiga #3038](https://tree.taiga.io/project/penpot/issue/3038)
+- Some fixes to SVG imports [Taiga #3122](https://tree.taiga.io/project/penpot/issue/3122) [#1720](https://github.com/penpot/penpot/issues/1720) [Taiga #2884](https://tree.taiga.io/project/penpot/issue/2884)
+- Fix drag guides to delete target area [#1679](https://github.com/penpot/penpot/issues/1679)
+- Fix undo when rotating groups [Taiga #3136](https://tree.taiga.io/project/penpot/issue/3136)
+- Fix component name in sidebar widget [Taiga #3144](https://tree.taiga.io/project/penpot/issue/3144)
+- Fix resize rotated shape with top&down constraints [Taiga #3167](https://tree.taiga.io/project/penpot/issue/3167)
+- Fix multi user not working [Taiga #3195](https://tree.taiga.io/project/penpot/issue/3195)
+- Fix guides are not duplicated with the artboard [Taiga #3072](https://tree.taiga.io/project/penpot/issue/3072)
+- Fix problem when changing group size with decimal values [Taiga #3203](https://tree.taiga.io/project/penpot/issue/3203)
+- Fix error when drawing curves with only one point [Taiga #3282](https://tree.taiga.io/project/penpot/issue/3282)
+- Fix issue with paste ordering sometimes not being respected [Taiga #3268](https://tree.taiga.io/project/penpot/issue/3268)
+- Fix problem when export/importing guides attached to frame [#1838](https://github.com/penpot/penpot/issues/1838)
+- Fix problem when resizing a group with texts with auto-width/height [#3171](https://tree.taiga.io/project/penpot/issue/3171)
+
+### :arrow_up: Deps updates
+### :heart: Community contributions by (Thank you!)
+
+## 1.12.4-beta
+
+### :bug: Bugs fixed
+
+- Fix crash on iOS when displaying viewer [#1522](https://github.com/penpot/penpot/issues/1522)
+- Fix problems with trackpad zoom and scroll in MacOS [#1161](https://github.com/penpot/penpot/issues/1161)
+- Fix problem with copy/paste in Safari [#1209](https://github.com/penpot/penpot/issues/1209)
+- Improved command support for MacOS [Taiga #2789](https://tree.taiga.io/project/penpot/issue/2789)
+- Fix shift+2 shortcut in MacOS with non-english keyboards [Taiga #3038](https://tree.taiga.io/project/penpot/issue/3038)
+
+## 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
@@ -31,7 +191,7 @@
 
 ### :bug: Bugs fixed
 
-- Fixed ungroup typography when editing it [Taiga #2391](https://tree.taiga.io/project/penpot/issue/2391) 
+- 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)

CONTRIBUTING.md

@@ -93,12 +93,24 @@ More info:
 Each commit should have:
 
 - A concise subject using imperative mood.
-- The subject should have capitalized the first letter and without
-  period at the end.
+- The subject should have capitalized the first letter, without period
+  at the end and no larger than 65 characters.
 - A blank line between the subject line and the body.
 - An entry on the CHANGES.md file if applicable, referencing the
   github or taiga issue/user-story using the these same rules.
 
+Examples of good commit messags:
+
+- :bug: Fix unexpected error on launching modal
+- :bug: Set proper error message on generic error
+- :sparkles: Enable new modal for profile
+- :zap: Improve performance of dashboard navigation
+- :wrench: Update default backend configuration
+- :books: Add more documentation for authentication process
+- :ambulance: Fix critical bug on user registration process
+- :tada: Add new approach for user registration
+
+
 ## Code of conduct ##
 
 As contributors and maintainers of this project, we pledge to respect

backend/deps.edn

@@ -1,31 +1,32 @@
 {: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.2-1"}
+  com.github.luben/zstd-jni {:mvn/version "1.5.2-2"}
   org.clojure/data.fressian {:mvn/version "1.0.0"}
 
-  io.prometheus/simpleclient {:mvn/version "0.14.1"}
-  io.prometheus/simpleclient_hotspot {:mvn/version "0.14.1"}
-  io.prometheus/simpleclient_jetty {:mvn/version "0.14.1"
+  io.prometheus/simpleclient {:mvn/version "0.15.0"}
+  io.prometheus/simpleclient_hotspot {:mvn/version "0.15.0"}
+  io.prometheus/simpleclient_jetty {:mvn/version "0.15.0"
                                     :exclusions [org.eclipse.jetty/jetty-server
                                                  org.eclipse.jetty/jetty-servlet]}
-  io.prometheus/simpleclient_httpserver {:mvn/version "0.14.1"}
+  io.prometheus/simpleclient_httpserver {:mvn/version "0.15.0"}
 
   io.lettuce/lettuce-core {:mvn/version "6.1.6.RELEASE"}
   java-http-clj/java-http-clj {:mvn/version "0.4.3"}
 
-  funcool/yetti {:git/tag "v4.0" :git/sha "59ed2a7"
+  funcool/yetti {:git/tag "v9.1" :git/sha "63f35d9"
                  :git/url "https://github.com/funcool/yetti.git"
                  :exclusions [org.slf4j/slf4j-api]}
 
-  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.2"}
+  com.github.seancorfield/next.jdbc {:mvn/version "1.2.772"}
+  metosin/reitit-core {:mvn/version "0.5.16"}
+  org.postgresql/postgresql {:mvn/version "42.3.3"}
   com.zaxxer/HikariCP {:mvn/version "5.0.1"}
   funcool/datoteka {:mvn/version "2.0.0"}
 
@@ -41,9 +42,12 @@
 
   io.sentry/sentry {:mvn/version "5.6.1"}
 
+  dawran6/emoji {:mvn/version "0.1.5"}
+  markdown-clj/markdown-clj {:mvn/version "1.11.0"}
+
   ;; Pretty Print specs
   pretty-spec/pretty-spec {:mvn/version "0.1.4"}
-  software.amazon.awssdk/s3 {:mvn/version "2.17.122"}}
+  software.amazon.awssdk/s3 {:mvn/version "2.17.136"}}
 
  :paths ["src" "resources" "target/classes"]
  :aliases
@@ -60,7 +64,7 @@
 
   :build
   {:extra-deps
-   {io.github.clojure/tools.build {:git/tag "v0.7.5" :git/sha "34727f7"}}
+   {io.github.clojure/tools.build {:git/tag "v0.7.7" :git/sha "1474ad6"}}
    :ns-default build}
 
   :test

backend/scripts/build

@@ -8,6 +8,7 @@ rm -rf target;
 mkdir -p target/classes;
 mkdir -p target/dist;
 echo "$CURRENT_VERSION" > target/classes/version.txt;
+cp ../CHANGES.md target/classes/changelog.md;
 
 clojure -T:build jar;
 mv target/penpot.jar target/dist/penpot.jar

backend/scripts/repl

@@ -1,5 +1,9 @@
 #!/usr/bin/env bash
 
+export PENPOT_HOST=devenv
+export PENPOT_TENANT=dev
+export PENPOT_FLAGS="$PENPOT_FLAGS enable-backend-asserts enable-audit-log enable-transit-readable-response enable-demo-users disable-secure-session-cookies"
+
 # export PENPOT_DATABASE_URI="postgresql://172.17.0.1:5432/penpot"
 # export PENPOT_DATABASE_USERNAME="penpot"
 # export PENPOT_DATABASE_PASSWORD="penpot"
@@ -8,25 +12,28 @@
 # export PENPOT_DATABASE_URI="postgresql://172.17.0.1:5432/penpot_pre"
 # export PENPOT_DATABASE_USERNAME="penpot_pre"
 # export PENPOT_DATABASE_PASSWORD="penpot_pre"
-# export PENPOT_FLAGS="enable-asserts enable-audit-log $PENPOT_FLAGS"
+
+# export PENPOT_LOGGERS_LOKI_URI="http://172.17.0.1:3100/loki/api/v1/push"
+# export PENPOT_AUDIT_LOG_ARCHIVE_URI="http://localhost:6070/api/audit"
 
 # 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
+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-fs
+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 \
+       -A:dev:jmx-remote \
        -J-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager \
        -J-Dlog4j2.configurationFile=log4j2-devenv.xml \
-       -J-XX:+UseZGC \
+       -J-XX:+UseG1GC \
        -J-XX:-OmitStackTraceInFastThrow \
        -J-Xms50m -J-Xmx1024m \
        -J-Djdk.attach.allowAttachSelf \

backend/scripts/start-dev

@@ -1,6 +1,8 @@
 #!/usr/bin/env bash
 
-export PENPOT_FLAGS="$PENPOT_FLAGS enable-asserts"
+export PENPOT_HOST=devenv
+export PENPOT_TENANT=dev
+export PENPOT_FLAGS="$PENPOT_FLAGS enable-backend-asserts enable-audit-log enable-transit-readable-response enable-demo-users disable-secure-session-cookies"
 
 set -ex
 

backend/src/app/cli/migrate_media.clj

@@ -1,129 +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.cli.migrate-media
-  (:require
-   [app.common.logging :as l]
-   [app.common.media :as cm]
-   [app.config :as cf]
-   [app.db :as db]
-   [app.main :as main]
-   [app.storage :as sto]
-   [cuerdas.core :as str]
-   [datoteka.core :as fs]
-   [integrant.core :as ig]))
-
-(declare migrate-profiles)
-(declare migrate-teams)
-(declare migrate-file-media)
-
-(defn run-in-system
-  [system]
-  (db/with-atomic [conn (:app.db/pool system)]
-    (let [system (assoc system ::conn conn)]
-      (migrate-profiles system)
-      (migrate-teams system)
-      (migrate-file-media system))
-    system))
-
-(defn run
-  []
-  (let [config (select-keys main/system-config
-                            [:app.db/pool
-                             :app.migrations/migrations
-                             :app.metrics/metrics
-                             :app.storage.s3/backend
-                             :app.storage.db/backend
-                             :app.storage.fs/backend
-                             :app.storage/storage])]
-    (ig/load-namespaces config)
-    (try
-      (-> (ig/prep config)
-          (ig/init)
-          (run-in-system)
-          (ig/halt!))
-      (catch Exception e
-        (l/error :hint "unhandled exception" :cause e)))))
-
-
-;; --- IMPL
-
-(defn migrate-profiles
-  [{:keys [::conn] :as system}]
-  (letfn [(retrieve-profiles [conn]
-            (->> (db/exec! conn ["select * from profile"])
-                 (filter #(not (str/empty? (:photo %))))
-                 (seq)))]
-    (let [base    (fs/path (cf/get :storage-fs-old-directory))
-          storage (-> (:app.storage/storage system)
-                      (assoc :conn conn))]
-      (doseq [profile (retrieve-profiles conn)]
-        (let [path  (fs/path (:photo profile))
-              full  (-> (fs/join base path)
-                        (fs/normalize))
-              ext   (fs/ext path)
-              mtype (cm/format->mtype (keyword ext))
-              obj   (sto/put-object storage {:content (sto/content full)
-                                             :content-type mtype})]
-          (db/update! conn :profile
-                      {:photo-id (:id obj)}
-                      {:id (:id profile)}))))))
-
-(defn migrate-teams
-  [{:keys [::conn] :as system}]
-  (letfn [(retrieve-teams [conn]
-            (->> (db/exec! conn ["select * from team"])
-                 (filter #(not (str/empty? (:photo %))))
-                 (seq)))]
-    (let [base    (fs/path (cf/get :storage-fs-old-directory))
-          storage (-> (:app.storage/storage system)
-                      (assoc :conn conn))]
-      (doseq [team (retrieve-teams conn)]
-        (let [path  (fs/path (:photo team))
-              full  (-> (fs/join base path)
-                        (fs/normalize))
-              ext   (fs/ext path)
-              mtype (cm/format->mtype (keyword ext))
-              obj   (sto/put-object storage {:content (sto/content full)
-                                             :content-type mtype})]
-          (db/update! conn :team
-                      {:photo-id (:id obj)}
-                      {:id (:id team)}))))))
-
-
-
-(defn migrate-file-media
-  [{:keys [::conn] :as system}]
-  (letfn [(retrieve-media-objects [conn]
-            (->> (db/exec! conn ["select fmo.id, fmo.path, fth.path as thumbnail_path
-                                    from file_media_object as fmo
-                                    join file_media_thumbnail as fth on (fth.media_object_id = fmo.id)"])
-                 (seq)))]
-    (let [base    (fs/path (cf/get :storage-fs-old-directory))
-          storage (-> (:app.storage/storage system)
-                      (assoc :conn conn))]
-      (doseq [mobj (retrieve-media-objects conn)]
-        (let [img-path  (fs/path (:path mobj))
-              thm-path  (fs/path (:thumbnail-path mobj))
-              img-path  (-> (fs/join base img-path)
-                            (fs/normalize))
-              thm-path  (-> (fs/join base thm-path)
-                            (fs/normalize))
-              img-ext   (fs/ext img-path)
-              thm-ext   (fs/ext thm-path)
-
-              img-mtype (cm/format->mtype (keyword img-ext))
-              thm-mtype (cm/format->mtype (keyword thm-ext))
-
-              img-obj   (sto/put-object storage {:content (sto/content img-path)
-                                                 :content-type img-mtype})
-              thm-obj   (sto/put-object storage {:content (sto/content thm-path)
-                                                 :content-type thm-mtype})]
-
-          (db/update! conn :file-media-object
-                      {:media-id (:id img-obj)
-                       :thumbnail-id (:id thm-obj)}
-                      {:id (:id mobj)}))))))

backend/src/app/config.clj

@@ -41,21 +41,22 @@
     data))
 
 (def defaults
-  {:host "devenv"
-   :tenant "dev"
+  {
    :database-uri "postgresql://postgres/penpot"
    :database-username "penpot"
    :database-password "penpot"
 
-   :default-blob-version 3
+   :default-blob-version 4
    :loggers-zmq-uri "tcp://localhost:45556"
 
    :file-change-snapshot-every 5
    :file-change-snapshot-timeout "3h"
 
    :public-uri "http://localhost:3449"
-   :redis-uri "redis://redis/0"
+   :host "localhost"
+   :tenant "main"
 
+   :redis-uri "redis://redis/0"
    :srepl-host "127.0.0.1"
    :srepl-port 6062
 
@@ -63,11 +64,6 @@
    :storage-assets-fs-directory "assets"
 
    :assets-path "/internal/assets/"
-
-   :rlimit-password 10
-   :rlimit-image 2
-   :rlimit-font 5
-
    :smtp-default-reply-to "Penpot <no-reply@example.com>"
    :smtp-default-from "Penpot <no-reply@example.com>"
 
@@ -90,7 +86,7 @@
 
 (s/def ::flags ::us/set-of-keywords)
 
-;; DEPRECATED PROPERTIES: should be removed in 1.10
+;; DEPRECATED PROPERTIES
 (s/def ::registration-enabled ::us/boolean)
 (s/def ::smtp-enabled ::us/boolean)
 (s/def ::telemetry-enabled ::us/boolean)
@@ -138,11 +134,15 @@
 (s/def ::oidc-scopes ::us/set-of-str)
 (s/def ::oidc-roles ::us/set-of-str)
 (s/def ::oidc-roles-attr ::us/keyword)
+(s/def ::oidc-email-attr ::us/keyword)
+(s/def ::oidc-name-attr ::us/keyword)
 (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-server-max-body-size ::us/integer)
+(s/def ::http-server-max-multipart-body-size ::us/integer)
+(s/def ::http-server-io-threads ::us/integer)
+(s/def ::http-server-worker-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)
@@ -171,6 +171,7 @@
 (s/def ::redis-uri ::us/string)
 (s/def ::registration-domain-whitelist ::us/set-of-str)
 (s/def ::rlimit-font ::us/integer)
+(s/def ::rlimit-file-update ::us/integer)
 (s/def ::rlimit-image ::us/integer)
 (s/def ::rlimit-password ::us/integer)
 (s/def ::smtp-default-from ::us/string)
@@ -239,12 +240,16 @@
                    ::oidc-user-uri
                    ::oidc-scopes
                    ::oidc-roles-attr
+                   ::oidc-email-attr
+                   ::oidc-name-attr
                    ::oidc-roles
                    ::host
                    ::http-server-host
                    ::http-server-port
-                   ::http-server-max-threads
-                   ::http-server-min-threads
+                   ::http-server-max-body-size
+                   ::http-server-max-multipart-body-size
+                   ::http-server-io-threads
+                   ::http-server-worker-threads
                    ::http-session-idle-max-age
                    ::http-session-updater-batch-max-age
                    ::http-session-updater-batch-max-size
@@ -273,6 +278,7 @@
                    ::registration-domain-whitelist
                    ::registration-enabled
                    ::rlimit-font
+                   ::rlimit-file-update
                    ::rlimit-image
                    ::rlimit-password
                    ::sentry-dsn
@@ -307,8 +313,7 @@
                    ::tenant]))
 
 (def default-flags
-  [:enable-backend-asserts
-   :enable-backend-api-doc
+  [:enable-backend-api-doc
    :enable-secure-session-cookies])
 
 (defn- parse-flags
@@ -339,8 +344,8 @@
       (when (ex/ex-info? e)
         (println ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;")
         (println "Error on validating configuration:")
-        (println (:explain (ex-data e))
-        (println ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;")))
+        (println (us/pretty-explain (ex-data e)))
+        (println ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"))
       (throw e))))
 
 (def version

backend/src/app/db.clj

@@ -233,21 +233,21 @@
   ([ds table params opts]
    (exec-one! ds
               (sql/insert table params opts)
-              (assoc opts :return-keys true))))
+              (merge {:return-keys true} opts))))
 
 (defn insert-multi!
   ([ds table cols rows] (insert-multi! ds table cols rows nil))
   ([ds table cols rows opts]
    (exec! ds
           (sql/insert-multi table cols rows opts)
-          (assoc opts :return-keys true))))
+          (merge {:return-keys true} opts))))
 
 (defn update!
   ([ds table params where] (update! ds table params where nil))
   ([ds table params where opts]
    (exec-one! ds
               (sql/update table params where opts)
-              (assoc opts :return-keys true))))
+              (merge {:return-keys true} opts))))
 
 (defn delete!
   ([ds table params] (delete! ds table params nil))

backend/src/app/emails.clj

@@ -8,6 +8,7 @@
   "Main api for send emails."
   (:require
    [app.common.logging :as l]
+   [app.common.pprint :as pp]
    [app.common.spec :as us]
    [app.config :as cf]
    [app.db :as db]
@@ -165,19 +166,25 @@
     (let [enabled? (or (contains? cf/flags :smtp)
                        (cf/get :smtp-enabled)
                        (:enabled task))]
-      (if enabled?
-        (emails/send! cfg props)
+      (when enabled?
+        (emails/send! cfg props))
+
+      (when (contains? cf/flags :log-emails)
         (send-console! cfg props)))))
 
 (defn- send-console!
-  [cfg email]
-  (let [baos (java.io.ByteArrayOutputStream.)
-        mesg (emails/smtp-message cfg email)]
-    (.writeTo mesg baos)
-    (let [out (with-out-str
-                (println "email console dump:")
-                (println "******** start email" (:id email) "**********")
-                (println (.toString baos))
-                (println "******** end email "(:id email) "**********"))]
-      (l/info :email out))))
+  [_ email]
+  (let [body (:body email)
+        out  (with-out-str
+               (println "email console dump:")
+               (println "******** start email" (:id email) "**********")
+               (pp/pprint (dissoc email :body))
+               (if (string? body)
+                 (println body)
+                 (println (->> body
+                               (filter #(= "text/plain" (:type %)))
+                               (map :content)
+                               first)))
+               (println "******** end email" (:id email) "**********"))]
+    (l/info ::l/raw out)))
 

backend/src/app/http.clj

@@ -7,21 +7,20 @@
 (ns app.http
   (:require
    [app.common.data :as d]
-   [app.common.exceptions :as ex]
    [app.common.logging :as l]
-   [app.common.spec :as us]
-   [app.config :as cf]
+   [app.common.transit :as t]
    [app.http.doc :as doc]
    [app.http.errors :as errors]
    [app.http.middleware :as middleware]
    [app.metrics :as mtx]
+   [app.worker :as wrk]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]
-   [reitit.ring :as rr]
-   [yetti.adapter :as yt])
-  (:import
-   org.eclipse.jetty.server.Server
-   org.eclipse.jetty.server.handler.StatisticsHandler))
+   [reitit.core :as r]
+   [reitit.middleware :as rr]
+   [yetti.adapter :as yt]
+   [yetti.request :as yrq]
+   [yetti.response :as yrs]))
 
 (declare wrap-router)
 
@@ -31,154 +30,153 @@
 
 (s/def ::handler fn?)
 (s/def ::router some?)
-(s/def ::port ::us/integer)
-(s/def ::host ::us/string)
-(s/def ::name ::us/string)
-(s/def ::max-threads ::cf/http-server-max-threads)
-(s/def ::min-threads ::cf/http-server-min-threads)
+(s/def ::port integer?)
+(s/def ::host string?)
+(s/def ::name string?)
+
+(s/def ::max-body-size integer?)
+(s/def ::max-multipart-body-size integer?)
+(s/def ::io-threads integer?)
+(s/def ::worker-threads integer?)
 
 (defmethod ig/prep-key ::server
   [_ cfg]
   (merge {:name "http"
-          :min-threads 4
-          :max-threads 60
           :port 6060
-          :host "0.0.0.0"}
+          :host "0.0.0.0"
+          :max-body-size (* 1024 1024 30)             ; 30 MiB
+          :max-multipart-body-size (* 1024 1024 120)} ; 120 MiB
          (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]
-  (let [stats (doto (StatisticsHandler.)
-                (.setHandler (.getHandler server)))]
-    (.setHandler server stats)
-    (mtx/instrument-jetty! (:registry metrics) stats)
-    server))
+  (s/and
+   (s/keys :req-un [::port ::host ::name ::max-body-size ::max-multipart-body-size]
+           :opt-un [::router ::handler ::io-threads ::worker-threads ::wrk/executor])
+   (fn [cfg]
+     (or (contains? cfg :router)
+         (contains? cfg :handler)))))
 
 (defmethod ig/init-key ::server
-  [_ {:keys [handler router port name metrics host] :as opts}]
-  (l/info :hint "starting http server"
-          :port port :host host :name name
-          :min-threads (:min-threads opts)
-          :max-threads (:max-threads opts))
+  [_ {:keys [handler router port name host] :as cfg}]
+  (l/info :hint "starting http server" :port port :host host :name name)
   (let [options {:http/port port
                  :http/host host
-                 :thread-pool/max-threads (:max-threads opts)
-                 :thread-pool/min-threads (:min-threads opts)
+                 :http/max-body-size (:max-body-size cfg)
+                 :http/max-multipart-body-size (:max-multipart-body-size cfg)
+                 :xnio/io-threads (:io-threads cfg)
+                 :xnio/worker-threads (:worker-threads cfg)
+                 :xnio/dispatch (:executor cfg)
                  :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 (d/without-nils options))
-                    (cond-> metrics (instrument-metrics metrics)))]
-    (assoc opts :server (yt/start! server))))
+        handler (if (some? router)
+                  (wrap-router router)
+                  handler)
+        server  (yt/server handler (d/without-nils options))]
+    (assoc cfg :server (yt/start! server))))
 
 (defmethod ig/halt-key! ::server
-  [_ {:keys [server name port] :as opts}]
+  [_ {:keys [server name port] :as cfg}]
   (l/info :msg "stoping http server" :name name :port port)
   (yt/stop! server))
 
+(defn- not-found-handler
+  [_ respond _]
+  (respond (yrs/response 404)))
+
 (defn- wrap-router
   [router]
-  (let [default (rr/routes
-                 (rr/create-resource-handler {:path "/"})
-                 (rr/create-default-handler))
-        options {:middleware [middleware/wrap-server-timing]
-                 :inject-match? false
-                 :inject-router? false}
-        handler (rr/ring-handler router default options)]
+  (letfn [(handler [request respond raise]
+            (if-let [match (r/match-by-path router (yrq/path request))]
+              (let [params  (:path-params match)
+                    result  (:result match)
+                    handler (or (:handler result) not-found-handler)
+                    request (-> request
+                                (assoc :path-params params)
+                                (update :params merge params))]
+                (handler request respond raise))
+              (not-found-handler request respond raise)))
+
+          (on-error [cause request respond]
+            (let [{:keys [body] :as response} (errors/handle cause request)]
+              (respond
+               (cond-> response
+                 (map? body)
+                 (-> (update :headers assoc "content-type" "application/transit+json")
+                     (assoc :body (t/encode-str body {:type :json-verbose})))))))]
+
     (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"}))))))
+      (try
+        (handler request respond #(on-error % request respond))
+        (catch Throwable cause
+          (on-error cause request respond))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; HTTP ROUTER
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (s/def ::rpc map?)
-(s/def ::session map?)
 (s/def ::oauth map?)
 (s/def ::storage map?)
 (s/def ::assets map?)
 (s/def ::feedback fn?)
 (s/def ::ws fn?)
-(s/def ::audit-http-handler fn?)
+(s/def ::audit-handler fn?)
 (s/def ::debug map?)
+(s/def ::awsns-handler fn?)
+(s/def ::session map?)
 
 (defmethod ig/pre-init-spec ::router [_]
-  (s/keys :req-un [::rpc ::session ::mtx/metrics ::ws
-                   ::oauth ::storage ::assets ::feedback
-                   ::debug ::audit-http-handler]))
+  (s/keys :req-un [::rpc ::mtx/metrics ::ws ::oauth ::storage ::assets
+                   ::session ::feedback ::awsns-handler ::debug ::audit-handler]))
 
 (defmethod ig/init-key ::router
   [_ {:keys [ws session rpc oauth metrics assets feedback debug] :as cfg}]
   (rr/router
-   [["/metrics" {:get (:handler metrics)}]
-    ["/assets" {:middleware [[middleware/format-response-body]
-                             [middleware/errors errors/handle]
-                             [middleware/cookies]
-                             (:middleware session)]}
-     ["/by-id/:id" {:get (:objects-handler assets)}]
-     ["/by-file-media-id/:id" {:get (:file-objects-handler assets)}]
-     ["/by-file-media-id/:id/thumbnail" {:get (:file-thumbnails-handler assets)}]]
+   [["" {:middleware [[middleware/server-timing]
+                      [middleware/format-response]
+                      [middleware/params]
+                      [middleware/parse-request]
+                      [middleware/errors errors/handle]
+                      [middleware/restrict-methods]]}
+     ["/metrics" {:handler (:handler metrics)}]
+     ["/assets" {:middleware [(:middleware session)]}
+      ["/by-id/:id" {:handler (:objects-handler assets)}]
+      ["/by-file-media-id/:id" {:handler (:file-objects-handler assets)}]
+      ["/by-file-media-id/:id/thumbnail" {:handler (:file-thumbnails-handler assets)}]]
 
-    ["/dbg" {:middleware [[middleware/multipart-params]
-                          [middleware/params]
-                          [middleware/keyword-params]
-                          [middleware/format-response-body]
-                          [middleware/errors errors/handle]
-                          [middleware/cookies]
-                          [(:middleware session)]]}
-     ["" {:get (:index debug)}]
-     ["/error-by-id/:id" {:get (:retrieve-error debug)}]
-     ["/error/:id" {:get (:retrieve-error debug)}]
-     ["/error" {:get (:retrieve-error-list debug)}]
-     ["/file/data" {:get (:retrieve-file-data debug)
-                    :post (:upload-file-data debug)}]
-     ["/file/changes" {:get (:retrieve-file-changes debug)}]]
+     ["/dbg" {:middleware [(:middleware session)]}
+      ["" {:handler (:index debug)}]
+      ["/changelog" {:handler (:changelog debug)}]
+      ["/error-by-id/:id" {:handler (:retrieve-error debug)}]
+      ["/error/:id" {:handler (:retrieve-error debug)}]
+      ["/error" {:handler (:retrieve-error-list debug)}]
+      ["/file/data" {:handler (:file-data debug)}]
+      ["/file/changes" {:handler (:retrieve-file-changes debug)}]]
 
-    ["/webhooks"
-     ["/sns" {:post (:sns-webhook cfg)}]]
+     ["/webhooks"
+      ["/sns" {:handler (:awsns-handler cfg)
+               :allowed-methods #{:post}}]]
 
-    ["/ws/notifications"
-     {:middleware [[middleware/params]
-                   [middleware/keyword-params]
-                   [middleware/format-response-body]
-                   [middleware/errors errors/handle]
-                   [middleware/cookies]
-                   [(:middleware session)]]
-      :get ws}]
+     ["/ws/notifications" {:middleware [(:middleware session)]
+                           :handler ws
+                           :allowed-methods #{:get}}]
 
-    ["/api" {:middleware [[middleware/cors]
-                          [middleware/params]
-                          [middleware/multipart-params]
-                          [middleware/keyword-params]
-                          [middleware/format-response-body]
-                          [middleware/parse-request-body]
-                          [middleware/errors errors/handle]
-                          [middleware/cookies]]}
+     ["/api" {:middleware [[middleware/cors]
+                           (:middleware session)]}
+      ["/health" {:handler (:health-check debug)}]
+      ["/_doc" {:handler (doc/handler rpc)
+                :allowed-methods #{:get}}]
+      ["/feedback" {:handler feedback
+                    :allowed-methods #{:post}}]
 
-     ["/health" {:get (:health-check debug)}]
-     ["/_doc" {:get (doc/handler rpc)}]
-     ["/feedback" {:middleware [(:middleware session)]
-                   :post feedback}]
-     ["/auth/oauth/:provider" {:post (:handler oauth)}]
-     ["/auth/oauth/:provider/callback" {:get (:callback-handler oauth)}]
+      ["/auth/oauth/:provider" {:handler (:handler oauth)
+                                :allowed-methods #{:post}}]
+      ["/auth/oauth/:provider/callback" {:handler (:callback-handler oauth)
+                                         :allowed-methods #{:get}}]
 
-     ["/audit/events" {:middleware [(:middleware session)]
-                       :post (:audit-http-handler cfg)}]
+      ["/audit/events" {:handler (:audit-handler cfg)
+                        :allowed-methods #{:post}}]
 
-     ["/rpc" {:middleware [(:middleware session)]}
-      ["/query/:type" {:get (:query-handler rpc)
-                       :post (:query-handler rpc)}]
-      ["/mutation/:type" {:post (:mutation-handler rpc)}]]]]))
+      ["/rpc"
+       ["/query/:type" {:handler (:query-handler rpc)}]
+       ["/mutation/:type" {:handler (:mutation-handler rpc)
+                           :allowed-methods #{:post}}]]]]]))

backend/src/app/http/assets.clj

@@ -13,12 +13,13 @@
    [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]
-   [promesa.core :as p]))
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.response :as yrs]))
 
 (def ^:private cache-max-age
   (dt/duration {:hours 24}))
@@ -35,71 +36,79 @@
     res))
 
 (defn- get-file-media-object
-  [{:keys [pool] :as storage} id]
-  (let [id   (coerce-id id)
-        mobj (db/exec-one! pool ["select * from file_media_object where id=?" id])]
-    (when-not mobj
-      (ex/raise :type :not-found
-                :hint "object does not found"))
-      mobj))
+  [{:keys [pool executor] :as storage} id]
+  (px/with-dispatch executor
+    (let [id   (coerce-id id)
+          mobj (db/exec-one! pool ["select * from file_media_object where id=?" id])]
+      (when-not mobj
+        (ex/raise :type :not-found
+                  :hint "object does not found"))
+      mobj)))
 
 (defn- serve-object
+  "Helper function that returns the appropriate response depending on
+  the storage object backend type."
   [{:keys [storage] :as cfg} obj]
   (let [mdata   (meta obj)
         backend (sto/resolve-backend storage (:backend obj))]
     (case (:type backend)
       :db
-      {:status 200
-       :headers {"content-type" (:content-type mdata)
-                 "cache-control" (str "max-age=" (inst-ms cache-max-age))}
-       :body (sto/get-object-bytes storage obj)}
+      (p/let [body (sto/get-object-bytes storage obj)]
+        (yrs/response :status  200
+                      :body    body
+                      :headers {"content-type" (:content-type mdata)
+                                "cache-control" (str "max-age=" (inst-ms cache-max-age))}))
 
       :s3
-      (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"   (cond-> host port (str ":" port))
-                   "cache-control" (str "max-age=" (inst-ms cache-max-age))}
-         :body ""})
+      (p/let [{:keys [host port] :as url} (sto/get-object-url storage obj {:max-age signature-max-age})]
+        (yrs/response :status  307
+                      :headers {"location" (str url)
+                                "x-host"   (cond-> host port (str ":" port))
+                                "cache-control" (str "max-age=" (inst-ms cache-max-age))}))
 
       :fs
-      (let [purl (u/uri (:assets-path cfg))
-            purl (u/join purl (sto/object->relative-path obj))]
-        {:status 204
-         :headers {"x-accel-redirect" (:path purl)
-                   "content-type" (:content-type mdata)
-                   "cache-control" (str "max-age=" (inst-ms cache-max-age))}
-         :body ""}))))
-
-(defn- generic-handler
-  [{: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 ""}))))
+      (p/let [purl (u/uri (:assets-path cfg))
+              purl (u/join purl (sto/object->relative-path obj))]
+        (yrs/response :status  204
+                      :headers {"x-accel-redirect" (:path purl)
+                                "content-type" (:content-type mdata)
+                                "cache-control" (str "max-age=" (inst-ms cache-max-age))})))))
 
 (defn objects-handler
+  "Handler that servers storage objects by 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)]
+  (-> (px/with-dispatch executor
+        (p/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)
+            (yrs/response 404))))
+
+      (p/bind p/wrap)
+      (p/then' respond)
       (p/catch raise)))
 
+(defn- generic-handler
+  "A generic handler helper/common code for file-media based handlers."
+  [{:keys [storage] :as cfg} request kf]
+  (p/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)
+      (yrs/response 404))))
+
 (defn file-objects-handler
+  "Handler that serves storage objects by file media id."
   [cfg request respond raise]
   (-> (generic-handler cfg request :media-id)
       (p/then respond)
       (p/catch raise)))
 
 (defn file-thumbnails-handler
+  "Handler that serves storage objects by thumbnail-id and quick
+  fallback to file-media-id if no thumbnail is available."
   [cfg request respond raise]
   (-> (generic-handler cfg request #(or (:thumbnail-id %) (:media-id %)))
       (p/then respond)

backend/src/app/http/awsns.clj

@@ -11,45 +11,54 @@
    [app.common.logging :as l]
    [app.db :as db]
    [app.db.sql :as sql]
-   [app.util.http :as http]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [integrant.core :as ig]
-   [jsonista.core :as j]))
+   [jsonista.core :as j]
+   [promesa.exec :as px]
+   [yetti.response :as yrs]))
 
 (declare parse-json)
+(declare handle-request)
 (declare parse-notification)
 (declare process-report)
 
+(s/def ::http-client fn?)
+
 (defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::db/pool]))
+  (s/keys :req-un [::db/pool ::http-client]))
 
 (defmethod ig/init-key ::handler
-  [_ cfg]
+  [_ {:keys [executor] :as cfg}]
   (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}))
+    (let [data (slurp (:body request))]
+      (px/run! executor #(handle-request cfg data))
+      (respond (yrs/response 200)))))
 
-          (= mtype "Notification")
-          (when-let [message (parse-json (get body "Message"))]
-            (let [notification (parse-notification cfg message)]
-              (process-report cfg notification)))
+(defn handle-request
+  [{:keys [http-client] :as cfg} data]
+  (try
+    (let [body  (parse-json data)
+          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-client {:uri surl :method :post :timeout 10000} {:sync? true}))
 
-          :else
-          (l/warn :hint "unexpected data received"
-                  :report (pr-str body))))
-      (catch Throwable cause
-        (l/error :hint "unexpected exception on awsns handler"
-                 :cause cause)))
+        (= mtype "Notification")
+        (when-let [message (parse-json (get body "Message"))]
+          (let [notification (parse-notification cfg message)]
+            (process-report cfg notification)))
 
-    (respond {:status 200 :body ""})))
+        :else
+        (l/warn :hint "unexpected data received"
+                :report (pr-str body))))
+
+    (catch Throwable cause
+      (l/error :hint "unexpected exception on awsns"
+               :cause cause))))
 
 (defn- parse-bounce
   [data]

backend/src/app/http/client.clj

@@ -0,0 +1,30 @@
+;; 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.http.client
+  "Http client abstraction layer."
+  (:require
+   [app.worker :as wrk]
+   [clojure.spec.alpha :as s]
+   [integrant.core :as ig]
+   [java-http-clj.core :as http]))
+
+(defmethod ig/pre-init-spec :app.http/client [_]
+  (s/keys :req-un [::wrk/executor]))
+
+(defmethod ig/init-key :app.http/client
+  [_ {:keys [executor] :as cfg}]
+  (let [client (http/build-client {:executor executor
+                                   :connect-timeout 30000 ;; 10s
+                                   :follow-redirects :always})]
+    (with-meta
+      (fn send
+        ([req] (send req {}))
+        ([req {:keys [response-type sync?] :or {response-type :string sync? false}}]
+         (if sync?
+           (http/send req {:client client :as response-type})
+           (http/send-async req {:client client :as response-type}))))
+      {::client client})))

backend/src/app/http/debug.clj

@@ -12,9 +12,9 @@
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
+   [app.db.sql :as sql]
    [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]
@@ -23,9 +23,15 @@
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [datoteka.core :as fs]
+   [emoji.core :as emj]
    [fipp.edn :as fpp]
    [integrant.core :as ig]
-   [promesa.core :as p]))
+   [markdown.core :as md]
+   [markdown.transformers :as mdt]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.request :as yrq]
+   [yetti.response :as yrs]))
 
 ;; (selmer.parser/cache-off!)
 
@@ -41,11 +47,10 @@
   (when-not (authorized? pool request)
     (ex/raise :type :authentication
               :code :only-admins-allowed))
-
-  {:status 200
-   :headers {"content-type" "text/html"}
-   :body (-> (io/resource "templates/debug.tmpl")
-             (tmpl/render {}))})
+  (yrs/response :status  200
+                :headers {"content-type" "text/html"}
+                :body    (-> (io/resource "templates/debug.tmpl")
+                             (tmpl/render {}))))
 
 
 (def sql:retrieve-range-of-changes
@@ -55,26 +60,27 @@
   "select revn, changes, data from file_change where file_id=? and revn = ?")
 
 (defn prepare-response
-  [{:keys [params] :as request} body]
+  [{:keys [params] :as request} body filename]
   (when-not body
     (ex/raise :type :not-found
               :code :enpty-data
               :hint "empty response"))
 
-  (cond-> {:status 200
-           :headers {"content-type" "application/transit+json"}
-           :body body}
+  (cond-> (yrs/response :status  200
+                        :body    body
+                        :headers {"content-type" "application/transit+json"})
     (contains? params :download)
-    (update :headers assoc "content-disposition" "attachment")))
+    (update :headers assoc "content-disposition" (str "attachment; filename=" filename))))
 
-(defn retrieve-file-data
+(defn- retrieve-file-data
   [{:keys [pool]} {:keys [params] :as request}]
   (when-not (authorized? pool request)
     (ex/raise :type :authentication
               :code :only-admins-allowed))
 
-  (let [file-id (some-> (get-in request [:params :file-id]) uuid/uuid)
-        revn    (some-> (get-in request [:params :revn]) d/parse-integer)]
+  (let [file-id  (some-> (get-in request [:params :file-id]) uuid/uuid)
+        revn     (some-> (get-in request [:params :revn]) d/parse-integer)
+        filename (str file-id)]
     (when-not file-id
       (ex/raise :type :validation
                 :code :missing-arguments))
@@ -83,26 +89,40 @@
                  (some-> (db/exec-one! pool [sql:retrieve-single-change file-id revn]) :data)
                  (some-> (db/get-by-id pool :file file-id) :data))]
       (if (contains? params :download)
-        (-> (prepare-response request data)
+        (-> (prepare-response request data filename)
             (update :headers assoc "content-type" "application/octet-stream"))
-        (prepare-response request (some-> data blob/decode))))))
+        (prepare-response request (some-> data blob/decode) filename)))))
 
-(defn upload-file-data
+(defn- upload-file-data
   [{:keys [pool]} {:keys [profile-id params] :as request}]
   (let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)
-        data       (some-> params :file :tempfile fs/slurp-bytes blob/decode)]
+        data       (some-> params :file :path fs/slurp-bytes blob/decode)]
 
     (if (and data project-id)
-      (let [fname (str "imported-file-" (dt/now))]
-        (m.files/create-file pool {:id (uuid/next)
-                                   :name fname
-                                   :project-id project-id
-                                   :profile-id profile-id
-                                   :data data})
-        {:status 200
-         :body "OK"})
-      {:status 500
-       :body "error"})))
+      (let [fname (str "imported-file-" (dt/now))
+            file-id (try
+                      (uuid/uuid (-> params :file :filename))
+                      (catch Exception _ (uuid/next)))
+            file (db/exec-one! pool (sql/select :file {:id file-id}))]
+        (if file
+          (db/update! pool :file
+                      {:data (blob/encode data)}
+                      {:id file-id})
+          (m.files/create-file pool {:id file-id
+                                     :name fname
+                                     :project-id project-id
+                                     :profile-id profile-id
+                                     :data data}))
+        (yrs/response 200 "OK"))
+      (yrs/response 500 "ERROR"))))
+
+(defn file-data
+  [cfg request]
+  (case (yrq/method request)
+    :get (retrieve-file-data cfg request)
+    :post (upload-file-data cfg request)
+    (ex/raise :type :http
+              :code :method-not-found)))
 
 (defn retrieve-file-changes
   [{:keys [pool]} request]
@@ -110,8 +130,9 @@
     (ex/raise :type :authentication
               :code :only-admins-allowed))
 
-  (let [file-id (some-> (get-in request [:params :id]) uuid/uuid)
-        revn    (or (get-in request [:params :revn]) "latest")]
+  (let [file-id  (some-> (get-in request [:params :id]) uuid/uuid)
+        revn     (or (get-in request [:params :revn]) "latest")
+        filename (str file-id)]
 
     (when (or (not file-id) (not revn))
       (ex/raise :type :validation
@@ -121,7 +142,7 @@
     (cond
       (d/num-string? revn)
       (let [item (db/exec-one! pool [sql:retrieve-single-change file-id (d/parse-integer revn)])]
-        (prepare-response request (some-> item :changes blob/decode vec)))
+        (prepare-response request (some-> item :changes blob/decode vec) filename))
 
       (str/includes? revn ":")
       (let [[start end] (->> (str/split revn #":")
@@ -133,7 +154,8 @@
                                    (map :changes)
                                    (map blob/decode)
                                    (mapcat identity)
-                                   (vec))))
+                                   (vec))
+                          filename))
       :else
       (ex/raise :type :validation :code :invalid-arguments))))
 
@@ -154,7 +176,8 @@
             (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}))
+                  params  {:context (with-out-str
+                                      (fpp/pprint context {:width 200}))
                            :hint    (:hint report)
                            :spec-explain  (:spec-explain report)
                            :spec-problems (:spec-problems report)
@@ -164,8 +187,7 @@
                                               (some-> report :error :trace))
                            :params        (:params report)}]
               (-> (io/resource "templates/error-report.tmpl")
-                  (tmpl/render params))))
-          ]
+                  (tmpl/render params))))]
 
     (when-not (authorized? pool request)
       (ex/raise :type :authentication
@@ -175,12 +197,11 @@
                          (retrieve-report)
                          (render-template))]
       (if result
-        {:status 200
-         :headers {"content-type" "text/html; charset=utf-8"
-                   "x-robots-tag" "noindex"}
-         :body result}
-        {:status 404
-         :body "not found"}))))
+        (yrs/response :status 200
+                      :body result
+                      :headers {"content-type" "text/html; charset=utf-8"
+                                "x-robots-tag" "noindex"})
+        (yrs/response 404 "not found")))))
 
 (def sql:error-reports
   "select id, created_at from server_error_report order by created_at desc limit 100")
@@ -192,24 +213,35 @@
               :code :only-admins-allowed))
   (let [items (db/exec! pool [sql:error-reports])
         items (map #(update % :created-at dt/format-instant :rfc1123) items)]
-    {:status 200
-     :headers {"content-type" "text/html; charset=utf-8"
-               "x-robots-tag" "noindex"}
-     :body (-> (io/resource "templates/error-list.tmpl")
-               (tmpl/render {:items items}))}))
+    (yrs/response :status 200
+                  :body (-> (io/resource "templates/error-list.tmpl")
+                            (tmpl/render {:items items}))
+                  :headers {"content-type" "text/html; charset=utf-8"
+                            "x-robots-tag" "noindex"})))
 
 (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"}))
+    (yrs/response 200 "OK")))
+
+(defn changelog
+  [_ _]
+  (letfn [(transform-emoji [text state]
+            [(emj/emojify text) state])
+          (md->html [text]
+            (md/md-to-html-string text :replacement-transformers (into [transform-emoji] mdt/transformer-vector)))]
+    (if-let [clog (io/resource "changelog.md")]
+      (yrs/response :status 200
+                    :headers {"content-type" "text/html; charset=utf-8"}
+                    :body (-> clog slurp md->html))
+      (yrs/response :status 404 :body "NOT FOUND"))))
 
 (defn- wrap-async
   [{:keys [executor] :as cfg} f]
   (fn [request respond raise]
-    (-> (async/with-dispatch executor
-          (f cfg request))
+    (-> (px/submit! executor #(f cfg request))
         (p/then respond)
         (p/catch raise))))
 
@@ -220,8 +252,8 @@
   [_ 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)})
+   :file-data (wrap-async cfg file-data)
+   :changelog (wrap-async cfg changelog)})

backend/src/app/http/doc.clj

@@ -13,7 +13,8 @@
    [app.util.template :as tmpl]
    [clojure.java.io :as io]
    [clojure.spec.alpha :as s]
-   [pretty-spec.core :as ps]))
+   [pretty-spec.core :as ps]
+   [yetti.response :as yrs]))
 
 (defn get-spec-str
   [k]
@@ -47,8 +48,7 @@
   (let [context (prepare-context rpc)]
     (if (contains? cf/flags :backend-api-doc)
       (fn [_ respond _]
-        (respond {:status 200
-                  :body (-> (io/resource "api-doc.tmpl")
-                            (tmpl/render context))}))
+        (respond (yrs/response 200 (-> (io/resource "api-doc.tmpl")
+                                       (tmpl/render context)))))
       (fn [_ respond _]
-        (respond {:status 404 :body ""})))))
+        (respond (yrs/response 404))))))

backend/src/app/http/errors.clj

@@ -11,35 +11,30 @@
    [app.common.logging :as l]
    [app.common.spec :as us]
    [clojure.spec.alpha :as s]
-   [cuerdas.core :as str]))
+   [cuerdas.core :as str]
+   [yetti.request :as yrq]
+   [yetti.response :as yrs]))
+
+(def ^:dynamic *context* {})
 
 (defn- parse-client-ip
-  [{:keys [headers] :as request}]
-  (or (some-> (get headers "x-forwarded-for") (str/split ",") first)
-      (get headers "x-real-ip")
-      (get request :remote-addr)))
+  [request]
+  (or (some-> (yrq/get-header request "x-forwarded-for") (str/split ",") first)
+      (yrq/get-header request "x-real-ip")
+      (yrq/remote-addr request)))
 
-(defn get-error-context
-  [request error]
-  (let [data (ex-data error)]
-    (merge
-     {:path          (:uri request)
-      :method        (:request-method request)
-      :hint          (ex-message error)
-      :params        (:params request)
-
-      :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))
-      :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 (us/pretty-explain data)}))))
+(defn get-context
+  [request]
+  (merge
+   *context*
+   {:path          (:path request)
+    :method        (:method request)
+    :params        (:params request)
+    :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")})))
 
 (defmulti handle-exception
   (fn [err & _rest]
@@ -49,88 +44,117 @@
 
 (defmethod handle-exception :authentication
   [err _]
-  {:status 401 :body (ex-data err)})
+  (yrs/response 401 (ex-data err)))
 
 (defmethod handle-exception :restriction
   [err _]
-  {:status 400 :body (ex-data err)})
+  (yrs/response 400 (ex-data err)))
 
 (defmethod handle-exception :validation
   [err _]
-  (let [data    (ex-data err)
-        explain (us/pretty-explain data)]
-    {:status 400
-     :body (-> data
-               (dissoc ::s/problems)
-               (dissoc ::s/value)
-               (cond-> explain (assoc :explain explain)))}))
+  (let [{:keys [code] :as data} (ex-data err)]
+    (cond
+      (= code :spec-validation)
+      (let [explain (us/pretty-explain data)]
+        (yrs/response :status 400
+                      :body   (-> data
+                                  (dissoc ::s/problems ::s/value)
+                                  (cond-> explain (assoc :explain explain)))))
+
+      (= code :request-body-too-large)
+      (yrs/response :status 413 :body data)
+
+      :else
+      (yrs/response :status 400 :body data))))
 
 (defmethod handle-exception :assertion
   [error request]
-  (let [edata (ex-data error)]
+  (let [edata (ex-data error)
+        explain (us/pretty-explain edata)]
     (l/error ::l/raw (ex-message error)
-             ::l/context (get-error-context request error)
+             ::l/context (get-context request)
              :cause error)
-
-    {:status 500
-     :body {:type :server-error
-            :code :assertion
-            :data (dissoc edata ::s/problems ::s/value ::s/spec)}}))
+    (yrs/response :status 500
+                  :body   {:type :server-error
+                           :code :assertion
+                           :data (-> edata
+                                     (dissoc ::s/problems ::s/value ::s/spec)
+                                     (cond-> explain (assoc :explain explain)))})))
 
 (defmethod handle-exception :not-found
   [err _]
-  {:status 404 :body (ex-data err)})
-
-(defmethod handle-exception :default
-  [error request]
-  (let [edata (ex-data error)]
-    ;; NOTE: this is a special case for the idle-in-transaction error;
-    ;; when it happens, the connection is automatically closed and
-    ;; next-jdbc combines the two errors in a single ex-info. We only
-    ;; need the :handling error, because the :rollback error will be
-    ;; always "connection closed".
-    (if (and (ex/exception? (:rollback edata))
-             (ex/exception? (:handling edata)))
-      (handle-exception (:handling edata) request)
-      (do
-        (l/error ::l/raw (ex-message error)
-                 ::l/context (get-error-context request error)
-                 :cause error)
-        {:status 500
-         :body {:type :server-error
-                :code :unexpected
-                :hint (ex-message error)
-                :data edata}}))))
+  (yrs/response 404 (ex-data err)))
 
 (defmethod handle-exception org.postgresql.util.PSQLException
   [error request]
   (let [state (.getSQLState ^java.sql.SQLException error)]
     (l/error ::l/raw (ex-message error)
-             ::l/context (get-error-context request error)
+             ::l/context (get-context request)
              :cause error)
     (cond
       (= state "57014")
-      {:status 504
-       :body {:type :server-timeout
-              :code :statement-timeout
-              :hint (ex-message error)}}
+      (yrs/response 504 {:type :server-error
+                         :code :statement-timeout
+                         :hint (ex-message error)})
 
       (= state "25P03")
-      {:status 504
-       :body {:type :server-timeout
-              :code :idle-in-transaction-timeout
-              :hint (ex-message error)}}
+      (yrs/response 504 {:type :server-error
+                         :code :idle-in-transaction-timeout
+                         :hint (ex-message error)})
 
       :else
-      {:status 500
-       :body {:type :server-error
-              :code :psql-exception
-              :hint (ex-message error)
-              :state state}})))
+      (yrs/response 500 {:type :server-error
+                         :code :unexpected
+                         :hint (ex-message error)
+                         :state state}))))
+
+(defmethod handle-exception :default
+  [error request]
+  (let [edata (ex-data error)]
+    (cond
+      ;; This means that exception is not a controlled exception.
+      (nil? edata)
+      (do
+        (l/error ::l/raw (ex-message error)
+                 ::l/context (get-context request)
+                 :cause error)
+        (yrs/response 500 {:type :server-error
+                           :code :unexpected
+                           :hint (ex-message error)}))
+
+      ;; This is a special case for the idle-in-transaction error;
+      ;; when it happens, the connection is automatically closed and
+      ;; next-jdbc combines the two errors in a single ex-info. We
+      ;; only need the :handling error, because the :rollback error
+      ;; will be always "connection closed".
+      (and (ex/exception? (:rollback edata))
+           (ex/exception? (:handling edata)))
+      (handle-exception (:handling edata) request)
+
+      :else
+      (do
+        (l/error ::l/raw (ex-message error)
+                 ::l/context (get-context request)
+                 :cause error)
+        (yrs/response 500 {:type :server-error
+                           :code :unhandled
+                           :hint (ex-message error)
+                           :data edata})))))
 
 (defn handle
-  [error req]
-  (if (or (instance? java.util.concurrent.CompletionException error)
-          (instance? java.util.concurrent.ExecutionException error))
-    (handle-exception (.getCause ^Throwable error) req)
-    (handle-exception error req)))
+  [cause request]
+
+  (cond
+    (or (instance? java.util.concurrent.CompletionException cause)
+        (instance? java.util.concurrent.ExecutionException cause))
+    (handle-exception (.getCause ^Throwable cause) request)
+
+
+    (ex/wrapped? cause)
+    (let [context (meta cause)
+          cause   (deref cause)]
+      (binding [*context* context]
+        (handle-exception cause request)))
+
+    :else
+    (handle-exception cause request)))

backend/src/app/http/feedback.clj

@@ -18,7 +18,9 @@
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]
    [promesa.core :as p]
-   [promesa.exec :as px]))
+   [promesa.exec :as px]
+   [yetti.request :as yrq]
+   [yetti.response :as yrs]))
 
 (declare ^:private send-feedback)
 (declare ^:private handler)
@@ -42,7 +44,7 @@
 (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"])
+        token  (yrq/get-header request "x-feedback-token")
         params (d/merge (:params request)
                         (:body-params request))]
     (cond
@@ -54,7 +56,7 @@
       (= token ftoken)
       (send-feedback cfg nil params))
 
-    {:status 204 :body ""}))
+    (yrs/response 204)))
 
 (s/def ::content ::us/string)
 (s/def ::from    ::us/email)

backend/src/app/http/middleware.clj

@@ -6,74 +6,77 @@
 
 (ns app.http.middleware
   (:require
+   [app.common.exceptions :as ex]
    [app.common.logging :as l]
    [app.common.transit :as t]
    [app.config :as cf]
    [app.util.json :as json]
-   [ring.core.protocols :as rp]
-   [ring.middleware.cookies :refer [wrap-cookies]]
-   [ring.middleware.keyword-params :refer [wrap-keyword-params]]
-   [ring.middleware.multipart-params :refer [wrap-multipart-params]]
-   [ring.middleware.params :refer [wrap-params]]
-   [yetti.adapter :as yt]))
+   [cuerdas.core :as str]
+   [yetti.adapter :as yt]
+   [yetti.middleware :as ymw]
+   [yetti.request :as yrq]
+   [yetti.response :as yrs])
+  (:import
+   com.fasterxml.jackson.core.io.JsonEOFException
+   io.undertow.server.RequestTooBigException
+   java.io.OutputStream))
 
-(defn wrap-server-timing
+(def server-timing
+  {:name ::server-timing
+   :compile (constantly ymw/wrap-server-timing)})
+
+(def params
+  {:name ::params
+   :compile (constantly ymw/wrap-params)})
+
+(defn wrap-parse-request
   [handler]
-  (letfn [(get-age [start]
-            (float (/ (- (System/nanoTime) start) 1000000000)))
+  (letfn [(process-request [request]
+            (let [header (yrq/get-header request "content-type")]
+              (cond
+                (str/starts-with? header "application/transit+json")
+                (with-open [is (-> request yrq/body yrq/body-stream)]
+                  (let [params (t/read! (t/reader is))]
+                    (-> request
+                        (assoc :body-params params)
+                        (update :params merge params))))
 
-          (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]
-  (letfn [(parse-transit [body]
-            (let [reader (t/reader body)]
-              (t/read! reader)))
-
-          (parse-json [body]
-            (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)))
+                (str/starts-with? header "application/json")
+                (with-open [is (-> request yrq/body yrq/body-stream)]
+                  (let [params (json/read is)]
+                    (-> request
+                        (assoc :body-params params)
+                        (update :params merge params))))
 
+                :else
                 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})}))]
+          (handle-error [raise cause]
+            (cond
+              (instance? RequestTooBigException cause)
+              (raise (ex/error :type :validation
+                               :code :request-body-too-large
+                               :hint (ex-message cause)))
+
+              (instance? JsonEOFException cause)
+              (raise (ex/error :type :validation
+                               :code :malformed-json
+                               :hint (ex-message cause)))
+              :else
+              (raise cause)))]
 
     (fn [request respond raise]
-      (try
-        (let [request (handle-request request)]
-          (handler request respond raise))
-        (catch Exception cause
-          (respond (handle-exception cause)))))))
+      (when-let [request (try
+                           (process-request request)
+                           (catch RuntimeException cause
+                             (handle-error raise (or (.getCause cause) cause)))
+                           (catch Throwable cause
+                             (handle-error raise cause)))]
+        (handler request respond raise)))))
 
-(def parse-request-body
-  {:name ::parse-request-body
-   :compile (constantly wrap-parse-request-body)})
+(def parse-request
+  {:name ::parse-request
+   :compile (constantly wrap-parse-request)})
 
 (defn buffered-output-stream
   "Returns a buffered output stream that ignores flush calls. This is
@@ -87,56 +90,54 @@
       (proxy-super flush)
       (proxy-super close))))
 
-(def ^:const buffer-size (:http/output-buffer-size yt/base-defaults))
+(def ^:const buffer-size (:xnio/buffer-size yt/defaults))
 
-(defn wrap-format-response-body
+(defn wrap-format-response
   [handler]
   (letfn [(transit-streamable-body [data opts]
-            (reify rp/StreamableResponseBody
-              (write-body-to-stream [_ _ output-stream]
-                ;; Use the same buffer as jetty output buffer size
+            (reify yrs/StreamableResponseBody
+              (-write-body-to-stream [_ _ output-stream]
                 (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
+
+                  (catch java.io.IOException _cause
                     ;; Do nothing, EOF means client closes connection abruptly
                     nil)
                   (catch Throwable cause
                     (l/warn :hint "unexpected error on encoding response"
-                            :cause cause))))))
+                            :cause cause))
+                  (finally
+                    (.close ^OutputStream output-stream))))))
 
-          (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
+          (format-response [response request]
+            (let [body (yrs/body response)]
+              (if (coll? body)
+                (let [qs   (yrq/query request)
+                      opts (if (or (contains? cf/flags :transit-readable-response)
+                                   (str/includes? qs "transit_verbose"))
+                             {:type :json-verbose}
+                             {:type :json})]
+                  (-> response
+                      (update :headers assoc "content-type" "application/transit+json")
+                      (assoc :body (transit-streamable-body body opts))))
                 response)))
 
-          (handle-response [response request]
+          (process-response [response request]
             (cond-> response
-              (map? response) (impl-format-response-body request)))]
+              (map? response) (format-response request)))]
 
     (fn [request respond raise]
       (handler request
                (fn [response]
-                 (respond (handle-response response request)))
+                 (let [response (process-response response request)]
+                   (respond response)))
                raise))))
 
-(def format-response-body
-  {:name ::format-response-body
-   :compile (constantly wrap-format-response-body)})
+(def format-response
+  {:name ::format-response
+   :compile (constantly wrap-format-response)})
 
 (defn wrap-errors
   [handler on-error]
@@ -148,51 +149,46 @@
   {:name ::errors
    :compile (constantly wrap-errors)})
 
-(def cookies
-  {:name ::cookies
-   :compile (constantly wrap-cookies)})
-
-(def params
-  {:name ::params
-   :compile (constantly wrap-params)})
-
-(def multipart-params
-  {:name ::multipart-params
-   :compile (constantly wrap-multipart-params)})
-
-(def keyword-params
-  {:name ::keyword-params
-   :compile (constantly wrap-keyword-params)})
-
-(def server-timing
-  {:name ::server-timing
-   :compile (constantly wrap-server-timing)})
-
 (defn wrap-cors
   [handler]
   (if-not (contains? cf/flags :cors)
     handler
-    (letfn [(add-cors-headers [response request]
-              (-> response
-                  (update
-                   :headers
-                   (fn [headers]
-                     (-> headers
-                         (assoc "access-control-allow-origin" (get-in request [:headers "origin"]))
-                         (assoc "access-control-allow-methods" "GET,POST,DELETE,OPTIONS,PUT,HEAD,PATCH")
-                         (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"))))))]
+    (letfn [(add-headers [headers request]
+              (let [origin (yrq/get-header request "origin")]
+                (-> headers
+                    (assoc "access-control-allow-origin" origin)
+                    (assoc "access-control-allow-methods" "GET,POST,DELETE,OPTIONS,PUT,HEAD,PATCH")
+                    (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"))))
+
+            (update-response [response request]
+              (update response :headers add-headers request))]
+
       (fn [request respond raise]
-        (if (= (:request-method request) :options)
-          (-> {:status 200 :body ""}
-              (add-cors-headers request)
+        (if (= (yrq/method request) :options)
+          (-> (yrs/response 200)
+              (update-response request)
               (respond))
           (handler request
                    (fn [response]
-                     (respond (add-cors-headers response request)))
+                     (respond (update-response response request)))
                    raise))))))
 
 (def cors
   {:name ::cors
    :compile (constantly wrap-cors)})
+
+(defn compile-restrict-methods
+  [data _]
+  (when-let [allowed (:allowed-methods data)]
+    (fn [handler]
+      (fn [request respond raise]
+        (let [method (yrq/method request)]
+          (if (contains? allowed method)
+            (handler request respond raise)
+            (respond (yrs/response 405))))))))
+
+(def restrict-methods
+  {:name ::restrict-methods
+   :compile compile-restrict-methods})

backend/src/app/http/oauth.clj

@@ -15,16 +15,15 @@
    [app.db :as db]
    [app.loggers.audit :as audit]
    [app.rpc.queries.profile :as profile]
-   [app.util.http :as http]
+   [app.util.json :as json]
    [app.util.time :as dt]
-   [clojure.data.json :as json]
    [clojure.set :as set]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [integrant.core :as ig]
-   [promesa.exec :as px]))
-
-;; TODO: make it fully async (?)
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.response :as yrs]))
 
 (defn- build-redirect-uri
   [{:keys [provider] :as cfg}]
@@ -43,27 +42,6 @@
         (assoc :query query)
         (str))))
 
-(defn retrieve-access-token
-  [{:keys [provider] :as cfg} code]
-  (try
-    (let [params {:client_id (:client-id provider)
-                  :client_secret (:client-secret provider)
-                  :code code
-                  :grant_type "authorization_code"
-                  :redirect_uri (build-redirect-uri cfg)}
-          req    {:method :post
-                  :headers {"content-type" "application/x-www-form-urlencoded"}
-                  :uri (:token-uri provider)
-                  :body (u/map->query-string params)}
-          res    (http/send! req)]
-      (when (= 200 (:status res))
-        (let [data (json/read-str (:body res))]
-          {:token (get data "access_token")
-           :type  (get data "token_type")})))
-    (catch Exception e
-      (l/warn :hint "unexpected error on retrieve-access-token" :cause e)
-      nil)))
-
 (defn- qualify-props
   [provider props]
   (reduce-kv (fn [result k v]
@@ -71,31 +49,99 @@
              {}
              props))
 
-(defn- retrieve-user-info
-  [{:keys [provider] :as cfg} tdata]
-  (try
-    (let [req {:uri (:user-uri provider)
-               :headers {"Authorization" (str (:type tdata) " " (:token tdata))}
-               :timeout 6000
-               :method :get}
-          res (http/send! req)]
+(defn retrieve-access-token
+  [{:keys [provider http-client] :as cfg} code]
+  (let [params {:client_id (:client-id provider)
+                :client_secret (:client-secret provider)
+                :code code
+                :grant_type "authorization_code"
+                :redirect_uri (build-redirect-uri cfg)}
+        req    {:method :post
+                :headers {"content-type" "application/x-www-form-urlencoded"
+                          "accept" "application/json"}
+                :uri (:token-uri provider)
+                :body (u/map->query-string params)}]
+    (p/then
+     (http-client req)
+     (fn [{:keys [status body] :as res}]
+       (if (= status 200)
+         (let [data (json/read body)]
+           {:token (get data :access_token)
+            :type (get data :token_type)})
+         (ex/raise :type :internal
+                   :code :unable-to-retrieve-token
+                   :http-status status
+                   :http-body body))))))
 
-      (when (= 200 (:status res))
-        (let [info (json/read-str (:body res) :key-fn keyword)]
-          {:backend (:name provider)
-           :email (:email info)
-           :fullname (:name info)
-           :props (->> (dissoc info :name :email)
-                       (qualify-props provider))})))
-    (catch Exception e
-      (l/warn :hint "unexpected exception on retrieve-user-info" :cause e)
-      nil)))
+(defn- retrieve-user-info
+  [{:keys [provider http-client] :as cfg} tdata]
+  (letfn [(retrieve []
+            (http-client {:uri (:user-uri provider)
+                          :headers {"Authorization" (str (:type tdata) " " (:token tdata))}
+                          :timeout 6000
+                          :method :get}))
+
+          (retrieve-emails []
+            (if (some? (:emails-uri provider))
+              (http-client {:uri (:emails-uri provider)
+                            :headers {"Authorization" (str (:type tdata) " " (:token tdata))}
+                            :timeout 6000
+                            :method :get})
+              (p/resolved {:status 200})))
+
+          (validate-response [[retrieve-res emails-res]]
+            (when-not (s/int-in-range? 200 300 (:status retrieve-res))
+              (ex/raise :type :internal
+                        :code :unable-to-retrieve-user-info
+                        :hint "unable to retrieve user info"
+                        :http-status (:status retrieve-res)
+                        :http-body (:body retrieve-res)))
+            (when-not (s/int-in-range? 200 300 (:status emails-res))
+              (ex/raise :type :internal
+                        :code :unable-to-retrieve-user-info
+                        :hint "unable to retrieve user info"
+                        :http-status (:status emails-res)
+                        :http-body (:body emails-res)))
+            [retrieve-res emails-res])
+
+          (get-email [info]
+            (let [attr-kw (cf/get :oidc-email-attr :email)]
+              (get info attr-kw)))
+
+          (get-name [info]
+            (let [attr-kw (cf/get :oidc-name-attr :name)]
+              (get info attr-kw)))
+
+          (process-response [[retrieve-res emails-res]]
+            (let [info (json/read (:body retrieve-res))
+                  email (if (some? (:extract-email-callback provider))
+                          ((:extract-email-callback provider) emails-res)
+                          (get-email info))]
+              {:backend  (:name provider)
+               :email    email
+               :fullname (get-name info)
+               :props (->> (dissoc info :name :email)
+                           (qualify-props provider))}))
+
+          (validate-info [info]
+            (when-not (s/valid? ::info info)
+              (l/warn :hint "received incomplete profile info object (please set correct scopes)"
+                      :info (pr-str info))
+              (ex/raise :type :internal
+                        :code :incomplete-user-info
+                        :hint "inconmplete user info"
+                        :info info))
+            info)]
+
+    (-> (p/all [(retrieve) (retrieve-emails)])
+        (p/then' validate-response)
+        (p/then' process-response)
+        (p/then' validate-info))))
 
 (s/def ::backend ::us/not-empty-string)
 (s/def ::email ::us/not-empty-string)
 (s/def ::fullname ::us/not-empty-string)
 (s/def ::props (s/map-of ::us/keyword any?))
-
 (s/def ::info
   (s/keys :req-un [::backend
                    ::email
@@ -103,73 +149,66 @@
                    ::props]))
 
 (defn retrieve-info
-  [{:keys [tokens provider] :as cfg} request]
-  (let [state  (get-in request [:params :state])
-        state  (tokens :verify {:token state :iss :oauth})
-        info   (some->> (get-in request [:params :code])
-                        (retrieve-access-token cfg)
-                        (retrieve-user-info cfg))]
+  [{:keys [tokens provider] :as cfg} {:keys [params] :as request}]
+  (letfn [(validate-oidc [info]
+            ;; If the provider is OIDC, we can proceed to check
+            ;; roles if they are defined.
+            (when (and (= "oidc" (:name provider))
+                       (seq (:roles provider)))
+              (let [provider-roles (into #{} (:roles provider))
+                    profile-roles  (let [attr  (cf/get :oidc-roles-attr :roles)
+                                         roles (get info attr)]
+                                     (cond
+                                       (string? roles) (into #{} (str/words roles))
+                                       (vector? roles) (into #{} roles)
+                                       :else #{}))]
 
-    (when-not (s/valid? ::info info)
-      (l/warn :hint "received incomplete profile info object (please set correct scopes)"
-              :info (pr-str info))
+                ;; check if profile has a configured set of roles
+                (when-not (set/subset? provider-roles profile-roles)
+                  (ex/raise :type :internal
+                            :code :unable-to-auth
+                            :hint "not enough permissions"))))
+            info)
+
+          (post-process [state info]
+            (cond-> info
+              (some? (:invitation-token state))
+              (assoc :invitation-token (:invitation-token state))
+
+              ;; If state token comes with props, merge them. The state token
+              ;; props can contain pm_ and utm_ prefixed query params.
+              (map? (:props state))
+              (update :props merge (:props state))))]
+
+    (when-let [error (get params :error)]
       (ex/raise :type :internal
-                :code :unable-to-auth
-                :hint "no user info"))
+                :code :error-on-retrieving-code
+                :error-id error
+                :error-desc (get params :error_description)))
 
-    ;; If the provider is OIDC, we can proceed to check
-    ;; roles if they are defined.
-    (when (and (= "oidc" (:name provider))
-               (seq (:roles provider)))
-      (let [provider-roles (into #{} (:roles provider))
-            profile-roles  (let [attr  (cf/get :oidc-roles-attr :roles)
-                                 roles (get info attr)]
-                             (cond
-                               (string? roles) (into #{} (str/words roles))
-                               (vector? roles) (into #{} roles)
-                               :else #{}))]
-
-        ;; check if profile has a configured set of roles
-        (when-not (set/subset? provider-roles profile-roles)
-          (ex/raise :type :internal
-                    :code :unable-to-auth
-                    :hint "not enough permissions"))))
-
-    (cond-> info
-      (some? (:invitation-token state))
-      (assoc :invitation-token (:invitation-token state))
-
-      ;; If state token comes with props, merge them. The state token
-      ;; props can contain pm_ and utm_ prefixed query params.
-      (map? (:props state))
-      (update :props merge (:props state)))))
+    (let [state  (get params :state)
+          code   (get params :code)
+          state  (tokens :verify {:token state :iss :oauth})]
+      (-> (p/resolved code)
+          (p/then #(retrieve-access-token cfg %))
+          (p/then #(retrieve-user-info cfg %))
+          (p/then' validate-oidc)
+          (p/then' (partial post-process state))))))
 
 ;; --- HTTP HANDLERS
 
-(defn extract-utm-props
-  "Extracts additional data from user params."
-  [params]
-  (reduce-kv (fn [params k v]
-               (let [sk (name k)]
-                 (cond-> params
-                   (str/starts-with? sk "utm_")
-                   (assoc (->> sk str/kebab (keyword "penpot")) v))))
-             {}
-             params))
-
 (defn- retrieve-profile
-  [{:keys [pool] :as cfg} info]
-  (with-open [conn (db/open pool)]
-    (some->> (:email info)
-             (profile/retrieve-profile-data-by-email conn)
-             (profile/populate-additional-data conn)
-             (profile/decode-profile-row))))
+  [{:keys [pool executor] :as cfg} info]
+  (px/with-dispatch executor
+    (with-open [conn (db/open pool)]
+      (some->> (:email info)
+               (profile/retrieve-profile-data-by-email conn)
+               (profile/populate-additional-data conn)
+               (profile/decode-profile-row)))))
 
 (defn- redirect-response
   [uri]
-  {:status 302
-   :headers {"location" (str uri)}
-   :body ""})
+  (yrs/response :status 302 :headers {"location" (str uri)}))
 
 (defn- generate-error-redirect
   [cfg error]
@@ -202,6 +241,7 @@
 
       (->> (redirect-response uri)
            (sxf request)))
+
     (let [info   (assoc info
                         :iss :prepared-register
                         :is-active true
@@ -216,35 +256,33 @@
       (redirect-response uri))))
 
 (defn- auth-handler
-  [{: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}})))))
+  [{:keys [tokens] :as cfg} {:keys [params] :as request} respond raise]
+  (try
+    (let [props (audit/extract-utm-params params)
+          state (tokens :generate
+                        {:iss :oauth
+                         :invitation-token (:invitation-token params)
+                         :props props
+                         :exp (dt/in-future "15m")})
+          uri   (build-auth-uri cfg state)]
+      (respond (yrs/response 200 {:redirect-uri uri})))
+    (catch Throwable cause
+      (raise cause))))
 
 (defn- callback-handler
-  [{: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)))))))
+  [cfg request respond _]
+  (letfn [(process-request []
+            (p/let [info    (retrieve-info cfg request)
+                    profile (retrieve-profile cfg info)]
+              (generate-redirect cfg request info profile)))
+
+          (handle-error [cause]
+            (l/error :hint "error on oauth process" :cause cause)
+            (respond (generate-error-redirect cfg cause)))]
+
+    (-> (process-request)
+        (p/then respond)
+        (p/catch handle-error))))
 
 ;; --- INIT
 
@@ -281,10 +319,10 @@
      :callback-handler (wrap-handler cfg callback-handler)}))
 
 (defn- discover-oidc-config
-  [{:keys [base-uri] :as opts}]
+  [{:keys [http-client]} {:keys [base-uri] :as opts}]
 
   (let [discovery-uri (u/join base-uri ".well-known/openid-configuration")
-        response      (ex/try (http/send! {:method :get :uri (str discovery-uri)}))]
+        response      (ex/try (http-client {:method :get :uri (str discovery-uri)} {:sync? true}))]
     (cond
       (ex/exception? response)
       (do
@@ -294,10 +332,10 @@
         nil)
 
       (= 200 (:status response))
-      (let [data (json/read-str (:body response))]
-        {:token-uri (get data "token_endpoint")
-         :auth-uri  (get data "authorization_endpoint")
-         :user-uri  (get data "userinfo_endpoint")})
+      (let [data (json/read (:body response))]
+        {:token-uri (get data :token_endpoint)
+         :auth-uri  (get data :authorization_endpoint)
+         :user-uri  (get data :userinfo_endpoint)})
 
       :else
       (do
@@ -325,6 +363,7 @@
               :roles-attr    (cf/get :oidc-roles-attr)
               :roles         (cf/get :oidc-roles)
               :name          "oidc"}]
+
     (if (and (string? (:base-uri opts))
              (string? (:client-id opts))
              (string? (:client-secret opts)))
@@ -339,7 +378,7 @@
             (assoc-in cfg [:providers "oidc"] opts))
           (do
             (l/debug :hint "trying to discover oidc provider configuration using BASE_URI")
-            (if-let [opts' (discover-oidc-config opts)]
+            (if-let [opts' (discover-oidc-config cfg opts)]
               (do
                 (l/debug :hint "discovered opts" :additional-opts opts')
                 (assoc-in cfg [:providers "oidc"] (merge opts opts')))
@@ -364,15 +403,25 @@
         (assoc-in cfg [:providers "google"] opts))
       cfg)))
 
+(defn extract-github-email
+  [response]
+  (let [emails (json/read (:body response))
+        primary-email (->> emails
+                           (filter #(:primary %))
+                           first)]
+  (:email primary-email)))
+
 (defn- initialize-github-provider
   [cfg]
-  (let [opts {:client-id     (cf/get :github-client-id)
-              :client-secret (cf/get :github-client-secret)
-              :scopes        #{"read:user" "user:email"}
-              :auth-uri      "https://github.com/login/oauth/authorize"
-              :token-uri     "https://github.com/login/oauth/access_token"
-              :user-uri      "https://api.github.com/user"
-              :name          "github"}]
+  (let [opts {:client-id              (cf/get :github-client-id)
+              :client-secret          (cf/get :github-client-secret)
+              :scopes                 #{"read:user" "user:email"}
+              :auth-uri               "https://github.com/login/oauth/authorize"
+              :token-uri              "https://github.com/login/oauth/access_token"
+              :emails-uri             "https://api.github.com/user/emails"
+              :extract-email-callback extract-github-email
+              :user-uri               "https://api.github.com/user"
+              :name                   "github"}]
     (if (and (string? (:client-id opts))
              (string? (:client-secret opts)))
       (do
@@ -381,17 +430,16 @@
         (assoc-in cfg [:providers "github"] opts))
       cfg)))
 
-
 (defn- initialize-gitlab-provider
   [cfg]
   (let [base (cf/get :gitlab-base-uri "https://gitlab.com")
         opts {:base-uri      base
               :client-id     (cf/get :gitlab-client-id)
               :client-secret (cf/get :gitlab-client-secret)
-              :scopes        #{"read_user"}
+              :scopes        #{"openid" "profile" "email"}
               :auth-uri      (str base "/oauth/authorize")
               :token-uri     (str base "/oauth/token")
-              :user-uri      (str base "/api/v4/user")
+              :user-uri      (str base "/oauth/userinfo")
               :name          "gitlab"}]
     (if (and (string? (:client-id opts))
              (string? (:client-secret opts)))

backend/src/app/http/session.clj

@@ -19,7 +19,9 @@
    [clojure.core.async :as a]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]
-   [ring.middleware.session.store :as rss]))
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.request :as yrq]))
 
 ;; A default cookie name for storing the session. We don't allow to configure it.
 (def token-cookie-name "auth-token")
@@ -29,75 +31,100 @@
 ;; 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})))
+(defprotocol ISessionStore
+  (read-session [store key])
+  (write-session [store key data])
+  (delete-session [store key]))
 
-  (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})
+(defn- make-database-store
+  [{:keys [pool tokens executor]}]
+  (reify ISessionStore
+    (read-session [_ token]
+      (px/with-dispatch executor
+        (db/exec-one! pool (sql/select :http-session {:id token}))))
 
-          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))
+    (write-session [_ _ data]
+      (px/with-dispatch executor
+        (let [profile-id (:profile-id data)
+              user-agent (:user-agent data)
+              token      (tokens :generate {:iss "authentication"
+                                            :iat (dt/now)
+                                            :uid profile-id})
 
-  (delete-session [_ token]
-    (db/delete! pool :http-session {:id token})
-    nil))
+              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)))
 
-(deftype MemoryStore [cache tokens]
-  rss/SessionStore
-  (read-session [_ token]
-    (get @cache token))
+    (delete-session [_ token]
+      (px/with-dispatch executor
+        (db/delete! pool :http-session {:id token})
+        nil))))
 
-  (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}]
+(defn make-inmemory-store
+  [{:keys [tokens]}]
+  (let [cache (atom {})]
+    (reify ISessionStore
+      (read-session [_ token]
+        (p/do (get @cache token)))
 
-      (swap! cache assoc token params)
-      token))
+      (write-session [_ _ data]
+        (p/do
+          (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}]
 
-  (delete-session [_ token]
-    (swap! cache dissoc token)
-    nil))
+            (swap! cache assoc token params)
+            token)))
+
+      (delete-session [_ token]
+        (p/do
+          (swap! cache dissoc token)
+          nil)))))
+
+(s/def ::tokens fn?)
+(defmethod ig/pre-init-spec ::store [_]
+  (s/keys :req-un [::db/pool ::wrk/executor ::tokens]))
+
+(defmethod ig/init-key ::store
+  [_ {:keys [pool] :as cfg}]
+  (if (db/read-only? pool)
+    (make-inmemory-store cfg)
+    (make-database-store cfg)))
+
+(defmethod ig/halt-key! ::store
+  [_ _])
 
 ;; --- IMPL
 
-(defn- create-session
+(defn- create-session!
   [store request profile-id]
-  (let [params {:user-agent (get-in request [:headers "user-agent"])
+  (let [params {:user-agent (yrq/get-header request "user-agent")
                 :profile-id profile-id}]
-    (rss/write-session store nil params)))
+    (write-session store nil params)))
 
-(defn- delete-session
+(defn- delete-session!
   [store {:keys [cookies] :as request}]
   (when-let [token (get-in cookies [token-cookie-name :value])]
-    (rss/delete-session store token)))
+    (delete-session store token)))
 
 (defn- retrieve-session
-  [store token]
-  (when token
-    (rss/read-session store token)))
-
-(defn- retrieve-from-request
-  [store {:keys [cookies] :as request}]
-  (->> (get-in cookies [token-cookie-name :value])
-       (retrieve-session store)))
+  [store request]
+  (when-let [cookie (yrq/get-cookie request token-cookie-name)]
+    (-> (read-session store (:value cookie))
+        (p/then (fn [session]
+                  (when session
+                    {:session-id (:id session)
+                     :profile-id (:profile-id session)}))))))
 
 (defn- add-cookies
   [response token]
@@ -124,64 +151,69 @@
 (defn- clear-cookies
   [response]
   (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}})))
+    (assoc response :cookies
+           {token-cookie-name {:path "/"
+                               :value ""
+                               :max-age -1}
+            authenticated-cookie-name {:domain authenticated-cookie-domain
+                                       :path "/"
+                                       :value ""
+                                       :max-age -1}})))
+
+(defn- make-middleware
+  [{:keys [::events-ch store] :as cfg}]
+  {:name :session-middleware
+   :wrap (fn [handler]
+           (fn [request respond raise]
+             (try
+               (-> (retrieve-session store request)
+                   (p/then' #(merge request %))
+                   (p/finally (fn [request cause]
+                                (if cause
+                                  (raise cause)
+                                  (do
+                                    (when-let [session-id (:session-id request)]
+                                      (a/offer! events-ch session-id))
+                                    (handler request respond raise))))))
+               (catch Throwable cause
+                 (raise cause)))))})
 
-(defn- middleware
-  [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 id)
-        (l/set-context! {:profile-id profile-id})
-        (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 ::tokens]))
+(s/def ::store #(satisfies? ISessionStore %))
 
-(defmethod ig/prep-key ::session
+(defmethod ig/pre-init-spec :app.http/session [_]
+  (s/keys :req-un [::store]))
+
+(defmethod ig/prep-key :app.http/session
   [_ cfg]
   (d/merge {:buffer-size 128}
            (d/without-nils cfg)))
 
-(defmethod ig/init-key ::session
-  [_ {:keys [pool tokens] :as cfg}]
+(defmethod ig/init-key :app.http/session
+  [_ {:keys [store] :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 cfg ::events-ch events-ch)]
 
     (-> cfg
-        (assoc ::events-ch events-ch)
-        (assoc :middleware (partial middleware events-ch store))
+        (assoc :middleware (make-middleware cfg))
         (assoc :create (fn [profile-id]
                          (fn [request response]
-                           (let [token (create-session store request profile-id)]
+                           (p/let [token (create-session! store request profile-id)]
                              (add-cookies response token)))))
         (assoc :delete (fn [request response]
-                         (delete-session store request)
-                         (-> response
-                             (assoc :status 204)
-                             (assoc :body "")
-                             (clear-cookies)))))))
+                         (p/do
+                           (delete-session! store request)
+                           (-> response
+                               (assoc :status 204)
+                               (assoc :body nil)
+                               (clear-cookies))))))))
 
-(defmethod ig/halt-key! ::session
+(defmethod ig/halt-key! :app.http/session
   [_ data]
   (a/close! (::events-ch data)))
 
-
 ;; --- STATE INIT: SESSION UPDATER
 
 (declare update-sessions)
@@ -192,8 +224,7 @@
 
 (defmethod ig/pre-init-spec ::updater [_]
   (s/keys :req-un [::db/pool ::wrk/executor ::mtx/metrics ::session]
-          :opt-un [::max-batch-age
-                   ::max-batch-size]))
+          :opt-un [::max-batch-age ::max-batch-size]))
 
 (defmethod ig/prep-key ::updater
   [_ cfg]

backend/src/app/http/websocket.clj

@@ -22,51 +22,161 @@
 ;; WEBSOCKET HANDLER
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(declare send-presence!)
-
 (defmulti handle-message
-  (fn [_wsp message] (:type message)))
+  (fn [_ message]
+    (:type message)))
 
 (defmethod handle-message :connect
   [wsp _]
-  (let [{:keys [msgbus file-id team-id session-id ::ws/output-ch]} @wsp
-        sub-ch (a/chan (a/dropping-buffer 32))]
+  (l/trace :fn "handle-message" :event :connect)
 
-    (swap! wsp assoc :sub-ch sub-ch)
+  (let [msgbus-fn  (:msgbus @wsp)
+        profile-id (::profile-id @wsp)
+        session-id (::session-id @wsp)
+        output-ch  (::ws/output-ch @wsp)
 
-    ;; Start a subscription forwarding goroutine
-    (a/go-loop []
-      (when-let [val (a/<! sub-ch)]
-        (when-not (= (:session-id val) session-id)
-          ;; If we receive a connect message of other user, we need
-          ;; to send an update presence to all participants.
-          (when (= :connect (:type val))
-            (a/<! (send-presence! @wsp :presence)))
+        xform      (remove #(= (:session-id %) session-id))
+        channel    (a/chan (a/dropping-buffer 16) xform)]
 
-          ;; Then, just forward the message
-          (a/>! output-ch val))
-        (recur)))
-
-    (a/go
-      (a/<! (msgbus :sub {:topics [file-id team-id] :chan sub-ch}))
-      (a/<! (send-presence! @wsp :connect)))))
+    (swap! wsp assoc ::profile-subs-channel channel)
+    (a/pipe channel output-ch false)
+    (msgbus-fn :cmd :sub :topic profile-id :chan channel)))
 
 (defmethod handle-message :disconnect
   [wsp _]
-  (a/close! (:sub-ch @wsp))
-  (send-presence! @wsp :disconnect))
+  (l/trace :fn "handle-message" :event :disconnect)
+  (a/go
+    (let [msgbus-fn  (:msgbus @wsp)
+          profile-id (::profile-id @wsp)
+          session-id (::session-id @wsp)
+          profile-ch (::profile-subs-channel @wsp)
+          subs       (::subscriptions @wsp)]
+
+      ;; Close the main profile subscription
+      (a/close! profile-ch)
+      (a/<! (msgbus-fn :cmd :purge :chans [profile-ch]))
+
+      ;; Close all other active subscrption on this websocket context.
+      (doseq [{:keys [channel topic]} (map second subs)]
+        (a/close! channel)
+        (a/<! (msgbus-fn :cmd :pub :topic topic
+                         :message {:type :disconnect
+                                   :profile-id profile-id
+                                   :session-id session-id}))
+        (a/<! (msgbus-fn :cmd :purge :chans [channel]))))))
+
+(defmethod handle-message :subscribe-team
+  [wsp {:keys [team-id] :as params}]
+  (l/trace :fn "handle-message" :event :subscribe-team :team-id team-id)
+
+  (let [msgbus-fn  (:msgbus @wsp)
+        session-id (::session-id @wsp)
+        output-ch  (::ws/output-ch @wsp)
+        subs       (get-in @wsp [::subscriptions team-id])
+        xform      (comp
+                    (remove #(= (:session-id %) session-id))
+                    (map #(assoc % :subs-id team-id)))]
+
+    (a/go
+      (when (not= (:team-id subs) team-id)
+        ;; if it exists we just need to close that
+        (when-let [channel (:channel subs)]
+          (a/close! channel)
+          (a/<! (msgbus-fn :cmd :purge :chans [channel])))
+
+
+        (let [channel (a/chan (a/dropping-buffer 64) xform)]
+          ;; Message forwarding
+          (a/pipe channel output-ch false)
+
+          (let [state {:team-id team-id :channel channel :topic team-id}]
+            (swap! wsp update ::subscriptions assoc team-id state))
+
+          (a/<! (msgbus-fn :cmd :sub :topic team-id :chan channel)))))))
+
+(defmethod handle-message :subscribe-file
+  [wsp {:keys [subs-id file-id] :as params}]
+  (l/trace :fn "handle-message" :event :subscribe-file :subs-id subs-id :file-id file-id)
+  (let [msgbus-fn  (:msgbus @wsp)
+        profile-id (::profile-id @wsp)
+        session-id (::session-id @wsp)
+        output-ch  (::ws/output-ch @wsp)
+
+        xform      (comp
+                    (remove #(= (:session-id %) session-id))
+                    (map #(assoc % :subs-id subs-id)))
+
+        channel    (a/chan (a/dropping-buffer 64) xform)]
+
+    ;; Message forwarding
+    (a/go-loop []
+      (when-let [{:keys [type] :as message} (a/<! channel)]
+        (when (or (= :join-file type)
+                  (= :leave-file type)
+                  (= :disconnect type))
+          (let [message {:type :presence
+                         :file-id file-id
+                         :session-id session-id
+                         :profile-id profile-id}]
+            (a/<! (msgbus-fn :cmd :pub
+                             :topic file-id
+                             :message message))))
+        (a/>! output-ch message)
+        (recur)))
+
+    (let [state {:file-id file-id :channel channel :topic file-id}]
+      (swap! wsp update ::subscriptions assoc subs-id state))
+
+    (a/go
+      ;; Subscribe to file topic
+      (a/<! (msgbus-fn :cmd :sub :topic file-id :chan channel))
+
+      ;; Notifify the rest of participants of the new connection.
+      (let [message {:type :join-file
+                     :file-id file-id
+                     :session-id session-id
+                     :profile-id profile-id}]
+        (a/<! (msgbus-fn :cmd :pub
+                         :topic file-id
+                         :message message))))))
+
+(defmethod handle-message :unsubscribe-file
+  [wsp {:keys [subs-id] :as params}]
+  (l/trace :fn "handle-message" :event :unsubscribe-file :subs-id subs-id)
+  (let [msgbus-fn  (:msgbus @wsp)
+        session-id (::session-id @wsp)
+        profile-id (::profile-id @wsp)]
+    (a/go
+      (when-let [{:keys [file-id channel]} (get-in @wsp [::subscriptions subs-id])]
+        (let [message {:type :leave-file
+                       :file-id file-id
+                       :session-id session-id
+                       :profile-id profile-id}]
+          (a/close! channel)
+          (a/<! (msgbus-fn :cmd :pub :topic file-id :message message))
+          (a/<! (msgbus-fn :cmd :purge :chans [channel])))))))
 
 (defmethod handle-message :keepalive
   [_ _]
+  (l/trace :fn "handle-message" :event :keepalive)
   (a/go :nothing))
 
 (defmethod handle-message :pointer-update
-  [wsp message]
-  (let [{:keys [profile-id file-id session-id msgbus]} @wsp]
-    (msgbus :pub {:topic file-id
-                  :message (assoc message
-                                  :profile-id profile-id
-                                  :session-id session-id)})))
+  [wsp {:keys [subs-id] :as message}]
+  (a/go
+    ;; Only allow receive pointer updates when active subscription
+    (when-let [{:keys [topic]} (get-in @wsp [::subscriptions subs-id])]
+      (let [msgbus-fn  (:msgbus @wsp)
+            profile-id (::profile-id @wsp)
+            session-id (::session-id @wsp)
+            message    (-> message
+                           (dissoc :subs-id)
+                           (assoc :profile-id profile-id)
+                           (assoc :session-id session-id))]
+
+        (a/<! (msgbus-fn :cmd :pub
+                         :topic topic
+                         :message message))))))
 
 (defmethod handle-message :default
   [_ message]
@@ -75,51 +185,33 @@
            :msg "received unexpected message"
            :message message)))
 
-;; --- IMPL
-
-(defn- send-presence!
-  ([ws] (send-presence! ws :presence))
-  ([{:keys [msgbus session-id profile-id file-id]} type]
-   (msgbus :pub {:topic file-id
-                 :message {:type type
-                           :session-id session-id
-                           :profile-id profile-id}})))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; HTTP HANDLER
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(declare retrieve-file)
-
 (s/def ::msgbus fn?)
-(s/def ::file-id ::us/uuid)
 (s/def ::session-id ::us/uuid)
 
 (s/def ::handler-params
-  (s/keys :req-un [::file-id ::session-id]))
+  (s/keys :req-un [::session-id]))
 
 (defmethod ig/pre-init-spec ::handler [_]
   (s/keys :req-un [::msgbus ::db/pool ::mtx/metrics]))
 
 (defmethod ig/init-key ::handler
-  [_ {:keys [pool] :as cfg}]
+  [_ 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)))]
+    (let [{:keys [session-id]} (us/conform ::handler-params params)
+          cfg    (-> cfg
+                     (assoc ::profile-id profile-id)
+                     (assoc ::session-id session-id))]
 
+      (l/trace :hint "http request to websocket" :profile-id profile-id :session-id session-id)
       (cond
         (not profile-id)
         (raise (ex/error :type :authentication
                          :hint "Authentication required."))
 
-        (not file)
-        (raise (ex/error :type :not-found
-                         :code :object-not-found))
-
-
         (not (yws/upgrade-request? req))
         (raise (ex/error :type :validation
                          :code :websocket-request-expected
@@ -129,16 +221,3 @@
         (->> (ws/handler handle-message cfg)
              (yws/upgrade req)
              (respond))))))
-
-(def ^:private
-  sql:retrieve-file
-  "select f.id as id,
-          p.team_id as team_id
-     from file as f
-     join project as p on (p.id = f.project_id)
-    where f.id = ?")
-
-(defn- retrieve-file
-  [conn id]
-  (db/exec-one! conn [sql:retrieve-file id]))
-

backend/src/app/loggers/audit.clj

@@ -16,7 +16,6 @@
    [app.config :as cf]
    [app.db :as db]
    [app.util.async :as aa]
-   [app.util.http :as http]
    [app.util.time :as dt]
    [app.worker :as wrk]
    [clojure.core.async :as a]
@@ -25,13 +24,29 @@
    [integrant.core :as ig]
    [lambdaisland.uri :as u]
    [promesa.core :as p]
-   [promesa.exec :as px]))
+   [promesa.exec :as px]
+   [yetti.request :as yrq]
+   [yetti.response :as yrs]))
 
 (defn parse-client-ip
-  [{:keys [headers] :as request}]
-  (or (some-> (get headers "x-forwarded-for") (str/split ",") first)
-      (get headers "x-real-ip")
-      (get request :remote-addr)))
+  [request]
+  (or (some-> (yrq/get-header request "x-forwarded-for") (str/split ",") first)
+      (yrq/get-header request "x-real-ip")
+      (yrq/remote-addr request)))
+
+(defn extract-utm-params
+  "Extracts additional data from params and namespace them under
+  `penpot` ns."
+  [params]
+  (letfn [(process-param [params k v]
+            (let [sk (d/name k)]
+              (cond-> params
+                (str/starts-with? sk "utm_")
+                (assoc (->> sk str/kebab (keyword "penpot")) v)
+
+                (str/starts-with? sk "mtm_")
+                (assoc (->> sk str/kebab (keyword "penpot")) v))))]
+    (reduce-kv process-param {} params)))
 
 (defn profile->props
   [profile]
@@ -88,11 +103,10 @@
     (do
       (l/warn :hint "audit log http handler disabled or db is read-only")
       (fn [_ respond _]
-        (respond {:status 204 :body ""})))
+        (respond (yrs/response 204))))
 
-
-    (letfn [(handler [{:keys [params profile-id] :as request}]
-              (let [events  (->> (:events params)
+    (letfn [(handler [{:keys [profile-id] :as request}]
+              (let [events  (->> (:events (:params request))
                                  (remove #(not= profile-id (:profile-id %)))
                                  (us/conform ::frontend-events))
 
@@ -114,7 +128,7 @@
         (-> (px/submit! executor #(handler request))
             (p/catch handle-error))
 
-        (respond {:status 204 :body ""})))))
+        (respond (yrs/response 204))))))
 
 (defn- persist-http-events
   [{:keys [pool events ip-addr source] :as cfg}]
@@ -221,11 +235,12 @@
 
 (declare archive-events)
 
+(s/def ::http-client fn?)
 (s/def ::uri ::us/string)
 (s/def ::tokens fn?)
 
 (defmethod ig/pre-init-spec ::archive-task [_]
-  (s/keys :req-un [::db/pool ::tokens]
+  (s/keys :req-un [::db/pool ::tokens ::http-client]
           :opt-un [::uri]))
 
 (defmethod ig/init-key ::archive-task
@@ -253,11 +268,11 @@
   "select * from audit_log
     where archived_at is null
     order by created_at asc
-    limit 1000
+    limit 256
       for update skip locked;")
 
 (defn archive-events
-  [{:keys [pool uri tokens] :as cfg}]
+  [{:keys [pool uri tokens http-client] :as cfg}]
   (letfn [(decode-row [{:keys [props ip-addr context] :as row}]
             (cond-> row
               (db/pgobject? props)
@@ -293,12 +308,13 @@
                            :method :post
                            :headers headers
                            :body body}
-                  resp    (http/send! params)]
+                  resp    (http-client params {:sync? true})]
               (if (= (:status resp) 204)
                 true
                 (do
-                  (l/warn :hint "unable to archive events"
-                          :resp-status (:status resp))
+                  (l/error :hint "unable to archive events"
+                           :resp-status (:status resp)
+                           :resp-body (:body resp))
                   false))))
 
           (mark-as-archived [conn rows]

backend/src/app/loggers/loki.clj

@@ -10,36 +10,34 @@
    [app.common.logging :as l]
    [app.common.spec :as us]
    [app.config :as cfg]
-   [app.util.async :as aa]
-   [app.util.http :as http]
    [app.util.json :as json]
-   [app.worker :as wrk]
    [clojure.core.async :as a]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]))
 
-(declare handle-event)
+(declare ^:private handle-event)
+(declare ^:private start-rcv-loop)
 
 (s/def ::uri ::us/string)
 (s/def ::receiver fn?)
+(s/def ::http-client fn?)
 
 (defmethod ig/pre-init-spec ::reporter [_]
-  (s/keys :req-un [::wrk/executor ::receiver]
+  (s/keys :req-un [ ::receiver ::http-client]
           :opt-un [::uri]))
 
 (defmethod ig/init-key ::reporter
   [_ {:keys [receiver uri] :as cfg}]
   (when uri
     (l/info :msg "initializing loki reporter" :uri uri)
-    (let [input (a/chan (a/dropping-buffer 512))]
+    (let [input (a/chan (a/dropping-buffer 2048))]
       (receiver :sub input)
-      (a/go-loop []
-        (let [msg (a/<! input)]
-          (if (nil? msg)
-            (l/info :msg "stoping error reporting loop")
-            (do
-              (a/<! (handle-event cfg msg))
-              (recur)))))
+
+      (doto (Thread. #(start-rcv-loop cfg input))
+        (.setDaemon true)
+        (.setName "penpot/loki-sender")
+        (.start))
+
       input)))
 
 (defmethod ig/halt-key! ::reporter
@@ -47,53 +45,49 @@
   (when output
     (a/close! output)))
 
+(defn- start-rcv-loop
+  [cfg input]
+  (loop []
+    (let [msg (a/<!! input)]
+      (when-not (nil? msg)
+        (handle-event cfg msg)
+        (recur))))
+
+  (l/info :msg "stoping error reporting loop"))
+
 (defn- prepare-payload
   [event]
   (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]
-  (try
-    (let [response (http/send! {:uri uri
-                                :timeout 6000
-                                :method :post
-                                :headers {"content-type" "application/json"}
-                                :body (json/write payload)})]
-      (cond
-        (= (:status response) 204)
-        true
 
-        (= (:status response) 400)
-        (do
-          (l/error :hint "error on sending log to loki (no retry)"
-                   :rsp (pr-str response))
-          true)
-
-        :else
-        (do
-          (l/error :hint "error on sending log to loki" :try i
-                   :rsp (pr-str response))
-          false)))
-    (catch Exception e
-      (l/error :hint "error on sending message to loki" :cause e :try i)
-      false)))
+(defn- make-request
+  [{:keys [http-client uri] :as cfg} payload]
+  (http-client {:uri uri
+                :timeout 3000
+                :method :post
+                :headers {"content-type" "application/json"}
+                :body (json/write payload)}
+               {:sync? true}))
 
 (defn- handle-event
-  [{:keys [executor uri]} event]
-  (aa/with-thread executor
-    (let [payload (prepare-payload event)]
-      (loop [i 1]
-        (when (and (not (send-log uri payload i)) (< i 20))
-          (Thread/sleep (* i 2000))
-          (recur (inc i)))))))
-
+  [cfg event]
+  (try
+    (let [payload  (prepare-payload event)
+          response (make-request cfg payload)]
+      (when-not (= 204 (:status response))
+        (map? response)
+        (l/error :hint "error on sending log to loki (unexpected response)"
+                 :response (pr-str response))))
+    (catch Throwable cause
+      (l/error :hint "error on sending log to loki (unexpected exception)"
+               :cause cause))))

backend/src/app/loggers/mattermost.clj

@@ -9,52 +9,47 @@
   (:require
    [app.common.logging :as l]
    [app.config :as cf]
-   [app.db :as db]
    [app.loggers.database :as ldb]
-   [app.util.async :as aa]
-   [app.util.http :as http]
    [app.util.json :as json]
-   [app.worker :as wrk]
    [clojure.core.async :as a]
    [clojure.spec.alpha :as s]
-   [integrant.core :as ig]))
+   [integrant.core :as ig]
+   [promesa.core :as p]))
 
 (defonce enabled (atom true))
 
 (defn- send-mattermost-notification!
-  [cfg {:keys [host id public-uri] :as event}]
-  (try
-    (let [uri  (:uri cfg)
-          text (str "Exception on (host: " host ", url: " public-uri "/dbg/error/" id ")\n"
-                    (when-let [pid (:profile-id event)]
-                      (str "- profile-id: #uuid-" pid "\n")))
-          rsp  (http/send! {:uri uri
-                            :method :post
-                            :headers {"content-type" "application/json"}
-                            :body (json/write-str {:text text})})]
-      (when (not= (:status rsp) 200)
-        (l/error :hint "error on sending data to mattermost"
-                 :response (pr-str rsp))))
-
-    (catch Exception e
-      (l/error :hint "unexpected exception on error reporter"
-               :cause e))))
+  [{:keys [http-client] :as cfg} {:keys [host id public-uri] :as event}]
+  (let [uri  (:uri cfg)
+        text (str "Exception on (host: " host ", url: " public-uri "/dbg/error/" id ")\n"
+                  (when-let [pid (:profile-id event)]
+                    (str "- profile-id: #uuid-" pid "\n")))]
+    (p/then
+     (http-client {:uri uri
+                   :method :post
+                   :headers {"content-type" "application/json"}
+                   :body (json/write-str {:text text})})
+     (fn [{:keys [status] :as rsp}]
+       (when (not= status 200)
+         (l/warn :hint "error on sending data to mattermost"
+                 :response (pr-str rsp)))))))
 
 (defn handle-event
-  [{:keys [executor] :as cfg} event]
-  (aa/with-thread executor
-    (try
-      (let [event (ldb/parse-event event)]
-        (when @enabled
-          (send-mattermost-notification! cfg event)))
-      (catch Exception e
-        (l/warn :hint "unexpected exception on error reporter" :cause e)))))
-
+  [cfg event]
+  (let [ch (a/chan)]
+    (-> (p/let [event (ldb/parse-event event)]
+          (send-mattermost-notification! cfg event))
+        (p/finally (fn [_ cause]
+                     (when cause
+                       (l/warn :hint "unexpected exception on error reporter" :cause cause))
+                     (a/close! ch))))
+    ch))
 
+(s/def ::http-client fn?)
 (s/def ::uri ::cf/error-report-webhook)
 
 (defmethod ig/pre-init-spec ::reporter [_]
-  (s/keys :req-un [::wrk/executor ::db/pool ::receiver]
+  (s/keys :req-un [::http-client ::receiver]
           :opt-un [::uri]))
 
 (defmethod ig/init-key ::reporter

backend/src/app/loggers/zmq.clj

@@ -37,7 +37,11 @@
                                (keep prepare)))
         mult   (a/mult output)]
     (when endpoint
-      (a/thread (start-rcv-loop {:out buffer :endpoint endpoint})))
+      (let [thread (Thread. #(start-rcv-loop {:out buffer :endpoint endpoint}))]
+        (.setDaemon thread false)
+        (.setName thread "penpot/zmq-logger-receiver")
+        (.start thread)))
+
     (a/pipe buffer output)
     (with-meta
       (fn [cmd ch]
@@ -62,7 +66,7 @@
   ([] (start-rcv-loop nil))
   ([{:keys [out endpoint] :or {endpoint "tcp://localhost:5556"}}]
    (let [out    (or out (a/chan 1))
-         zctx   (ZContext.)
+         zctx   (ZContext. 1)
          socket (.. zctx (createSocket SocketType/SUB))]
      (.. socket (connect ^String endpoint))
      (.. socket (subscribe ""))
@@ -75,7 +79,7 @@
            (recur)
            (do
              (.close ^java.lang.AutoCloseable socket)
-             (.close ^java.lang.AutoCloseable zctx))))))))
+             (.destroy ^ZContext zctx))))))))
 
 (s/def ::logger-name string?)
 (s/def ::level string?)
@@ -83,7 +87,7 @@
 (s/def ::time-millis integer?)
 (s/def ::message string?)
 (s/def ::context-map map?)
-(s/def ::throw map?)
+(s/def ::thrown map?)
 
 (s/def ::log4j-event
   (s/keys :req-un [::logger-name ::level ::thread ::time-millis ::message]
@@ -97,8 +101,8 @@
             :logger/name  (:logger-name event)
             :logger/level (str/lower (:level event))}
 
-           (when-let [thrown (:thrown event)]
-             {:trace (:extended-stack-trace thrown)})
+           (when-let [trace (-> event :thrown :extended-stack-trace)]
+             {:trace trace})
 
            (:context-map event))
     (do

backend/src/app/main.clj

@@ -20,19 +20,19 @@
     :read-only  (cf/get :database-readonly false)
     :metrics    (ig/ref :app.metrics/metrics)
     :migrations (ig/ref :app.migrations/all)
-    :name :main
-    :min-size (cf/get :database-min-pool-size 0)
-    :max-size (cf/get :database-max-pool-size 30)}
+    :name       :main
+    :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.
+   ;; Constrained thread pool. Should only be used from high resources
+   ;; demanding operations.
    [::blocking :app.worker/executor]
-   {:parallelism (cf/get :blocking-executor-parallelism 20)
+   {:parallelism (cf/get :blocking-executor-parallelism 10)
     :prefix :blocking}
 
    ;; Dedicated thread pool for backround tasks execution.
@@ -40,6 +40,10 @@
    {:parallelism (cf/get :worker-executor-parallelism 10)
     :prefix :worker}
 
+   :app.worker/scheduler
+   {:parallelism 1
+    :prefix :scheduler}
+
    :app.worker/executors
    {:default  (ig/ref [::default :app.worker/executor])
     :worker   (ig/ref [::worker :app.worker/executor])
@@ -47,6 +51,7 @@
 
    :app.worker/executors-monitor
    {:metrics   (ig/ref :app.metrics/metrics)
+    :scheduler (ig/ref :app.worker/scheduler)
     :executors (ig/ref :app.worker/executors)}
 
    :app.migrations/migrations
@@ -60,6 +65,7 @@
 
    :app.msgbus/msgbus
    {:backend   (cf/get :msgbus-backend :redis)
+    :executor  (ig/ref [::default :app.worker/executor])
     :redis-uri (cf/get :redis-uri)}
 
    :app.tokens/tokens
@@ -68,14 +74,22 @@
    :app.storage/gc-deleted-task
    {:pool     (ig/ref :app.db/pool)
     :storage  (ig/ref :app.storage/storage)
+    :executor (ig/ref [::worker :app.worker/executor])
     :min-age  (dt/duration {:hours 2})}
 
    :app.storage/gc-touched-task
-   {:pool     (ig/ref :app.db/pool)}
+   {:pool (ig/ref :app.db/pool)}
 
-   :app.http.session/session
+   :app.http/client
+   {:executor (ig/ref [::default :app.worker/executor])}
+
+   :app.http/session
+   {:store (ig/ref :app.http.session/store)}
+
+   :app.http.session/store
    {:pool     (ig/ref :app.db/pool)
-    :tokens   (ig/ref :app.tokens/tokens)}
+    :tokens   (ig/ref :app.tokens/tokens)
+    :executor (ig/ref [::default :app.worker/executor])}
 
    :app.http.session/gc-task
    {:pool        (ig/ref :app.db/pool)
@@ -85,41 +99,45 @@
    {:pool           (ig/ref :app.db/pool)
     :metrics        (ig/ref :app.metrics/metrics)
     :executor       (ig/ref [::worker :app.worker/executor])
-    :session        (ig/ref :app.http.session/session)
+    :session        (ig/ref :app.http/session)
     :max-batch-age  (cf/get :http-session-updater-batch-max-age)
     :max-batch-size (cf/get :http-session-updater-batch-max-size)}
 
    :app.http.awsns/handler
-   {:tokens  (ig/ref :app.tokens/tokens)
-    :pool    (ig/ref :app.db/pool)}
+   {:tokens      (ig/ref :app.tokens/tokens)
+    :pool        (ig/ref :app.db/pool)
+    :http-client (ig/ref :app.http/client)
+    :executor    (ig/ref [::worker :app.worker/executor])}
 
    :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)
-
-    :max-threads (cf/get :http-server-max-threads)
-    :min-threads (cf/get :http-server-min-threads)}
+    :executor    (ig/ref [::default :app.worker/executor])
+    :io-threads  (cf/get :http-server-io-threads)
+    :max-body-size           (cf/get :http-server-max-body-size)
+    :max-multipart-body-size (cf/get :http-server-max-multipart-body-size)}
 
    :app.http/router
-   {:assets               (ig/ref :app.http.assets/handlers)
-    :feedback             (ig/ref :app.http.feedback/handler)
-    :session              (ig/ref :app.http.session/session)
-    :sns-webhook          (ig/ref :app.http.awsns/handler)
-    :oauth                (ig/ref :app.http.oauth/handler)
-    :debug                (ig/ref :app.http.debug/handlers)
-    :ws                   (ig/ref :app.http.websocket/handler)
-    :metrics              (ig/ref :app.metrics/metrics)
-    :public-uri           (cf/get :public-uri)
-    :storage              (ig/ref :app.storage/storage)
-    :tokens               (ig/ref :app.tokens/tokens)
-    :audit-http-handler   (ig/ref :app.loggers.audit/http-handler)
-    :rpc                  (ig/ref :app.rpc/rpc)}
+   {:assets        (ig/ref :app.http.assets/handlers)
+    :feedback      (ig/ref :app.http.feedback/handler)
+    :session       (ig/ref :app.http/session)
+    :awsns-handler (ig/ref :app.http.awsns/handler)
+    :oauth         (ig/ref :app.http.oauth/handler)
+    :debug         (ig/ref :app.http.debug/handlers)
+    :ws            (ig/ref :app.http.websocket/handler)
+    :metrics       (ig/ref :app.metrics/metrics)
+    :public-uri    (cf/get :public-uri)
+    :storage       (ig/ref :app.storage/storage)
+    :tokens        (ig/ref :app.tokens/tokens)
+    :audit-handler (ig/ref :app.loggers.audit/http-handler)
+    :rpc           (ig/ref :app.rpc/rpc)
+    :executor      (ig/ref [::default :app.worker/executor])}
 
    :app.http.debug/handlers
    {:pool (ig/ref :app.db/pool)
-    :executor (ig/ref [::default :app.worker/executor])}
+    :executor (ig/ref [::worker :app.worker/executor])}
 
    :app.http.websocket/handler
    {:pool     (ig/ref :app.db/pool)
@@ -139,24 +157,26 @@
     :executor (ig/ref [::default :app.worker/executor])}
 
    :app.http.oauth/handler
-   {:rpc        (ig/ref :app.rpc/rpc)
-    :session    (ig/ref :app.http.session/session)
-    :pool       (ig/ref :app.db/pool)
-    :tokens     (ig/ref :app.tokens/tokens)
-    :audit      (ig/ref :app.loggers.audit/collector)
-    :executor   (ig/ref [::default :app.worker/executor])
-    :public-uri (cf/get :public-uri)}
+   {:rpc         (ig/ref :app.rpc/rpc)
+    :session     (ig/ref :app.http/session)
+    :pool        (ig/ref :app.db/pool)
+    :tokens      (ig/ref :app.tokens/tokens)
+    :audit       (ig/ref :app.loggers.audit/collector)
+    :executor    (ig/ref [::default :app.worker/executor])
+    :http-client (ig/ref :app.http/client)
+    :public-uri  (cf/get :public-uri)}
 
    :app.rpc/rpc
-   {:pool       (ig/ref :app.db/pool)
-    :session    (ig/ref :app.http.session/session)
-    :tokens     (ig/ref :app.tokens/tokens)
-    :metrics    (ig/ref :app.metrics/metrics)
-    :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)
-    :executors  (ig/ref :app.worker/executors)}
+   {:pool        (ig/ref :app.db/pool)
+    :session     (ig/ref :app.http/session)
+    :tokens      (ig/ref :app.tokens/tokens)
+    :metrics     (ig/ref :app.metrics/metrics)
+    :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)
+    :http-client (ig/ref :app.http/client)
+    :executors   (ig/ref :app.worker/executors)}
 
    :app.worker/worker
    {:executor (ig/ref [::worker :app.worker/executor])
@@ -164,13 +184,14 @@
     :metrics  (ig/ref :app.metrics/metrics)
     :pool     (ig/ref :app.db/pool)}
 
-   :app.worker/scheduler
+   :app.worker/cron
    {:executor   (ig/ref [::worker :app.worker/executor])
+    :scheduler  (ig/ref :app.worker/scheduler)
     :tasks      (ig/ref :app.worker/registry)
     :pool       (ig/ref :app.db/pool)
-    :schedule
+    :entries
     [{:cron #app/cron "0 0 0 * * ?" ;; daily
-      :task :file-media-gc}
+      :task :file-gc}
 
      {:cron #app/cron "0 0 * * * ?"  ;; hourly
       :task :file-xlog-gc}
@@ -190,6 +211,9 @@
      {:cron #app/cron "0 0 0 * * ?"  ;; daily
       :task :tasks-gc}
 
+     {:cron #app/cron "0 30 */3,23 * * ?"
+      :task :telemetry}
+
      (when (cf/get :fdata-storage-backed)
        {:cron #app/cron "0 0 * * * ?"  ;; hourly
         :task :file-offload})
@@ -200,19 +224,14 @@
 
      (when (contains? cf/flags :audit-log-gc)
        {:cron #app/cron "0 0 0 * * ?" ;; daily
-        :task :audit-log-gc})
-
-     (when (or (contains? cf/flags :telemetry)
-               (cf/get :telemetry-enabled))
-       {:cron #app/cron "0 30 */3,23 * * ?"
-        :task :telemetry})]}
+        :task :audit-log-gc})]}
 
    :app.worker/registry
    {:metrics (ig/ref :app.metrics/metrics)
     :tasks
     {:sendmail           (ig/ref :app.emails/sendmail-handler)
      :objects-gc         (ig/ref :app.tasks.objects-gc/handler)
-     :file-media-gc      (ig/ref :app.tasks.file-media-gc/handler)
+     :file-gc            (ig/ref :app.tasks.file-gc/handler)
      :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)
@@ -243,7 +262,7 @@
     :storage (ig/ref :app.storage/storage)
     :max-age cf/deletion-delay}
 
-   :app.tasks.file-media-gc/handler
+   :app.tasks.file-gc/handler
    {:pool    (ig/ref :app.db/pool)
     :max-age cf/deletion-delay}
 
@@ -261,7 +280,8 @@
    {:pool        (ig/ref :app.db/pool)
     :version     (:full cf/version)
     :uri         (cf/get :telemetry-uri)
-    :sprops      (ig/ref :app.setup/props)}
+    :sprops      (ig/ref :app.setup/props)
+    :http-client (ig/ref :app.http/client)}
 
    :app.srepl/server
    {:port (cf/get :srepl-port)
@@ -279,31 +299,31 @@
 
    :app.loggers.audit/http-handler
    {:pool     (ig/ref :app.db/pool)
-    :executor (ig/ref [::worker :app.worker/executor])}
+    :executor (ig/ref [::default :app.worker/executor])}
 
    :app.loggers.audit/collector
    {:pool     (ig/ref :app.db/pool)
     :executor (ig/ref [::worker :app.worker/executor])}
 
    :app.loggers.audit/archive-task
-   {:uri      (cf/get :audit-log-archive-uri)
-    :tokens   (ig/ref :app.tokens/tokens)
-    :pool     (ig/ref :app.db/pool)}
+   {:uri         (cf/get :audit-log-archive-uri)
+    :tokens      (ig/ref :app.tokens/tokens)
+    :pool        (ig/ref :app.db/pool)
+    :http-client (ig/ref :app.http/client)}
 
    :app.loggers.audit/gc-task
    {:max-age  (cf/get :audit-log-gc-max-age cf/deletion-delay)
     :pool     (ig/ref :app.db/pool)}
 
    :app.loggers.loki/reporter
-   {:uri      (cf/get :loggers-loki-uri)
-    :receiver (ig/ref :app.loggers.zmq/receiver)
-    :executor (ig/ref [::worker :app.worker/executor])}
+   {:uri         (cf/get :loggers-loki-uri)
+    :receiver    (ig/ref :app.loggers.zmq/receiver)
+    :http-client (ig/ref :app.http/client)}
 
    :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 [::worker :app.worker/executor])}
+   {:uri         (cf/get :error-report-webhook)
+    :receiver    (ig/ref :app.loggers.zmq/receiver)
+    :http-client (ig/ref :app.http/client)}
 
    :app.loggers.database/reporter
    {:receiver (ig/ref :app.loggers.zmq/receiver)
@@ -312,6 +332,8 @@
 
    :app.storage/storage
    {:pool     (ig/ref :app.db/pool)
+    :executor (ig/ref [::default :app.worker/executor])
+
     :backends
     {:assets-s3 (ig/ref [::assets :app.storage.s3/backend])
      :assets-db (ig/ref [::assets :app.storage.db/backend])
@@ -328,12 +350,14 @@
    {: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)}
+    :prefix   (cf/get :storage-fdata-s3-prefix)
+    :executor (ig/ref [::default :app.worker/executor])}
 
    [::assets :app.storage.s3/backend]
    {:region   (cf/get :storage-assets-s3-region)
     :endpoint (cf/get :storage-assets-s3-endpoint)
-    :bucket   (cf/get :storage-assets-s3-bucket)}
+    :bucket   (cf/get :storage-assets-s3-bucket)
+    :executor (ig/ref [::default :app.worker/executor])}
 
    [::assets :app.storage.fs/backend]
    {:directory (cf/get :storage-assets-fs-directory)}

backend/src/app/media.clj

@@ -28,27 +28,30 @@
    org.im4java.core.IMOperation
    org.im4java.core.Info))
 
-(s/def ::image-content-type cm/valid-image-types)
-(s/def ::font-content-type cm/valid-font-types)
-
-(s/def :internal.http.upload/filename ::us/string)
-(s/def :internal.http.upload/size ::us/integer)
-(s/def :internal.http.upload/content-type ::us/string)
-(s/def :internal.http.upload/tempfile any?)
+(s/def ::path fs/path?)
+(s/def ::filename string?)
+(s/def ::size integer?)
+(s/def ::headers (s/map-of string? string?))
+(s/def ::mtype string?)
 
 (s/def ::upload
-  (s/keys :req-un [:internal.http.upload/filename
-                   :internal.http.upload/size
-                   :internal.http.upload/tempfile
-                   :internal.http.upload/content-type]))
+  (s/keys :req-un [::filename ::size ::path]
+          :opt-un [::mtype ::headers]))
 
-(defn validate-media-type
-  ([mtype] (validate-media-type mtype cm/valid-image-types))
-  ([mtype allowed]
-   (when-not (contains? allowed mtype)
+;; A subset of fields from the ::upload spec
+(s/def ::input
+  (s/keys :req-un [::path]
+          :opt-un [::mtype]))
+
+(defn validate-media-type!
+  ([upload] (validate-media-type! upload cm/valid-image-types))
+  ([upload allowed]
+   (when-not (contains? allowed (:mtype upload))
      (ex/raise :type :validation
                :code :media-type-not-allowed
-               :hint "Seems like you are uploading an invalid media object"))))
+               :hint "Seems like you are uploading an invalid media object"))
+
+   upload))
 
 (defmulti process :cmd)
 (defmulti process-error class)
@@ -71,26 +74,16 @@
       (process-error e))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; --- Thumbnails Generation
+;; IMAGE THUMBNAILS
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(s/def ::cmd keyword?)
-
-(s/def ::path (s/or :path fs/path?
-                    :string string?
-                    :file fs/file?))
-
-(s/def ::input
-  (s/keys :req-un [::path]
-          :opt-un [::cm/mtype]))
-
 (s/def ::width integer?)
 (s/def ::height integer?)
 (s/def ::format #{:jpeg :webp :png})
 (s/def ::quality #(< 0 % 101))
 
 (s/def ::thumbnail-params
-  (s/keys :req-un [::cmd ::input ::format ::width ::height]))
+  (s/keys :req-un [::input ::format ::width ::height]))
 
 ;; Related info on how thumbnails generation
 ;;  http://www.imagemagick.org/Usage/thumbnails/
@@ -177,7 +170,7 @@
           (ex/raise :type :validation
                     :code :invalid-svg-file
                     :hint "uploaded svg does not provides dimensions"))
-        (assoc info :mtype mtype))
+        (merge input info))
 
       (let [instance (Info. (str path))
             mtype'   (.getProperty instance "Mime type")]
@@ -190,9 +183,9 @@
         ;; For an animated GIF, getImageWidth/Height returns the delta size of one frame (if no frame given
         ;; it returns size of the last one), whereas getPageWidth/Height always return the full size of
         ;; any frame.
-        {:width  (.getPageWidth instance)
-         :height (.getPageHeight instance)
-         :mtype  mtype}))))
+        (assoc input
+               :width  (.getPageWidth instance)
+               :height (.getPageHeight instance))))))
 
 (defmethod process-error org.im4java.core.InfoException
   [error]
@@ -202,7 +195,7 @@
             :cause error))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Fonts Generation
+;; FONTS
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defmethod process :generate-fonts
@@ -325,11 +318,10 @@
 
 (defn configure-assets-storage
   "Given storage map, returns a storage configured with the appropriate
-  backend for assets."
+  backend for assets and optional connection attached."
   ([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

@@ -23,8 +23,6 @@
    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))
 
 (set! *warn-on-reflection* true)
@@ -264,10 +262,3 @@
     :gauge   (make-gauge props)
     :summary (make-summary props)
     :histogram (make-histogram props)))
-
-(defn instrument-jetty!
-  [^CollectorRegistry registry ^StatisticsHandler handler]
-  (doto (JettyStatisticsCollector. handler)
-    (.register registry))
-  nil)
-

backend/src/app/migrations.clj

@@ -205,9 +205,27 @@
 
    {: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")}
+
+   {:name "0067-add-team-invitation-table"
+    :fn (mg/resource "app/migrations/sql/0067-add-team-invitation-table.sql")}
+
+   {:name "0068-mod-storage-object-table"
+    :fn (mg/resource "app/migrations/sql/0068-mod-storage-object-table.sql")}
+
+   {:name "0069-add-file-thumbnail-table"
+    :fn (mg/resource "app/migrations/sql/0069-add-file-thumbnail-table.sql")}
+
+   {:name "0070-del-frame-thumbnail-table"
+    :fn (mg/resource "app/migrations/sql/0070-del-frame-thumbnail-table.sql")}
+
+   {:name "0071-add-file-object-thumbnail-table"
+    :fn (mg/resource "app/migrations/sql/0071-add-file-object-thumbnail-table.sql")}
+
+   {:name "0072-mod-file-object-thumbnail-table"
+    :fn (mg/resource "app/migrations/sql/0072-mod-file-object-thumbnail-table.sql")}
    ])
 
 

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

@@ -8,3 +8,6 @@ CREATE TABLE file_frame_thumbnail (
 
   PRIMARY KEY(file_id, frame_id)
 );
+
+ALTER TABLE file_frame_thumbnail
+  ALTER COLUMN data SET STORAGE external;

backend/src/app/migrations/sql/0067-add-team-invitation-table.sql

@@ -0,0 +1,14 @@
+CREATE TABLE team_invitation (  
+  team_id uuid NOT NULL REFERENCES team(id) ON DELETE CASCADE,
+  email_to text NOT NULL,
+  role text NOT NULL,
+  valid_until timestamptz NOT NULL,
+  created_at timestamptz NOT NULL DEFAULT now(),
+  updated_at timestamptz NOT NULL DEFAULT now(),
+
+  PRIMARY KEY(team_id, email_to)
+);
+
+ALTER TABLE team_invitation
+  ALTER COLUMN email_to SET STORAGE external,
+  ALTER COLUMN role SET STORAGE external;

backend/src/app/migrations/sql/0068-mod-storage-object-table.sql

@@ -0,0 +1,3 @@
+CREATE INDEX storage_object__hash_backend_bucket__idx
+    ON storage_object ((metadata->>'~:hash'), (metadata->>'~:bucket'), backend)
+ WHERE deleted_at IS NULL;

backend/src/app/migrations/sql/0069-add-file-thumbnail-table.sql

@@ -0,0 +1,14 @@
+CREATE TABLE file_thumbnail (
+  file_id uuid NOT NULL REFERENCES file(id) ON DELETE CASCADE,
+  revn bigint NOT NULL,
+  created_at timestamptz NOT NULL DEFAULT now(),
+  updated_at timestamptz NOT NULL DEFAULT now(),
+  deleted_at timestamptz NULL,
+  data text NULL,
+  props jsonb NULL,
+  PRIMARY KEY(file_id, revn)
+);
+
+ALTER TABLE file_thumbnail
+  ALTER COLUMN data SET STORAGE external,
+  ALTER COLUMN props SET STORAGE external;

backend/src/app/migrations/sql/0070-del-frame-thumbnail-table.sql

@@ -0,0 +1 @@
+DROP TABLE file_frame_thumbnail;

backend/src/app/migrations/sql/0071-add-file-object-thumbnail-table.sql

@@ -0,0 +1,11 @@
+CREATE TABLE file_object_thumbnail (
+  file_id uuid NOT NULL REFERENCES file(id) ON DELETE CASCADE,
+  object_id uuid NOT NULL,
+  created_at timestamptz NOT NULL DEFAULT now(),
+  data text NULL,
+
+  PRIMARY KEY(file_id, object_id)
+);
+
+ALTER TABLE file_object_thumbnail
+  ALTER COLUMN data SET STORAGE external;

backend/src/app/migrations/sql/0072-mod-file-object-thumbnail-table.sql

@@ -0,0 +1,4 @@
+TRUNCATE TABLE file_object_thumbnail;
+
+ALTER TABLE file_object_thumbnail
+  ALTER COLUMN object_id TYPE text;

backend/src/app/msgbus.clj

@@ -7,12 +7,15 @@
 (ns app.msgbus
   "The msgbus abstraction implemented using redis as underlying backend."
   (:require
+   [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.logging :as l]
    [app.common.spec :as us]
+   [app.common.transit :as t]
    [app.config :as cfg]
-   [app.util.blob :as blob]
+   [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]
@@ -28,120 +31,83 @@
    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.sync.RedisPubSubCommands
    io.lettuce.core.resource.ClientResources
    io.lettuce.core.resource.DefaultClientResources
    java.time.Duration))
 
+(set! *warn-on-reflection* true)
+
 (def ^:private prefix (cfg/get :tenant))
 
 (defn- prefix-topic
   [topic]
   (str prefix "." topic))
 
-(def xform-prefix (map prefix-topic))
-(def xform-topics (map (fn [m] (update m :topics #(into #{} xform-prefix %)))))
-(def xform-topic  (map (fn [m] (update m :topic prefix-topic))))
+(def ^:private xform-prefix-topic
+  (map (fn [obj] (update obj :topic prefix-topic))))
 
-(s/def ::redis-uri ::us/string)
-(s/def ::buffer-size ::us/integer)
-
-(defmulti init-backend :backend)
-(defmulti stop-backend :backend)
-(defmulti init-pub-loop :backend)
-(defmulti init-sub-loop :backend)
-
-(defmethod ig/pre-init-spec ::msgbus [_]
-  (s/keys :opt-un [::buffer-size ::redis-uri]))
+(declare ^:private redis-connect)
+(declare ^:private redis-disconnect)
+(declare ^:private start-io-loop)
+(declare ^:private subscribe)
+(declare ^:private purge)
+(declare ^:private redis-pub)
+(declare ^:private redis-sub)
+(declare ^:private redis-unsub)
 
 (defmethod ig/prep-key ::msgbus
   [_ cfg]
-  (merge {:buffer-size 128} cfg))
+  (merge {:buffer-size 128
+          :timeout (dt/duration {:seconds 30})}
+         (d/without-nils cfg)))
+
+(s/def ::timeout ::dt/duration)
+(s/def ::redis-uri ::us/string)
+(s/def ::buffer-size ::us/integer)
+
+(defmethod ig/pre-init-spec ::msgbus [_]
+  (s/keys :req-un [::buffer-size ::redis-uri ::timeout ::wrk/executor]))
 
 (defmethod ig/init-key ::msgbus
-  [_ {:keys [backend buffer-size] :as cfg}]
-  (l/debug :action "initialize msgbus"
-           :backend (name backend))
-  (let [cfg     (init-backend cfg)
+  [_ {:keys [buffer-size redis-uri] :as cfg}]
+  (l/info :hint "initialize msgbus"
+          :buffer-size buffer-size
+          :redis-uri redis-uri)
+  (let [cmd-ch (a/chan buffer-size)
+        rcv-ch (a/chan (a/dropping-buffer buffer-size))
+        pub-ch (a/chan (a/dropping-buffer buffer-size) xform-prefix-topic)
+        state  (agent {} :error-handler #(l/error :cause % :hint "unexpected error on agent" ::l/async false))
+        cfg    (-> (redis-connect cfg)
+                   (assoc ::cmd-ch cmd-ch)
+                   (assoc ::rcv-ch rcv-ch)
+                   (assoc ::pub-ch pub-ch)
+                   (assoc ::state state))]
 
-        ;; Channel used for receive publications from the application.
-        pub-ch  (-> (a/dropping-buffer buffer-size)
-                    (a/chan xform-topic))
-
-        ;; Channel used for receive subscription requests.
-        sub-ch  (a/chan 1 xform-topics)
-
-        cfg     (-> cfg
-                    (assoc ::pub-ch pub-ch)
-                    (assoc ::sub-ch sub-ch))]
-
-    (init-pub-loop cfg)
-    (init-sub-loop cfg)
+    (start-io-loop cfg)
 
     (with-meta
-      (fn run
-        ([command] (run command nil))
-        ([command params]
-         (a/go
-           (case command
-             :pub (a/>! pub-ch params)
-             :sub (a/>! sub-ch params)))))
+      (fn [& {:keys [cmd] :as params}]
+        (a/go
+          (case cmd
+            :pub   (a/>! pub-ch params)
+            :sub   (a/<! (subscribe cfg params))
+            :purge (a/<! (purge cfg params))
+            (l/error :hint "unexpeced error on msgbus command processing" :params params))))
       cfg)))
 
 (defmethod ig/halt-key! ::msgbus
   [_ f]
   (let [mdata (meta f)]
-    (stop-backend mdata)
-    (a/close! (::pub-ch mdata))
-    (a/close! (::sub-ch mdata))))
+    (redis-disconnect mdata)
+    (a/close! (::cmd-ch mdata))
+    (a/close! (::rcv-ch mdata))))
 
-;; --- IN-MEMORY BACKEND IMPL
+;; --- IMPL
 
-(defmethod init-backend :memory [cfg] cfg)
-(defmethod stop-backend :memory [_])
-(defmethod init-pub-loop :memory [_])
-
-(defmethod init-sub-loop :memory
-  [{:keys [::sub-ch ::pub-ch]}]
-  (a/go-loop [state {}]
-    (let [[val port] (a/alts! [pub-ch sub-ch])]
-      (cond
-        (and (= port sub-ch) (some? val))
-        (let [{:keys [topics chan]} val]
-          (recur (reduce #(update %1 %2 (fnil conj #{}) chan) state topics)))
-
-        (and (= port pub-ch) (some? val))
-        (let [topic   (:topic val)
-              message (:message val)
-              state   (loop [state state
-                             chans (get state topic)]
-                        (if-let [c (first chans)]
-                          (if (a/>! c message)
-                            (recur state (rest chans))
-                            (recur (update state topic disj c)
-                                   (rest chans)))
-                          state))]
-          (recur state))
-
-        :else
-        (->> (vals state)
-             (mapcat identity)
-             (run! a/close!))))))
-
-
-;; Add a unique listener to connection
-
-;; --- REDIS BACKEND IMPL
-
-(declare impl-redis-open?)
-(declare impl-redis-pub)
-(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)
+(defn- redis-connect
+  [{:keys [redis-uri timeout] :as cfg}]
+  (let [codec     (RedisCodec/of StringCodec/UTF8 ByteArrayCodec/INSTANCE)
 
         resources (.. (DefaultClientResources/builder)
                       (ioThreadPoolSize 4)
@@ -151,162 +117,181 @@
         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)]
+        pconn     (.connect ^RedisClient rclient ^RedisCodec codec)
+        sconn     (.connectPubSub ^RedisClient rclient ^RedisCodec codec)]
 
-    (.setTimeout ^StatefulRedisConnection pub-conn ^Duration (dt/duration {:seconds 10}))
-    (.setTimeout ^StatefulRedisPubSubConnection sub-conn ^Duration (dt/duration {:seconds 10}))
+    (.setTimeout ^StatefulRedisConnection pconn ^Duration timeout)
+    (.setTimeout ^StatefulRedisPubSubConnection sconn ^Duration timeout)
 
     (-> cfg
         (assoc ::resources resources)
-        (assoc ::pub-conn pub-conn)
-        (assoc ::sub-conn sub-conn))))
+        (assoc ::pconn pconn)
+        (assoc ::sconn sconn))))
 
-(defmethod stop-backend :redis
-  [{:keys [::pub-conn ::sub-conn ::resources] :as cfg}]
-  (.close ^StatefulRedisConnection pub-conn)
-  (.close ^StatefulRedisPubSubConnection sub-conn)
+(defn- redis-disconnect
+  [{:keys [::pconn ::sconn ::resources] :as cfg}]
+  (.. ^StatefulConnection pconn close)
+  (.. ^StatefulConnection sconn close)
   (.shutdown ^ClientResources resources))
 
-(defmethod init-pub-loop :redis
-  [{:keys [::pub-conn ::pub-ch]}]
-  (let [rac (.async ^StatefulRedisConnection pub-conn)]
-    (a/go-loop []
-      (when-let [val (a/<! pub-ch)]
-        (let [result (a/<! (impl-redis-pub rac val))]
-          (when (and (impl-redis-open? pub-conn)
-                     (ex/exception? result))
-            (l/error :cause result
-                     :hint "unexpected error on publish message to redis")))
-        (recur)))))
+(defn- conj-subscription
+  "A low level function that is responsible to create on-demand
+  subscriptions on redis. It reuses the same subscription if it is
+  already established. Intended to be executed in agent."
+  [nsubs cfg topic chan]
+  (let [nsubs (if (nil? nsubs) #{chan} (conj nsubs chan))]
+    (when (= 1 (count nsubs))
+      (l/trace :hint "open subscription" :topic topic ::l/async false)
+      (redis-sub cfg topic))
+    nsubs))
 
-(defmethod init-sub-loop :redis
-  [{:keys [::sub-conn ::sub-ch buffer-size]}]
-  (let [rcv-ch  (a/chan (a/dropping-buffer buffer-size))
-        chans   (agent {} :error-handler #(l/error :cause % :hint "unexpected error on agent"))
-        rac     (.async ^StatefulRedisPubSubConnection sub-conn)]
+(defn- disj-subscription
+  "A low level function responsible on removing subscriptions. The
+  subscription is trully removed from redis once no single local
+  subscription is look for it. Intended to be executed in agent."
+  [nsubs cfg topic chan]
+  (let [nsubs (disj nsubs chan)]
+    (when (empty? nsubs)
+      (l/trace :hint "close subscription" :topic topic ::l/async false)
+      (redis-unsub cfg topic))
+    nsubs))
 
-    ;; Add a unique listener to connection
-    (.addListener sub-conn
-                  (reify RedisPubSubListener
-                    (message [_ _pattern _topic _message])
-                    (message [_ topic message]
-                      ;; There are no back pressure, so we use a slidding
-                      ;; buffer for cases when the pubsub broker sends
-                      ;; more messages that we can process.
-                      (let [val {:topic topic :message (blob/decode message)}]
-                        (when-not (a/offer! rcv-ch val)
-                          (l/warn :msg "dropping message on subscription loop"))))
-                    (psubscribed [_ _pattern _count])
-                    (punsubscribed [_ _pattern _count])
-                    (subscribed [_ _topic _count])
-                    (unsubscribed [_ _topic _count])))
+(defn- subscribe-to-topics
+  "Function responsible to attach local subscription to the
+  state. Intended to be used in agent."
+  [state cfg topics chan done-ch]
+  (l/trace :hint "subscribe-to-topics" :topics topics ::l/async false)
+  (aa/with-closing done-ch
+    (let [state (update state :chans assoc chan topics)]
+      (reduce (fn [state topic]
+                (update-in state [:topics topic] conj-subscription cfg topic chan))
+              state
+              topics))))
 
-    (letfn [(subscribe-to-single-topic [nsubs topic chan]
-              (let [nsubs (if (nil? nsubs) #{chan} (conj nsubs chan))]
-                (when (= 1 (count nsubs))
-                  (let [result (a/<!! (impl-redis-sub rac topic))]
-                    (l/trace :action "open subscription"
-                             :topic topic)
-                    (when (ex/exception? result)
-                      (l/error :cause result
-                               :hint "unexpected exception on subscribing"
-                               :topic topic))))
-                nsubs))
+(defn- unsubscribe-single-channel
+  "Auxiliar function responsible on removing a single local
+  subscription from the state."
+  [state cfg chan]
+  (let [topics (get-in state [:chans chan])
+        state  (update state :chans dissoc chan)]
+    (reduce (fn [state topic]
+              (update-in state [:topics topic] disj-subscription cfg topic chan))
+            state
+            topics)))
 
-            (subscribe-to-topics [state topics chan]
-              (let [state  (update state :chans assoc chan topics)]
-                (reduce (fn [state topic]
-                          (update-in state [:topics topic] subscribe-to-single-topic topic chan))
-                        state
-                        topics)))
+(defn- unsubscribe-channels
+  "Function responsible from detach from state a seq of channels,
+  useful when client disconnects or in-bulk unsubscribe
+  operations. Intended to be executed in agent."
+  [state cfg channels done-ch]
+  (l/trace :hint "unsubscribe-channels" :chans (count channels) ::l/async false)
+  (aa/with-closing done-ch
+    (reduce #(unsubscribe-single-channel %1 cfg %2) state channels)))
 
-            (unsubscribe-from-single-topic [nsubs topic chan]
-              (let [nsubs (disj nsubs chan)]
-                (when (empty? nsubs)
-                  (let [result (a/<!! (impl-redis-unsub rac topic))]
-                    (l/trace :action "close subscription"
-                             :topic topic)
-                    (when (and (impl-redis-open? sub-conn)
-                               (ex/exception? result))
-                      (l/error :cause result
-                               :hint "unexpected exception on unsubscribing"
-                               :topic topic))))
-                nsubs))
+(defn- subscribe
+  [{:keys [::state executor] :as cfg} {:keys [topic topics chan]}]
+  (let [done-ch (a/chan)
+        topics  (into [] (map prefix-topic) (if topic [topic] topics))]
+    (l/trace :hint "subscribe" :topics topics)
+    (send-via executor state subscribe-to-topics cfg topics chan done-ch)
+    done-ch))
 
-            (unsubscribe-channels [state pending]
-              (reduce (fn [state ch]
-                        (let [topics (get-in state [:chans ch])
-                              state  (update state :chans dissoc ch)]
-                          (reduce (fn [state topic]
-                                    (update-in state [:topics topic] unsubscribe-from-single-topic topic ch))
-                                  state
-                                  topics)))
-                      state
-                      pending))]
+(defn- purge
+  [{:keys [::state executor] :as cfg} {:keys [chans]}]
+  (l/trace :hint "purge" :chans (count chans))
+  (let [done-ch (a/chan)]
+    (send-via executor state unsubscribe-channels cfg chans done-ch)
+    done-ch))
 
-      ;; Asynchronous subscription loop;
-      (a/go-loop []
-        (if-let [{:keys [topics chan]} (a/<! sub-ch)]
-          (do
-            (send-off chans subscribe-to-topics topics chan)
-            (recur))
-          (a/close! rcv-ch)))
+(defn- create-listener
+  [rcv-ch]
+  (reify RedisPubSubListener
+    (message [_ _pattern _topic _message])
+    (message [_ topic message]
+      ;; There are no back pressure, so we use a slidding
+      ;; buffer for cases when the pubsub broker sends
+      ;; more messages that we can process.
+      (let [val {:topic topic :message (t/decode message)}]
+        (when-not (a/offer! rcv-ch val)
+          (l/warn :msg "dropping message on subscription loop"))))
+    (psubscribed [_ _pattern _count])
+    (punsubscribed [_ _pattern _count])
+    (subscribed [_ _topic _count])
+    (unsubscribed [_ _topic _count])))
 
-      ;; Asynchronous message processing loop;x
-      (a/go-loop []
-        (if-let [{:keys [topic message]} (a/<! rcv-ch)]
-          ;; This means we receive data from redis and we need to
-          ;; forward it to the underlying subscriptions.
-          (let [pending (loop [chans   (seq (get-in @chans [:topics topic]))
-                               pending #{}]
-                          (if-let [ch (first chans)]
-                            (if (a/>! ch message)
-                              (recur (rest chans) pending)
-                              (recur (rest chans) (conj pending ch)))
-                            pending))]
-            (some->> (seq pending)
-                     (send-off chans unsubscribe-channels))
+(defn start-io-loop
+  [{:keys [::sconn ::rcv-ch ::pub-ch ::state executor] :as cfg}]
 
-            (recur))
+  ;; Add a single listener to the pubsub connection
+  (.addListener ^StatefulRedisPubSubConnection sconn
+                ^RedisPubSubListener (create-listener rcv-ch))
 
-          ;; Stop condition; close all underlying subscriptions and
-          ;; exit. The close operation is performed asynchronously.
-          (send-off chans (fn [state]
-                            (->> (vals state)
-                                 (mapcat identity)
-                                 (filter some?)
-                                 (run! a/close!)))))))))
+  (letfn [(send-to-topic [topic message]
+            (a/go-loop [chans  (seq (get-in @state [:topics topic]))
+                        closed #{}]
+              (if-let [ch (first chans)]
+                (if (a/>! ch message)
+                  (recur (rest chans) closed)
+                  (recur (rest chans) (conj closed ch)))
+                (seq closed))))
 
+          (process-incoming [{:keys [topic message]}]
+            (a/go
+              (when-let [closed (a/<! (send-to-topic topic message))]
+                (send-via executor state unsubscribe-channels cfg closed nil))))
+          ]
 
-(defn- impl-redis-open?
-  [^StatefulConnection conn]
-  (.isOpen conn))
+  (a/go-loop []
+    (let [[val port] (a/alts! [pub-ch rcv-ch])]
+      (cond
+        (nil? val)
+        (do
+          (l/trace :hint "stoping io-loop, nil received")
+          (send-via executor state (fn [state]
+                                     (->> (vals state)
+                                          (mapcat identity)
+                                          (filter some?)
+                                          (run! a/close!))
+                                     nil)))
 
-(defn- impl-redis-pub
-  [^RedisAsyncCommands rac {:keys [topic message]}]
-  (let [message (blob/encode message)
-        res     (a/chan 1)]
-    (-> (.publish rac ^String topic ^bytes message)
-        (p/finally (fn [_ e]
-                     (when e (a/>!! res e))
+        (= port rcv-ch)
+        (do
+          (a/<! (process-incoming val))
+          (recur))
+
+        (= port pub-ch)
+        (let [result (a/<! (redis-pub cfg val))]
+          (when (ex/exception? result)
+            (l/error :hint "unexpected error on publishing" :message val
+                     :cause result))
+          (recur)))))))
+
+(defn- redis-pub
+  "Publish a message to the redis server. Asynchronous operation,
+  intended to be used in core.async go blocks."
+  [{:keys [::pconn] :as cfg} {:keys [topic message]}]
+  (let [message (t/encode message)
+        res     (a/chan 1)
+        pcomm   (.async ^StatefulRedisConnection pconn)]
+    (-> (.publish ^RedisAsyncCommands pcomm ^String topic ^bytes message)
+        (p/finally (fn [_ cause]
+                     (when (and cause (.isOpen ^StatefulConnection pconn))
+                       (a/offer! res cause))
                      (a/close! res))))
     res))
 
-(defn impl-redis-sub
-  [^RedisPubSubAsyncCommands rac topic]
-  (let [res (a/chan 1)]
-    (-> (.subscribe rac (into-array String [topic]))
-        (p/finally (fn [_ e]
-                     (when e (a/>!! res e))
-                     (a/close! res))))
-    res))
+(defn redis-sub
+  "Create redis subscription. Blocking operation, intended to be used
+  inside an agent."
+  [{:keys [::sconn] :as cfg} topic]
+  (let [topic (into-array String [topic])
+        scomm (.sync ^StatefulRedisPubSubConnection sconn)]
+    (.subscribe ^RedisPubSubCommands scomm topic)))
 
-(defn impl-redis-unsub
-  [rac topic]
-  (let [res (a/chan 1)]
-    (-> (.unsubscribe rac (into-array String [topic]))
-        (p/finally (fn [_ e]
-                     (when e (a/>!! res e))
-                     (a/close! res))))
-    res))
+(defn redis-unsub
+  "Removes redis subscription. Blocking operation, intended to be used
+  inside an agent."
+  [{:keys [::sconn] :as cfg} topic]
+  (let [topic (into-array String [topic])
+        scomm (.sync ^StatefulRedisPubSubConnection sconn)]
+    (.unsubscribe ^RedisPubSubCommands scomm topic)))

backend/src/app/rpc.clj

@@ -21,7 +21,8 @@
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]
    [promesa.core :as p]
-   [promesa.exec :as px]))
+   [promesa.exec :as px]
+   [yetti.response :as yrs]))
 
 (defn- default-handler
   [_]
@@ -30,8 +31,8 @@
 (defn- handle-response-transformation
   [response request mdata]
   (if-let [transform-fn (:transform-response mdata)]
-    (transform-fn request response)
-    response))
+    (p/do (transform-fn request response))
+    (p/resolved response)))
 
 (defn- handle-before-comple-hook
   [response mdata]
@@ -42,55 +43,49 @@
 (defn- rpc-query-handler
   "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]
+  [methods {:keys [profile-id session-id params] :as request} respond raise]
   (letfn [(handle-response [result]
             (let [mdata (meta result)]
-              (-> {:status 200 :body result}
+              (-> (yrs/response 200 result)
                   (handle-response-transformation request mdata))))]
 
-    (let [type   (keyword (get-in request [:path-params :type]))
-          data   (merge (:params request)
-                        (:body-params request)
-                        (:uploads request)
-                        {::request request})
-
+    (let [type   (keyword (:type params))
+          data   (into {::request request} params)
           data   (if profile-id
                    (assoc data :profile-id profile-id ::session-id session-id)
                    (dissoc data :profile-id))
-
-          ;; Get the method from methods registry and if method does
-          ;; not exists asigns it to the default handler.
           method (get methods type default-handler)]
 
       (-> (method data)
-          (p/then #(respond (handle-response %)))
-          (p/catch raise)))))
+          (p/then handle-response)
+          (p/then respond)
+          (p/catch (fn [cause]
+                     (let [context {:profile-id profile-id}]
+                       (raise (ex/wrap-with-context cause context)))))))))
 
 (defn- rpc-mutation-handler
   "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]
+  [methods {:keys [profile-id session-id params] :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))))]
-
-    (let [type   (keyword (get-in request [:path-params :type]))
-          data   (merge (:params request)
-                        (:body-params request)
-                        (:uploads request)
-                        {::request request})
+              (p/-> (yrs/response 200 result)
+                    (handle-response-transformation request mdata)
+                    (handle-before-comple-hook mdata))))]
 
+    (let [type   (keyword (:type params))
+          data   (into {::request request} params)
           data   (if profile-id
                    (assoc data :profile-id profile-id ::session-id session-id)
                    (dissoc data :profile-id))
 
           method (get methods type default-handler)]
-
       (-> (method data)
-          (p/then #(respond (handle-response %)))
-          (p/catch raise)))))
+          (p/then handle-response)
+          (p/then respond)
+          (p/catch (fn [cause]
+                     (let [context {:profile-id profile-id}]
+                       (raise (ex/wrap-with-context cause context)))))))))
 
 (defn- wrap-metrics
   "Wrap service method with metrics measurement."
@@ -110,11 +105,11 @@
   "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)]
+  (let [dname (::async/dispatch mdata :default)]
     (if (= :none dname)
       (with-meta
         (fn [cfg params]
-          (p/do! (f cfg params)))
+          (p/do (f cfg params)))
         mdata)
 
       (let [executor (get executors dname)]
@@ -147,7 +142,7 @@
                                 :name (or (::audit/name resultm)
                                           (::sv/name mdata))
                                 :profile-id profile-id
-                                :ip-addr (audit/parse-client-ip request)
+                                :ip-addr (some-> request audit/parse-client-ip)
                                 :props (dissoc props ::request)))))))
       mdata)
     f))

backend/src/app/rpc/helpers.clj

@@ -0,0 +1,16 @@
+;; 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.helpers
+  "General purpose RPC helpers."
+  (:require [app.common.data.macros :as dm]))
+
+(defn http-cache
+  [{:keys [max-age]}]
+  (fn [_ response]
+    (let [exp (if (integer? max-age) max-age (inst-ms max-age))
+          val (dm/fmt "max-age=%" (int (/ exp 1000.0)))]
+      (update response :headers assoc "cache-control" val))))

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

@@ -17,12 +17,13 @@
    [app.rpc.permissions :as perms]
    [app.rpc.queries.files :as files]
    [app.rpc.queries.projects :as proj]
+   [app.rpc.rlimit :as rlimit]
    [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]
-   [clojure.spec.alpha :as s]))
+   [clojure.spec.alpha :as s]
+   [promesa.core :as p]))
 
 (declare create-file)
 
@@ -57,8 +58,9 @@
          (db/insert! conn :file-profile-rel))))
 
 (defn create-file
-  [conn {:keys [id name project-id is-shared data deleted-at]
+  [conn {:keys [id name project-id is-shared data deleted-at revn]
          :or {is-shared false
+              revn 0
               deleted-at nil}
          :as params}]
   (let [id   (or id (:id data) (uuid/next))
@@ -67,6 +69,7 @@
                          {:id id
                           :project-id project-id
                           :name name
+                          :revn revn
                           :is-shared is-shared
                           :data (blob/encode data)
                           :deleted-at deleted-at})]
@@ -126,7 +129,6 @@
   [{:keys [pool] :as cfg} {:keys [id profile-id] :as params}]
   (db/with-atomic [conn pool]
     (files/check-edition-permissions! conn profile-id id)
-
     (mark-file-deleted conn params)))
 
 (defn mark-file-deleted
@@ -273,7 +275,7 @@
          (contains? o :changes-with-metadata)))))
 
 (sv/defmethod ::update-file
-  {::async/dispatch :blocking}
+  {::rlimit/permits (cf/get :rlimit-file-update)}
   [{:keys [pool] :as cfg} {:keys [id profile-id] :as params}]
   (db/with-atomic [conn pool]
     (db/xact-lock! conn id)
@@ -295,8 +297,9 @@
 
 (defn- delete-from-storage
   [{:keys [storage] :as cfg} file]
-  (when-let [backend (simpl/resolve-backend storage (:data-backend file))]
-    (simpl/del-object backend file)))
+  (p/do
+    (when-let [backend (simpl/resolve-backend storage (:data-backend file))]
+      (simpl/del-object backend file))))
 
 (defn- update-file
   [{:keys [conn metrics] :as cfg} {:keys [file changes changes-with-metadata session-id profile-id] :as params}]
@@ -319,7 +322,7 @@
         _       (mtx/run! metrics {:id :update-file-changes :inc (count changes)})
 
         ts      (dt/now)
-        file    (-> (files/retrieve-data cfg file)
+        file    (-> file
                     (update :revn inc)
                     (update :data (fn [data]
                                     ;; Trace the length of bytes of processed data
@@ -353,7 +356,7 @@
 
     ;; We need to delete the data from external storage backend
     (when-not (nil? (:data-backend file))
-      (delete-from-storage cfg file))
+      @(delete-from-storage cfg file))
 
     (db/update! conn :project
                 {:modified-at ts}
@@ -385,31 +388,33 @@
                                (assoc :changes []))))))))
 
 (defn- send-notifications
-  [{:keys [msgbus conn] :as cfg} {:keys [file changes session-id] :as params}]
-  (let [lchanges (filter library-change? changes)]
+  [{:keys [conn] :as cfg} {:keys [file changes session-id] :as params}]
+  (let [lchanges  (filter library-change? changes)
+        msgbus-fn (:msgbus cfg)]
+
 
     ;; Asynchronously publish message to the msgbus
-    (msgbus :pub {:topic (:id file)
-                  :message
-                  {:type :file-change
-                   :profile-id (:profile-id params)
-                   :file-id (:id file)
-                   :session-id (:session-id params)
-                   :revn (:revn file)
-                   :changes changes}})
+    (msgbus-fn :cmd :pub
+               :topic (:id file)
+               :message {:type :file-change
+                         :profile-id (:profile-id params)
+                         :file-id (:id file)
+                         :session-id (:session-id params)
+                         :revn (:revn file)
+                         :changes changes})
 
     (when (and (:is-shared file) (seq lchanges))
       (let [team-id (retrieve-team-id conn (:project-id file))]
         ;; Asynchronously publish message to the msgbus
-        (msgbus :pub {:topic team-id
-                      :message
-                      {:type :library-change
-                       :profile-id (:profile-id params)
-                       :file-id (:id file)
-                       :session-id session-id
-                       :revn (:revn file)
-                       :modified-at (dt/now)
-                       :changes lchanges}})))))
+        (msgbus-fn :cmd :pub
+                   :topic team-id
+                   :message {:type :library-change
+                             :profile-id (:profile-id params)
+                             :file-id (:id file)
+                             :session-id session-id
+                             :revn (:revn file)
+                             :modified-at (dt/now)
+                             :changes lchanges})))))
 
 (defn- retrieve-team-id
   [conn project-id]
@@ -471,27 +476,48 @@
                        :revn revn
                        :data (blob/encode data)}
                       {:id id})))
-
       nil)))
 
+;; --- Mutation: upsert object thumbnail
 
-;; --- Mutation: Upsert frame thumbnail
-
-(def sql:upsert-frame-thumbnail
-  "insert into file_frame_thumbnail(file_id, frame_id, data)
+(def sql:upsert-object-thumbnail
+  "insert into file_object_thumbnail(file_id, object_id, data)
    values (?, ?, ?)
-       on conflict(file_id, frame_id) do
+       on conflict(file_id, object_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]))
+(s/def ::data (s/nilable ::us/string))
+(s/def ::object-id ::us/string)
+(s/def ::upsert-file-object-thumbnail
+  (s/keys :req-un [::profile-id ::file-id ::object-id ::data]))
 
-(sv/defmethod ::upsert-frame-thumbnail
-  [{:keys [pool] :as cfg} {:keys [profile-id file-id frame-id data]}]
+(sv/defmethod ::upsert-file-object-thumbnail
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id object-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])
+    (if data
+      (db/exec-one! conn [sql:upsert-object-thumbnail file-id object-id data data])
+      (db/delete! conn :file-object-thumbnail {:file-id file-id :object-id object-id}))
     nil))
 
+;; --- Mutation: upsert file thumbnail
 
+(def sql:upsert-file-thumbnail
+  "insert into file_thumbnail (file_id, revn, data, props)
+   values (?, ?, ?, ?::jsonb)
+       on conflict(file_id, revn) do
+          update set data = ?, props=?, updated_at=now();")
+
+(s/def ::revn ::us/integer)
+(s/def ::props map?)
+(s/def ::upsert-file-thumbnail
+  (s/keys :req-un [::profile-id ::file-id ::revn ::data ::props]))
+
+(sv/defmethod ::upsert-file-thumbnail
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id revn data props]}]
+  (db/with-atomic [conn pool]
+    (files/check-edition-permissions! conn profile-id file-id)
+    (let [props (db/tjson (or props {}))]
+      (db/exec-one! conn [sql:upsert-file-thumbnail
+                          file-id revn data props data props])
+      nil)))

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

@@ -6,16 +6,21 @@
 
 (ns app.rpc.mutations.fonts
   (:require
+   [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
+   [app.config :as cf]
    [app.db :as db]
    [app.media :as media]
    [app.rpc.queries.teams :as teams]
+   [app.rpc.rlimit :as rlimit]
    [app.storage :as sto]
    [app.util.services :as sv]
    [app.util.time :as dt]
-   [clojure.spec.alpha :as s]))
+   [clojure.spec.alpha :as s]
+   [promesa.core :as p]
+   [promesa.exec :as px]))
 
 (declare create-font-variant)
 
@@ -29,7 +34,6 @@
 (s/def ::weight valid-weight)
 (s/def ::style valid-style)
 (s/def ::font-id ::us/uuid)
-(s/def ::content-type ::media/font-content-type)
 (s/def ::data (s/map-of ::us/string any?))
 
 (s/def ::create-font-variant
@@ -37,57 +41,76 @@
                    ::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}]
-  (teams/check-edition-permissions! pool profile-id team-id)
-  (create-font-variant cfg params))
+  (let [cfg (update cfg :storage media/configure-assets-storage)]
+    (teams/check-edition-permissions! pool profile-id team-id)
+    (create-font-variant cfg params)))
 
 (defn create-font-variant
-  [{:keys [storage pool] :as cfg} {:keys [data] :as params}]
-  (let [data    (media/run {:cmd :generate-fonts :input data})
-        storage (media/configure-assets-storage storage)]
+  [{:keys [storage pool executors] :as cfg} {:keys [data] :as params}]
+  (letfn [(generate-fonts [data]
+            (px/with-dispatch (:blocking executors)
+              (media/run {:cmd :generate-fonts :input data})))
 
-    (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))
+          ;; Function responsible of calculating cryptographyc hash of
+          ;; the provided data. Even though it uses the hight
+          ;; performance BLAKE2b algorithm, we prefer to schedule it
+          ;; to be executed on the blocking executor.
+          (calculate-hash [data]
+            (px/with-dispatch (:blocking executors)
+              (sto/calculate-hash data)))
 
-    (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)}))
+          (validate-data [data]
+            (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))
+            data)
 
-          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}))
+          (persist-font-object [data mtype]
+            (when-let [fdata (get data mtype)]
+              (p/let [hash    (calculate-hash fdata)
+                      content (-> (sto/content fdata)
+                                  (sto/wrap-with-hash hash))]
+                (sto/put-object! storage {::sto/content content
+                                          ::sto/touched-at (dt/now)
+                                          ::sto/deduplicate? true
+                                          :content-type mtype
+                                          :bucket "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}))
+          (persist-fonts [data]
+            (p/let [otf   (persist-font-object data "font/otf")
+                    ttf   (persist-font-object data "font/ttf")
+                    woff1 (persist-font-object data "font/woff")
+                    woff2 (persist-font-object data "font/woff2")]
 
-          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}))]
+              (d/without-nils
+               {:otf otf
+                :ttf ttf
+                :woff1 woff1
+                :woff2 woff2})))
 
-      (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)}))))
+          (insert-into-db [{:keys [woff1 woff2 otf ttf]}]
+            (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)}))
+          ]
+
+    (-> (generate-fonts data)
+        (p/then validate-data)
+        (p/then persist-fonts (:default executors))
+        (p/then insert-into-db (:default executors)))))
 
 ;; --- UPDATE FONT FAMILY
 

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

@@ -6,6 +6,7 @@
 
 (ns app.rpc.mutations.media
   (:require
+   [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.media :as cm]
    [app.common.spec :as us]
@@ -16,12 +17,11 @@
    [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.services :as sv]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
-   [datoteka.core :as fs]))
+   [promesa.core :as p]
+   [promesa.exec :as px]))
 
 (def thumbnail-options
   {:width 100
@@ -40,9 +40,7 @@
 (declare create-file-media-object)
 (declare select-file)
 
-(s/def ::content-type ::media/image-content-type)
-(s/def ::content (s/and ::media/upload (s/keys :req-un [::content-type])))
-
+(s/def ::content ::media/upload)
 (s/def ::is-local ::us/boolean)
 
 (s/def ::upload-file-media-object
@@ -50,10 +48,10 @@
           :opt-un [::id]))
 
 (sv/defmethod ::upload-file-media-object
-  {::rlimit/permits (cf/get :rlimit-image)
-   ::async/dispatch :default}
+  {::rlimit/permits (cf/get :rlimit-image)}
   [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
-  (let [file (select-file pool file-id)]
+  (let [file (select-file pool file-id)
+        cfg  (update cfg :storage media/configure-assets-storage)]
     (teams/check-edition-permissions! pool profile-id (:team-id file))
     (create-file-media-object cfg params)))
 
@@ -68,34 +66,6 @@
   [info]
   (= (:mtype info) "image/svg+xml"))
 
-(defn- fetch-url
-  [url]
-  (try
-    (http/get! url {:as :byte-array})
-    (catch Exception e
-      (ex/raise :type :validation
-                :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)
-        data   (:body result)
-        mtype  (get (:headers result) "content-type")
-        format (cm/mtype->format mtype)]
-    (when (nil? format)
-      (ex/raise :type :validation
-                :code :media-type-not-allowed
-                :hint "Seems like the url points to an invalid media object."))
-    (-> (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`
 ;; because postgresql does not returns anything if no update is
 ;; performed, the `do update` does the trick.
@@ -121,67 +91,138 @@
 ;; inverse, soft referential integrity).
 
 (defn create-file-media-object
-  [{:keys [storage pool] :as cfg} {:keys [id file-id is-local name content] :as params}]
-  (media/validate-media-type (:content-type 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)
+  [{:keys [storage pool executors] :as cfg} {:keys [id file-id is-local name content] :as params}]
+  (media/validate-media-type! content)
 
-        thumb        (when (and (not (svg-image? source-info))
-                                (big-enough-for-thumbnail? source-info))
-                       (media/run (assoc thumbnail-options
-                                         :cmd :generic-thumbnail
-                                         :input {:mtype (:mtype source-info)
-                                                 :path source-path})))
+  (letfn [;; Function responsible to retrieve the file information, as
+          ;; it is synchronous operation it should be wrapped into
+          ;; with-dispatch macro.
+          (get-info [content]
+            (px/with-dispatch (:blocking executors)
+              (media/run {:cmd :info :input content})))
 
-        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)
-                                          :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)}))
+          ;; Function responsible of calculating cryptographyc hash of
+          ;; the provided data. Even though it uses the hight
+          ;; performance BLAKE2b algorithm, we prefer to schedule it
+          ;; to be executed on the blocking executor.
+          (calculate-hash [data]
+            (px/with-dispatch (:blocking executors)
+              (sto/calculate-hash data)))
 
-        thumb        (when thumb
-                       (sto/put-object storage
-                                       {:content (sto/content (:data thumb) (:size thumb))
-                                        :content-type (:mtype thumb)
-                                        :reference :file-media-object
-                                        :touched-at (dt/now)}))]
+          ;; Function responsible of generating thumnail. As it is synchronous
+          ;; opetation, it should be wrapped into with-dispatch macro
+          (generate-thumbnail [info]
+            (px/with-dispatch (:blocking executors)
+              (media/run (assoc thumbnail-options
+                                :cmd :generic-thumbnail
+                                :input info))))
 
-    (db/exec-one! pool [sql:create-file-media-object
-                        (or id (uuid/next))
-                        file-id is-local name
-                        (:id image)
-                        (:id thumb)
-                        (:width source-info)
-                        (:height source-info)
-                        source-mtype])))
+          (create-thumbnail [info]
+            (when (and (not (svg-image? info))
+                       (big-enough-for-thumbnail? info))
+              (p/let [thumb   (generate-thumbnail info)
+                      hash    (calculate-hash (:data thumb))
+                      content (-> (sto/content (:data thumb) (:size thumb))
+                                  (sto/wrap-with-hash hash))]
+                (sto/put-object! storage
+                                 {::sto/content content
+                                  ::sto/deduplicate? true
+                                  ::sto/touched-at (dt/now)
+                                  :content-type (:mtype thumb)
+                                  :bucket "file-media-object"}))))
+
+          (create-image [info]
+            (p/let [data    (cond-> (:path info) (= (:mtype info) "image/svg+xml") slurp)
+                    hash    (calculate-hash data)
+                    content (-> (sto/content data)
+                                (sto/wrap-with-hash hash))]
+              (sto/put-object! storage
+                               {::sto/content content
+                                ::sto/deduplicate? true
+                                ::sto/touched-at (dt/now)
+                                :content-type (:mtype info)
+                                :bucket "file-media-object"})))
+
+          (insert-into-database [info image thumb]
+            (px/with-dispatch (:default executors)
+              (db/exec-one! pool [sql:create-file-media-object
+                                  (or id (uuid/next))
+                                  file-id is-local name
+                                  (:id image)
+                                  (:id thumb)
+                                  (:width info)
+                                  (:height info)
+                                  (:mtype info)])))]
+
+    (p/let [info  (get-info content)
+            thumb (create-thumbnail info)
+            image (create-image info)]
+      (insert-into-database info image thumb))))
 
 ;; --- Create File Media Object (from URL)
 
+(declare ^:private create-file-media-object-from-url)
+
 (s/def ::create-file-media-object-from-url
   (s/keys :req-un [::profile-id ::file-id ::is-local ::url]
           :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}]
-  (let [file (select-file pool file-id)]
+  {::rlimit/permits (cf/get :rlimit-image)}
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
+  (let [file (select-file pool file-id)
+        cfg  (update cfg :storage media/configure-assets-storage)]
     (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))}]
+    (create-file-media-object-from-url cfg params)))
 
+(def max-download-file-size
+  (* 1024 1024 100)) ; 100MiB
+
+(defn- create-file-media-object-from-url
+  [{:keys [storage http-client] :as cfg} {:keys [url name] :as params}]
+  (letfn [(parse-and-validate-size [headers]
+            (let [size   (some-> (get headers "content-length") d/parse-integer)
+                  mtype  (get headers "content-type")
+                  format (cm/mtype->format mtype)]
+              (when-not size
+                (ex/raise :type :validation
+                          :code :unknown-size
+                          :hint "Seems like the url points to resource with unknown size"))
+
+              (when (> size max-download-file-size)
+                (ex/raise :type :validation
+                          :code :file-too-large
+                          :hint "Seems like the url points to resource with size greater than 100MiB"))
+
+              (when (nil? format)
+                (ex/raise :type :validation
+                          :code :media-type-not-allowed
+                          :hint "Seems like the url points to an invalid media object"))
+
+              {:size size
+               :mtype mtype
+               :format format}))
+
+          (get-upload-object [sobj]
+            (p/let [path  (sto/get-object-path storage sobj)
+                    mdata (meta sobj)]
+              {:filename "tempfile"
+               :size (:size sobj)
+               :path path
+               :mtype (:content-type mdata)}))
+
+          (download-media [uri]
+            (p/let [{:keys [body headers]} (http-client {:method :get :uri uri} {:response-type :input-stream})
+                    {:keys [size mtype]} (parse-and-validate-size headers)]
+
+              (-> (assoc storage :backend :tmp)
+                  (sto/put-object! {::sto/content (sto/content body size)
+                                    ::sto/expired-at (dt/in-future {:minutes 30})
+                                    :content-type mtype
+                                    :bucket "file-media-object"})
+                  (p/then get-upload-object))))]
+
+    (p/let [content (download-media url)]
       (->> (merge params {:content content :name (or name (:filename content))})
            (create-file-media-object cfg)))))
 
@@ -197,7 +238,6 @@
   (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)
           (clone-file-media-object params)))))
 

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

@@ -6,31 +6,32 @@
 
 (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]
    [app.config :as cf]
    [app.db :as db]
    [app.emails :as eml]
-   [app.http.oauth :refer [extract-utm-props]]
    [app.loggers.audit :as audit]
    [app.media :as media]
    [app.rpc.mutations.teams :as teams]
    [app.rpc.queries.profile :as profile]
    [app.rpc.rlimit :as rlimit]
    [app.storage :as sto]
-   [app.util.async :as async]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [buddy.hashers :as hashers]
    [clojure.spec.alpha :as s]
-   [cuerdas.core :as str]))
+   [cuerdas.core :as str]
+   [promesa.core :as p]
+   [promesa.exec :as px]))
 
 ;; --- Helpers & Specs
 
 (s/def ::email ::us/email)
 (s/def ::fullname ::us/not-empty-string)
-(s/def ::lang (s/nilable ::us/not-empty-string))
+(s/def ::lang ::us/string)
 (s/def ::path ::us/string)
 (s/def ::profile-id ::us/uuid)
 (s/def ::password ::us/not-empty-string)
@@ -99,8 +100,14 @@
 (sv/defmethod ::prepare-register-profile {:auth false}
   [{:keys [pool tokens] :as cfg} params]
   (when-not (contains? cf/flags :registration)
-    (ex/raise :type :restriction
-              :code :registration-disabled))
+    (if-not (contains? params :invitation-token)
+      (ex/raise :type :restriction
+                :code :registration-disabled)
+      (let [invitation (tokens :verify {:token (:invitation-token params) :iss :team-invitation})]
+        (when-not (= (:email params) (:member-email invitation))
+          (ex/raise :type :restriction
+                    :code :email-does-not-match-invitation
+                    :hint "email should match the invitation")))))
 
   (when-let [domains (cf/get :registration-domain-whitelist)]
     (when-not (email-domain-in-whitelist? domains (:email params))
@@ -123,10 +130,12 @@
               :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}))
 
@@ -147,19 +156,15 @@
   [{:keys [conn tokens session] :as cfg} {:keys [token] :as params}]
   (let [claims    (tokens :verify {:token token :iss :prepared-register})
         params    (merge params claims)]
-
     (check-profile-existence! conn params)
-
     (let [is-active  (or (:is-active params)
                          (contains? cf/flags :insecure-register))
           profile    (->> (assoc params :is-active is-active)
                           (create-profile conn)
                           (create-profile-relations conn)
                           (decode-profile-row))
-
           invitation (when-let [token (:invitation-token params)]
                        (tokens :verify {:token token :iss :team-invitation}))]
-
       (cond
         ;; If invitation token comes in params, this is because the user comes from team-invitation process;
         ;; in this case, regenerate token and send back to the user a new invitation token (and mark current
@@ -218,7 +223,7 @@
   [conn params]
   (let [id        (or (:id params) (uuid/next))
 
-        props     (-> (extract-utm-props params)
+        props     (-> (audit/extract-utm-params params)
                       (merge (:props params))
                       (db/tjson))
 
@@ -278,10 +283,14 @@
           :opt-un [::scope ::invitation-token]))
 
 (sv/defmethod ::login
-  {:auth false
-   ::async/dispatch :default
-   ::rlimit/permits (cf/get :rlimit-password)}
+  {:auth false ::rlimit/permits (cf/get :rlimit-password)}
   [{:keys [pool session tokens] :as cfg} {:keys [email password] :as params}]
+
+  (when-not (contains? cf/flags :login)
+    (ex/raise :type :restriction
+              :code :login-disabled
+              :hint "login is disabled in this instance"))
+
   (letfn [(check-password [profile password]
             (when (= (:password profile) "!")
               (ex/raise :type :validation
@@ -334,27 +343,41 @@
 
 ;; --- MUTATION: Update Profile (own)
 
-(defn- update-profile
-  [conn {:keys [id fullname lang theme] :as params}]
-  (let [profile (db/update! conn :profile
-                            {:fullname fullname
-                             :lang lang
-                             :theme theme}
-                            {:id id})]
-    (-> profile
-        (profile/decode-profile-row)
-        (profile/strip-private-attrs))))
-
+(s/def ::newsletter-subscribed ::us/boolean)
 (s/def ::update-profile
-  (s/keys :req-un [::id ::fullname]
-          :opt-un [::lang ::theme]))
+  (s/keys :req-un [::fullname ::profile-id]
+          :opt-un [::lang ::theme ::newsletter-subscribed]))
 
 (sv/defmethod ::update-profile
-  {::async/dispatch :default}
-  [{:keys [pool] :as cfg} params]
+  [{:keys [pool] :as cfg} {:keys [profile-id fullname lang theme newsletter-subscribed] :as params}]
   (db/with-atomic [conn pool]
-    (let [profile (update-profile conn params)]
-      (with-meta profile
+    ;; NOTE: we need to retrieve the profile independently if we use
+    ;; it or not for explicit locking and avoid concurrent updates of
+    ;; the same row/object.
+    (let [profile (-> (db/get-by-id conn :profile profile-id {:for-update true})
+                      (profile/decode-profile-row))
+
+          ;; Update the profile map with direct params
+          profile (-> profile
+                      (assoc :fullname fullname)
+                      (assoc :lang lang)
+                      (assoc :theme theme))
+
+          ;; Update profile props if the indirect prop is coming in
+          ;; the params map and update the profile props data
+          ;; acordingly.
+          profile (cond-> profile
+                    (some? newsletter-subscribed)
+                    (update :props assoc :newsletter-subscribed newsletter-subscribed))]
+
+      (db/update! conn :profile
+                  {:fullname fullname
+                   :lang lang
+                   :theme theme
+                   :props (db/tjson (:props profile))}
+                  {:id profile-id})
+
+      (with-meta (-> profile profile/strip-private-attrs d/without-nils)
         {::audit/props (audit/profile->props profile)}))))
 
 ;; --- MUTATION: Update Password
@@ -405,39 +428,33 @@
 
 (declare update-profile-photo)
 
-(s/def ::content-type ::media/image-content-type)
-(s/def ::file (s/and ::media/upload (s/keys :req-un [::content-type])))
-
+(s/def ::file ::media/upload)
 (s/def ::update-profile-photo
   (s/keys :req-un [::profile-id ::file]))
 
 (sv/defmethod ::update-profile-photo
   {::rlimit/permits (cf/get :rlimit-image)}
-  [{:keys [pool storage] :as cfg} {:keys [profile-id file] :as params}]
-  (db/with-atomic [conn pool]
-    (media/validate-media-type (:content-type file) #{"image/jpeg" "image/png" "image/webp"})
-    (media/run {:cmd :info :input {:path (:tempfile file)
-                                   :mtype (:content-type file)}})
+  [cfg {:keys [file] :as params}]
+  ;; Validate incoming mime type
+  (media/validate-media-type! file #{"image/jpeg" "image/png" "image/webp"})
+  (let [cfg (update cfg :storage media/configure-assets-storage)]
+    (update-profile-photo cfg params)))
 
-    (let [profile (db/get-by-id conn :profile profile-id)
-          storage (media/configure-assets-storage storage conn)
-          cfg     (assoc cfg :storage storage)
+(defn update-profile-photo
+  [{:keys [pool storage executors] :as cfg} {:keys [profile-id] :as params}]
+  (p/let [profile (px/with-dispatch (:default executors)
+                    (db/get-by-id pool :profile profile-id))
           photo   (teams/upload-photo cfg params)]
 
-      ;; Schedule deletion of old photo
-      (when-let [id (:photo-id profile)]
-        (sto/del-object storage id))
-
-      ;; Save new photo
-      (update-profile-photo conn profile-id photo))))
-
-(defn- update-profile-photo
-  [conn profile-id sobj]
-  (db/update! conn :profile
-              {:photo-id (:id sobj)}
-              {:id profile-id})
-  nil)
+    ;; Schedule deletion of old photo
+    (when-let [id (:photo-id profile)]
+      (sto/touch-object! storage id))
 
+    ;; Save new photo
+    (db/update! pool :profile
+                {:photo-id (:id photo)}
+                {:id profile-id})
+    nil))
 
 ;; --- MUTATION: Request Email Change
 
@@ -602,7 +619,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

@@ -8,11 +8,13 @@
   (:require
    [app.common.data :as d]
    [app.common.exceptions :as ex]
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
    [app.emails :as eml]
+   [app.loggers.audit :as audit]
    [app.media :as media]
    [app.rpc.mutations.projects :as projects]
    [app.rpc.permissions :as perms]
@@ -23,7 +25,9 @@
    [app.util.services :as sv]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
-   [datoteka.core :as fs]))
+   [cuerdas.core :as str]
+   [promesa.core :as p]
+   [promesa.exec :as px]))
 
 ;; --- Helpers & Specs
 
@@ -275,54 +279,73 @@
 
       nil)))
 
-
 ;; --- Mutation: Update Team Photo
 
-(declare upload-photo)
-
-(s/def ::content-type ::media/image-content-type)
-(s/def ::file (s/and ::media/upload (s/keys :req-un [::content-type])))
+(declare ^:private upload-photo)
+(declare ^:private update-team-photo)
 
+(s/def ::file ::media/upload)
 (s/def ::update-team-photo
   (s/keys :req-un [::profile-id ::team-id ::file]))
 
 (sv/defmethod ::update-team-photo
   {::rlimit/permits (cf/get :rlimit-image)}
-  [{:keys [pool storage] :as cfg} {:keys [profile-id file team-id] :as params}]
-  (db/with-atomic [conn pool]
-    (teams/check-edition-permissions! conn profile-id team-id)
-    (media/validate-media-type (:content-type file) #{"image/jpeg" "image/png" "image/webp"})
-    (media/run {:cmd :info :input {:path (:tempfile file)
-                                   :mtype (:content-type file)}})
+  [cfg {:keys [file] :as params}]
+  ;; Validate incoming mime type
+  (media/validate-media-type! file #{"image/jpeg" "image/png" "image/webp"})
+  (let [cfg (update cfg :storage media/configure-assets-storage)]
+    (update-team-photo cfg params)))
 
-    (let [team    (teams/retrieve-team conn profile-id team-id)
-          storage (media/configure-assets-storage storage conn)
-          cfg     (assoc cfg :storage storage)
-          photo   (upload-photo cfg params)]
+(defn update-team-photo
+  [{:keys [pool storage executors] :as cfg} {:keys [profile-id team-id] :as params}]
+  (p/let [team  (px/with-dispatch (:default executors)
+                  (teams/retrieve-team pool profile-id team-id))
+          photo (upload-photo cfg params)]
 
-      ;; Schedule deletion of old photo
-      (when-let [id (:photo-id team)]
-        (sto/del-object storage id))
+    ;; Mark object as touched for make it ellegible for tentative
+    ;; garbage collection.
+    (when-let [id (:photo-id team)]
+      (sto/touch-object! storage id))
 
-      ;; Save new photo
-      (db/update! conn :team
-                  {:photo-id (:id photo)}
-                  {:id team-id})
+    ;; Save new photo
+    (db/update! pool :team
+                {:photo-id (:id photo)}
+                {:id team-id})
 
-      (assoc team :photo-id (:id photo)))))
+    (assoc team :photo-id (:id photo))))
 
 (defn upload-photo
-  [{:keys [storage] :as cfg} {:keys [file]}]
-  (let [thumb (media/run {:cmd :profile-thumbnail
+  [{:keys [storage executors] :as cfg} {:keys [file]}]
+  (letfn [(get-info [content]
+            (px/with-dispatch (:blocking executors)
+              (media/run {:cmd :info :input content})))
+
+          (generate-thumbnail [info]
+            (px/with-dispatch (:blocking executors)
+              (media/run {:cmd :profile-thumbnail
                           :format :jpeg
                           :quality 85
                           :width 256
                           :height 256
-                          :input {:path (fs/path (:tempfile file))
-                                  :mtype (:content-type file)}})]
-    (sto/put-object storage
-                    {:content (sto/content (:data thumb) (:size thumb))
-                     :content-type (:mtype thumb)})))
+                          :input info})))
+
+          ;; Function responsible of calculating cryptographyc hash of
+          ;; the provided data. Even though it uses the hight
+          ;; performance BLAKE2b algorithm, we prefer to schedule it
+          ;; to be executed on the blocking executor.
+          (calculate-hash [data]
+            (px/with-dispatch (:blocking executors)
+              (sto/calculate-hash data)))]
+
+    (p/let [info    (get-info file)
+            thumb   (generate-thumbnail info)
+            hash    (calculate-hash (:data thumb))
+            content (-> (sto/content (:data thumb) (:size thumb))
+                        (sto/wrap-with-hash hash))]
+      (sto/put-object! storage {::sto/content content
+                                ::sto/deduplicate? true
+                                :bucket "profile"
+                                :content-type (:mtype thumb)}))))
 
 
 ;; --- Mutation: Invite Member
@@ -330,15 +353,20 @@
 (declare create-team-invitation)
 
 (s/def ::email ::us/email)
+(s/def ::emails ::us/set-of-emails)
 (s/def ::invite-team-member
-  (s/keys :req-un [::profile-id ::team-id ::email ::role]))
+  (s/keys :req-un [::profile-id ::team-id ::role]
+          :opt-un [::email ::emails]))
 
 (sv/defmethod ::invite-team-member
-  [{:keys [pool] :as cfg} {:keys [profile-id team-id email role] :as params}]
+  "A rpc call that allow to send a single or multiple invitations to
+  join the team."
+  [{:keys [pool] :as cfg} {:keys [profile-id team-id email emails role] :as params}]
   (db/with-atomic [conn pool]
     (let [perms    (teams/get-permissions conn profile-id team-id)
           profile  (db/get-by-id conn :profile profile-id)
-          team     (db/get-by-id conn :team team-id)]
+          team     (db/get-by-id conn :team team-id)
+          emails   (cond-> (or emails #{}) (string? email) (conj email))]
 
       (when-not (:is-admin perms)
         (ex/raise :type :validation
@@ -350,41 +378,60 @@
                   :code :profile-is-muted
                   :hint "looks like the profile has reported repeatedly as spam or has permanent bounces"))
 
-      (create-team-invitation
-       (assoc cfg
-              :email email
-              :conn conn
-              :team team
-              :profile profile
-              :role role))
-      nil)))
+      (doseq [email emails]
+        (create-team-invitation
+         (assoc cfg
+                :email email
+                :conn conn
+                :team team
+                :profile profile
+                :role role))
+        )
+
+      (with-meta {}
+        {::audit/props {:invitations (count emails)}}))))
+
+(def sql:upsert-team-invitation
+  "insert into team_invitation(team_id, email_to, role, valid_until)
+   values (?, ?, ?, ?)
+       on conflict(team_id, email_to) do
+          update set role = ?, valid_until = ?, updated_at = now();")
 
 (defn- create-team-invitation
   [{:keys [conn tokens team profile role email] :as cfg}]
-  (let [member   (profile/retrieve-profile-data-by-email conn email)
-        itoken   (tokens :generate
-                         {:iss :team-invitation
-                          :exp (dt/in-future "48h")
-                          :profile-id (:id profile)
-                          :role role
-                          :team-id (:id team)
-                          :member-email (:email member email)
-                          :member-id (:id member)})
-        ptoken   (tokens :generate-predefined
-                         {:iss :profile-identity
-                          :profile-id (:id profile)})]
+  (let [member    (profile/retrieve-profile-data-by-email conn email)
+        token-exp (dt/in-future "48h")
+        itoken    (tokens :generate
+                          {:iss :team-invitation
+                           :exp token-exp
+                           :profile-id (:id profile)
+                           :role role
+                           :team-id (:id team)
+                           :member-email (:email member email)
+                           :member-id (:id member)})
+        ptoken    (tokens :generate-predefined
+                          {:iss :profile-identity
+                           :profile-id (:id profile)})]
+
+    (when (contains? cf/flags :log-invitation-tokens)
+      (l/trace :hint "invitation token" :token itoken))
 
     (when (and member (not (eml/allow-send-emails? conn member)))
       (ex/raise :type :validation
                 :code :member-is-muted
+                :email email
                 :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.
     (when (eml/has-bounce-reports? conn email)
       (ex/raise :type :validation
                 :code :email-has-permanent-bounces
+                :email email
                 :hint "looks like the email you invite has been repeatedly reported as spam or permanent bounce"))
 
+    (db/exec-one! conn [sql:upsert-team-invitation
+                        (:id team) (str/lower email) (name role) token-exp (name role) token-exp])
+
     (eml/send! {::eml/conn conn
                 ::eml/factory eml/invite-to-team
                 :public-uri (:public-uri cfg)
@@ -394,7 +441,6 @@
                 :token itoken
                 :extra-data ptoken})))
 
-
 ;; --- Mutation: Create Team & Invite Members
 
 (s/def ::emails ::us/set-of-emails)
@@ -402,21 +448,14 @@
   (s/and ::create-team (s/keys :req-un [::emails ::role])))
 
 (sv/defmethod ::create-team-and-invite-members
-  [{:keys [pool audit] :as cfg} {:keys [profile-id emails role] :as params}]
+  [{:keys [pool] :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)]
+    (let [team     (create-team conn params)
+          audit-fn (:audit cfg)
+          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
@@ -424,4 +463,53 @@
                 :profile profile
                 :email email
                 :role role)))
-      team)))
+
+      (with-meta team
+        {::audit/props {:invitations (count emails)}
+
+         :before-complete
+         #(audit-fn :cmd :submit
+                    :type "mutation"
+                    :name "invite-team-member"
+                    :profile-id profile-id
+                    :props {:emails emails
+                            :role role
+                            :profile-id profile-id
+                            :invitations (count emails)})}))))
+
+;; --- Mutation: Update invitation role
+
+(s/def ::update-team-invitation-role
+  (s/keys :req-un [::profile-id ::team-id ::email ::role]))
+
+(sv/defmethod ::update-team-invitation-role
+  [{:keys [pool] :as cfg} {:keys [profile-id team-id email role] :as params}]
+  (db/with-atomic [conn pool]
+    (let [perms    (teams/get-permissions conn profile-id team-id)]
+
+      (when-not (:is-admin perms)
+        (ex/raise :type :validation
+                  :code :insufficient-permissions))
+
+      (db/update! conn :team-invitation
+                  {:role (name role) :updated-at (dt/now)}
+                  {:team-id team-id :email-to (str/lower email)})
+      nil)))
+
+;; --- Mutation: Delete invitation
+
+(s/def ::delete-team-invitation
+  (s/keys :req-un [::profile-id ::team-id ::email]))
+
+(sv/defmethod ::delete-team-invitation
+  [{:keys [pool] :as cfg} {:keys [profile-id team-id email] :as params}]
+  (db/with-atomic [conn pool]
+    (let [perms    (teams/get-permissions conn profile-id team-id)]
+
+      (when-not (:is-admin perms)
+        (ex/raise :type :validation
+                  :code :insufficient-permissions))
+
+      (db/delete! conn :team-invitation
+                {:team-id team-id :email-to (str/lower email)})
+      nil)))

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

@@ -13,7 +13,8 @@
    [app.rpc.mutations.teams :as teams]
    [app.rpc.queries.profile :as profile]
    [app.util.services :as sv]
-   [clojure.spec.alpha :as s]))
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]))
 
 (defmulti process-token (fn [_ _ claims] (:iss claims)))
 
@@ -90,11 +91,18 @@
           :opt-un [:internal.tokens.team-invitation/member-id]))
 
 (defn- accept-invitation
-  [{:keys [conn] :as cfg} {:keys [member-id team-id role] :as claims}]
-  (let [params (merge {:team-id team-id
+  [{:keys [conn] :as cfg} {:keys [member-id team-id role member-email] :as claims}]
+  (let [
+        member (profile/retrieve-profile conn member-id)
+        invitation (db/get-by-params conn :team-invitation
+                                    {:team-id team-id :email-to (str/lower member-email)}
+                                    {:check-not-found false})
+        ;; Update the role if there is an invitation
+        role (or (some-> invitation :role keyword) role)
+        params (merge {:team-id team-id
                        :profile-id member-id}
                       (teams/role->params role))
-        member (profile/retrieve-profile conn member-id)]
+        ]
 
     ;; Insert the invited member to the team
     (db/insert! conn :team-profile-rel params {:on-conflict-do-nothing true})
@@ -105,11 +113,26 @@
       (db/update! conn :profile
                   {:is-active true}
                   {:id member-id}))
-    (assoc member :is-active true)))
+    (assoc member :is-active true)
+
+    ;; Delete the invitation
+    (db/delete! conn :team-invitation
+                {:team-id team-id :email-to (str/lower member-email)})))
+
 
 (defmethod process-token :team-invitation
   [cfg {:keys [profile-id token]} {:keys [member-id] :as claims}]
   (us/assert ::team-invitation-claims claims)
+  (let [conn (:conn cfg)
+        team-id (:team-id claims)
+        member-email (:member-email claims)
+        invitation (db/get-by-params conn :team-invitation
+                                     {:team-id team-id :email-to (str/lower member-email)}
+                                     {:check-not-found false})]
+    (when (nil? invitation)
+      (ex/raise :type :validation
+                :code :invalid-token)))
+
   (cond
     ;; This happens when token is filled with member-id and current
     ;; user is already logged in with exactly invited account.

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

@@ -7,19 +7,22 @@
 (ns app.rpc.queries.files
   (:require
    [app.common.data :as d]
+   [app.common.data.macros :as dm]
+   [app.common.exceptions :as ex]
    [app.common.pages.helpers :as cph]
    [app.common.pages.migrations :as pmg]
    [app.common.spec :as us]
-   [app.common.uuid :as uuid]
    [app.db :as db]
+   [app.db.sql :as sql]
+   [app.rpc.helpers :as rpch]
    [app.rpc.permissions :as perms]
    [app.rpc.queries.projects :as projects]
    [app.rpc.queries.share-link :refer [retrieve-share-link]]
    [app.rpc.queries.teams :as teams]
-   [app.storage.impl :as simpl]
    [app.util.blob :as blob]
    [app.util.services :as sv]
-   [clojure.spec.alpha :as s]))
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]))
 
 (declare decode-row)
 (declare decode-row-xf)
@@ -35,7 +38,6 @@
 (s/def ::team-id ::us/uuid)
 (s/def ::search-term ::us/string)
 
-
 ;; --- Query: File Permissions
 
 (def ^:private sql:file-permissions
@@ -186,21 +188,28 @@
 
 ;; --- Query: File (By ID)
 
-(defn- retrieve-data*
-  [{:keys [storage] :as cfg} file]
-  (when-let [backend (simpl/resolve-backend storage (:data-backend file))]
-    (simpl/get-object-bytes backend file)))
+(defn retrieve-object-thumbnails
+  ([{:keys [pool]} file-id]
+   (let [sql (str/concat
+              "select object_id, data "
+              "  from file_object_thumbnail"
+              " where file_id=?")]
+     (->> (db/exec! pool [sql file-id])
+          (d/index-by :object-id :data))))
 
-(defn retrieve-data
-  [cfg file]
-  (if (bytes? (:data file))
-    file
-    (assoc file :data (retrieve-data* cfg file))))
+  ([{:keys [pool]} file-id object-ids]
+   (with-open [conn (db/open pool)]
+     (let [sql (str/concat
+                "select object_id, data "
+                "  from file_object_thumbnail"
+                " where file_id=? and object_id = ANY(?)")
+           ids (db/create-array conn "text" (seq object-ids))]
+       (->> (db/exec! conn [sql file-id ids])
+            (d/index-by :object-id :data))))))
 
 (defn retrieve-file
-  [{:keys [conn] :as cfg} id]
-  (->> (db/get-by-id conn :file id)
-       (retrieve-data cfg)
+  [{:keys [pool] :as cfg} id]
+  (->> (db/get-by-id pool :file id)
        (decode-row)
        (pmg/migrate-file)))
 
@@ -210,95 +219,139 @@
 (sv/defmethod ::file
   "Retrieve a file by its ID. Only authenticated users."
   [{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
-  (db/with-atomic [conn pool]
-    (let [cfg   (assoc cfg :conn conn)
-          perms (get-permissions conn profile-id id)]
+  (let [perms (get-permissions pool profile-id id)]
+    (check-read-permissions! perms)
+    (let [file   (retrieve-file cfg id)
+          thumbs (retrieve-object-thumbnails cfg id)]
+      (-> file
+          (assoc :thumbnails thumbs)
+          (assoc :permissions perms)))))
 
-      (check-read-permissions! perms)
-      (some-> (retrieve-file cfg id)
-              (assoc :permissions perms)))))
 
-(declare trim-file-data)
+;; --- QUERY: page
+
+(defn- prune-objects
+  "Given the page data and the object-id returns the page data with all
+  other not needed objects removed from the `:objects` data
+  structure."
+  [{:keys [objects] :as page} object-id]
+  (let [objects (cph/get-children-with-self objects object-id)]
+     (assoc page :objects (d/index-by :id objects))))
+
+(defn- prune-thumbnails
+  "Given the page data, removes the `:thumbnail` prop from all
+  shapes."
+  [page]
+  (update page :objects d/update-vals #(dissoc % :thumbnail)))
 
 (s/def ::page-id ::us/uuid)
 (s/def ::object-id ::us/uuid)
 
-(s/def ::trimmed-file
-  (s/keys :req-un [::profile-id ::id ::object-id ::page-id]))
-
-(sv/defmethod ::trimmed-file
-  "Retrieve a file by its ID and trims all unnecesary content from
-  it. It is mainly used for rendering a concrete object, so we don't
-  need force download all shapes when only a small subset is
-  necesseary."
-  [{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
-  (db/with-atomic [conn pool]
-    (let [cfg   (assoc cfg :conn conn)
-          perms (get-permissions conn profile-id id)]
-      (check-read-permissions! perms)
-      (some-> (retrieve-file cfg id)
-              (trim-file-data params)
-              (assoc :permissions perms)))))
-
-(defn- trim-file-data
-  [file {:keys [page-id object-id]}]
-  (let [page    (get-in file [:data :pages-index page-id])
-        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]))))
-
-(declare strip-frames-with-thumbnails)
-
-(s/def ::strip-frames-with-thumbnails ::us/boolean)
-
 (s/def ::page
-  (s/keys :req-un [::profile-id ::file-id]
-          :opt-un [::strip-frames-with-thumbnails]))
+  (s/and
+   (s/keys :req-un [::profile-id ::file-id]
+           :opt-un [::page-id ::object-id])
+   (fn [obj]
+     (if (contains? obj :object-id)
+       (contains? obj :page-id)
+       true))))
 
 (sv/defmethod ::page
-  "Retrieves the first page of the file. Used mainly for render
-  thumbnails on dashboard."
+  "Retrieves the page data from file and returns it. If no page-id is
+  specified, the first page will be returned. If object-id is
+  specified, only that object and its children will be returned in the
+  page objects data structure.
+
+  If you specify the object-id, the page-id parameter becomes
+  mandatory.
+
+  Mainly used for rendering purposes."
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id page-id object-id] :as props}]
+  (check-read-permissions! pool profile-id file-id)
+  (let [file    (retrieve-file cfg file-id)
+        page-id (or page-id (-> file :data :pages first))
+        page    (get-in file [:data :pages-index page-id])]
+
+    (cond-> (prune-thumbnails page)
+      (uuid? object-id)
+      (prune-objects object-id))))
+
+;; --- QUERY: file-data-for-thumbnail
+
+(defn- get-file-thumbnail-data
+  [cfg {:keys [data id] :as file}]
+  (letfn [;; function responsible on finding the frame marked to be
+          ;; used as thumbnail; the returned frame always have
+          ;; the :page-id set to the page that it belongs.
+          (get-thumbnail-frame [data]
+            (d/seek :use-for-thumbnail?
+                    (for [page  (-> data :pages-index vals)
+                          frame (-> page :objects cph/get-frames)]
+                      (assoc frame :page-id (:id page)))))
+
+          ;; function responsible to filter objects data strucuture of
+          ;; all unneded shapes if a concrete frame is provided. If no
+          ;; frame, the objects is returned untouched.
+          (filter-objects [objects frame-id]
+            (d/index-by :id (cph/get-children-with-self objects frame-id)))
+
+          ;; function responsible of assoc available thumbnails
+          ;; to frames and remove all children shapes from objects if
+          ;; thumbnails is available
+          (assoc-thumbnails [objects page-id thumbnails]
+            (loop [objects objects
+                   frames  (filter cph/frame-shape? (vals objects))]
+
+              (if-let [frame  (-> frames first)]
+                (let [frame-id (:id frame)
+                      object-id (str page-id frame-id)
+                      frame (if-let [thumb (get thumbnails object-id)]
+                              (assoc frame :thumbnail thumb :shapes [])
+                              (dissoc frame :thumbnail))]
+                  (if (:thumbnail frame)
+                    (recur (-> (assoc objects frame-id frame)
+                               (d/without-keys (cph/get-children-ids objects frame-id)))
+                           (rest frames))
+                    (recur (assoc objects frame-id frame)
+                           (rest frames))))
+
+                objects)))]
+
+    (let [frame     (get-thumbnail-frame data)
+          frame-id  (:id frame)
+          page-id   (or (:page-id frame)
+                        (-> data :pages first))
+
+          page      (dm/get-in data [:pages-index page-id])
+          frame-ids (if (some? frame) (list frame-id) (map :id (cph/get-frames (:objects page))))
+
+          obj-ids   (map #(str page-id %) frame-ids)
+          thumbs    (retrieve-object-thumbnails cfg id obj-ids)]
+
+      (cond-> page
+        ;; If we have frame, we need to specify it on the page level
+        ;; and remove the all other unrelated objects.
+        (some? frame-id)
+        (-> (assoc :thumbnail-frame-id frame-id)
+            (update :objects filter-objects frame-id))
+
+        ;; Assoc the available thumbnails and prune not visible shapes
+        ;; for avoid transfer unnecesary data.
+        :always
+        (update :objects assoc-thumbnails page-id thumbs)))))
+
+(s/def ::file-data-for-thumbnail
+  (s/keys :req-un [::profile-id ::file-id]))
+
+(sv/defmethod ::file-data-for-thumbnail
+  "Retrieves the data for generate the thumbnail of the file. Used
+  mainly for render thumbnails on dashboard."
   [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as props}]
-  (db/with-atomic [conn pool]
-    (check-read-permissions! conn profile-id file-id)
-
-    (let [cfg     (assoc cfg :conn conn)
-          file    (retrieve-file cfg file-id)
-          page-id (get-in file [:data :pages 0])]
-      (cond-> (get-in file [:data :pages-index page-id])
-        (true? (:strip-frames-with-thumbnails props))
-        (strip-frames-with-thumbnails)))))
-
-(defn strip-frames-with-thumbnails
-  "Remove unnecesary shapes from frames that have thumbnail."
-  [data]
-  (let [filter-shape?
-        (fn [objects [id shape]]
-          (let [frame-id (:frame-id shape)]
-            (or (= id uuid/zero)
-                (= frame-id uuid/zero)
-                (not (some? (get-in objects [frame-id :thumbnail]))))))
-
-        ;; We need to remove from the attribute :shapes its children because
-        ;; they will not be sent in the data
-        remove-frame-children
-        (fn [[id shape]]
-          [id (cond-> shape
-                (some? (:thumbnail shape))
-                (assoc :shapes []))])
-
-        update-objects
-        (fn [objects]
-          (into {}
-                (comp (map remove-frame-children)
-                      (filter (partial filter-shape? objects)))
-                objects))]
-
-    (update data :objects update-objects)))
+  (check-read-permissions! pool profile-id file-id)
+  (let [file (retrieve-file cfg file-id)]
+    {:file-id file-id
+     :revn (:revn file)
+     :page (get-file-thumbnail-data cfg file)}))
 
 
 ;; --- Query: Shared Library Files
@@ -354,22 +407,19 @@
     WHERE l.deleted_at IS NULL OR l.deleted_at > now();")
 
 (defn retrieve-file-libraries
-  [{:keys [conn] :as cfg} is-indirect file-id]
+  [{:keys [pool] :as cfg} is-indirect file-id]
   (let [xform (comp
                (map #(assoc % :is-indirect is-indirect))
-               (map #(retrieve-data cfg %))
                (map decode-row))]
-    (into #{} xform (db/exec! conn [sql:file-libraries file-id]))))
+    (into #{} xform (db/exec! pool [sql:file-libraries file-id]))))
 
 (s/def ::file-libraries
   (s/keys :req-un [::profile-id ::file-id]))
 
 (sv/defmethod ::file-libraries
   [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
-  (db/with-atomic [conn pool]
-    (let [cfg (assoc cfg :conn conn)]
-      (check-read-permissions! conn profile-id file-id)
-      (retrieve-file-libraries cfg false file-id))))
+  (check-read-permissions! pool profile-id file-id)
+  (retrieve-file-libraries cfg false file-id))
 
 ;; --- QUERY: team-recent-files
 
@@ -399,28 +449,38 @@
 
 (sv/defmethod ::team-recent-files
   [{:keys [pool] :as cfg} {:keys [profile-id team-id]}]
-  (with-open [conn (db/open pool)]
-    (teams/check-read-permissions! conn profile-id team-id)
-    (db/exec! conn [sql:team-recent-files team-id])))
+  (teams/check-read-permissions! pool profile-id team-id)
+  (db/exec! pool [sql:team-recent-files team-id]))
 
+;; --- QUERY: get file thumbnail
 
-;; --- QUERY: get the thumbnail for an frame
+(s/def ::revn ::us/integer)
 
-(def ^:private sql:file-frame-thumbnail
-  "select data
-     from file_frame_thumbnail
-    where file_id = ?
-      and frame_id = ?")
+(s/def ::file-thumbnail
+  (s/keys :req-un [::profile-id ::file-id]
+          :opt-un [::revn]))
 
-(s/def ::file-frame-thumbnail
-  (s/keys :req-un [::profile-id ::file-id ::frame-id]))
+(sv/defmethod ::file-thumbnail
+  [{:keys [pool]} {:keys [profile-id file-id revn]}]
+  (check-read-permissions! pool profile-id file-id)
+  (let [sql (sql/select :file-thumbnail
+                        (cond-> {:file-id file-id}
+                          revn (assoc :revn revn))
+                        {:limit 1
+                         :order-by [[:revn :desc]]})
 
-(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])))
+        row (db/exec-one! pool sql)]
 
+    (when-not row
+      (ex/raise :type :not-found
+                :code :file-thumbnail-not-found))
+
+    (with-meta
+      {:data (:data row)
+       :props (some-> (:props row) db/decode-transit-pgobject)
+       :revn (:revn row)
+       :file-id (:file-id row)}
+      {:transform-response (rpch/http-cache {:max-age (* 1000 60 60)})})))
 
 ;; --- Helpers
 

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

@@ -75,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/queries/teams.clj

@@ -229,3 +229,21 @@
 (defn retrieve-team-stats
   [conn team-id]
   (db/exec-one! conn [sql:team-stats team-id team-id]))
+
+
+;; --- Query: Team invitations
+
+(s/def ::team-id ::us/uuid)
+(s/def ::team-invitations
+  (s/keys :req-un [::profile-id ::team-id]))
+
+(def sql:team-invitations
+  "select email_to as email, role, (valid_until < now()) as expired 
+   from team_invitation where team_id = ? order by valid_until desc")
+
+(sv/defmethod ::team-invitations
+  [{:keys [pool] :as cfg} {:keys [profile-id team-id]}]
+  (with-open [conn (db/open pool)]
+    (check-read-permissions! conn profile-id team-id)
+    (->> (db/exec! conn [sql:team-invitations team-id])
+         (mapv #(update % :role keyword)))))

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

@@ -13,27 +13,28 @@
    [app.rpc.queries.share-link :as slnk]
    [app.rpc.queries.teams :as teams]
    [app.util.services :as sv]
-   [clojure.spec.alpha :as s]))
+   [clojure.spec.alpha :as s]
+   [promesa.core :as p]))
 
 ;; --- Query: View Only Bundle
 
 (defn- retrieve-project
-  [conn id]
-  (db/get-by-id conn :project id {:columns [:id :name :team-id]}))
+  [pool id]
+  (db/get-by-id pool :project id {:columns [:id :name :team-id]}))
 
 (defn- retrieve-bundle
-  [{:keys [conn] :as cfg} file-id]
-  (let [file    (files/retrieve-file cfg file-id)
-        project (retrieve-project conn (:project-id file))
-        libs    (files/retrieve-file-libraries cfg false file-id)
-        users   (teams/retrieve-users conn (:team-id project))
+  [{:keys [pool] :as cfg} file-id]
+  (p/let [file    (files/retrieve-file cfg file-id)
+          project (retrieve-project pool (:project-id file))
+          libs    (files/retrieve-file-libraries cfg false file-id)
+          users   (teams/retrieve-users pool (:team-id project))
 
-        links   (->> (db/query conn :share-link {:file-id file-id})
-                     (mapv slnk/decode-share-link-row))
+          links   (->> (db/query pool :share-link {:file-id file-id})
+                       (mapv slnk/decode-share-link-row))
 
-        fonts   (db/query conn :team-font-variant
-                          {:team-id (:team-id project)
-                           :deleted-at nil})]
+          fonts   (db/query pool :team-font-variant
+                            {:team-id (:team-id project)
+                             :deleted-at nil})]
     {:file file
      :users users
      :fonts fonts
@@ -50,34 +51,31 @@
 
 (sv/defmethod ::view-only-bundle {:auth false}
   [{:keys [pool] :as cfg} {:keys [profile-id file-id share-id] :as params}]
-  (db/with-atomic [conn pool]
-    (let [cfg    (assoc cfg :conn conn)
-          slink  (slnk/retrieve-share-link conn file-id share-id)
-          perms  (files/get-permissions conn profile-id file-id share-id)
+  (p/let [slink  (slnk/retrieve-share-link pool file-id share-id)
+          perms  (files/get-permissions pool profile-id file-id share-id)
+          bundle (p/-> (retrieve-bundle cfg file-id)
+                       (assoc :permissions perms))]
 
-          bundle (some-> (retrieve-bundle cfg file-id)
-                         (assoc :permissions perms))]
+    ;; When we have neither profile nor share, we just return a not
+    ;; found response to the user.
+    (when (and (not profile-id)
+               (not slink))
+      (ex/raise :type :not-found
+                :code :object-not-found))
 
-      ;; When we have neither profile nor share, we just return a not
-      ;; found response to the user.
-      (when (and (not profile-id)
-                 (not slink))
-        (ex/raise :type :not-found
-                  :code :object-not-found))
+    ;; When we have only profile, we need to check read permissions
+    ;; on file.
+    (when (and profile-id (not slink))
+      (files/check-read-permissions! pool profile-id file-id))
 
-      ;; When we have only profile, we need to check read permissions
-      ;; on file.
-      (when (and profile-id (not slink))
-        (files/check-read-permissions! conn profile-id file-id))
+    (cond-> bundle
+      (some? slink)
+      (assoc :share slink)
 
-      (cond-> bundle
-        (some? slink)
-        (assoc :share slink)
-
-        (and (some? slink)
-             (not (contains? (:flags slink) "view-all-pages")))
-        (update-in [:file :data] (fn [data]
-                                   (let [allowed-pages (:pages slink)]
-                                     (-> data
-                                         (update :pages (fn [pages] (filterv #(contains? allowed-pages %) pages)))
-                                         (update :pages-index (fn [index] (select-keys index allowed-pages)))))))))))
+      (and (some? slink)
+           (not (contains? (:flags slink) "view-all-pages")))
+      (update-in [:file :data] (fn [data]
+                                 (let [allowed-pages (:pages slink)]
+                                   (-> data
+                                       (update :pages (fn [pages] (filterv #(contains? allowed-pages %) pages)))
+                                       (update :pages-index (fn [index] (select-keys index allowed-pages))))))))))

backend/src/app/rpc/rlimit.clj

@@ -52,7 +52,7 @@
         ))))
 
 (defn wrap-rlimit
-  [{:keys [metrics] :as cfg} f mdata]
+  [{:keys [metrics executors] :as cfg} f mdata]
   (if-let [permits (::permits mdata)]
     (let [sem (semaphore {:permits permits
                           :metrics metrics
@@ -60,7 +60,7 @@
       (l/debug :hint "wrapping rlimit" :handler (::sv/name mdata) :permits permits)
       (fn [cfg params]
         (-> (acquire! sem)
-            (p/then (fn [_] (f cfg params)))
+            (p/then (fn [_] (f cfg params)) (:default executors))
             (p/finally (fn [_ _] (release! sem))))))
     f))
 

backend/src/app/srepl/main.clj

@@ -17,10 +17,11 @@
    [app.srepl.dev :as dev]
    [app.util.blob :as blob]
    [app.util.time :as dt]
-   [fipp.edn :refer [pprint]]
    [clojure.spec.alpha :as s]
+   [clojure.walk :as walk]
    [cuerdas.core :as str]
-   [expound.alpha :as expound]))
+   [expound.alpha :as expound]
+   [fipp.edn :refer [pprint]]))
 
 (defn update-file
   ([system id f] (update-file system id f false))
@@ -66,86 +67,103 @@
           (db/insert! conn :file params)
           (:id file))))))
 
-(defn verify-files
-  [system {:keys [age sleep chunk-size max-chunks stop-on-error? verbose?]
-           :or {sleep 1000
-                age "72h"
-                chunk-size 10
-                verbose? false
-                stop-on-error? true
-                max-chunks ##Inf}}]
+(defn repair-orphaned-components
+  "We have detected some cases of component instances that are not nested, but
+  however they have not the :component-root? attribute (so the system considers
+  them nested). This script fixes this adding them the attribute.
 
-  (letfn [(retrieve-chunk [conn cursor]
-            (let [sql (str "select id, name, modified_at, data from file "
-                           " where modified_at > ? and deleted_at is null "
-                           " order by modified_at asc limit ?")
-                  age (if cursor
-                        cursor
-                        (-> (dt/now) (dt/minus age)))]
-              (seq (db/exec! conn [sql age chunk-size]))))
+  Use it with the update-file function above."
+  [data]
+  (let [update-page
+        (fn [page]
+          (prn "================= Page:" (:name page))
+          (letfn [(is-nested? [object]
+                    (and (some? (:component-id object))
+                         (nil? (:component-root? object))))
 
-          (validate-item [{:keys [id data modified-at] :as file}]
-            (let [data   (blob/decode data)
-                  valid? (s/valid? ::spec.file/data data)]
+                  (is-instance? [object]
+                    (some? (:shape-ref object)))
 
-              (l/debug :hint "validated file"
-                       :file-id id
-                       :age (-> (dt/diff modified-at (dt/now))
-                                (dt/truncate :minutes)
-                                (str)
-                                (subs 2)
-                                (str/lower))
-                       :valid valid?)
+                  (get-parent [object]
+                    (get (:objects page) (:parent-id object)))
 
-              (when (and (not valid?) verbose?)
-                (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))))))
+                  (update-object [object]
+                    (if (and (is-nested? object)
+                             (not (is-instance? (get-parent object))))
+                      (do
+                        (prn "Orphan:" (:name object))
+                        (assoc object :component-root? true))
+                      object))]
 
-              (when (and (not valid?) stop-on-error?)
-                (throw (ex-info "penpot/abort" {})))
+            (update page :objects d/update-vals update-object)))]
 
-              valid?))
+    (update data :pages-index d/update-vals update-page)))
 
-          (validate-chunk [chunk]
-            (loop [items   chunk
-                   success 0
-                   errored 0]
+(defn repair-idless-components
+  "There are some files that contains components with no :id attribute.
+  This function detects them and repairs it.
 
-              (if-let [item (first items)]
-                (if (validate-item item)
-                  (recur (rest items) (inc success) errored)
-                  (recur (rest items) success (inc errored)))
-                [(:modified-at (last chunk))
-                 success
-                 errored])))
+  Use it with the update-file function above."
+  [data]
+  (letfn [(update-component [id component]
+            (if (nil? (:id component))
+              (do
+                (prn (:id data) "Broken component" (:name component) id)
+                (assoc component :id id))
+              component))]
 
-          (fmt-result [ns ne]
-            {:total (+ ns ne)
-             :errors ne
-             :success ns})
+    (update data :components #(d/mapm update-component %))))
 
-          ]
+(defn analyze-idless-components
+  "Scan all files to check if there are any one with idless components.
+  (Does not save the changes, only used to detect affected files)."
+  [file _]
+  (repair-idless-components (:data file)))
+
+;; (defn check-image-shapes
+;;   [{:keys [data] :as file} stats]
+;;   (println "=> analizing file:" (:name file) (:id file))
+;;   (swap! stats update :total-files (fnil inc 0))
+;;   (let [affected? (atom false)]
+;;     (walk/prewalk (fn [obj]
+;;                     (when (and (map? obj) (= :image (:type obj)))
+;;                       (when-let [fcolor (some-> obj :fill-color str/upper)]
+;;                         (when (or (= fcolor "#B1B2B5")
+;;                                   (= fcolor "#7B7D85"))
+;;                           (reset! affected? true)
+;;                           (swap! stats update :affected-shapes (fnil inc 0))
+;;                           (println "--> image shape:" ((juxt :id :name :fill-color :fill-opacity) obj)))))
+;;                     obj)
+;;                   data)
+;;     (when @affected?
+;;       (swap! stats update :affected-files (fnil inc 0)))))
+
+(defn analyze-files
+  [system {:keys [sleep chunk-size max-chunks on-file]
+           :or {sleep 1000 chunk-size 10 max-chunks ##Inf}}]
+  (let [stats (atom {})]
+    (letfn [(retrieve-chunk [conn cursor]
+              (let [sql (str "select id, name, modified_at, data from file "
+                             " where modified_at < ? and deleted_at is null "
+                             " order by modified_at desc limit ?")]
+                (->> (db/exec! conn [sql cursor chunk-size])
+                     (map #(update % :data blob/decode)))))
+
+            (process-chunk [chunk]
+              (loop [items chunk]
+                (when-let [item (first items)]
+                  (on-file item stats)
+                  (recur (rest items)))))]
 
-    (try
       (db/with-atomic [conn (:app.db/pool system)]
-        (loop [cursor  nil
-               chunks  0
-               success 0
-               errors 0]
-          (if (< chunks max-chunks)
-            (if-let [chunk (retrieve-chunk conn cursor)]
-              (let [[cursor success' errors'] (validate-chunk chunk)]
-                (Thread/sleep (inst-ms (dt/duration sleep)))
-                (recur cursor
-                       (inc chunks)
-                       (+ success success')
-                       (+ errors errors')))
-              (fmt-result success errors))
-            (fmt-result success errors))))
-      (catch Throwable cause
-        (when (not= "penpot/abort" (ex-message cause))
-          (throw cause))
-        :error))))
+        (loop [cursor (dt/now)
+               chunks 0]
+          (when (< chunks max-chunks)
+            (let [chunk (retrieve-chunk conn cursor)]
+              (when-not (empty? chunk)
+                (let [cursor (-> chunk last :modified-at)]
+                  (process-chunk chunk)
+                  (Thread/sleep (inst-ms (dt/duration sleep)))
+                  (recur cursor (inc chunks)))))))
+        @stats))))
 

backend/src/app/storage.clj

@@ -8,6 +8,7 @@
   "Objects storage abstraction layer."
   (:require
    [app.common.data :as d]
+   [app.common.data.macros :as dm]
    [app.common.exceptions :as ex]
    [app.common.logging :as l]
    [app.common.spec :as us]
@@ -18,9 +19,12 @@
    [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]))
+   [integrant.core :as ig]
+   [promesa.core :as p]
+   [promesa.exec :as px]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Storage Module State
@@ -38,7 +42,7 @@
                    :db ::sdb/backend))))
 
 (defmethod ig/pre-init-spec ::storage [_]
-  (s/keys :req-un [::db/pool ::backends]))
+  (s/keys :req-un [::db/pool ::wrk/executor ::backends]))
 
 (defmethod ig/prep-key ::storage
   [_ {:keys [backends] :as cfg}]
@@ -66,48 +70,58 @@
 (s/def ::storage-object storage-object?)
 (s/def ::storage-content impl/content?)
 
+(defn get-metadata
+  [params]
+  (into {}
+        (remove (fn [[k _]] (qualified-keyword? k)))
+        params))
 
-(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- get-database-object-by-hash
+  [conn backend bucket hash]
+  (let [sql (str "select * from storage_object "
+                 " where (metadata->>'~:hash') = ? "
+                 "   and (metadata->>'~:bucket') = ? "
+                 "   and backend = ?"
+                 "   and deleted_at is null"
+                 " limit 1")]
+    (db/exec-one! conn [sql hash bucket (name backend)])))
 
 (defn- create-database-object
-  [{:keys [conn backend]} {:keys [content] :as object}]
+  [{:keys [conn backend executor]} {:keys [::content ::expired-at ::touched-at] :as params}]
   (us/assert ::storage-content content)
-  (let [id     (uuid/random)
-        mdata  (dissoc object :content :expired-at :touched-at)
+  (px/with-dispatch executor
+    (let [id     (uuid/random)
 
-        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)})]
+          mdata  (cond-> (get-metadata params)
+                   (satisfies? impl/IContentHash content)
+                   (assoc :hash (impl/get-hash content)))
 
-    (StorageObject. (:id result)
-                    (:size result)
-                    (:created-at result)
-                    (:deleted-at result)
-                    (:touched-at result)
-                    backend
-                    mdata
-                    nil)))
+          ;; NOTE: for now we don't reuse the deleted objects, but in
+          ;; futute we can consider reusing deleted objects if we
+          ;; found a duplicated one and is marked for deletion but
+          ;; still not deleted.
+          result (when (and (::deduplicate? params)
+                            (:hash mdata)
+                            (:bucket mdata))
+                   (get-database-object-by-hash conn backend (:bucket mdata) (:hash mdata)))
+
+          result (or result
+                     (db/insert! conn :storage-object
+                                 {:id id
+                                  :size (count content)
+                                  :backend (name backend)
+                                  :metadata (db/tjson mdata)
+                                  :deleted-at expired-at
+                                  :touched-at touched-at}))]
+
+      (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())")
@@ -128,14 +142,6 @@
   (when-let [res (db/exec-one! conn [sql:retrieve-storage-object id])]
     (row->storage-object res)))
 
-(def sql:delete-storage-object
-  "update storage_object set deleted_at=now() where id=?")
-
-(defn- delete-database-object
-  [{:keys [conn] :as storage} id]
-  (let [result (db/exec-one! conn [sql:delete-storage-object id])]
-    (pos? (:next.jdbc/update-count result))))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; API
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -148,24 +154,24 @@
   [url]
   (fs/path (java.net.URI. (str url))))
 
-(defn content
-  ([data] (impl/content data nil))
-  ([data size] (impl/content data size)))
+(dm/export impl/content)
+(dm/export impl/wrap-with-hash)
 
 (defn get-object
   [{:keys [conn pool] :as storage} id]
   (us/assert ::storage storage)
-  (-> (assoc storage :conn (or conn pool))
-      (retrieve-database-object id)))
+  (p/do
+    (-> (assoc storage :conn (or conn pool))
+        (retrieve-database-object id))))
 
-(defn put-object
+(defn put-object!
   "Creates a new object with the provided content."
-  [{:keys [pool conn backend] :as storage} {:keys [content] :as params}]
+  [{:keys [pool conn backend] :as storage} {:keys [::content] :as params}]
   (us/assert ::storage storage)
   (us/assert ::storage-content content)
   (us/assert ::us/keyword backend)
-  (let [storage (assoc storage :conn (or conn pool))
-        object  (create-database-object storage params)]
+  (p/let [storage (assoc storage :conn (or conn pool))
+          object  (create-database-object storage params)]
 
     ;; Store the data finally on the underlying storage subsystem.
     (-> (impl/resolve-backend storage backend)
@@ -173,96 +179,94 @@
 
     object))
 
-(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 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* (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
-      ;; implementation on backend.
-      (-> (impl/resolve-backend storage (:backend storage))
-          (impl/copy-object object object*))
-
-      ;; if the source and destination backends are different, we just
-      ;; need to obtain the streams and proceed full copy of the data
-      (with-open [is (-> (impl/resolve-backend storage (:backend object))
-                         (impl/get-object-data object))]
-        (-> (impl/resolve-backend storage (:backend storage))
-            (impl/put-object object* (impl/content is (:size object))))))
-    object*))
+(defn touch-object!
+  "Mark object as touched."
+  [{:keys [pool conn] :as storage} object-or-id]
+  (p/do
+    (let [id  (if (storage-object? object-or-id) (:id object-or-id) object-or-id)
+          res (db/update! (or conn pool) :storage-object
+                          {:touched-at (dt/now)}
+                          {:id id}
+                          {:return-keys false})]
+      (pos? (:next.jdbc/update-count res)))))
 
 (defn get-object-data
   "Return an input stream instance of the object content."
   [{:keys [pool conn] :as storage} object]
   (us/assert ::storage storage)
-  (when (or (nil? (:expired-at object))
-            (dt/is-after? (:expired-at object) (dt/now)))
-    (-> (assoc storage :conn (or conn pool))
-        (impl/resolve-backend (:backend object))
-        (impl/get-object-data object))))
+  (p/do
+    (when (or (nil? (:expired-at object))
+              (dt/is-after? (:expired-at object) (dt/now)))
+      (-> (assoc storage :conn (or conn pool))
+          (impl/resolve-backend (:backend object))
+          (impl/get-object-data object)))))
 
 (defn get-object-bytes
   "Returns a byte array of object content."
   [{:keys [pool conn] :as storage} object]
   (us/assert ::storage storage)
-  (when (or (nil? (:expired-at object))
-            (dt/is-after? (:expired-at object) (dt/now)))
-    (-> (assoc storage :conn (or conn pool))
-        (impl/resolve-backend (:backend object))
-        (impl/get-object-bytes object))))
+  (p/do
+    (when (or (nil? (:expired-at object))
+              (dt/is-after? (:expired-at object) (dt/now)))
+      (-> (assoc storage :conn (or conn pool))
+          (impl/resolve-backend (:backend object))
+          (impl/get-object-bytes object)))))
 
 (defn get-object-url
   ([storage object]
    (get-object-url storage object nil))
   ([{:keys [conn pool] :as storage} object options]
    (us/assert ::storage storage)
-   (when (or (nil? (:expired-at object))
-             (dt/is-after? (:expired-at object) (dt/now)))
-     (-> (assoc storage :conn (or conn pool))
-         (impl/resolve-backend (:backend object))
-         (impl/get-object-url object options)))))
+   (p/do
+     (when (or (nil? (:expired-at object))
+               (dt/is-after? (:expired-at object) (dt/now)))
+       (-> (assoc storage :conn (or conn pool))
+           (impl/resolve-backend (:backend object))
+           (impl/get-object-url object options))))))
 
 (defn get-object-path
   "Get the Path to the object. Only works with `:fs` type of
   storages."
   [storage object]
-  (let [backend (impl/resolve-backend storage (:backend object))]
-    (when (not= :fs (:type backend))
-      (ex/raise :type :internal
-                :code :operation-not-allowed
-                :hint "get-object-path only works with fs type backends"))
-    (when (or (nil? (:expired-at object))
-              (dt/is-after? (:expired-at object) (dt/now)))
-      (-> (impl/get-object-url backend object nil)
-          (file-url->path)))))
+  (p/do
+    (let [backend (impl/resolve-backend storage (:backend object))]
+      (when (not= :fs (:type backend))
+        (ex/raise :type :internal
+                  :code :operation-not-allowed
+                  :hint "get-object-path only works with fs type backends"))
+      (when (or (nil? (:expired-at object))
+                (dt/is-after? (:expired-at object) (dt/now)))
+        (p/-> (impl/get-object-url backend object nil) file-url->path)))))
 
-(defn del-object
-  [{:keys [conn pool] :as storage} id-or-obj]
+(defn del-object!
+  [{:keys [conn pool] :as storage} object-or-id]
   (us/assert ::storage storage)
-  (-> (assoc storage :conn (or conn pool))
-      (delete-database-object (if (uuid? id-or-obj) id-or-obj (:id id-or-obj)))))
+  (p/do
+    (let [id  (if (storage-object? object-or-id) (:id object-or-id) object-or-id)
+          res (db/update! (or conn pool) :storage-object
+                          {:deleted-at (dt/now)}
+                          {:id id}
+                          {:return-keys false})]
+      (pos? (:next.jdbc/update-count res)))))
 
-(d/export impl/resolve-backend)
+(dm/export impl/resolve-backend)
+(dm/export impl/calculate-hash)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Garbage Collection: Permanently delete objects
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;; A task responsible to permanently delete already marked as deleted
-;; storage files.
+;; storage files. The storage objects are practically never marked to
+;; be deleted directly by the api call. The touched-gc is responsible
+;; of collecting the usage of the object and mark it as deleted.
 
 (declare sql:retrieve-deleted-objects-chunk)
 
 (s/def ::min-age ::dt/duration)
 
 (defmethod ig/pre-init-spec ::gc-deleted-task [_]
-  (s/keys :req-un [::storage ::db/pool ::min-age]))
+  (s/keys :req-un [::storage ::db/pool ::min-age ::wrk/executor]))
 
 (defmethod ig/init-key ::gc-deleted-task
   [_ {:keys [pool storage min-age] :as cfg}]
@@ -270,7 +274,7 @@
             (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)]))
+               (some->> (seq rows) (d/group-by #(-> % :backend keyword) :id #{}) seq)]))
 
           (retrieve-deleted-objects [conn]
             (->> (d/iteration (fn [cursor]
@@ -283,7 +287,7 @@
           (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)))]
+              @(impl/del-objects-in-bulk backend ids)))]
 
     (fn [_]
       (db/with-atomic [conn pool]
@@ -306,7 +310,7 @@
         and s.deleted_at < (now() - ?::interval)
         and s.created_at < ?
       order by s.created_at desc
-      limit 100
+      limit 25
    )
    delete from storage_object
     where id in (select id from items_part)
@@ -316,18 +320,23 @@
 ;; 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 process of storage
+;; objects and is responsible on analyzing the touched objects and
+;; mark them for deletion if corresponds.
 ;;
-;; 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).
+;; 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-chunk)
 (declare sql:retrieve-file-media-object-nrefs)
 (declare sql:retrieve-team-font-variant-nrefs)
+(declare sql:retrieve-profile-nrefs)
 
 (defmethod ig/pre-init-spec ::gc-touched-task [_]
   (s/keys :req-un [::db/pool]))
@@ -340,6 +349,9 @@
           (has-file-media-object-nrefs? [conn id]
             (-> (db/exec-one! conn [sql:retrieve-file-media-object-nrefs id id]) :nrefs pos?))
 
+          (has-profile-nrefs? [conn id]
+            (-> (db/exec-one! conn [sql:retrieve-profile-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" ids)]))
@@ -348,17 +360,30 @@
             (db/exec-one! conn ["update storage_object set deleted_at=now(), touched_at=null where id = ANY(?)"
                                 (db/create-array conn "uuid" ids)]))
 
+          ;; NOTE: A getter that retrieves the key witch will be used
+          ;; for group ids; previoulsy we have no value, then we
+          ;; introduced the `:reference` prop, and then it is renamed
+          ;; to `:bucket` and now is string instead. This is
+          ;; implemented in this way for backward comaptibilty.
+
+          ;; 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 bucket value.  And we know that if it does not
+          ;; have value, it means :file-media-object.
+
+          (get-bucket [{:keys [metadata]}]
+            (or (some-> metadata :bucket)
+                (some-> metadata :reference d/name)
+                "file-media-object"))
+
           (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)))]
+                            (mapv #(d/update-when % :metadata db/decode-transit-pgobject)))]
               (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)])))
+                 (d/group-by get-bucket :id #{} rows)])))
 
           (retrieve-touched [conn]
             (->> (d/iteration (fn [cursor]
@@ -388,13 +413,14 @@
         (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)
+          (if-let [[bucket ids] (first groups)]
+            (let [[f d] (case bucket
+                          "file-media-object" (process-objects! conn has-file-media-object-nrefs? ids)
+                          "team-font-variant" (process-objects! conn has-team-font-variant-nrefs? ids)
+                          "profile"           (process-objects! conn has-profile-nrefs? ids)
                           (ex/raise :type :internal
                                     :code :unexpected-unknown-reference
-                                    :hint (format "unknown reference %s" (pr-str reference))))]
+                                    :hint (dm/fmt "unknown reference %" bucket)))]
               (recur (+ to-freeze f)
                      (+ to-delete d)
                      (rest groups)))
@@ -418,3 +444,7 @@
            (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")
+
+(def sql:retrieve-profile-nrefs
+  "select ((select count(*) from profile where photo_id = ?) +
+           (select count(*) from team where photo_id = ?)) as nrefs")

backend/src/app/storage/db.clj

@@ -10,7 +10,8 @@
    [app.db :as db]
    [app.storage.impl :as impl]
    [clojure.spec.alpha :as s]
-   [integrant.core :as ig])
+   [integrant.core :as ig]
+   [promesa.exec :as px])
   (:import
    java.io.ByteArrayInputStream))
 
@@ -30,26 +31,23 @@
 ;; --- API IMPL
 
 (defmethod impl/put-object :db
-  [{:keys [conn] :as storage} {:keys [id] :as object} content]
-  (let [data (impl/slurp-bytes content)]
-    (db/insert! conn :storage-data {:id id :data data})
-    object))
-
-(defmethod impl/copy-object :db
-  [{:keys [conn] :as storage} src-object dst-object]
-  (db/exec-one! conn ["insert into storage_data (id, data) select ? as id, data from storage_data  where id=?"
-                      (:id dst-object)
-                      (:id src-object)]))
+  [{:keys [conn executor] :as storage} {:keys [id] :as object} content]
+  (px/with-dispatch executor
+    (let [data (impl/slurp-bytes content)]
+      (db/insert! conn :storage-data {:id id :data data})
+      object)))
 
 (defmethod impl/get-object-data :db
-  [{:keys [conn] :as backend} {:keys [id] :as object}]
-  (let [result (db/exec-one! conn ["select data from storage_data where id=?" id])]
-    (ByteArrayInputStream. (:data result))))
+  [{:keys [conn executor] :as backend} {:keys [id] :as object}]
+  (px/with-dispatch executor
+    (let [result (db/exec-one! conn ["select data from storage_data where id=?" id])]
+      (ByteArrayInputStream. (:data result)))))
 
 (defmethod impl/get-object-bytes :db
-  [{:keys [conn] :as backend} {:keys [id] :as object}]
-  (let [result (db/exec-one! conn ["select data from storage_data where id=?" id])]
-    (:data result)))
+  [{:keys [conn executor] :as backend} {:keys [id] :as object}]
+  (px/with-dispatch executor
+    (let [result (db/exec-one! conn ["select data from storage_data where id=?" id])]
+      (:data result))))
 
 (defmethod impl/get-object-url :db
   [_ _]

backend/src/app/storage/fs.clj

@@ -14,7 +14,8 @@
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [datoteka.core :as fs]
-   [integrant.core :as ig])
+   [integrant.core :as ig]
+   [promesa.exec :as px])
   (:import
    java.io.InputStream
    java.io.OutputStream
@@ -47,62 +48,57 @@
 ;; --- API IMPL
 
 (defmethod impl/put-object :fs
-  [backend {:keys [id] :as object} content]
-  (let [base (fs/path (:directory backend))
-        path (fs/path (impl/id->path id))
-        full (fs/normalize (fs/join base path))]
-    (when-not (fs/exists? (fs/parent full))
-      (fs/create-dir (fs/parent full)))
-    (with-open [^InputStream src  (io/input-stream content)
-                ^OutputStream dst (io/output-stream full)]
-      (io/copy src dst))))
-
-(defmethod impl/copy-object :fs
-  [backend src-object dst-object]
-  (let [base (fs/path (:directory backend))
-        path (fs/path (impl/id->path (:id dst-object)))
-        full (fs/normalize (fs/join base path))]
-    (when-not (fs/exists? (fs/parent full))
-      (fs/create-dir (fs/parent full)))
-    (with-open [^InputStream src  (impl/get-object-data backend src-object)
-                ^OutputStream dst (io/output-stream full)]
-      (io/copy src dst))))
+  [{:keys [executor] :as backend} {:keys [id] :as object} content]
+  (px/with-dispatch executor
+    (let [base (fs/path (:directory backend))
+          path (fs/path (impl/id->path id))
+          full (fs/normalize (fs/join base path))]
+      (when-not (fs/exists? (fs/parent full))
+        (fs/create-dir (fs/parent full)))
+      (with-open [^InputStream src  (io/input-stream content)
+                  ^OutputStream dst (io/output-stream full)]
+        (io/copy src dst)))))
 
 (defmethod impl/get-object-data :fs
-  [backend {:keys [id] :as object}]
-  (let [^Path base (fs/path (:directory backend))
-        ^Path path (fs/path (impl/id->path id))
-        ^Path full (fs/normalize (fs/join base path))]
-    (when-not (fs/exists? full)
-      (ex/raise :type :internal
-                :code :filesystem-object-does-not-exists
-                :path (str full)))
-    (io/input-stream full)))
+  [{:keys [executor] :as backend} {:keys [id] :as object}]
+  (px/with-dispatch executor
+    (let [^Path base (fs/path (:directory backend))
+          ^Path path (fs/path (impl/id->path id))
+          ^Path full (fs/normalize (fs/join base path))]
+      (when-not (fs/exists? full)
+        (ex/raise :type :internal
+                  :code :filesystem-object-does-not-exists
+                  :path (str full)))
+      (io/input-stream full))))
 
 (defmethod impl/get-object-bytes :fs
-  [backend object]
-  (fs/slurp-bytes (impl/get-object-data backend object)))
+  [{:keys [executor] :as backend} object]
+  (px/with-dispatch executor
+    (fs/slurp-bytes (impl/get-object-data backend object))))
 
 (defmethod impl/get-object-url :fs
-  [{:keys [uri] :as backend} {:keys [id] :as object} _]
-  (update uri :path
-          (fn [existing]
-            (if (str/ends-with? existing "/")
-              (str existing (impl/id->path id))
-              (str existing "/" (impl/id->path id))))))
+  [{:keys [uri executor] :as backend} {:keys [id] :as object} _]
+  (px/with-dispatch executor
+    (update uri :path
+            (fn [existing]
+              (if (str/ends-with? existing "/")
+                (str existing (impl/id->path id))
+                (str existing "/" (impl/id->path id)))))))
 
 (defmethod impl/del-object :fs
-  [backend {:keys [id] :as object}]
-  (let [base (fs/path (:directory backend))
-        path (fs/path (impl/id->path id))
-        path (fs/join base path)]
-    (Files/deleteIfExists ^Path path)))
+  [{:keys [executor] :as backend} {:keys [id] :as object}]
+  (px/with-dispatch executor
+    (let [base (fs/path (:directory backend))
+          path (fs/path (impl/id->path id))
+          path (fs/join base path)]
+      (Files/deleteIfExists ^Path path))))
 
 (defmethod impl/del-objects-in-bulk :fs
-  [backend ids]
-  (let [base (fs/path (:directory backend))]
-    (doseq [id ids]
-      (let [path (fs/path (impl/id->path id))
-            path (fs/join base path)]
-        (Files/deleteIfExists ^Path path)))))
+  [{:keys [executor] :as backend} ids]
+  (px/with-dispatch executor
+    (let [base (fs/path (:directory backend))]
+      (doseq [id ids]
+        (let [path (fs/path (impl/id->path id))
+              path (fs/join base path)]
+          (Files/deleteIfExists ^Path path))))))
 

backend/src/app/storage/impl.clj

@@ -7,17 +7,20 @@
 (ns app.storage.impl
   "Storage backends abstraction layer."
   (:require
+   [app.common.data.macros :as dm]
    [app.common.exceptions :as ex]
    [app.common.uuid :as uuid]
    [buddy.core.codecs :as bc]
-   [clojure.java.io :as io]
-   [cuerdas.core :as str])
+   [buddy.core.hash :as bh]
+   [clojure.java.io :as io])
   (:import
    java.nio.ByteBuffer
    java.util.UUID
    java.io.ByteArrayInputStream
    java.io.InputStream
-   java.nio.file.Files))
+   java.nio.file.Files
+   org.apache.commons.io.input.BoundedInputStream
+   ))
 
 ;; --- API Definition
 
@@ -29,14 +32,6 @@
             :code :invalid-storage-backend
             :context cfg))
 
-(defmulti copy-object (fn [cfg _ _] (:type cfg)))
-
-(defmethod copy-object :default
-  [cfg _ _]
-  (ex/raise :type :internal
-            :code :invalid-storage-backend
-            :context cfg))
-
 (defmulti get-object-data (fn [cfg _] (:type cfg)))
 
 (defmethod get-object-data :default
@@ -106,63 +101,26 @@
                     :code :invalid-id-type
                     :hint "id should be string or uuid")))
 
+(defprotocol IContentObject
+  (size [_] "get object size"))
 
-(defprotocol IContentObject)
+(defprotocol IContentHash
+  (get-hash [_] "get precalculated hash"))
 
-(defn- path->content
-  [path]
-  (let [size (Files/size path)]
-    (reify
-      IContentObject
-      io/IOFactory
-      (make-reader [_ opts]
-	    (io/make-reader path opts))
-      (make-writer [_ _]
-        (throw (UnsupportedOperationException. "not implemented")))
-      (make-input-stream [_ opts]
-        (io/make-input-stream path opts))
-      (make-output-stream [_ _]
-        (throw (UnsupportedOperationException. "not implemented")))
-      clojure.lang.Counted
-      (count [_] size)
-
-    java.lang.AutoCloseable
-    (close [_]))))
-
-(defn string->content
-  [^String v]
-  (let [data (.getBytes v "UTF-8")
-        bais (ByteArrayInputStream. ^bytes data)]
-    (reify
-      IContentObject
-      io/IOFactory
-      (make-reader [_ opts]
-	    (io/make-reader bais opts))
-      (make-writer [_ _]
-        (throw (UnsupportedOperationException. "not implemented")))
-      (make-input-stream [_ opts]
-        (io/make-input-stream bais opts))
-      (make-output-stream [_ _]
-        (throw (UnsupportedOperationException. "not implemented")))
-
-      clojure.lang.Counted
-      (count [_]
-        (alength data))
-
-    java.lang.AutoCloseable
-    (close [_]))))
-
-(defn- input-stream->content
-  [^InputStream is size]
+(defn- make-content
+  [^InputStream is ^long size]
   (reify
     IContentObject
+    (size [_] size)
+
     io/IOFactory
-    (make-reader [_ opts]
-      (io/make-reader is opts))
+    (make-reader [this opts]
+      (io/make-reader this opts))
     (make-writer [_ _]
       (throw (UnsupportedOperationException. "not implemented")))
-    (make-input-stream [_ opts]
-      (io/make-input-stream is opts))
+    (make-input-stream [_ _]
+      (doto (BoundedInputStream. is size)
+        (.setPropagateClose false)))
     (make-output-stream [_ _]
       (throw (UnsupportedOperationException. "not implemented")))
 
@@ -178,26 +136,63 @@
   ([data size]
    (cond
      (instance? java.nio.file.Path data)
-     (path->content data)
+     (make-content (io/input-stream data)
+                   (Files/size data))
 
      (instance? java.io.File data)
-     (path->content (.toPath ^java.io.File data))
+     (content (.toPath ^java.io.File data) nil)
 
      (instance? String data)
-     (string->content data)
+     (let [data (.getBytes data "UTF-8")
+           bais (ByteArrayInputStream. ^bytes data)]
+       (make-content bais (alength data)))
 
      (bytes? data)
-     (input-stream->content (ByteArrayInputStream. ^bytes data) (alength ^bytes data))
+     (let [size (alength ^bytes data)
+           bais (ByteArrayInputStream. ^bytes data)]
+       (make-content bais size))
 
      (instance? InputStream data)
      (do
        (when-not size
          (throw (UnsupportedOperationException. "size should be provided on InputStream")))
-       (input-stream->content data size))
+       (make-content data size))
 
      :else
      (throw (UnsupportedOperationException. "type not supported")))))
 
+(defn wrap-with-hash
+  [content ^String hash]
+  (when-not (satisfies? IContentObject content)
+    (throw (UnsupportedOperationException. "`content` should be an instance of IContentObject")))
+
+  (when-not (satisfies? io/IOFactory content)
+    (throw (UnsupportedOperationException. "`content` should be an instance of IOFactory")))
+
+  (reify
+    IContentObject
+    (size [_] (size content))
+
+    IContentHash
+    (get-hash [_] hash)
+
+    io/IOFactory
+    (make-reader [_ opts]
+      (io/make-reader content opts))
+    (make-writer [_ opts]
+      (io/make-writer content opts))
+    (make-input-stream [_ opts]
+      (io/make-input-stream content opts))
+    (make-output-stream [_ opts]
+      (io/make-output-stream content opts))
+
+    clojure.lang.Counted
+    (count [_] (count content))
+
+    java.lang.AutoCloseable
+    (close [_]
+      (.close ^java.lang.AutoCloseable content))))
+
 (defn content?
   [v]
   (satisfies? IContentObject v))
@@ -209,15 +204,33 @@
     (io/copy input output)
     (.toByteArray output)))
 
-(defn resolve-backend
-  [{:keys [conn pool] :as storage} backend-id]
-  (when backend-id
-    (let [backend (get-in storage [:backends backend-id])]
-      (when-not backend
-        (ex/raise :type :internal
-                  :code :backend-not-configured
-                  :hint (str/fmt "backend '%s' not configured" backend-id)))
-      (assoc backend
-             :conn (or conn pool)
-             :id backend-id))))
+(defn calculate-hash
+  [path-or-stream]
+  (let [result (cond
+                 (instance? InputStream path-or-stream)
+                 (let [result (-> (bh/blake2b-256 path-or-stream)
+                                  (bc/bytes->hex))]
+                   (.reset path-or-stream)
+                   result)
 
+                 (string? path-or-stream)
+                 (-> (bh/blake2b-256 path-or-stream)
+                     (bc/bytes->hex))
+
+                 :else
+                 (with-open [is (io/input-stream path-or-stream)]
+                   (-> (bh/blake2b-256 is)
+                       (bc/bytes->hex))))]
+    (str "blake2b:" result)))
+
+(defn resolve-backend
+  [{:keys [conn pool executor] :as storage} backend-id]
+  (let [backend (get-in storage [:backends backend-id])]
+    (when-not backend
+      (ex/raise :type :internal
+                :code :backend-not-configured
+                :hint (dm/fmt "backend '%' not configured" backend-id)))
+    (assoc backend
+           :executor executor
+           :conn (or conn pool)
+           :id backend-id)))

backend/src/app/storage/s3.clj

@@ -13,36 +13,42 @@
    [app.common.uri :as u]
    [app.storage.impl :as impl]
    [app.util.time :as dt]
+   [app.worker :as wrk]
    [clojure.java.io :as io]
    [clojure.spec.alpha :as s]
-   [integrant.core :as ig])
+   [integrant.core :as ig]
+   [promesa.core :as p]
+   [promesa.exec :as px])
   (:import
-   java.time.Duration
    java.io.InputStream
+   java.nio.ByteBuffer
+   java.time.Duration
    java.util.Collection
-   software.amazon.awssdk.core.sync.RequestBody
+   java.util.Optional
+   java.util.concurrent.Semaphore
+   org.reactivestreams.Subscriber
+   org.reactivestreams.Subscription
    software.amazon.awssdk.core.ResponseBytes
-   ;; software.amazon.awssdk.core.ResponseInputStream
+   software.amazon.awssdk.core.async.AsyncRequestBody
+   software.amazon.awssdk.core.client.config.ClientAsyncConfiguration
+   software.amazon.awssdk.core.client.config.SdkAdvancedAsyncClientOption
+   software.amazon.awssdk.http.nio.netty.NettyNioAsyncHttpClient
+   software.amazon.awssdk.http.nio.netty.SdkEventLoopGroup
    software.amazon.awssdk.regions.Region
-   software.amazon.awssdk.services.s3.S3Client
+   software.amazon.awssdk.services.s3.S3AsyncClient
    software.amazon.awssdk.services.s3.model.Delete
-   software.amazon.awssdk.services.s3.model.CopyObjectRequest
+   software.amazon.awssdk.services.s3.model.DeleteObjectRequest
    software.amazon.awssdk.services.s3.model.DeleteObjectsRequest
    software.amazon.awssdk.services.s3.model.DeleteObjectsResponse
-   software.amazon.awssdk.services.s3.model.DeleteObjectRequest
    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
-   software.amazon.awssdk.services.s3.presigner.model.PresignedGetObjectRequest
-
-   ))
+   software.amazon.awssdk.services.s3.presigner.model.PresignedGetObjectRequest))
 
 (declare put-object)
-(declare copy-object)
 (declare get-object-bytes)
 (declare get-object-data)
 (declare get-object-url)
@@ -59,7 +65,7 @@
 (s/def ::endpoint ::us/string)
 
 (defmethod ig/pre-init-spec ::backend [_]
-  (s/keys :opt-un [::region ::bucket ::prefix ::endpoint]))
+  (s/keys :opt-un [::region ::bucket ::prefix ::endpoint ::wrk/executor]))
 
 (defmethod ig/prep-key ::backend
   [_ {:keys [prefix] :as cfg}]
@@ -75,12 +81,18 @@
     (let [client    (build-s3-client cfg)
           presigner (build-s3-presigner cfg)]
       (assoc cfg
-             :client client
+             :client @client
              :presigner presigner
-             :type :s3))))
+             :type :s3
+             ::close-fn #(.close ^java.lang.AutoCloseable client)))))
+
+(defmethod ig/halt-key! ::backend
+  [_ {:keys [::close-fn]}]
+  (when (fn? close-fn)
+    (px/run! close-fn)))
 
 (s/def ::type ::us/keyword)
-(s/def ::client #(instance? S3Client %))
+(s/def ::client #(instance? S3AsyncClient %))
 (s/def ::presigner #(instance? S3Presigner %))
 (s/def ::backend
   (s/keys :req-un [::region ::bucket ::client ::type ::presigner]
@@ -92,10 +104,6 @@
   [backend object content]
   (put-object backend object content))
 
-(defmethod impl/copy-object :s3
-  [backend src-object dst-object]
-  (copy-object backend src-object dst-object))
-
 (defmethod impl/get-object-data :s3
   [backend object]
   (get-object-data backend object))
@@ -118,21 +126,44 @@
 
 ;; --- HELPERS
 
+(def default-eventloop-threads 4)
+(def default-timeout
+  (dt/duration {:seconds 30}))
+
 (defn- ^Region lookup-region
   [region]
   (Region/of (name region)))
 
 (defn build-s3-client
-  [{: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))))
+  [{:keys [region endpoint executor]}]
+  (let [hclient (.. (NettyNioAsyncHttpClient/builder)
+                    (eventLoopGroupBuilder (.. (SdkEventLoopGroup/builder)
+                                               (numberOfThreads (int default-eventloop-threads))))
+                    (connectionAcquisitionTimeout default-timeout)
+                    (connectionTimeout default-timeout)
+                    (readTimeout default-timeout)
+                    (writeTimeout default-timeout)
+                    (build))
+        client  (.. (S3AsyncClient/builder)
+                    (asyncConfiguration (.. (ClientAsyncConfiguration/builder)
+                                            (advancedOption SdkAdvancedAsyncClientOption/FUTURE_COMPLETION_EXECUTOR
+                                                            executor)
+                                            (build)))
+                    (httpClient hclient)
+                    (region (lookup-region region)))]
+
+    (when-let [uri (some-> endpoint (java.net.URI.))]
+      (.endpointOverride client uri))
+
+    (let [client (.build client)]
+      (reify
+        clojure.lang.IDeref
+        (deref [_] client)
+
+        java.lang.AutoCloseable
+        (close [_]
+          (.close hclient)
+          (.close client))))))
 
 (defn build-s3-presigner
   [{:keys [region endpoint]}]
@@ -146,58 +177,83 @@
         (region (lookup-region region))
         (build))))
 
+(defn- make-request-body
+  [content]
+  (let [is        (io/input-stream content)
+        buff-size (* 1024 64)
+        sem       (Semaphore. 0)
+
+        writer-fn (fn [s]
+                    (try
+                      (loop []
+                        (.acquire sem 1)
+                        (let [buffer (byte-array buff-size)
+                              readed (.read is buffer)]
+                          (when (pos? readed)
+                            (.onNext ^Subscriber s (ByteBuffer/wrap buffer 0 readed))
+                            (when (= readed buff-size)
+                              (recur)))))
+                      (.onComplete s)
+                      (catch Throwable cause
+                        (.onError s cause))
+                      (finally
+                        (.close ^InputStream is))))]
+
+    (reify
+      AsyncRequestBody
+      (contentLength [_]
+        (Optional/of (long (count content))))
+
+      (^void subscribe [_ ^Subscriber s]
+       (let [thread (Thread. #(writer-fn s))]
+         (.setDaemon thread true)
+         (.setName thread "penpot/storage:s3")
+         (.start thread)
+
+         (.onSubscribe s (reify Subscription
+                           (cancel [_]
+                             (.interrupt thread)
+                             (.release sem 1))
+
+                           (request [_ n]
+                             (.release sem (int n))))))))))
+
+
 (defn put-object
   [{:keys [client bucket prefix]} {:keys [id] :as object} content]
-  (let [path    (str prefix (impl/id->path id))
-        mdata   (meta object)
-        mtype   (:content-type mdata "application/octet-stream")
-        request (.. (PutObjectRequest/builder)
-                    (bucket bucket)
-                    (contentType mtype)
-                    (key path)
-                    (build))]
+  (p/let [path    (str prefix (impl/id->path id))
+          mdata   (meta object)
+          mtype   (:content-type mdata "application/octet-stream")
+          request (.. (PutObjectRequest/builder)
+                      (bucket bucket)
+                      (contentType mtype)
+                      (key path)
+                      (build))]
 
-    (with-open [^InputStream is (io/input-stream content)]
-      (let [content (RequestBody/fromInputStream is (count content))]
-        (.putObject ^S3Client client
-                    ^PutObjectRequest request
-                    ^RequestBody content)))))
-
-(defn copy-object
-  [{:keys [client bucket prefix]} src-object dst-object]
-  (let [source-path  (str prefix (impl/id->path (:id src-object)))
-        source-mdata (meta src-object)
-        source-mtype (:content-type source-mdata "application/octet-stream")
-        dest-path    (str prefix (impl/id->path (:id dst-object)))
-
-        request      (.. (CopyObjectRequest/builder)
-                         (copySource (u/query-encode (str bucket "/" source-path)))
-                         (destinationBucket bucket)
-                         (destinationKey dest-path)
-                         (contentType source-mtype)
-                         (build))]
-
-    (.copyObject ^S3Client client ^CopyObjectRequest request)))
+    (let [content (make-request-body content)]
+      (.putObject ^S3AsyncClient client
+                  ^PutObjectRequest request
+                  ^AsyncRequestBody content))))
 
 (defn get-object-data
   [{:keys [client bucket prefix]} {:keys [id]}]
-  (let [gor (.. (GetObjectRequest/builder)
-                (bucket bucket)
-                (key (str prefix (impl/id->path id)))
-                (build))
-        obj (.getObject ^S3Client client ^GetObjectRequest gor)
-        ;; rsp (.response ^ResponseInputStream obj)
-        ;; len (.contentLength ^GetObjectResponse rsp)
-        ]
+  (p/let [gor (.. (GetObjectRequest/builder)
+                  (bucket bucket)
+                  (key (str prefix (impl/id->path id)))
+                  (build))
+          obj (.getObject ^S3AsyncClient client ^GetObjectRequest gor)
+          ;; rsp (.response ^ResponseInputStream obj)
+          ;; len (.contentLength ^GetObjectResponse rsp)
+          ]
     (io/input-stream obj)))
 
 (defn get-object-bytes
   [{:keys [client bucket prefix]} {:keys [id]}]
-  (let [gor (.. (GetObjectRequest/builder)
-                (bucket bucket)
-                (key (str prefix (impl/id->path id)))
-                (build))
-        obj (.getObjectAsBytes ^S3Client client ^GetObjectRequest gor)]
+  (p/let [gor (.. (GetObjectRequest/builder)
+                  (bucket bucket)
+                  (key (str prefix (impl/id->path id)))
+                  (build))
+          obj (.getObjectAsBytes ^S3AsyncClient client ^GetObjectRequest gor)]
     (.asByteArray ^ResponseBytes obj)))
 
 (def default-max-age
@@ -206,42 +262,43 @@
 (defn get-object-url
   [{:keys [presigner bucket prefix]} {:keys [id]} {:keys [max-age] :or {max-age default-max-age}}]
   (us/assert dt/duration? max-age)
-  (let [gor  (.. (GetObjectRequest/builder)
-                 (bucket bucket)
-                 (key (str prefix (impl/id->path id)))
-                 (build))
-        gopr (.. (GetObjectPresignRequest/builder)
-                 (signatureDuration ^Duration max-age)
-                 (getObjectRequest ^GetObjectRequest gor)
-                 (build))
-        pgor (.presignGetObject ^S3Presigner presigner ^GetObjectPresignRequest gopr)]
-    (u/uri (str (.url ^PresignedGetObjectRequest pgor)))))
+  (p/do
+    (let [gor  (.. (GetObjectRequest/builder)
+                   (bucket bucket)
+                   (key (str prefix (impl/id->path id)))
+                   (build))
+          gopr (.. (GetObjectPresignRequest/builder)
+                   (signatureDuration ^Duration max-age)
+                   (getObjectRequest ^GetObjectRequest gor)
+                   (build))
+          pgor (.presignGetObject ^S3Presigner presigner ^GetObjectPresignRequest gopr)]
+      (u/uri (str (.url ^PresignedGetObjectRequest pgor))))))
 
 (defn del-object
   [{:keys [bucket client prefix]} {:keys [id] :as obj}]
-  (let [dor (.. (DeleteObjectRequest/builder)
-                (bucket bucket)
-                (key (str prefix (impl/id->path id)))
-                (build))]
-    (.deleteObject ^S3Client client
+  (p/let [dor (.. (DeleteObjectRequest/builder)
+                  (bucket bucket)
+                  (key (str prefix (impl/id->path id)))
+                  (build))]
+    (.deleteObject ^S3AsyncClient client
                    ^DeleteObjectRequest dor)))
 
 (defn del-object-in-bulk
   [{:keys [bucket client prefix]} ids]
-  (let [oids (map (fn [id]
-                    (.. (ObjectIdentifier/builder)
-                        (key (str prefix (impl/id->path id)))
-                        (build)))
-                  ids)
-        delc (.. (Delete/builder)
-                 (objects ^Collection oids)
-                 (build))
-        dor  (.. (DeleteObjectsRequest/builder)
-                 (bucket bucket)
-                 (delete ^Delete delc)
-                 (build))
-        dres (.deleteObjects ^S3Client client
-                             ^DeleteObjectsRequest dor)]
+  (p/let [oids (map (fn [id]
+                      (.. (ObjectIdentifier/builder)
+                          (key (str prefix (impl/id->path id)))
+                          (build)))
+                    ids)
+          delc (.. (Delete/builder)
+                   (objects ^Collection oids)
+                   (build))
+          dor  (.. (DeleteObjectsRequest/builder)
+                   (bucket bucket)
+                   (delete ^Delete delc)
+                   (build))
+          dres (.deleteObjects ^S3AsyncClient client
+                               ^DeleteObjectsRequest dor)]
     (when (.hasErrors ^DeleteObjectsResponse dres)
       (let [errors (seq (.errors ^DeleteObjectsResponse dres))]
         (ex/raise :type :internal

backend/src/app/tasks/file_gc.clj

@@ -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.tasks.file-gc
+  "A maintenance task that is responsible of: purge unused file media,
+  clean unused object thumbnails and remove old file thumbnails.  The
+  file is eligible to be garbage collected after some period of
+  inactivity (the default threshold is 72h)."
+  (:require
+   [app.common.data :as d]
+   [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]
+   [app.util.time :as dt]
+   [clojure.set :as set]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [integrant.core :as ig]))
+
+(declare ^:private retrieve-candidates)
+(declare ^:private process-file)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HANDLER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(s/def ::max-age ::dt/duration)
+
+(defmethod ig/pre-init-spec ::handler [_]
+  (s/keys :req-un [::db/pool ::max-age]))
+
+(defmethod ig/init-key ::handler
+  [_ {:keys [pool] :as cfg}]
+  (fn [_]
+    (db/with-atomic [conn pool]
+      (let [cfg (assoc cfg :conn conn)]
+        (loop [total 0
+               files (retrieve-candidates cfg)]
+          (if-let [file (first files)]
+            (do
+              (process-file cfg file)
+              (recur (inc total)
+                     (rest files)))
+            (do
+              (l/debug :msg "finished processing files" :processed total)
+              {:processed total})))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; IMPL
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^:private
+  sql:retrieve-candidates-chunk
+  "select f.id,
+          f.data,
+          f.revn,
+          f.modified_at
+     from file as f
+    where f.has_media_trimmed is false
+      and f.modified_at < now() - ?::interval
+      and f.modified_at < ?
+    order by f.modified_at desc
+    limit 1
+    for update skip locked")
+
+(defn- retrieve-candidates
+  [{:keys [conn max-age] :as cfg}]
+  (let [interval (db/interval max-age)
+
+        get-chunk
+        (fn [cursor]
+          (let [rows (db/exec! conn [sql:retrieve-candidates-chunk interval cursor])]
+            [(some->> rows peek :modified-at) (seq rows)]))]
+
+    (sequence cat (d/iteration get-chunk
+                               :vf second
+                               :kf first
+                               :initk (dt/now)))))
+
+(defn- collect-used-media
+  [data]
+  (let [xform (comp
+               (map :objects)
+               (mapcat vals)
+               (keep (fn [{:keys [type] :as obj}]
+                       (case type
+                         :path (get-in obj [:fill-image :id])
+                         :image (get-in obj [:metadata :id])
+                         nil))))
+        pages (concat
+               (vals (:pages-index data))
+               (vals (:components data)))]
+    (-> #{}
+        (into xform pages)
+        (into (keys (:media data))))))
+
+(defn- clean-file-media!
+  "Performs the garbage collection of file media objects."
+  [conn file-id data]
+  (let [used   (collect-used-media data)
+        unused (->> (db/query conn :file-media-object {:file-id file-id})
+                    (remove #(contains? used (:id %))))]
+
+    (doseq [mobj unused]
+      (l/debug :hint "delete file 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)}))))
+
+(defn- clean-file-frame-thumbnails!
+  [conn file-id data]
+  (let [stored (->> (db/query conn :file-object-thumbnail
+                              {:file-id file-id}
+                              {:columns [:object-id]})
+                    (into #{} (map :object-id)))
+
+        get-objects-ids
+        (fn [{:keys [id objects]}]
+          (->> (cph/get-frames objects)
+               (map #(str id (:id %)))))
+
+        using (into #{}
+                    (mapcat get-objects-ids)
+                    (vals (:pages-index data)))
+
+        unused (set/difference stored using)]
+
+    (when (seq unused)
+      (let [sql (str/concat
+                 "delete from file_object_thumbnail "
+                 " where file_id=? and object_id=ANY(?)")
+            res (db/exec-one! conn [sql file-id (db/create-array conn "text" unused)])]
+        (l/debug :hint "delete object thumbnails" :total (:next.jdbc/update-count res))))))
+
+(defn- clean-file-thumbnails!
+  [conn file-id revn]
+  (let [sql (str "delete from file_thumbnail "
+                 " where file_id=? and revn < ?")
+        res (db/exec-one! conn [sql file-id revn])]
+    (l/debug :hint "delete file thumbnails" :total (:next.jdbc/update-count res))))
+
+(defn- process-file
+  [{:keys [conn] :as cfg} {:keys [id data revn modified-at] :as file}]
+  (l/debug :hint "processing file" :id id :modified-at modified-at)
+
+  (let [data (-> (blob/decode data)
+                 (assoc :id id)
+                 (pmg/migrate-data))]
+
+    (clean-file-media! conn id data)
+    (clean-file-frame-thumbnails! conn id data)
+    (clean-file-thumbnails! conn id revn)
+
+    ;; Mark file as trimmed
+    (db/update! conn :file
+                  {:has-media-trimmed true}
+                  {:id id})
+    nil))

backend/src/app/tasks/file_media_gc.clj

@@ -1,139 +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.tasks.file-media-gc
-  "A maintenance task that is responsible to purge the unused media
-  objects from files. A file is eligible to be garbage collected
-  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]
-   [app.util.time :as dt]
-   [clojure.spec.alpha :as s]
-   [integrant.core :as ig]))
-
-(declare process-file)
-(declare retrieve-candidates)
-
-(s/def ::max-age ::dt/duration)
-
-(defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::db/pool ::max-age]))
-
-(defmethod ig/init-key ::handler
-  [_ {:keys [pool] :as cfg}]
-  (fn [_]
-    (db/with-atomic [conn pool]
-      (let [cfg (assoc cfg :conn conn)]
-        (loop [n 0]
-          (let [files (retrieve-candidates cfg)]
-            (if (seq files)
-              (do
-                (run! (partial process-file cfg) files)
-                (recur (+ n (count files))))
-              (do
-                (l/debug :msg "finished processing files" :processed n)
-                {:processed n}))))))))
-
-(def ^:private
-  sql:retrieve-candidates-chunk
-  "select f.id,
-          f.data,
-          extract(epoch from (now() - f.modified_at))::bigint as age
-     from file as f
-    where f.has_media_trimmed is false
-      and f.modified_at < now() - ?::interval
-    order by f.modified_at asc
-    limit 10
-    for update skip locked")
-
-
-(defn- retrieve-candidates
-  [{:keys [conn max-age] :as cfg}]
-  (let [interval (db/interval max-age)]
-    (->> (db/exec! conn [sql:retrieve-candidates-chunk interval])
-         (mapv (fn [{:keys [age] :as row}]
-                 (assoc row :age (dt/duration {:seconds age})))))))
-
-(def ^:private
-  collect-media-xf
-  (comp
-   (map :objects)
-   (mapcat vals)
-   (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]
-  (let [pages (concat
-               (vals (:pages-index data))
-               (vals (:components data)))]
-  (-> #{}
-      (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 [used   (collect-used-media data)
-          unused (->> (db/query conn :file-media-object {:file-id id})
-                      (remove #(contains? used (:id %))))]
-
-      (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})
-
-      (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)})))
-
-    (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/objects_gc.clj

@@ -9,10 +9,9 @@
   of deleted objects."
   (:require
    [app.common.logging :as l]
-   [app.config :as cf]
    [app.db :as db]
+   [app.media :as media]
    [app.storage :as sto]
-   [app.storage.impl :as simpl]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
@@ -52,20 +51,15 @@
 
     (count result)))
 
-
 ;; --- IMPL: file deletion
 
 (defmethod delete-objects "file"
-  [{:keys [conn max-age table storage] :as cfg}]
-  (let [sql     (str/fmt sql:delete-objects
-                         {:table table :limit 50})
-        result  (db/exec! conn [sql max-age])
-        backend (simpl/resolve-backend storage (cf/get :fdata-storage-backend))]
+  [{:keys [conn max-age table] :as cfg}]
+  (let [sql    (str/fmt sql:delete-objects {:table table :limit 50})
+        result (db/exec! conn [sql max-age])]
 
     (doseq [{:keys [id] :as item} result]
-      (l/trace :hint "delete object" :table table :id id)
-      (when backend
-        (simpl/del-object backend item)))
+      (l/trace :hint "delete object" :table table :id id))
 
     (count result)))
 
@@ -76,13 +70,13 @@
   (let [sql     (str/fmt sql:delete-objects
                          {:table table :limit 50})
         fonts   (db/exec! conn [sql max-age])
-        storage (assoc storage :conn conn)]
+        storage (media/configure-assets-storage storage conn)]
     (doseq [{:keys [id] :as font} fonts]
       (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))
-      (some->> (:ttf-file-id font)   (sto/del-object storage)))
+      (some->> (:woff1-file-id font) (sto/touch-object! storage) deref)
+      (some->> (:woff2-file-id font) (sto/touch-object! storage) deref)
+      (some->> (:otf-file-id font)   (sto/touch-object! storage) deref)
+      (some->> (:ttf-file-id font)   (sto/touch-object! storage) deref))
     (count fonts)))
 
 ;; --- IMPL: team deletion
@@ -96,7 +90,7 @@
 
     (doseq [{:keys [id] :as team} teams]
       (l/trace :hint "delete object" :table table :id id)
-      (some->> (:photo-id team) (sto/del-object storage)))
+      (some->> (:photo-id team) (sto/touch-object! storage) deref))
 
     (count teams)))
 
@@ -135,7 +129,7 @@
 
       ;; Mark as deleted the storage object related with the photo-id
       ;; field.
-      (some->> (:photo-id profile) (sto/del-object storage))
+      (some->> (:photo-id profile) (sto/touch-object! storage) deref)
 
       ;; And finally, permanently delete the profile.
       (db/delete! conn :profile {:id id}))

backend/src/app/tasks/telemetry.clj

@@ -12,10 +12,9 @@
    [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
-   [app.config :as cfg]
+   [app.config :as cf]
    [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]))
@@ -26,7 +25,9 @@
 
 (declare get-stats)
 (declare send!)
+(declare get-subscriptions)
 
+(s/def ::http-client fn?)
 (s/def ::version ::us/string)
 (s/def ::uri ::us/string)
 (s/def ::instance-id ::us/uuid)
@@ -34,38 +35,67 @@
   (s/keys :req-un [::instance-id]))
 
 (defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::db/pool ::version ::uri ::sprops]))
+  (s/keys :req-un [::db/pool ::http-client ::version ::uri ::sprops]))
 
 (defmethod ig/init-key ::handler
   [_ {:keys [pool sprops version] :as cfg}]
-  (fn [{:keys [send?] :or {send? true}}]
-    ;; Sleep randomly between 0 to 10s
-    (when send?
-      (thread-sleep (rand-int 10000)))
+  (fn [{:keys [send? enabled?] :or {send? true enabled? false}}]
+    (let [subs     (get-subscriptions pool)
+          enabled? (or enabled?
+                       (contains? cf/flags :telemetry)
+                       (cf/get :telemetry-enabled))
 
-    (let [instance-id (:instance-id sprops)
-          stats       (-> (get-stats pool version)
-                          (assoc :instance-id instance-id))]
-      (when send?
-        (send! stats cfg))
-      stats)))
+          data     {:subscriptions subs
+                    :version version
+                    :instance-id (:instance-id sprops)}]
+      (cond
+        ;; If we have telemetry enabled, then proceed the normal
+        ;; operation.
+        enabled?
+        (let [data (merge data (get-stats pool))]
+          (when send?
+            (thread-sleep (rand-int 10000))
+            (send! cfg data))
+          data)
+
+        ;; If we have telemetry disabled, but there are users that are
+        ;; explicitly checked the newsletter subscription on the
+        ;; onboarding dialog or the profile section, then proceed to
+        ;; send a limited telemetry data, that consists in the list of
+        ;; subscribed emails and the running penpot version.
+        (seq subs)
+        (do
+          (when send?
+            (thread-sleep (rand-int 10000))
+            (send! cfg data))
+          data)
+
+        :else
+        data))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; IMPL
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defn- send!
-  [data cfg]
-  (let [response (http/send! {:method :post
-                              :uri (:uri cfg)
-                              :headers {"content-type" "application/json"}
-                              :body (json/write-str data)})]
+  [{:keys [http-client uri] :as cfg} data]
+  (let [response (http-client {:method :post
+                               :uri uri
+                               :headers {"content-type" "application/json"}
+                               :body (json/write-str data)}
+                               {:sync? true})]
     (when (> (:status response) 206)
       (ex/raise :type :internal
                 :code :invalid-response
                 :response-status (:status response)
                 :response-body (:body response)))))
 
+(defn- get-subscriptions
+  [conn]
+  (let [sql "select email from profile where props->>'~:newsletter-subscribed' = 'true'"]
+    (->> (db/exec! conn [sql])
+         (mapv :email))))
+
 (defn- retrieve-num-teams
   [conn]
   (-> (db/exec-one! conn ["select count(*) as count from team;"]) :count))
@@ -164,12 +194,11 @@
      :user-tz          (System/getProperty "user.timezone")}))
 
 (defn get-stats
-  [conn version]
-  (let [referer (if (cfg/get :telemetry-with-taiga)
+  [conn]
+  (let [referer (if (cf/get :telemetry-with-taiga)
                   "taiga"
-                  (cfg/get :telemetry-referer))]
-    (-> {:version        version
-         :referer        referer
+                  (cf/get :telemetry-referer))]
+    (-> {:referer        referer
          :total-teams    (retrieve-num-teams conn)
          :total-projects (retrieve-num-projects conn)
          :total-files    (retrieve-num-files conn)

backend/src/app/util/async.clj

@@ -7,8 +7,7 @@
 (ns app.util.async
   (:require
    [clojure.core.async :as a]
-   [clojure.spec.alpha :as s]
-   [promesa.exec :as px])
+   [clojure.spec.alpha :as s])
   (:import
    java.util.concurrent.Executor))
 
@@ -39,6 +38,13 @@
        (throw r#)
        r#)))
 
+(defmacro with-closing
+  [ch & body]
+  `(try
+     ~@body
+     (finally
+       (some-> ~ch a/close!))))
+
 (defn thread-call
   [^Executor executor f]
   (let [c (a/chan 1)]
@@ -61,10 +67,6 @@
     `(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/fressian.clj

@@ -203,7 +203,7 @@
        (Instant/ofEpochMilli (.readInt rdr))))
 
 
-   "clj/ratio"
+   "ratio"
    (reify ReadHandler
      (read [_ rdr _ _]
        (Ratio. (biginteger (.readObject rdr))

backend/src/app/util/http.clj

@@ -1,27 +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.http
-  "Http client abstraction layer."
-  (:require
-   [java-http-clj.core :as http]
-   [promesa.exec :as px]))
-
-(def default-client
-  (delay (http/build-client {:executor @px/default-executor
-                             :connect-timeout 10000 ;; 10s
-                             :follow-redirects :always})))
-
-(defn get!
-  [url opts]
-  (let [opts' (merge {:client @default-client :as :string} opts)]
-    (http/get url nil opts')))
-
-(defn send!
-  ([req]
-   (http/send req {:client @default-client :as :string}))
-  ([req opts]
-   (http/send req (merge {:client @default-client :as :string} opts))))

backend/src/app/util/websocket.clj

@@ -13,11 +13,10 @@
    [app.metrics :as mtx]
    [app.util.time :as dt]
    [clojure.core.async :as a]
+   [yetti.util :as yu]
    [yetti.websocket :as yws])
   (:import
-   java.nio.ByteBuffer
-   org.eclipse.jetty.io.EofException))
-
+   java.nio.ByteBuffer))
 
 (declare decode-beat)
 (declare encode-beat)
@@ -49,20 +48,28 @@
                          output-buff-size 64
                          idle-timeout 30000}
                     :as options}]
-   (fn [_]
+   (fn [{:keys [::yws/channel] :as request}]
      (let [input-ch   (a/chan input-buff-size)
            output-ch  (a/chan output-buff-size)
            pong-ch    (a/chan (a/sliding-buffer 6))
            close-ch   (a/chan)
-           options    (-> options
-                          (assoc ::input-ch input-ch)
-                          (assoc ::output-ch output-ch)
-                          (assoc ::close-ch close-ch)
-                          (dissoc ::metrics))
+
+           options    (atom
+                       (-> options
+                           (assoc ::input-ch input-ch)
+                           (assoc ::output-ch output-ch)
+                           (assoc ::close-ch close-ch)
+                           (assoc ::channel channel)
+                           (dissoc ::metrics)))
 
            terminated (atom false)
            created-at (dt/now)
 
+           on-open
+           (fn [channel]
+             (mtx/run! metrics {:id :websocket-active-connections :inc 1})
+             (yws/idle-timeout! channel (dt/duration idle-timeout)))
+
            on-terminate
            (fn [& _args]
              (when (compare-and-set! terminated false true)
@@ -77,36 +84,14 @@
            on-error
            (fn [_ error]
              (on-terminate)
-             (when-not (or (instance? org.eclipse.jetty.websocket.api.exceptions.WebSocketTimeoutException error)
-                           (instance? java.nio.channels.ClosedChannelException error))
+             ;; TODO: properly log timeout exceptions
+             (when-not (or (instance? java.nio.channels.ClosedChannelException error)
+                           (instance? java.net.SocketException error))
                (l/error :hint (ex-message error) :cause error)))
 
-           on-connect
-           (fn [conn]
-             (mtx/run! metrics {:id :websocket-active-connections :inc 1})
-
-             (let [wsp (atom (assoc options ::conn conn))]
-               ;; Handle heartbeat
-               (yws/idle-timeout! conn (dt/duration idle-timeout))
-               (-> @wsp
-                   (assoc ::pong-ch pong-ch)
-                   (assoc ::on-close on-terminate)
-                   (process-heartbeat))
-
-               ;; Forward all messages from output-ch to the websocket
-               ;; connection
-               (a/go-loop []
-                 (when-let [val (a/<! output-ch)]
-                   (mtx/run! metrics {:id :websocket-messages-total :labels ["send"] :inc 1})
-                   (a/<! (ws-send! conn (t/encode-str val)))
-                   (recur)))
-
-               ;; React on messages received from the client
-               (process-input wsp handle-message)))
-
            on-message
            (fn [_ message]
-             (mtx/run! metrics {:id :websocket-messages-total :labels ["send"] :inc 1})
+             (mtx/run! metrics {:id :websocket-messages-total :labels ["recv"] :inc 1})
              (try
                (let [message (t/decode-str message)]
                  (a/offer! input-ch message))
@@ -117,35 +102,52 @@
                  (on-terminate))))
 
            on-pong
-           (fn [_ buffer]
-             (a/>!! pong-ch buffer))]
+           (fn [_ buffers]
+             (a/>!! pong-ch (yu/copy-many buffers)))]
 
-       {:on-connect on-connect
+       ;; launch heartbeat process
+       (-> @options
+           (assoc ::pong-ch pong-ch)
+           (assoc ::on-close on-terminate)
+           (process-heartbeat))
+
+       ;; Forward all messages from output-ch to the websocket
+       ;; connection
+       (a/go-loop []
+         (when-let [val (a/<! output-ch)]
+           (mtx/run! metrics {:id :websocket-messages-total :labels ["send"] :inc 1})
+           (a/<! (ws-send! channel (t/encode-str val)))
+           (recur)))
+
+       ;; React on messages received from the client
+       (process-input options handle-message)
+
+       {:on-open on-open
         :on-error on-error
         :on-close on-terminate
         :on-text on-message
         :on-pong on-pong}))))
 
 (defn- ws-send!
-  [conn s]
+  [channel s]
   (let [ch (a/chan 1)]
     (try
-      (yws/send! conn s (fn [e]
-                          (when e (a/offer! ch e))
-                          (a/close! ch)))
-      (catch EofException cause
+      (yws/send! channel s (fn [e]
+                             (when e (a/offer! ch e))
+                             (a/close! ch)))
+      (catch java.io.IOException cause
         (a/offer! ch cause)
         (a/close! ch)))
     ch))
 
 (defn- ws-ping!
-  [conn s]
+  [channel s]
   (let [ch (a/chan 1)]
     (try
-      (yws/ping! conn s (fn [e]
+      (yws/ping! channel s (fn [e]
                           (when e (a/offer! ch e))
                           (a/close! ch)))
-      (catch EofException cause
+      (catch java.io.IOException cause
         (a/offer! ch cause)
         (a/close! ch)))
     ch))
@@ -162,14 +164,21 @@
     (.rewind buffer)
     (.getLong buffer)))
 
+(defn- wrap-handler
+  [handler]
+  (fn [wsp message]
+    (locking wsp
+      (handler wsp message))))
+
 (defn- process-input
   [wsp handler]
-  (let [{:keys [::input-ch ::output-ch ::close-ch]} @wsp]
+  (let [{:keys [::input-ch ::output-ch ::close-ch]} @wsp
+        handler (wrap-handler handler)]
     (a/go
       (a/<! (handler wsp {:type :connect}))
       (a/<! (a/go-loop []
-              (when-let [request (a/<! input-ch)]
-                (let [[val port] (a/alts! [(handler wsp request) close-ch])]
+              (when-let [message (a/<! input-ch)]
+                (let [[val port] (a/alts! [(handler wsp message) close-ch])]
                   (when-not (= port close-ch)
                     (cond
                       (ex/ex-info? val)
@@ -179,25 +188,24 @@
                       (a/>! output-ch {:type :error :error {:message (ex-message val)}})
 
                       (map? val)
-                      (a/>! output-ch (cond-> val (:request-id request) (assoc :request-id (:request-id request)))))
-
+                      (a/>! output-ch (cond-> val (:request-id message) (assoc :request-id (:request-id message)))))
                     (recur))))))
       (a/<! (handler wsp {:type :disconnect})))))
 
 (defn- process-heartbeat
-  [{:keys [::conn ::close-ch ::on-close ::pong-ch
+  [{:keys [::channel ::close-ch ::on-close ::pong-ch
            ::heartbeat-interval ::max-missed-heartbeats]
     :or {heartbeat-interval 2000
          max-missed-heartbeats 4}}]
   (let [beats (atom #{})]
     (a/go-loop [i 0]
       (let [[_ port] (a/alts! [close-ch (a/timeout heartbeat-interval)])]
-        (when (and (yws/connected? conn)
+        (when (and (yws/connected? channel)
                    (not= port close-ch))
-          (a/<! (ws-ping! conn (encode-beat i)))
+          (a/<! (ws-ping! channel (encode-beat i)))
           (let [issued (swap! beats conj (long i))]
             (if (>= (count issued) max-missed-heartbeats)
-              (on-close conn -1 "heartbeat-timeout")
+              (on-close channel -1 "heartbeat-timeout")
               (recur (inc i)))))))
 
     (a/go-loop []

backend/src/app/worker.clj

@@ -23,47 +23,77 @@
    [promesa.exec :as px])
   (:import
    java.util.concurrent.ExecutorService
+   java.util.concurrent.Executors
    java.util.concurrent.ForkJoinPool
-   java.util.concurrent.ForkJoinWorkerThread
+   java.util.concurrent.Future
    java.util.concurrent.ForkJoinPool$ForkJoinWorkerThreadFactory
-   java.util.concurrent.atomic.AtomicLong
-   java.util.concurrent.Executors))
+   java.util.concurrent.ForkJoinWorkerThread
+   java.util.concurrent.ScheduledExecutorService
+   java.util.concurrent.ThreadFactory
+   java.util.concurrent.atomic.AtomicLong))
 
 (set! *warn-on-reflection* true)
 
 (s/def ::executor #(instance? ExecutorService %))
+(s/def ::scheduler #(instance? ScheduledExecutorService %))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Executor
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(declare ^:private get-fj-thread-factory)
+(declare ^:private get-thread-factory)
+
 (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 [::prefix ::parallelism]))
+  (s/keys :req-un [::prefix]
+          :opt-un [::parallelism]))
 
-(defn- get-thread-factory
+(defmethod ig/init-key ::executor
+  [_ {:keys [parallelism prefix]}]
+  (let [counter  (AtomicLong. 0)]
+    (if parallelism
+      (ForkJoinPool. (int parallelism) (get-fj-thread-factory prefix counter) nil false)
+      (Executors/newCachedThreadPool (get-thread-factory prefix counter)))))
+
+(defmethod ig/halt-key! ::executor
+  [_ instance]
+  (.shutdown ^ExecutorService instance))
+
+(defmethod ig/pre-init-spec ::scheduler [_]
+  (s/keys :req-un [::prefix]
+          :opt-un [::parallelism]))
+
+(defmethod ig/init-key ::scheduler
+  [_ {:keys [parallelism prefix] :or {parallelism 1}}]
+  (let [counter (AtomicLong. 0)]
+    (px/scheduled-pool parallelism (get-thread-factory prefix counter))))
+
+(defmethod ig/halt-key! ::scheduler
+  [_ instance]
+  (.shutdown ^ExecutorService instance))
+
+(defn- get-fj-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))]
+            ^String thread-name (str "penpot/" (name prefix) "-" (.getAndIncrement ^AtomicLong counter))]
         (.setName thread thread-name)
         thread))))
 
-(defmethod ig/init-key ::executor
-  [_ {:keys [parallelism prefix]}]
-  (let [counter (AtomicLong. 0)]
-    (ForkJoinPool. (int parallelism) (get-thread-factory prefix counter) nil false)))
-
-(defmethod ig/halt-key! ::executor
-  [_ instance]
-  (.shutdown ^ForkJoinPool instance))
+(defn- get-thread-factory
+  ^ThreadFactory
+  [prefix counter]
+  (reify ThreadFactory
+    (newThread [_ runnable]
+      (doto (Thread. runnable)
+        (.setDaemon true)
+        (.setName (str "penpot/" (name prefix) "-" (.getAndIncrement ^AtomicLong counter)))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Executor Monitor
@@ -72,16 +102,16 @@
 (s/def ::executors (s/map-of keyword? ::executor))
 
 (defmethod ig/pre-init-spec ::executors-monitor [_]
-  (s/keys :req-un [::executors ::mtx/metrics]))
+  (s/keys :req-un [::executors ::scheduler ::mtx/metrics]))
 
 (defmethod ig/init-key ::executors-monitor
-  [_ {:keys [executors metrics interval] :or {interval 3000}}]
-  (letfn [(log-stats [scheduler state]
+  [_ {:keys [executors metrics interval scheduler] :or {interval 3000}}]
+  (letfn [(log-stats [state]
             (doseq [[key ^ForkJoinPool executor] executors]
               (let [labels  (into-array String [(name key)])
-                    active  (.getActiveThreadCount executor)
                     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)]
@@ -97,18 +127,17 @@
                        :queued queued
                        :steals steals)))
 
-            (when-not (.isShutdown scheduler)
-              (px/schedule! scheduler interval (partial log-stats scheduler state))))]
+            (when (and (not (.isShutdown scheduler))
+                       (not (:shutdown @state)))
+              (px/schedule! scheduler interval (partial log-stats state))))]
 
-    (let [scheduler (px/scheduled-pool 1)
-          state     (atom {})]
-      (px/schedule! scheduler interval (partial log-stats scheduler state))
-      {::scheduler scheduler
-       ::state state})))
+    (let [state (atom {})]
+      (px/schedule! scheduler interval (partial log-stats state))
+      {:state state})))
 
 (defmethod ig/halt-key! ::executors-monitor
-  [_ {:keys [::scheduler]}]
-  (.shutdown ^ExecutorService scheduler))
+  [_ {:keys [state]}]
+  (swap! state assoc :shutdown true))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Worker
@@ -252,7 +281,6 @@
     (db/exec-one! conn [sql:insert-new-task id (d/name task) props (d/name queue) priority max-retries interval])
     id))
 
-
 ;; --- RUNNER
 
 (def ^:private
@@ -392,13 +420,12 @@
   [{:keys [executor] :as cfg}]
   (aa/thread-call executor #(event-loop-fn* cfg)))
 
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Scheduler
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(declare schedule-task)
-(declare synchronize-schedule)
+(declare schedule-cron-task)
+(declare synchronize-cron-entries)
 
 (s/def ::fn (s/or :var var? :fn fn?))
 (s/def ::id keyword?)
@@ -406,79 +433,85 @@
 (s/def ::props (s/nilable map?))
 (s/def ::task keyword?)
 
-(s/def ::scheduled-task
+(s/def ::cron-task
   (s/keys :req-un [::cron ::task]
           :opt-un [::props ::id]))
 
-(s/def ::schedule (s/coll-of (s/nilable ::scheduled-task)))
+(s/def ::entries (s/coll-of (s/nilable ::cron-task)))
 
-(defmethod ig/pre-init-spec ::scheduler [_]
-  (s/keys :req-un [::executor ::db/pool ::schedule ::tasks]))
+(defmethod ig/pre-init-spec ::cron [_]
+  (s/keys :req-un [::executor ::scheduler ::db/pool ::entries ::tasks]))
 
-(defmethod ig/init-key ::scheduler
-  [_ {: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))
+(defmethod ig/init-key ::cron
+  [_ {:keys [entries tasks pool] :as cfg}]
+  (if (db/read-only? pool)
+    (l/warn :hint "scheduler not started, db is read-only")
+    (let [running (atom #{})
+          entries (->> entries
+                       (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))))))
 
-        (synchronize-schedule cfg)
-        (run! (partial schedule-task cfg)
-              (filter some? schedule))))
+          cfg     (assoc cfg :entries entries :running running)]
 
-    (reify
-      java.lang.AutoCloseable
-      (close [_]
-        (.shutdownNow ^ExecutorService scheduler)))))
+        (l/info :hint "cron started" :registred-tasks (count entries))
+        (synchronize-cron-entries cfg)
 
-(defmethod ig/halt-key! ::scheduler
+        (->> (filter some? entries)
+             (run! (partial schedule-cron-task cfg)))
+
+        (reify
+          clojure.lang.IDeref
+          (deref [_] @running)
+
+          java.lang.AutoCloseable
+          (close [_]
+            (doseq [item @running]
+              (when-not (.isDone ^Future item)
+                (.cancel ^Future item true))))))))
+
+
+(defmethod ig/halt-key! ::cron
   [_ instance]
-  (.close ^java.lang.AutoCloseable instance))
+  (when instance
+    (.close ^java.lang.AutoCloseable instance)))
 
-(def sql:upsert-scheduled-task
+(def sql:upsert-cron-task
   "insert into scheduled_task (id, cron_expr)
    values (?, ?)
        on conflict (id)
        do update set cron_expr=?")
 
-(defn- synchronize-schedule-item
+(defn- synchronize-cron-item
   [conn {:keys [id cron]}]
   (let [cron (str cron)]
     (l/debug :action "initialize scheduled task" :id id :cron cron)
-    (db/exec-one! conn [sql:upsert-scheduled-task id cron cron])))
+    (db/exec-one! conn [sql:upsert-cron-task id cron cron])))
 
-(defn- synchronize-schedule
+(defn- synchronize-cron-entries
   [{:keys [pool schedule]}]
   (db/with-atomic [conn pool]
-    (run! (partial synchronize-schedule-item conn) schedule)))
+    (run! (partial synchronize-cron-item conn) schedule)))
 
-(def sql:lock-scheduled-task
+(def sql:lock-cron-task
   "select id from scheduled_task where id=? for update skip locked")
 
-(defn- execute-scheduled-task
+(defn- execute-cron-task
   [{:keys [executor pool] :as cfg} {:keys [id] :as task}]
   (letfn [(run-task [conn]
-            (when (db/exec-one! conn [sql:lock-scheduled-task (d/name id)])
+            (when (db/exec-one! conn [sql:lock-cron-task (d/name id)])
               (l/debug :action "execute scheduled task" :id id)
               ((:fn task) task)))
 
@@ -491,10 +524,10 @@
                          ::l/context (get-error-context cause task)
                          :task-id id
                          :cause cause))))]
-    (try
+
       (px/run! executor handle-task)
-      (finally
-        (schedule-task cfg task)))))
+      (px/run! executor #(schedule-cron-task cfg task))
+      nil))
 
 (defn- ms-until-valid
   [cron]
@@ -503,10 +536,16 @@
         next (dt/next-valid-instant-from cron now)]
     (inst-ms (dt/diff now next))))
 
-(defn- schedule-task
-  [{:keys [scheduler] :as cfg} {:keys [cron] :as task}]
-  (let [ms (ms-until-valid cron)]
-    (px/schedule! scheduler ms (partial execute-scheduled-task cfg task))))
+(def ^:private
+  xf-without-done
+  (remove #(.isDone ^Future %)))
+
+(defn- schedule-cron-task
+  [{:keys [scheduler running] :as cfg} {:keys [cron] :as task}]
+  (let [ft (px/schedule! scheduler
+                         (ms-until-valid cron)
+                         (partial execute-cron-task cfg task))]
+    (swap! running #(into #{ft} xf-without-done %))))
 
 ;; --- INSTRUMENTATION
 

backend/test/app/services_files_test.clj

@@ -8,6 +8,7 @@
   (:require
    [app.common.uuid :as uuid]
    [app.db :as db]
+   [app.db.sql :as sql]
    [app.http :as http]
    [app.storage :as sto]
    [app.test-helpers :as th]
@@ -117,11 +118,11 @@
           (t/is (= 0 (count result))))))
     ))
 
-(t/deftest file-media-gc-task
+(t/deftest file-gc-task
   (letfn [(create-file-media-object [{:keys [profile-id file-id]}]
             (let [mfile  {:filename "sample.jpg"
-                          :tempfile (th/tempfile "app/test_files/sample.jpg")
-                          :content-type "image/jpeg"
+                          :path (th/tempfile "app/test_files/sample.jpg")
+                          :mtype "image/jpeg"
                           :size 312043}
                   params {::th/type :upload-file-media-object
                           :profile-id profile-id
@@ -130,6 +131,9 @@
                           :name "testfile"
                           :content mfile}
                   out    (th/mutation! params)]
+
+              ;; (th/print-result! out)
+
               (t/is (nil? (:error out)))
               (:result out)))
 
@@ -174,16 +178,22 @@
                             :type :image
                             :metadata {:id (:id fmo1)}}}]})]
 
+      ;; Check that reference storage objets on filemediaobjects
+      ;; are the same because of deduplication feature.
+      (t/is (= (:media-id fmo1) (:media-id fmo2)))
+      (t/is (= (:thumbnail-id fmo1) (:thumbnail-id fmo2)))
 
-
-      ;; If we launch gc-touched-task, we should have 4 items to freeze.
+      ;; If we launch gc-touched-task, we should have 2 items to
+      ;; freeze because of the deduplication (we have uploaded 2 times
+      ;; 2 two same files).
       (let [task (:app.storage/gc-touched-task th/*system*)
             res  (task {})]
-        (t/is (= 4 (:freeze res)))
+
+        (t/is (= 2 (:freeze res)))
         (t/is (= 0 (:delete res))))
 
       ;; run the task immediately
-      (let [task  (:app.tasks.file-media-gc/handler th/*system*)
+      (let [task  (:app.tasks.file-gc/handler th/*system*)
             res   (task {})]
         (t/is (= 0 (:processed res))))
 
@@ -192,7 +202,7 @@
       (th/sleep 300)
 
       ;; run the task again
-      (let [task  (:app.tasks.file-media-gc/handler th/*system*)
+      (let [task  (:app.tasks.file-gc/handler th/*system*)
             res   (task {})]
         (t/is (= 1 (:processed res))))
 
@@ -205,27 +215,26 @@
         (t/is (= 1 (count rows))))
 
       ;; The underlying storage objects are still available.
-      (t/is (some? (sto/get-object storage (:media-id fmo2))))
-      (t/is (some? (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))))
+      (t/is (some? @(sto/get-object storage (:media-id fmo2))))
+      (t/is (some? @(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))))
 
       ;; 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 (:freeze res)))
+        (t/is (= 0 (:delete res))))
 
       ;; 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))))
+      (t/is (some? @(sto/get-object storage (:media-id fmo2))))
+      (t/is (some? @(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))))
 
       )))
 
@@ -337,7 +346,7 @@
       (t/is (th/ex-info? error))
       (t/is (th/ex-of-type? error :not-found))))
 
-(t/deftest deletion-test
+(t/deftest deletion
   (let [task     (:app.tasks.objects-gc/handler th/*system*)
         profile1 (th/create-profile* 1)
         file     (th/create-file* 1 {:project-id (:default-project-id profile1)
@@ -404,72 +413,301 @@
         (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
+(t/deftest object-thumbnails-ops
   (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
+        page-id   (get-in file [:data :pages 0])
+        frame1-id (uuid/next)
+        shape1-id (uuid/next)
+        frame2-id (uuid/next)
+        shape2-id (uuid/next)
+
+        changes   [{:type :add-obj
+                   :page-id page-id
+                   :id frame1-id
+                   :parent-id uuid/zero
+                   :frame-id uuid/zero
+                   :obj {:id frame1-id
+                         :use-for-thumbnail? true
+                         :name "test-frame1"
+                         :type :frame}}
+                  {:type :add-obj
+                   :page-id page-id
+                   :id shape1-id
+                   :parent-id frame1-id
+                   :frame-id frame1-id
+                   :obj {:id shape1-id
+                         :name "test-shape1"
+                         :type :rect}}
+                  {:type :add-obj
+                   :page-id page-id
+                   :id frame2-id
+                   :parent-id uuid/zero
+                   :frame-id uuid/zero
+                   :obj {:id frame2-id
+                         :name "test-frame2"
+                         :type :frame}}
+                  {:type :add-obj
+                   :page-id page-id
+                   :id shape2-id
+                   :parent-id frame2-id
+                   :frame-id frame2-id
+                   :obj {:id shape2-id
+                         :name "test-shape2"
+                         :type :rect}}]]
+    ;; Update the file
+    (th/update-file* {:file-id (:id file)
+                      :profile-id (:id prof)
+                      :revn 0
+                      :changes changes})
+
+    (t/testing "RPC page query (rendering purposes)"
+
+      ;; Query :page RPC method without passing page-id
+      (let [data {::th/type :page
+                  :profile-id (:id prof)
+                  :file-id (:id file)}
+            {:keys [error result] :as out} (th/query! data)]
+
+        ;; (th/print-result! out)
+        (t/is (map? result))
+        (t/is (contains? result :objects))
+        (t/is (contains? (:objects result) frame1-id))
+        (t/is (contains? (:objects result) shape1-id))
+        (t/is (contains? (:objects result) frame2-id))
+        (t/is (contains? (:objects result) shape2-id))
+        (t/is (contains? (:objects result) uuid/zero)))
+
+      ;; Query :page RPC method with page-id
+      (let [data {::th/type :page
+                  :profile-id (:id prof)
+                  :file-id (:id file)
+                  :page-id page-id}
+            {:keys [error result] :as out} (th/query! data)]
+        ;; (th/print-result! out)
+        (t/is (map? result))
+        (t/is (contains? result :objects))
+        (t/is (contains? (:objects result) frame1-id))
+        (t/is (contains? (:objects result) shape1-id))
+        (t/is (contains? (:objects result) frame2-id))
+        (t/is (contains? (:objects result) shape2-id))
+        (t/is (contains? (:objects result) uuid/zero)))
+
+      ;; Query :page RPC method with page-id and object-id
+      (let [data {::th/type :page
+                  :profile-id (:id prof)
+                  :file-id (:id file)
+                  :page-id page-id
+                  :object-id frame1-id}
+            {:keys [error result] :as out} (th/query! data)]
+        ;; (th/print-result! out)
+        (t/is (map? result))
+        (t/is (contains? result :objects))
+        (t/is (contains? (:objects result) frame1-id))
+        (t/is (contains? (:objects result) shape1-id))
+        (t/is (not (contains? (:objects result) uuid/zero)))
+        (t/is (not (contains? (:objects result) frame2-id)))
+        (t/is (not (contains? (:objects result) shape2-id))))
+
+      ;; Query :page RPC method with wrong params
+      (let [data {::th/type :page
+                  :profile-id (:id prof)
+                  :file-id (:id file)
+                  :object-id frame1-id}
+            {:keys [error result] :as out} (th/query! data)]
+        ;; (th/print-result! out)
+        (t/is (= :validation (th/ex-type error)))
+        (t/is (= :spec-validation (th/ex-code error)))))
+
+    (t/testing "RPC :file-data-for-thumbnail"
+      ;; Insert a thumbnail data for the frame-id
+      (let [data {::th/type :upsert-file-object-thumbnail
+                  :profile-id (:id prof)
+                  :file-id (:id file)
+                  :object-id (str page-id frame1-id)
+                  :data "random-data-1"}
+
+            {:keys [error result] :as out} (th/mutation! data)]
+        (t/is (nil? error))
+        (t/is (nil? result)))
+
+      ;; Check the result
+      (let [data {::th/type :file-data-for-thumbnail
+                  :profile-id (:id prof)
+                  :file-id (:id file)}
+            {:keys [error result] :as out} (th/query! data)]
+        ;; (th/print-result! out)
+        (t/is (map? result))
+        (t/is (contains? result :page))
+        (t/is (contains? result :revn))
+        (t/is (contains? result :file-id))
+
+        (t/is (= (:id file) (:file-id result)))
+        (t/is (= "random-data-1" (get-in result [:page :objects frame1-id :thumbnail])))
+        (t/is (= [] (get-in result [:page :objects frame1-id :shapes]))))
+
+      ;; Delete thumbnail data
+      (let [data {::th/type :upsert-file-object-thumbnail
+                  :profile-id (:id prof)
+                  :file-id (:id file)
+                  :object-id (str page-id frame1-id)
+                  :data nil}
+            {:keys [error result] :as out} (th/mutation! data)]
+        (t/is (nil? error))
+        (t/is (nil? result)))
+
+      ;; Check the result
+      (let [data {::th/type :file-data-for-thumbnail
+                  :profile-id (:id prof)
+                  :file-id (:id file)}
+            {:keys [error result] :as out} (th/query! data)]
+        ;; (th/print-result! out)
+        (t/is (map? result))
+        (t/is (contains? result :page))
+        (t/is (contains? result :revn))
+        (t/is (contains? result :file-id))
+        (t/is (= (:id file) (:file-id result)))
+        (t/is (nil? (get-in result [:page :objects frame1-id :thumbnail])))
+        (t/is (not= [] (get-in result [:page :objects frame1-id :shapes])))))
+
+    (t/testing "TASK :file-gc"
+
+      ;; insert object snapshot for known frame
+      (let [data {::th/type :upsert-file-object-thumbnail
+                  :profile-id (:id prof)
+                  :file-id (:id file)
+                  :object-id (str page-id frame1-id)
+                  :data "new-data"}
+            {:keys [error result] :as out} (th/mutation! data)]
+        (t/is (nil? error))
+        (t/is (nil? result)))
+
+      ;; Wait to file be ellegible for GC
+      (th/sleep 300)
+
+      ;; run the task again
+      (let [task  (:app.tasks.file-gc/handler th/*system*)
+            res   (task {})]
+        (t/is (= 1 (:processed res))))
+
+      ;; check that object thumbnails are still here
+      (let [res (th/db-exec! ["select * from file_object_thumbnail"])]
+        (t/is (= 1 (count res)))
+        (t/is (= "new-data" (get-in res [0 :data]))))
+
+      ;; insert object snapshot for for unknown frame
+      (let [data {::th/type :upsert-file-object-thumbnail
+                  :profile-id (:id prof)
+                  :file-id (:id file)
+                  :object-id (str page-id (uuid/next))
+                  :data "new-data-2"}
+            {:keys [error result] :as out} (th/mutation! data)]
+        (t/is (nil? error))
+        (t/is (nil? result)))
+
+      ;; Mark file as modified
+      (th/db-exec! ["update file set has_media_trimmed=false where id=?" (:id file)])
+
+      ;; check that we have all object thumbnails
+      (let [res (th/db-exec! ["select * from file_object_thumbnail"])]
+        (t/is (= 2 (count res))))
+
+      ;; run the task again
+      (let [task  (:app.tasks.file-gc/handler th/*system*)
+            res   (task {})]
+        (t/is (= 1 (:processed res))))
+
+      ;; check that the unknown frame thumbnail is deleted
+      (let [res (th/db-exec! ["select * from file_object_thumbnail"])]
+        (t/is (= 1 (count res)))
+        (t/is (= "new-data" (get-in res [0 :data])))))))
+
+
+(t/deftest file-thumbnail-ops
+  (let [prof (th/create-profile* 1 {:is-active true})
+        file (th/create-file* 1 {:profile-id (:id prof)
+                                 :project-id (:default-project-id prof)
+                                 :revn 2
+                                 :is-shared false})
+        data {::th/type :file-thumbnail
               :profile-id (:id prof)
-              :file-id (:id file)
-              :frame-id (uuid/next)
-              :data "updated value"}]
+              :file-id (:id file)}]
 
-    ;;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"])
+    (t/testing "query a thumbnail with single revn"
+
+      ;; insert an entry on the database with a test value for the thumbnail of this frame
+      (th/db-insert! :file-thumbnail
+                     {:file-id (:file-id data)
+                      :revn 1
+                      :data "testvalue1"})
+
+      (let [{:keys [result error] :as out} (th/query! data)]
+        ;; (th/print-result! out)
+        (t/is (nil? error))
+        (t/is (= 4 (count result)))
+        (t/is (= "testvalue1" (:data result)))
+        (t/is (= 1 (:revn result)))))
+
+    (t/testing "query thumbnail with two revisions"
+      ;; insert an entry on the database with a test value for the thumbnail of this frame
+      (th/db-insert! :file-thumbnail
+                     {:file-id (:file-id data)
+                      :revn 2
+                      :data "testvalue2"})
+
+      (let [{:keys [result error] :as out} (th/query! data)]
+        ;; (th/print-result! out)
+        (t/is (nil? error))
+        (t/is (= 4 (count result)))
+        (t/is (= "testvalue2" (:data result)))
+        (t/is (= 2 (:revn result))))
+
+      ;; Then query the specific revn
+      (let [{:keys [result error] :as out} (th/query! (assoc data :revn 1))]
+        ;; (th/print-result! out)
+        (t/is (nil? error))
+        (t/is (= 4 (count result)))
+        (t/is (= "testvalue1" (:data result)))
+        (t/is (= 1 (:revn result)))))
+
+    (t/testing "upsert file-thumbnail"
+      (let [data {::th/type :upsert-file-thumbnail
+                  :profile-id (:id prof)
+                  :file-id (:id file)
+                  :data "foobar"
+                  :props {:baz 1}
+                  :revn 2}
+            {:keys [result error] :as out} (th/mutation! data)]
+        ;; (th/print-result! out)
+        (t/is (nil? error))
+        (t/is (nil? result))))
+
+    (t/testing "query last result"
+      (let [{:keys [result error] :as out} (th/query! data)]
+        ;; (th/print-result! out)
+        (t/is (nil? error))
+        (t/is (= 4 (count result)))
+        (t/is (= "foobar" (:data result)))
+        (t/is (= {:baz 1} (:props result)))
+        (t/is (= 2 (:revn result)))))
+
+    (t/testing "gc task"
+      ;; make the file eligible for GC waiting 300ms (configured
+      ;; timeout for testing)
+      (th/sleep 300)
+
+      ;; run the task again
+      (let [task  (:app.tasks.file-gc/handler th/*system*)
+            res   (task {})]
+        (t/is (= 1 (:processed res))))
+
+      ;; Then query the specific revn
+      (let [{:keys [result error] :as out} (th/query! (assoc data :revn 1))]
+        (t/is (= :not-found (th/ex-type error)))
+        (t/is (= :file-thumbnail-not-found (th/ex-code error)))))
+    ))
 
-    (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

@@ -23,9 +23,9 @@
   (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"})
+        sobject @(sto/put-object! storage {::sto/content (sto/content "content")
+                                           :content-type "text/plain"
+                                           :other "data"})
         profile (th/create-profile* 1 {:is-active true})
         project (th/create-project* 1 {:team-id (:default-team-id profile)
                                        :profile-id (:id profile)})
@@ -92,15 +92,17 @@
 
         ))))
 
-(t/deftest duplicate-file-with-deleted-rels
+(t/deftest duplicate-file-with-deleted-relations
   (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"})
+        sobject @(sto/put-object! storage {::sto/content (sto/content "content")
+                                           :content-type "text/plain"
+                                           :other "data"})
         profile (th/create-profile* 1 {:is-active true})
+
         project (th/create-project* 1 {:team-id (:default-team-id profile)
                                        :profile-id (:id profile)})
+
         file1   (th/create-file* 1 {:profile-id (:id profile)
                                     :project-id (:id project)})
         file2   (th/create-file* 2 {:profile-id (:id profile)
@@ -112,16 +114,10 @@
 
         mobj    (th/create-file-media-object* {:file-id (:id file1)
                                                :is-local false
-                                               :media-id (:id sobject)})
+                                               :media-id (:id sobject)})]
 
-        _       (th/mark-file-deleted* {:id (:id file2)})
-        _       (sto/del-object storage (:id sobject))]
-
-    (th/update-file*
-     {:file-id (:id file1)
-      :profile-id (:id profile)
-      :changes [{:type :add-media
-                 :object (select-keys mobj [:id :width :height :mtype :name])}]})
+    (th/mark-file-deleted* {:id (:id file2)})
+    @(sto/del-object! storage sobject)
 
     (let [data {::th/type :duplicate-file
                 :profile-id (:id profile)
@@ -140,7 +136,7 @@
         (t/is (= "file 1 (copy)" (:name result)))
         (t/is (not= (:id file1) (:id result)))
 
-        ;; Check that the deleted library is not duplicated
+        ;; Check that there are no relation to a deleted library
         (let [[item :as rows] (db/query th/*pool* :file-library-rel {:file-id (:id result)})]
           (t/is (= 0 (count rows))))
 
@@ -158,9 +154,10 @@
   (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"})
+        sobject @(sto/put-object! storage {::sto/content (sto/content "content")
+                                           :content-type "text/plain"
+                                           :other "data"})
+
         profile (th/create-profile* 1 {:is-active true})
         project (th/create-project* 1 {:team-id (:default-team-id profile)
                                        :profile-id (:id profile)})
@@ -176,6 +173,7 @@
                                                :is-local false
                                                :media-id (:id sobject)})]
 
+
     (th/update-file*
      {:file-id (:id file1)
       :profile-id (:id profile)
@@ -229,9 +227,9 @@
 (t/deftest duplicate-project-with-deleted-files
   (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"})
+        sobject @(sto/put-object! storage {::sto/content (sto/content "content")
+                                           :content-type "text/plain"
+                                           :other "data"})
         profile (th/create-profile* 1 {:is-active true})
         project (th/create-project* 1 {:team-id (:default-team-id profile)
                                        :profile-id (:id profile)})
@@ -247,12 +245,6 @@
                                                :is-local false
                                                :media-id (:id sobject)})]
 
-    (th/update-file*
-     {:file-id (:id file1)
-      :profile-id (:id profile)
-      :changes [{:type :add-media
-                 :object (select-keys mobj [:id :width :height :mtype :name])}]})
-
     (th/mark-file-deleted* {:id (:id file1)})
 
     (let [data {::th/type :duplicate-project
@@ -432,7 +424,7 @@
 
       ;; project1 now should have 2 file
       (let [[item1 item2 :as rows] (db/query th/*pool* :file {:project-id (:id project1)}
-                                      {:order-by [:created-at]})]
+                                             {:order-by [:created-at]})]
         ;; (clojure.pprint/pprint rows)
         (t/is (= 2 (count rows)))
         (t/is (= (:id item1) (:id file2))))
@@ -610,6 +602,3 @@
         (t/is (= (:library-file-id item1) (:id file2))))
 
       )))
-
-
-

backend/test/app/services_media_test.clj

@@ -41,8 +41,8 @@
       (t/is (uuid? media-id))
       (t/is (uuid? thumbnail-id))
       (let [storage (:app.storage/storage th/*system*)
-            mobj1   (sto/get-object storage media-id)
-            mobj2   (sto/get-object storage thumbnail-id)]
+            mobj1   @(sto/get-object storage media-id)
+            mobj2   @(sto/get-object storage thumbnail-id)]
         (t/is (sto/storage-object? mobj1))
         (t/is (sto/storage-object? mobj2))
         (t/is (= 122785 (:size mobj1)))
@@ -57,8 +57,8 @@
                                    :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"
+                :path (th/tempfile "app/test_files/sample.jpg")
+                :mtype "image/jpeg"
                 :size 312043}
 
         params {::th/type :upload-file-media-object
@@ -79,8 +79,8 @@
       (t/is (uuid? media-id))
       (t/is (uuid? thumbnail-id))
       (let [storage (:app.storage/storage th/*system*)
-            mobj1   (sto/get-object storage media-id)
-            mobj2   (sto/get-object storage thumbnail-id)]
+            mobj1   @(sto/get-object storage media-id)
+            mobj2   @(sto/get-object storage thumbnail-id)]
         (t/is (sto/storage-object? mobj1))
         (t/is (sto/storage-object? mobj2))
         (t/is (= 312043 (:size mobj1)))
@@ -96,8 +96,8 @@
                                    :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"
+                :path (th/tempfile "app/test_files/sample.jpg")
+                :mtype "image/jpeg"
                 :size 312043}
 
         params {::th/type :upload-file-media-object

backend/test/app/services_profile_test.clj

@@ -7,6 +7,7 @@
 (ns app.services-profile-test
   (:require
    [app.common.uuid :as uuid]
+   [app.config :as cf]
    [app.db :as db]
    [app.rpc.mutations.profile :as profile]
    [app.test-helpers :as th]
@@ -110,8 +111,8 @@
                   :profile-id (:id profile)
                   :file {:filename "sample.jpg"
                          :size 123123
-                         :tempfile (th/tempfile "app/test_files/sample.jpg")
-                         :content-type "image/jpeg"}}
+                         :path (th/tempfile "app/test_files/sample.jpg")
+                         :mtype "image/jpeg"}}
             out  (th/mutation! data)]
 
         ;; (th/print-result! out)
@@ -195,6 +196,56 @@
         (t/is (nil? error))))
     ))
 
+(t/deftest prepare-and-register-with-invitation-and-disabled-registration-1
+  (with-redefs [app.config/flags [:disable-registration]]
+    (let [tokens-fn (:app.tokens/tokens th/*system*)
+          itoken    (tokens-fn :generate
+                               {:iss :team-invitation
+                                :exp (dt/in-future "48h")
+                                :role :editor
+                                :team-id uuid/zero
+                                :member-email "user@example.com"})
+          data  {::th/type :prepare-register-profile
+                 :invitation-token itoken
+                 :email "user@example.com"
+                 :password "foobar"}
+
+          {:keys [result error] :as out} (th/mutation! data)]
+      (t/is (nil? error))
+      (t/is (map? result))
+      (t/is (string? (:token result)))
+
+      (let [rtoken (:token result)
+            data   {::th/type :register-profile
+                    :token rtoken
+                    :fullname "foobar"}
+
+            {:keys [result error] :as out} (th/mutation! data)]
+        ;; (th/print-result! out)
+        (t/is (nil? error))
+        (t/is (map? result))
+        (t/is (string? (:invitation-token result)))))))
+
+(t/deftest prepare-and-register-with-invitation-and-disabled-registration-2
+  (with-redefs [app.config/flags [:disable-registration]]
+    (let [tokens-fn (:app.tokens/tokens th/*system*)
+          itoken    (tokens-fn :generate
+                               {:iss :team-invitation
+                                :exp (dt/in-future "48h")
+                                :role :editor
+                                :team-id uuid/zero
+                                :member-email "user2@example.com"})
+
+          data  {::th/type :prepare-register-profile
+                 :invitation-token itoken
+                 :email "user@example.com"
+                 :password "foobar"}
+          {:keys [result error] :as out} (th/mutation! data)]
+      (t/is (th/ex-info? error))
+      (t/is (= :restriction (th/ex-type error)))
+      (t/is (= :email-does-not-match-invitation (th/ex-code error))))))
+
+
 (t/deftest prepare-register-with-registration-disabled
   (th/with-mocks {#'app.config/flags nil}
     (let [data  {::th/type :prepare-register-profile

backend/test/app/services_teams_test.clj

@@ -35,18 +35,24 @@
 
       ;; invite external user without complaints
       (let [data (assoc data :email "foo@bar.com")
-            out  (th/mutation! data)]
+            out  (th/mutation! data)
+            ;;retrieve the value from the database and check its content
+            invitation (db/exec-one!
+                  th/*pool*
+                  ["select count(*) as num from team_invitation where team_id = ? and email_to = ?"
+                   (:team-id data) "foo@bar.com"])]
 
         ;; (th/print-result! out)
 
-        (t/is (nil? (:result out)))
-        (t/is (= 1 (:call-count (deref mock)))))
+        (t/is (= {} (:result out)))
+        (t/is (= 1 (:call-count (deref mock))))
+        (t/is (= 1 (:num invitation))))
 
       ;; invite internal user without complaints
       (th/reset-mock! mock)
       (let [data (assoc data :email (:email profile2))
             out  (th/mutation! data)]
-        (t/is (nil? (:result out)))
+        (t/is (= {} (:result out)))
         (t/is (= 1 (:call-count (deref mock)))))
 
       ;; invite user with complaint
@@ -54,7 +60,7 @@
       (th/reset-mock! mock)
       (let [data (assoc data :email "foo@bar.com")
             out  (th/mutation! data)]
-        (t/is (nil? (:result out)))
+        (t/is (= {} (:result out)))
         (t/is (= 1 (:call-count (deref mock)))))
 
       ;; invite user with bounce
@@ -159,4 +165,86 @@
 
 
 
+(t/deftest query-team-invitations
+  (let [prof  (th/create-profile* 1 {:is-active true})
+        team     (th/create-team* 1 {:profile-id (:id prof)})
+        data {::th/type :team-invitations
+              :profile-id (:id prof)
+              :team-id (:id team)}]
 
+    ;;insert an entry on the database with an enabled invitation
+    (db/insert! th/*pool* :team-invitation
+               {:team-id (:team-id data)
+                :email-to "test1@mail.com"
+                :role "editor"
+                :valid-until (dt/in-future "48h")})
+
+
+    ;;insert an entry on the database with an expired invitation
+    (db/insert! th/*pool* :team-invitation
+                {:team-id (:team-id data)
+                 :email-to "test2@mail.com"
+                 :role "editor"
+                 :valid-until (dt/in-past "48h")})
+
+    (let [out (th/query! data)]
+      (t/is (nil? (:error out)))
+      (let [result (:result out)
+            one (first result)
+            two (second result)]
+        (t/is (= 2 (count result)))
+        (t/is (= "test1@mail.com" (:email one)))
+        (t/is (= "test2@mail.com" (:email two)))
+        (t/is (false? (:expired one)))
+        (t/is (true? (:expired two)))))))
+
+
+(t/deftest update-team-invitation-role
+  (let [prof  (th/create-profile* 1 {:is-active true})
+        team     (th/create-team* 1 {:profile-id (:id prof)})
+        data {::th/type :update-team-invitation-role
+              :profile-id (:id prof)
+              :team-id (:id team)
+              :email "TEST1@mail.com"
+              :role :admin}]
+
+    ;;insert an entry on the database with an invitation
+    (db/insert! th/*pool* :team-invitation
+                {:team-id (:team-id data)
+                 :email-to "test1@mail.com"
+                 :role "editor"
+                 :valid-until (dt/in-future "48h")})
+
+    (let [out (th/mutation! data)
+          ;;retrieve the value from the database and check its content
+          result (db/get-by-params th/*pool* :team-invitation
+                                       {:team-id (:team-id data) :email-to "test1@mail.com"}
+                                       {:check-not-found false})]
+      (t/is (nil? (:error out)))
+      (t/is (nil? (:result out)))
+      (t/is (= "admin" (:role result))))))
+
+
+(t/deftest delete-team-invitation
+  (let [prof  (th/create-profile* 1 {:is-active true})
+        team     (th/create-team* 1 {:profile-id (:id prof)})
+        data {::th/type :delete-team-invitation
+              :profile-id (:id prof)
+              :team-id (:id team)
+              :email "TEST1@mail.com"}]
+
+    ;;insert an entry on the database with an invitation
+    (db/insert! th/*pool* :team-invitation
+                {:team-id (:team-id data)
+                 :email-to "test1@mail.com"
+                 :role "editor"
+                 :valid-until (dt/in-future "48h")})
+
+    (let [out (th/mutation! data)
+          ;;retrieve the value from the database and check its content
+          result (db/get-by-params th/*pool* :team-invitation
+                                   {:team-id (:team-id data) :email-to "test1@mail.com"}
+                                   {:check-not-found false})]
+      (t/is (nil? (:error out)))
+      (t/is (nil? (:result out)))
+      (t/is (nil? result)))))

backend/test/app/storage_test.clj

@@ -37,69 +37,74 @@
   (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"
-                                         :other "data"})]
+        object  @(sto/put-object! storage {::sto/content content
+                                           :content-type "text/plain"
+                                           :other "data"})]
     (t/is (sto/storage-object? object))
-    (t/is (fs/path? (sto/get-object-path storage object)))
+    (t/is (fs/path? @(sto/get-object-path storage object)))
     (t/is (nil? (:expired-at object)))
     (t/is (= :tmp (:backend object)))
     (t/is (= "data" (:other (meta object))))
     (t/is (= "text/plain" (:content-type (meta object))))
-    (t/is (= "content" (slurp (sto/get-object-data storage object))))
-    (t/is (= "content" (slurp (sto/get-object-path storage object))))
+    (t/is (= "content" (slurp @(sto/get-object-data storage object))))
+    (t/is (= "content" (slurp @(sto/get-object-path storage object))))
     ))
 
 (t/deftest put-and-retrieve-expired-object
   (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"
-                                         :expired-at (dt/in-future {:seconds 1})})]
+        object  @(sto/put-object! storage {::sto/content content
+                                           ::sto/expired-at (dt/in-future {:seconds 1})
+                                           :content-type "text/plain"
+                                           })]
     (t/is (sto/storage-object? object))
     (t/is (dt/instant? (:expired-at object)))
     (t/is (dt/is-after? (:expired-at object) (dt/now)))
-    (t/is (= object (sto/get-object storage (:id object))))
+    (t/is (= object @(sto/get-object storage (:id object))))
 
     (th/sleep 1000)
-    (t/is (nil? (sto/get-object storage (:id object))))
-    (t/is (nil? (sto/get-object-data storage object)))
-    (t/is (nil? (sto/get-object-url storage object)))
-    (t/is (nil? (sto/get-object-path storage object)))
+    (t/is (nil? @(sto/get-object storage (:id object))))
+    (t/is (nil? @(sto/get-object-data storage object)))
+    (t/is (nil? @(sto/get-object-url storage object)))
+    (t/is (nil? @(sto/get-object-path storage object)))
     ))
 
 (t/deftest put-and-delete-object
   (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"
-                                         :expired-at (dt/in-future {:seconds 1})})]
+        object  @(sto/put-object! storage {::sto/content content
+                                           :content-type "text/plain"
+                                           :expired-at (dt/in-future {:seconds 1})})]
     (t/is (sto/storage-object? object))
-    (t/is (true? (sto/del-object storage object)))
+    (t/is (true? @(sto/del-object! storage object)))
 
     ;; retrieving the same object should be not nil because the
     ;; deletion is not immediate
-    (t/is (some? (sto/get-object-data storage object)))
-    (t/is (some? (sto/get-object-url storage object)))
-    (t/is (some? (sto/get-object-path storage object)))
+    (t/is (some? @(sto/get-object-data storage object)))
+    (t/is (some? @(sto/get-object-url storage object)))
+    (t/is (some? @(sto/get-object-path storage object)))
 
     ;; But you can't retrieve the object again because in database is
     ;; marked as deleted/expired.
-    (t/is (nil? (sto/get-object storage (:id object))))
+    (t/is (nil? @(sto/get-object storage (:id object))))
     ))
 
 (t/deftest test-deleted-gc-task
   (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"
-                                         :expired-at (dt/now)})
-        object2 (sto/put-object storage {:content content
-                                         :content-type "text/plain"
-                                         :expired-at (dt/in-past {:hours 2})})]
+        content1 (sto/content "content1")
+        content2 (sto/content "content2")
+        object1  @(sto/put-object! storage {::sto/content content1
+                                            ::sto/expired-at (dt/now)
+                                            :content-type "text/plain"
+                                            })
+        object2  @(sto/put-object! storage {::sto/content content2
+                                            ::sto/expired-at (dt/in-past {:hours 2})
+                                            :content-type "text/plain"
+                                            })]
+
     (th/sleep 200)
 
     (let [task (:app.storage/gc-deleted-task th/*system*)
@@ -121,8 +126,8 @@
                                     :is-shared false})
 
         mfile   {:filename "sample.jpg"
-                 :tempfile (th/tempfile "app/test_files/sample.jpg")
-                 :content-type "image/jpeg"
+                 :path (th/tempfile "app/test_files/sample.jpg")
+                 :mtype "image/jpeg"
                  :size 312043}
 
         params  {::th/type :upload-file-media-object
@@ -147,22 +152,24 @@
       (t/is (uuid? (:media-id result-1)))
       (t/is (uuid? (:media-id result-2)))
 
+      (t/is (= (:media-id result-1) (:media-id result-2)))
+
       ;; now we proceed to manually delete one file-media-object
       (db/exec-one! th/*pool* ["delete from file_media_object where id = ?" (:id result-1)])
 
       ;; check that we still have all the storage objects
       (let [res (db/exec-one! th/*pool* ["select count(*) from storage_object"])]
-        (t/is (= 4 (:count res))))
+        (t/is (= 2 (:count res))))
 
       ;; 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 (= 4 (:count res))))
+        (t/is (= 2 (:count res))))
 
       ;; run the touched gc task
       (let [task (:app.storage/gc-touched-task th/*system*)
             res  (task {})]
         (t/is (= 2 (:freeze res)))
-        (t/is (= 2 (:delete res))))
+        (t/is (= 0 (: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"])]
@@ -170,8 +177,8 @@
 
       ;; 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 (= 2 (:count res))))
-    )))
+        (t/is (= 0 (:count res))))
+      )))
 
 
 (t/deftest test-touched-gc-task-2
@@ -193,8 +200,8 @@
                     (fs/slurp-bytes))
 
         mfile   {:filename "sample.jpg"
-                 :tempfile (th/tempfile "app/test_files/sample.jpg")
-                 :content-type "image/jpeg"
+                 :path (th/tempfile "app/test_files/sample.jpg")
+                 :mtype "image/jpeg"
                  :size 312043}
 
         params1 {::th/type :upload-file-media-object
@@ -249,7 +256,7 @@
         (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
+(t/deftest test-touched-gc-task-3
   (let [storage (-> (:app.storage/storage th/*system*)
                     (configure-storage-backend))
         prof    (th/create-profile* 1)
@@ -259,8 +266,8 @@
                                     :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"
+                 :path (th/tempfile "app/test_files/sample.jpg")
+                 :mtype "image/jpeg"
                  :size 312043}
 
         params  {::th/type :upload-file-media-object
@@ -285,9 +292,23 @@
       ;; run the touched gc task
       (let [task (:app.storage/gc-touched-task th/*system*)
             res  (task {})]
-        (t/is (= 4 (:freeze res)))
+        (t/is (= 2 (:freeze res)))
         (t/is (= 0 (:delete res))))
 
       ;; 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)))))))
+        (t/is (= 2 (:count res)))))
+
+    ;; now we proceed to manually delete all team_font_variant
+    (db/exec-one! th/*pool* ["delete from file_media_object"])
+
+    ;; run the touched gc task
+    (let [task (:app.storage/gc-touched-task th/*system*)
+          res  (task {})]
+      (t/is (= 0 (:freeze res)))
+      (t/is (= 2 (:delete res))))
+
+    ;; check that we have all no objects
+    (let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where deleted_at is null"])]
+      (t/is (= 0 (:count res))))))
+

backend/test/app/tasks_telemetry_test.clj

@@ -21,13 +21,16 @@
   (with-mocks [mock {:target 'app.tasks.telemetry/send!
                      :return nil}]
     (let [task-fn (-> th/*system* :app.worker/registry :telemetry)
-          prof    (th/create-profile* 1 {:is-active true})]
+          prof    (th/create-profile* 1 {:is-active true
+                                         :props {:newsletter-subscribed true}})]
 
       ;; run the task
-      (task-fn nil)
+      (task-fn {:send? true :enabled? true})
 
       (t/is (:called? @mock))
-      (let [[data] (-> @mock :call-args)]
+      (let [[_ data] (-> @mock :call-args)]
+        (t/is (contains? data :subscriptions))
+        (t/is (= [(:email prof)] (get data :subscriptions)))
         (t/is (contains? data :total-fonts))
         (t/is (contains? data :total-users))
         (t/is (contains? data :total-projects))

backend/test/app/test_helpers.clj

@@ -11,6 +11,7 @@
    [app.common.pages :as cp]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
+   [app.common.pprint :as pp]
    [app.config :as cf]
    [app.db :as db]
    [app.main :as main]
@@ -30,6 +31,7 @@
    [expound.alpha :as expound]
    [integrant.core :as ig]
    [mockery.core :as mk]
+   [yetti.request :as yrq]
    [promesa.core :as p])
   (:import org.postgresql.ds.PGSimpleDataSource))
 
@@ -55,23 +57,35 @@
                    (dissoc :app.srepl/server
                            :app.http/server
                            :app.http/router
-                           :app.notifications/handler
-                           :app.loggers.sentry/reporter
+                           :app.http.awsns/handler
+                           :app.http.session/updater
                            :app.http.oauth/google
                            :app.http.oauth/gitlab
                            :app.http.oauth/github
                            :app.http.oauth/all
-                           :app.worker/scheduler
+                           :app.worker/executors-monitor
+                           :app.http.oauth/handler
+                           :app.notifications/handler
+                           :app.loggers.sentry/reporter
+                           :app.loggers.mattermost/reporter
+                           :app.loggers.loki/reporter
+                           :app.loggers.database/reporter
+                           :app.loggers.zmq/receiver
+                           :app.worker/cron
                            :app.worker/worker)
                    (d/deep-merge
-                    {:app.tasks.file-media-gc/handler {:max-age (dt/duration 300)}}))
+                    {:app.tasks.file-gc/handler {:max-age (dt/duration 300)}}))
         _      (ig/load-namespaces config)
         system (-> (ig/prep config)
                    (ig/init))]
     (try
       (binding [*system* system
                 *pool*   (:app.db/pool system)]
-        (next))
+        (mk/with-mocks [mock1 {:target 'app.rpc.mutations.profile/derive-password
+                               :return identity}
+                        mock2 {:target 'app.rpc.mutations.profile/verify-password
+                               :return (fn [a b] {:valid (= a b)})}]
+          (next)))
       (finally
         (ig/halt! system)))))
 
@@ -272,7 +286,8 @@
   (let [data (ex-data error)]
     (cond
       (= :spec-validation (:code data))
-      (expound/printer (:data data))
+      (println
+       (us/pretty-explain data))
 
       (= :service-error (:type data))
       (print-error! (.getCause ^Throwable error))
@@ -289,7 +304,7 @@
       (println "====> END ERROR"))
     (do
       (println "====> START RESPONSE")
-      (prn result)
+      (pp/pprint result)
       (println "====> END RESPONSE"))))
 
 (defn exception?
@@ -300,6 +315,14 @@
   [v]
   (instance? clojure.lang.ExceptionInfo v))
 
+(defn ex-type
+  [e]
+  (:type (ex-data e)))
+
+(defn ex-code
+  [e]
+  (:code (ex-data e)))
+
 (defn ex-of-type?
   [e type]
   (let [data (ex-data e)]
@@ -353,3 +376,15 @@
     (.readLine cnsl)
     nil))
 
+(defn db-exec!
+  [sql]
+  (db/exec! *pool* sql))
+
+(defn db-insert!
+  [& params]
+  (apply db/insert! *pool* params))
+
+(defn db-query
+  [& params]
+  (apply db/query *pool* params))
+

common/deps.edn

@@ -3,26 +3,26 @@
   org.clojure/data.json {:mvn/version "2.4.0"}
   org.clojure/tools.cli {:mvn/version "1.0.206"}
   metosin/jsonista {:mvn/version "0.3.5"}
-  org.clojure/clojurescript {:mvn/version "1.10.914"}
+  org.clojure/clojurescript {:mvn/version "1.11.4"}
 
   ;; Logging
-  org.apache.logging.log4j/log4j-api {:mvn/version "2.17.1"}
-  org.apache.logging.log4j/log4j-core {:mvn/version "2.17.1"}
-  org.apache.logging.log4j/log4j-web {:mvn/version "2.17.1"}
-  org.apache.logging.log4j/log4j-jul {:mvn/version "2.17.1"}
-  org.apache.logging.log4j/log4j-slf4j18-impl {:mvn/version "2.17.1"}
+  org.apache.logging.log4j/log4j-api {:mvn/version "2.17.2"}
+  org.apache.logging.log4j/log4j-core {:mvn/version "2.17.2"}
+  org.apache.logging.log4j/log4j-web {:mvn/version "2.17.2"}
+  org.apache.logging.log4j/log4j-jul {:mvn/version "2.17.2"}
+  org.apache.logging.log4j/log4j-slf4j18-impl {:mvn/version "2.17.2"}
   org.slf4j/slf4j-api {:mvn/version "2.0.0-alpha1"}
 
   selmer/selmer {:mvn/version "1.12.50"}
   criterium/criterium {:mvn/version "0.4.6"}
 
   expound/expound {:mvn/version "0.9.0"}
-  com.cognitect/transit-clj {:mvn/version "1.0.324"}
+  com.cognitect/transit-clj {:mvn/version "1.0.329"}
   com.cognitect/transit-cljs {:mvn/version "0.8.269"}
   java-http-clj/java-http-clj {:mvn/version "0.4.3"}
 
-  funcool/promesa {:mvn/version "7.0.444"}
-  funcool/cuerdas {:mvn/version "2022.01.14-391"}
+  funcool/promesa {:mvn/version "8.0.450"}
+  funcool/cuerdas {:mvn/version "2022.03.27-397"}
 
   lambdaisland/uri {:mvn/version "1.13.95"
                     :exclusions [org.clojure/data.json]}
@@ -42,7 +42,7 @@
   {:extra-deps
    {org.clojure/tools.namespace {:mvn/version "RELEASE"}
     org.clojure/test.check {:mvn/version "RELEASE"}
-    thheller/shadow-cljs {:mvn/version "2.17.3"}
+    thheller/shadow-cljs {:mvn/version "2.17.8"}
     com.bhauman/rebel-readline {:mvn/version "RELEASE"}
     criterium/criterium {:mvn/version "RELEASE"}
     mockery/mockery {:mvn/version "RELEASE"}}

common/package.json

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

common/src/app/common/attrs.cljc

@@ -5,7 +5,49 @@
 ;; Copyright (c) UXBOX Labs SL
 
 (ns app.common.attrs
-  (:refer-clojure :exclude [merge]))
+  (:require
+    [app.common.geom.shapes.transforms :as gst]
+    [app.common.math :as mth]))
+
+(defn- get-attr
+  [obj attr]
+  (if (= (get obj attr) :multiple)
+    :multiple
+    (cond
+      ;; For rotated or stretched shapes, the origin point we show in the menu
+      ;; is not the (:x :y) shape attribute, but the top left coordinate of the
+      ;; wrapping recangle (see measures.cljs). As the :points attribute cannot
+      ;; be merged for several objects, we calculate the origin point in two fake
+      ;; attributes to be used in the measures menu.
+      (#{:ox :oy} attr)
+      (if-let [value (get obj attr)]
+        value
+        (if-let [points (:points obj)]
+          (if (not= points :multiple)
+            (let [rect (gst/selection-rect [obj])]
+              (if (= attr :ox) (:x rect) (:y rect)))
+            :multiple)
+          (get obj attr ::unset)))
+
+      ;; Not all shapes have width and height (e.g. paths), so we extract
+      ;; them from the :selrect attribute.
+      (#{:width :height} attr)
+      (if-let [value (get obj attr)]
+        value
+        (if-let [selrect (:selrect obj)]
+          (if (not= selrect :multiple)
+            (get (:selrect obj) attr)
+            :multiple)
+          (get obj attr ::unset)))
+
+      :else
+      (get obj attr ::unset))))
+
+(defn- default-equal
+  [val1 val2]
+  (if (and (number? val1) (number? val2))
+    (mth/close? val1 val2)
+    (= val1 val2)))
 
 ;; Extract some attributes of a list of shapes.
 ;; For each attribute, if the value is the same in all shapes,
@@ -36,13 +78,11 @@
 ;;        :rx nil
 ;;        :ry nil}
 ;;
-
 (defn get-attrs-multi
   ([objs attrs]
-   (get-attrs-multi objs attrs = identity))
+   (get-attrs-multi objs attrs default-equal identity))
 
   ([objs attrs eqfn sel]
-
    (loop [attr (first attrs)
           attrs (rest attrs)
           result (transient {})]
@@ -50,34 +90,25 @@
        (let [value
              (loop [curr (first objs)
                     objs (rest objs)
-                    value ::undefined]
+                    value ::unset]
 
                (if (and curr (not= value :multiple))
-                 ;;
-                 (let [new-val (get curr attr ::undefined)
+                 (let [new-val (get-attr curr attr)
                        value (cond
-                               (= new-val ::undefined) value
-                               (= new-val :multiple)   :multiple
-                               (= value ::undefined)   (sel new-val)
-                               (eqfn new-val value)    value
-                               :else                   :multiple)]
+                               (= new-val ::unset)   value
+                               (= new-val :multiple) :multiple
+                               (= value ::unset)     (sel new-val)
+                               (eqfn new-val value)  value
+                               :else                 :multiple)]
                    (recur (first objs) (rest objs) value))
-                 ;;
+
                  value))]
+
          (recur (first attrs)
                 (rest attrs)
                 (cond-> result
-                  (not= value ::undefined)
+                  (not= value ::unset)
                   (assoc! attr value))))
 
        (persistent! result)))))
 
-(defn merge
-  "Attrs specific merge function."
-  [obj attrs]
-  (reduce-kv (fn [obj k v]
-               (if (nil? v)
-                 (dissoc obj k)
-                 (assoc obj k v)))
-             obj
-             attrs))

common/src/app/common/colors.cljc

@@ -10,10 +10,14 @@
 (def black "#000000")
 (def canvas "#E8E9EA")
 (def default-layout "#DE4762")
+(def gray-10 "#E3E3E3")
 (def gray-20 "#B1B2B5")
 (def gray-30 "#7B7D85")
+(def gray-40 "#64666A")
+(def gray-50 "#303236")
 (def info "#59B9E2")
 (def test "#fabada")
 (def white "#FFFFFF")
 (def primary "#31EFB8")
-
+(def danger "#E65244")
+(def warning "#FC8802")

common/src/app/common/data.cljc

@@ -6,12 +6,12 @@
 
 (ns app.common.data
   "Data manipulation and query helper functions."
-  (:refer-clojure :exclude [read-string hash-map merge name parse-double group-by iteration])
+  (:refer-clojure :exclude [read-string hash-map merge name update-vals
+                            parse-double group-by iteration])
   #?(:cljs
      (:require-macros [app.common.data]))
   (:require
    [app.common.math :as mth]
-   [cljs.analyzer.api :as aapi]
    [clojure.set :as set]
    [cuerdas.core :as str]
    #?(:cljs [cljs.reader :as r]
@@ -23,9 +23,9 @@
   #?(:clj
      (:import linked.set.LinkedSet)))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Data Structures
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defn ordered-set
   ([] lks/empty-linked-set)
@@ -49,9 +49,14 @@
   ([a] (into (queue) [a]))
   ([a & more] (into (queue) (cons a more))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Data Structures Manipulation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn editable-collection?
+  [m]
+  #?(:clj (instance? clojure.lang.IEditableCollection m)
+     :cljs (implements? core/IEditableCollection m)))
 
 (defn deep-merge
   ([a b]
@@ -101,7 +106,6 @@
 
 (defn preconj
   [coll elem]
-  (assert (vector? coll))
   (into [elem] coll))
 
 (defn enumerate
@@ -129,9 +133,10 @@
 (defn index-by
   "Return a indexed map of the collection keyed by the result of
   executing the getter over each element of the collection."
-  [getter coll]
-  (persistent!
-   (reduce #(assoc! %1 (getter %2) %2) (transient {}) coll)))
+  ([kf coll] (index-by kf identity coll))
+  ([kf vf coll]
+   (persistent!
+    (reduce #(assoc! %1 (kf %2) (vf %2)) (transient {}) coll))))
 
 (defn index-of-pred
   [coll pred]
@@ -173,9 +178,12 @@
   "Return a map without the keys provided
   in the `keys` parameter."
   [data keys]
-  (when (map? data)
-    (persistent!
-     (reduce #(dissoc! %1 %2) (transient data) keys))))
+  (persistent!
+   (reduce dissoc!
+           (if (editable-collection? data)
+             (transient data)
+             (transient {}))
+           keys)))
 
 (defn remove-at-index
   "Takes a vector and returns a vector with an element in the
@@ -198,6 +206,22 @@
   ([mfn coll]
    (into {} (mapm mfn) coll)))
 
+;; TEMPORARY COPY of clojure.core/update-vals until we migrate to clojure 1.11
+
+(defn update-vals
+  "m f => {k (f v) ...}
+  Given a map m and a function f of 1-argument, returns a new map where the keys of m
+  are mapped to result of applying f to the corresponding values of m."
+  [m f]
+  (with-meta
+    (persistent!
+     (reduce-kv (fn [acc k v] (assoc! acc k (f v)))
+                (if (editable-collection? m)
+                  (transient m)
+                  (transient {}))
+                m))
+    (meta m)))
+
 (defn removev
   "Returns a vector of the items in coll for which (fn item) returns logical false"
   [fn coll]
@@ -312,6 +336,16 @@
   [& maps]
   (reduce conj (or (first maps) {}) (rest maps)))
 
+(defn txt-merge
+  "Text attrs specific merge function."
+  [obj attrs]
+  (reduce-kv (fn [obj k v]
+               (if (nil? v)
+                 (dissoc obj k)
+                 (assoc obj k v)))
+             obj
+             attrs))
+
 (defn distinct-xf
   [f]
   (fn [rf]
@@ -326,13 +360,14 @@
              (do (vswap! seen conj input*)
                  (rf result input)))))))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Data Parsing / Conversion
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defn nan?
   [v]
-  (not= v v))
+  #?(:cljs (js/isNaN v)
+     :clj  (not= v v)))
 
 (defn- impl-parse-integer
   [v]
@@ -390,9 +425,9 @@
   [val default]
   (or val default))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Data Parsing / Conversion
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defn nilf
   "Returns a new function that if you pass nil as any argument will
   return nil"
@@ -407,54 +442,24 @@
   [v default]
   (if (some? v) v default))
 
+(defn num?
+  "Checks if a value `val` is a number but not an Infinite or NaN"
+  ([val]
+   (and (number? val)
+        (mth/finite? val)
+        (not (mth/nan? val))))
+
+  ([val & vals]
+   (and (num? val)
+        (->> vals (every? num?)))))
+
 (defn check-num
   "Function that checks if a number is nil or nan. Will return 0 when not
   valid and the number otherwise."
   ([v]
    (check-num v 0))
   ([v default]
-   (if (or (not v)
-           (not (mth/finite? v))
-           (mth/nan? v)) default v)))
-
-
-(defmacro export
-  "A helper macro that allows reexport a var in a current namespace."
-  [v]
-  (if (boolean (:ns &env))
-
-    ;; Code for ClojureScript
-    (let [mdata    (aapi/resolve &env v)
-          arglists (second (get-in mdata [:meta :arglists]))
-          sym      (symbol (core/name v))
-          andsym   (symbol "&")
-          procarg  #(if (= % andsym) % (gensym "param"))]
-      (if (pos? (count arglists))
-        `(def
-           ~(with-meta sym (:meta mdata))
-           (fn ~@(for [args arglists]
-                   (let [args (map procarg args)]
-                     (if (some #(= andsym %) args)
-                       (let [[sargs dargs] (split-with #(not= andsym %) args)]
-                         `([~@sargs ~@dargs] (apply ~v ~@sargs ~@(rest dargs))))
-                       `([~@args] (~v ~@args)))))))
-        `(def ~(with-meta sym (:meta mdata)) ~v)))
-
-    ;; Code for Clojure
-    (let [vr (resolve v)
-          m  (meta vr)
-          n  (:name m)
-          n  (with-meta n
-               (cond-> {}
-                 (:dynamic m) (assoc :dynamic true)
-                 (:protocol m) (assoc :protocol (:protocol m))))]
-      `(let [m# (meta ~vr)]
-         (def ~n (deref ~vr))
-         (alter-meta! (var ~n) merge (dissoc m# :name))
-         ;; (when (:macro m#)
-         ;;   (.setMacro (var ~n)))
-         ~vr))))
-
+   (if (num? v) v default)))
 
 (defn any-key? [element & rest]
   (some #(contains? element %) rest))
@@ -579,17 +584,20 @@
    (assert (string? basename))
    (assert (set? used))
 
-   (let [[prefix initial] (extract-numeric-suffix basename)]
-     (if (and (not prefix-first?)
-              (not (contains? used basename)))
-       basename
-       (loop [counter initial]
-         (let [candidate (if (and (= 1 counter) prefix-first?)
-                           (str prefix)
-                           (str prefix "-" counter))]
-           (if (contains? used candidate)
-             (recur (inc counter))
-             candidate)))))))
+   (if (> (count basename) 1000)
+     ;; We skip generating names for long strings. If the name is too long the regex can hang
+     basename
+     (let [[prefix initial] (extract-numeric-suffix basename)]
+       (if (and (not prefix-first?)
+                (not (contains? used basename)))
+         basename
+         (loop [counter initial]
+           (let [candidate (if (and (= 1 counter) prefix-first?)
+                             (str prefix)
+                             (str prefix "-" counter))]
+             (if (contains? used candidate)
+               (recur (inc counter))
+               candidate))))))))
 
 (defn deep-mapm
   "Applies a map function to an associative map and recurses over its children
@@ -628,19 +636,10 @@
 
 
 (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 #{})]
+  ([kf coll] (group-by kf identity [] coll))
+  ([kf vf coll] (group-by kf vf [] coll))
+  ([kf vf iv coll]
+   (let [conj (fnil conj iv)]
      (reduce (fn [result item]
                (update result (kf item) conj (vf item)))
              {}
@@ -693,3 +692,13 @@
                    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/data/macros.cljc

@@ -0,0 +1,98 @@
+;; 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
+
+#_:clj-kondo/ignore
+(ns app.common.data.macros
+  "Data retrieval & manipulation specific macros."
+  (:refer-clojure :exclude [get-in select-keys str])
+  #?(:cljs (:require-macros [app.common.data.macros]))
+  (:require
+   #?(:clj [clojure.core :as c]
+      :cljs [cljs.core :as c])
+   [app.common.data :as d]
+   [cuerdas.core :as str]
+   [cljs.analyzer.api :as aapi]))
+
+(defmacro select-keys
+  "A macro version of `select-keys`. Usefull when keys vector is known
+  at compile time (aprox 600% performance boost).
+
+  It is not 100% equivalent, this macro does not removes not existing
+  keys in contrast to clojure.core/select-keys"
+  [target keys]
+  (assert (vector? keys) "keys expected to be a vector")
+  `{ ~@(mapcat (fn [key] [key (list `c/get target key)]) keys) ~@[] })
+
+(defmacro get-in
+  "A macro version of `get-in`. Usefull when the keys vector is known at
+  compile time (20-40% performance improvement)."
+  ([target keys]
+   (assert (vector? keys) "keys expected to be a vector")
+   `(-> ~target ~@(map (fn [key] (list `c/get key)) keys)))
+  ([target keys default]
+   (assert (vector? keys) "keys expected to be a vector")
+   (let [last-index (dec (count keys))]
+     `(-> ~target ~@(map-indexed (fn [index key]
+                                   (if (= last-index index)
+                                     (list `c/get key default)
+                                     (list `c/get key)))
+                                 keys)))))
+
+(defmacro str
+  [& params]
+  `(str/concat ~@params))
+
+(defmacro export
+  "A helper macro that allows reexport a var in a current namespace."
+  [v]
+  (if (boolean (:ns &env))
+
+    ;; Code for ClojureScript
+    (let [mdata    (aapi/resolve &env v)
+          arglists (second (get-in mdata [:meta :arglists]))
+          sym      (symbol (c/name v))
+          andsym   (symbol "&")
+          procarg  #(if (= % andsym) % (gensym "param"))]
+      (if (pos? (count arglists))
+        `(def
+           ~(with-meta sym (:meta mdata))
+           (fn ~@(for [args arglists]
+                   (let [args (map procarg args)]
+                     (if (some #(= andsym %) args)
+                       (let [[sargs dargs] (split-with #(not= andsym %) args)]
+                         `([~@sargs ~@dargs] (apply ~v ~@sargs ~@(rest dargs))))
+                       `([~@args] (~v ~@args)))))))
+        `(def ~(with-meta sym (:meta mdata)) ~v)))
+
+    ;; Code for Clojure
+    (let [vr (resolve v)
+          m  (meta vr)
+          n  (:name m)
+          n  (with-meta n
+               (cond-> {}
+                 (:dynamic m) (assoc :dynamic true)
+                 (:protocol m) (assoc :protocol (:protocol m))))]
+      `(let [m# (meta ~vr)]
+         (def ~n (deref ~vr))
+         (alter-meta! (var ~n) merge (dissoc m# :name))
+         ;; (when (:macro m#)
+         ;;   (.setMacro (var ~n)))
+         ~vr))))
+
+(defmacro fmt
+  "String interpolation helper. Can only be used with strings known at
+  compile time. Can be used with indexed params access or sequential.
+
+  Examples:
+
+    (dm/fmt \"url(%)\" my-url) ; sequential
+    (dm/fmt \"url(%1)\" my-url) ; indexed
+  "
+  [s & params]
+  `(str/ffmt ~s ~@params))
+
+
+

common/src/app/common/exceptions.cljc

@@ -23,11 +23,12 @@
                    ::cause]))
 
 (defn error
-  [& {:keys [hint cause ::data] :as params}]
+  [& {:keys [hint cause ::data type] :as params}]
   (s/assert ::error-params params)
   (let [payload (-> params
                     (dissoc :cause ::data)
-                    (merge data))]
+                    (merge data))
+        hint    (or hint (pr-str type))]
     (ex-info hint payload cause)))
 
 (defmacro raise
@@ -56,3 +57,31 @@
 (defn exception?
   [v]
   (instance? #?(:clj java.lang.Throwable :cljs js/Error) v))
+
+
+#?(:cljs
+   (deftype WrappedException [cause meta]
+     cljs.core/IMeta
+     (-meta [_] meta)
+
+     cljs.core/IDeref
+     (-deref [_] cause))
+   :clj
+   (deftype WrappedException [cause meta]
+     clojure.lang.IMeta
+     (meta [_] meta)
+
+     clojure.lang.IDeref
+     (deref [_] cause)))
+
+
+(ns-unmap 'app.common.exceptions '->WrappedException)
+(ns-unmap 'app.common.exceptions 'map->WrappedException)
+
+(defn wrapped?
+  [o]
+  (instance? WrappedException o))
+
+(defn wrap-with-context
+  [cause context]
+  (WrappedException. cause context))

common/src/app/common/file_builder.cljc

@@ -21,6 +21,11 @@
 (def conjv (fnil conj []))
 (def conjs (fnil conj #{}))
 
+(defn- raise
+  [err-str]
+  #?(:clj (throw (Exception. err-str))
+     :cljs (throw (js/Error. err-str))))
+
 (defn- commit-change
   ([file change]
    (commit-change file change nil))
@@ -75,10 +80,12 @@
 
     (commit-change file change {:add-container? true :fail-on-spec? fail-on-spec?})))
 
-(defn setup-rect-selrect [obj]
-  (let [rect      (select-keys obj [:x :y :width :height])
+(defn setup-rect-selrect [{:keys [x y width height transform] :as obj}]
+  (when-not (d/num? x y width height)
+    (raise "Coords not valid for object"))
+
+  (let [rect      (gsh/make-rect x y width height)
         center    (gsh/center-rect rect)
-        transform (:transform obj (gmt/matrix))
         selrect   (gsh/rect->selrect rect)
 
         points (-> (gsh/rect->points rect)
@@ -89,17 +96,13 @@
         (assoc :points points))))
 
 (defn- setup-path-selrect
-  [obj]
-  (let [content (:content obj)
-        center  (:center obj)
+  [{:keys [content center transform transform-inverse] :as obj}]
 
-        transform-inverse
-        (->> (:transform-inverse obj (gmt/matrix))
-             (gmt/transform-in center))
+  (when (or (empty? content) (nil? center))
+    (raise "Path not valid"))
 
-        transform
-        (->> (:transform obj (gmt/matrix))
-             (gmt/transform-in center))
+  (let [transform (gmt/transform-in center transform)
+        transform-inverse (gmt/transform-in center transform-inverse)
 
         content' (gsh/transform-content content transform-inverse)
         selrect  (gsh/content->selrect content')
@@ -310,21 +313,30 @@
         children (->> bool :shapes (mapv #(lookup-shape file %)))
 
         file
-        (let [objects (lookup-objects file)
-              bool' (gsh/update-bool-selrect bool children objects)]
+        (cond
+          (empty? children)
           (commit-change
            file
-           {:type :mod-obj
-            :id bool-id
-            :operations
-            [{:type :set :attr :selrect :val (:selrect bool')}
-             {:type :set :attr :points  :val (:points bool')}
-             {:type :set :attr :x       :val (-> bool' :selrect :x)}
-             {:type :set :attr :y       :val (-> bool' :selrect :y)}
-             {:type :set :attr :width   :val (-> bool' :selrect :width)}
-             {:type :set :attr :height  :val (-> bool' :selrect :height)}]}
+           {:type :del-obj
+            :id bool-id}
+           {:add-container? true})
 
-           {:add-container? true}))]
+          :else
+          (let [objects (lookup-objects file)
+                bool' (gsh/update-bool-selrect bool children objects)]
+            (commit-change
+             file
+             {:type :mod-obj
+              :id bool-id
+              :operations
+              [{:type :set :attr :selrect :val (:selrect bool')}
+               {:type :set :attr :points  :val (:points bool')}
+               {:type :set :attr :x       :val (-> bool' :selrect :x)}
+               {:type :set :attr :y       :val (-> bool' :selrect :y)}
+               {:type :set :attr :width   :val (-> bool' :selrect :width)}
+               {:type :set :attr :height  :val (-> bool' :selrect :height)}]}
+
+             {:add-container? true})))]
 
     (-> file
         (update :parent-stack pop))))

common/src/app/common/flags.cljc

@@ -12,7 +12,7 @@
 (def default
   "A common flags that affects both: backend and frontend."
   [:enable-registration
-   :enable-demo-users])
+   :enable-login])
 
 (defn parse
   [& flags]

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

@@ -26,7 +26,7 @@
   (toString [_]
     (str "matrix(" a "," b "," c "," d "," e "," f ")")))
 
-(defn ^boolean matrix?
+(defn matrix?
   "Return true if `v` is Matrix instance."
   [v]
   (instance? Matrix v))
@@ -57,6 +57,15 @@
                     (map (comp d/parse-double first)))]
     (apply matrix params)))
 
+(defn close?
+  [m1 m2]
+  (and (mth/close? (.-a m1) (.-a m2))
+       (mth/close? (.-b m1) (.-b m2))
+       (mth/close? (.-c m1) (.-c m2))
+       (mth/close? (.-d m1) (.-d m2))
+       (mth/close? (.-e m1) (.-e m2))
+       (mth/close? (.-f m1) (.-f m2))))
+
 (defn multiply
   ([^Matrix m1 ^Matrix m2]
    (let [m1a (.-a m1)
@@ -108,9 +117,12 @@
   (= v base))
 
 (defn translate-matrix
-  [{x :x y :y :as pt}]
-  (assert (gpt/point? pt))
-  (Matrix. 1 0 0 1 x y))
+  ([{x :x y :y :as pt}]
+   (assert (gpt/point? pt))
+   (Matrix. 1 0 0 1 x y))
+
+  ([x y]
+   (translate-matrix (gpt/point x y))))
 
 (defn scale-matrix
   ([pt center]
@@ -184,9 +196,36 @@
 (defmethod pp/simple-dispatch Matrix [obj] (pr obj))
 
 (defn transform-in [pt mtx]
-  (if (some? pt)
+  (if (and (some? pt) (some? mtx))
     (-> (matrix)
         (translate pt)
         (multiply mtx)
         (translate (gpt/negate pt)))
     mtx))
+
+(defn determinant
+  "Determinant for the affinity transform"
+  [{:keys [a b c d _ _]}]
+  (- (* a d) (* c b)))
+
+(defn inverse
+  "Gets the inverse of the affinity transform `mtx`"
+  [{:keys [a b c d e f] :as mtx}]
+  (let [det (determinant mtx)
+        a' (/  d det)
+        b' (/ (- b) det)
+        c' (/ (- c) det)
+        d' (/  a det)
+        e' (/ (- (* c f) (* d e)) det)
+        f' (/ (- (* b e) (* a f)) det)]
+    (Matrix. a' b' c' d' e' f')))
+
+(defn round
+  [mtx]
+  (-> mtx
+      (update :a mth/precision 4)
+      (update :b mth/precision 4)
+      (update :c mth/precision 4)
+      (update :d mth/precision 4)
+      (update :e mth/precision 4)
+      (update :f mth/precision 4)))

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

@@ -21,7 +21,7 @@
 
 (defn s [{:keys [x y]}] (str "(" x "," y ")"))
 
-(defn ^boolean point?
+(defn point?
   "Return true if `v` is Point instance."
   [v]
   (or (instance? Point v)
@@ -33,8 +33,7 @@
 (s/def ::point
   (s/and (s/keys :req-un [::x ::y]) point?))
 
-
-(defn ^boolean point-like?
+(defn point-like?
   [{:keys [x y] :as v}]
   (and (map? v)
        (not (nil? x))
@@ -61,6 +60,11 @@
   ([x y]
    (Point. x y)))
 
+(defn close?
+  [p1 p2]
+  (and (mth/close? (:x p1) (:x p2))
+       (mth/close? (:y p1) (:y p2))))
+
 (defn angle->point [{:keys [x y]} angle distance]
   (point
    (+ x (* distance (mth/cos angle)))
@@ -96,7 +100,6 @@
   (assert (point? other))
   (Point. (/ x ox) (/ y oy)))
 
-
 (defn min
   ([] (min nil nil))
   ([p1] (min p1 nil))
@@ -132,9 +135,17 @@
   (assert (point? other))
   (let [dx (- x ox)
         dy (- y oy)]
-    (-> (mth/sqrt (+ (mth/pow dx 2)
-                     (mth/pow dy 2)))
-        (mth/precision 6))))
+    (mth/sqrt (+ (mth/pow dx 2)
+                 (mth/pow dy 2)))))
+
+(defn distance-vector
+  "Calculate the distance, separated x and y."
+  [{x :x y :y :as p} {ox :x oy :y :as other}]
+  (assert (point? p))
+  (assert (point? other))
+  (let [dx (mth/abs (- x ox))
+        dy (mth/abs (- y oy))]
+    (Point. dx dy)))
 
 (defn length
   [{x :x y :y :as p}]
@@ -168,8 +179,7 @@
                     (* y oy))
                  (* length-p length-other))
             a (mth/acos (if (< a -1) -1 (if (> a 1) 1 a)))
-            d (-> (mth/degrees a)
-                  (mth/precision 6))]
+            d (mth/degrees a)]
         (if (mth/nan? d) 0 d)))))
 
 (defn angle-sign [v1 v2]
@@ -194,14 +204,23 @@
     (if (>= y 0) 2 3)))
 
 (defn round
-  "Change the precision of the point coordinates."
-  ([point] (round point 0))
+  "Round the coordinates of the point to a precision"
+  ([point]
+   (round point 0))
+
   ([{:keys [x y] :as p} decimals]
    (assert (point? p))
    (assert (number? decimals))
    (Point. (mth/precision x decimals)
            (mth/precision y decimals))))
 
+(defn half-round
+  "Round the coordinates to the closest half-point"
+  [{:keys [x y] :as p}]
+  (assert (point? p))
+  (Point. (mth/half-round x)
+          (mth/half-round y)))
+
 (defn transform
   "Transform a point applying a matrix transformation."
   [{:keys [x y] :as p} {:keys [a b c d e f]}]

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

@@ -7,49 +7,18 @@
 (ns app.common.geom.shapes
   (:require
    [app.common.data :as d]
+   [app.common.data.macros :as dm]
    [app.common.geom.point :as gpt]
    [app.common.geom.shapes.bool :as gsb]
    [app.common.geom.shapes.common :as gco]
    [app.common.geom.shapes.constraints :as gct]
+   [app.common.geom.shapes.corners :as gsc]
    [app.common.geom.shapes.intersect :as gin]
    [app.common.geom.shapes.path :as gsp]
    [app.common.geom.shapes.rect :as gpr]
    [app.common.geom.shapes.transforms :as gtr]
    [app.common.math :as mth]))
 
-;; --- Setup (Initialize)
-;; FIXME: Is this the correct place for these functions?
-
-(defn- setup-rect
-  "A specialized function for setup rect-like shapes."
-  [shape {:keys [x y width height]}]
-  (let [rect    {:x x :y y :width width :height height}
-        points  (gpr/rect->points rect)
-        selrect (gpr/points->selrect points)]
-    (assoc shape
-           :x x
-           :y y
-           :width width
-           :height height
-           :points points
-           :selrect selrect)))
-
-(defn- setup-image
-  [{:keys [metadata] :as shape} props]
-  (-> (setup-rect shape props)
-      (assoc
-       :proportion (/ (:width metadata)
-                      (:height metadata))
-       :proportion-lock true)))
-
-(defn setup
-  "A function that initializes the first coordinates for
-  the shape. Used mainly for draw operations."
-  [shape props]
-  (case (:type shape)
-    :image (setup-image shape props)
-    (setup-rect shape props)))
-
 ;; --- Outer Rect
 
 (defn selection-rect
@@ -70,6 +39,14 @@
 
 ;; --- Helpers
 
+(defn left-bound
+  [shape]
+  (get shape :x (:x (:selrect shape)))) ; Paths don't have :x attribute
+
+(defn top-bound
+  [shape]
+  (get shape :y (:y (:selrect shape)))) ; Paths don't have :y attribute
+
 (defn fully-contained?
   "Checks if one rect is fully inside the other"
   [rect other]
@@ -106,12 +83,12 @@
              :width (- x2 x1)
              :height (- y2 y1)
              :type :rect}))
-        {frame-x1 :x1 frame-x2 :x2 frame-y1 :y1 frame-y2 :y2} bounds
+        {bound-x1 :x1 bound-x2 :x2 bound-y1 :y1 bound-y2 :y2} bounds
         {sr-x1 :x1 sr-x2 :x2 sr-y1 :y1 sr-y2 :y2} selrect]
-    {:left   (make-selrect frame-x1 sr-y1 (- sr-x1 2) sr-y2)
-     :top    (make-selrect sr-x1 frame-y1 sr-x2 (- sr-y1 2))
-     :right  (make-selrect (+ sr-x2 2) sr-y1 frame-x2 sr-y2)
-     :bottom (make-selrect sr-x1 (+ sr-y2 2) sr-x2 frame-y2)}))
+    {:left   (make-selrect bound-x1 sr-y1 sr-x1 sr-y2)
+     :top    (make-selrect sr-x1 bound-y1 sr-x2 sr-y1)
+     :right  (make-selrect sr-x2 sr-y1 bound-x2 sr-y2)
+     :bottom (make-selrect sr-x1 sr-y2 sr-x2 bound-y2)}))
 
 (defn distance-selrect [selrect other]
   (let [{:keys [x1 y1]} other
@@ -121,13 +98,6 @@
 (defn distance-shapes [shape other]
   (distance-selrect (:selrect shape) (:selrect other)))
 
-(defn setup-selrect [shape]
-  (let [selrect (gpr/rect->selrect shape)
-        points  (gpr/rect->points shape)]
-    (-> shape
-        (assoc :selrect selrect
-               :points points))))
-
 (defn shape-stroke-margin
   [shape stroke-width]
   (if (= (:type shape) :path)
@@ -135,57 +105,98 @@
     (mth/sqrt (* 2 stroke-width stroke-width))
     (- (mth/sqrt (* 2 stroke-width stroke-width)) stroke-width)))
 
+(defn close-attrs?
+  "Compares two shapes attributes to see if they are equal or almost
+  equal (in case of numeric). Takes into account attributes that are
+  data structures with numbers inside."
+  ([attr val1 val2]
+   (close-attrs? attr val1 val2 mth/float-equal-precision))
+
+  ([attr val1 val2 precision]
+   (let [close-val? (fn [num1 num2]
+                     (when (and (number? num1) (number? num2))
+                       (< (mth/abs (- num1 num2)) precision)))]
+     (cond
+       (and (number? val1) (number? val2))
+       (close-val? val1 val2)
+
+       (= attr :selrect)
+       (every? #(close-val? (get val1 %) (get val2 %))
+               [:x :y :x1 :y1 :x2 :y2 :width :height])
+
+       (= attr :points)
+       (every? #(and (close-val? (:x (first %)) (:x (second %)))
+                     (close-val? (:y (first %)) (:y (second %))))
+               (d/zip val1 val2))
+
+       (= attr :position-data)
+       (every? #(and (close-val? (:x (first %)) (:x (second %)))
+                     (close-val? (:y (first %)) (:y (second %))))
+               (d/zip val1 val2))
+
+       :else
+       (= val1 val2)))))
 
 ;; EXPORTS
-(d/export gco/center-shape)
-(d/export gco/center-selrect)
-(d/export gco/center-rect)
-(d/export gco/center-points)
-(d/export gco/make-centered-rect)
-(d/export gco/transform-points)
+(dm/export gco/center-shape)
+(dm/export gco/center-selrect)
+(dm/export gco/center-rect)
+(dm/export gco/center-points)
+(dm/export gco/transform-points)
 
-(d/export gpr/rect->selrect)
-(d/export gpr/rect->points)
-(d/export gpr/points->selrect)
-(d/export gpr/points->rect)
-(d/export gpr/center->rect)
-(d/export gpr/join-rects)
-(d/export gpr/contains-selrect?)
+(dm/export gpr/make-rect)
+(dm/export gpr/make-selrect)
+(dm/export gpr/rect->selrect)
+(dm/export gpr/rect->points)
+(dm/export gpr/points->selrect)
+(dm/export gpr/points->rect)
+(dm/export gpr/center->rect)
+(dm/export gpr/center->selrect)
+(dm/export gpr/join-rects)
+(dm/export gpr/join-selrects)
+(dm/export gpr/contains-selrect?)
 
-(d/export gtr/move)
-(d/export gtr/absolute-move)
-(d/export gtr/transform-matrix)
-(d/export gtr/inverse-transform-matrix)
-(d/export gtr/transform-point-center)
-(d/export gtr/transform-rect)
-(d/export gtr/calculate-adjust-matrix)
-(d/export gtr/update-group-selrect)
-(d/export gtr/resize-modifiers)
-(d/export gtr/rotation-modifiers)
-(d/export gtr/merge-modifiers)
-(d/export gtr/transform-shape)
-(d/export gtr/transform-selrect)
-(d/export gtr/modifiers->transform)
-(d/export gtr/empty-modifiers?)
+(dm/export gtr/move)
+(dm/export gtr/absolute-move)
+(dm/export gtr/transform-matrix)
+(dm/export gtr/inverse-transform-matrix)
+(dm/export gtr/transform-point-center)
+(dm/export gtr/transform-rect)
+(dm/export gtr/calculate-adjust-matrix)
+(dm/export gtr/update-group-selrect)
+(dm/export gtr/update-mask-selrect)
+(dm/export gtr/resize-modifiers)
+(dm/export gtr/rotation-modifiers)
+(dm/export gtr/merge-modifiers)
+(dm/export gtr/transform-shape)
+(dm/export gtr/transform-selrect)
+(dm/export gtr/transform-bounds)
+(dm/export gtr/modifiers->transform)
+(dm/export gtr/empty-modifiers?)
+(dm/export gtr/move-position-data)
 
 ;; Constratins
-(d/export gct/calc-child-modifiers)
+(dm/export gct/calc-child-modifiers)
 
 ;; PATHS
-(d/export gsp/content->selrect)
-(d/export gsp/transform-content)
-(d/export gsp/open-path?)
+(dm/export gsp/content->selrect)
+(dm/export gsp/transform-content)
+(dm/export gsp/open-path?)
 
 ;; Intersection
-(d/export gin/overlaps?)
-(d/export gin/has-point?)
-(d/export gin/has-point-rect?)
-(d/export gin/rect-contains-shape?)
+(dm/export gin/overlaps?)
+(dm/export gin/has-point?)
+(dm/export gin/has-point-rect?)
+(dm/export gin/rect-contains-shape?)
 
 ;; Bool
-(d/export gsb/update-bool-selrect)
-(d/export gsb/calc-bool-content)
+(dm/export gsb/update-bool-selrect)
+(dm/export gsb/calc-bool-content)
 
 ;; Constraints
-(d/export gct/default-constraints-h)
-(d/export gct/default-constraints-v)
+(dm/export gct/default-constraints-h)
+(dm/export gct/default-constraints-v)
+
+;; Corners
+(dm/export gsc/shape-corners-1)
+(dm/export gsc/shape-corners-4)

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

@@ -8,7 +8,6 @@
   (:require
    [app.common.data :as d]
    [app.common.geom.shapes.path :as gsp]
-   [app.common.geom.shapes.rect :as gpr]
    [app.common.geom.shapes.transforms :as gtr]
    [app.common.path.bool :as pb]
    [app.common.path.shapes-to-path :as stp]))
@@ -30,15 +29,13 @@
   "Calculates the selrect+points for the boolean shape"
   [shape children objects]
 
-  (let [content (calc-bool-content shape objects)
-        [points selrect]
-        (if (empty? content)
-          (let [selrect (gtr/selection-rect children)
-                points (gpr/rect->points selrect)]
-            [points selrect])
-          (gsp/content->points+selrect shape content))]
-    (-> shape
-        (assoc :selrect selrect)
-        (assoc :points points)
-        (assoc :bool-content content))))
+  (let [bool-content     (calc-bool-content shape objects)
+        shape            (assoc shape :bool-content bool-content)
+        [points selrect] (gsp/content->points+selrect shape bool-content)]
+
+    (if (and (some? selrect) (d/not-empty? points))
+      (-> shape
+          (assoc :selrect selrect)
+          (assoc :points points))
+      (gtr/update-group-selrect shape children))))
 

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

@@ -6,30 +6,24 @@
 
 (ns app.common.geom.shapes.common
   (:require
+   [app.common.data :as d]
    [app.common.geom.matrix :as gmt]
-   [app.common.geom.point :as gpt]
-   [app.common.math :as mth]))
+   [app.common.geom.point :as gpt]))
 
 (defn center-rect
   [{:keys [x y width height]}]
-  (when (and (mth/finite? x)
-             (mth/finite? y)
-             (mth/finite? width)
-             (mth/finite? height))
+  (when (d/num? x y width height)
     (gpt/point (+ x (/ width 2.0))
                (+ y (/ height 2.0)))))
 
 (defn center-selrect
-  "Calculate the center of the shape."
+  "Calculate the center of the selrect."
   [selrect]
   (center-rect selrect))
 
-(def map-x-xf (comp (map :x) (remove nil?)))
-(def map-y-xf (comp (map :y) (remove nil?)))
-
 (defn center-points [points]
-  (let [ptx  (into [] map-x-xf points)
-        pty  (into [] map-y-xf points)
+  (let [ptx  (into [] (keep :x) points)
+        pty  (into [] (keep :y) points)
         minx (reduce min ##Inf ptx)
         miny (reduce min ##Inf pty)
         maxx (reduce max ##-Inf ptx)
@@ -42,37 +36,16 @@
   [shape]
   (center-rect (:selrect shape)))
 
-(defn make-centered-rect
-  "Creates a rect given a center and a width and height"
-  [center width height]
-  {:x (- (:x center) (/ width 2.0))
-   :y (- (:y center) (/ height 2.0))
-   :width width
-   :height height})
-
-(defn make-centered-selrect
-  "Creates a rect given a center and a width and height"
-  [center width height]
-  (let [x1 (- (:x center) (/ width 2.0))
-        y1 (- (:y center) (/ height 2.0))
-        x2 (+ x1 width)
-        y2 (+ y1 height)]
-    {:x x1
-     :y y1
-     :x1 x1
-     :x2 x2
-     :y1 y1
-     :y2 y2
-     :width width
-     :height height}))
-
 (defn transform-points
   ([points matrix]
    (transform-points points nil matrix))
-  ([points center matrix]
-   (let [prev (if center (gmt/translate-matrix center) (gmt/matrix))
-         post (if center (gmt/translate-matrix (gpt/negate center)) (gmt/matrix))
 
-         tr-point (fn [point]
-                    (gpt/transform point (gmt/multiply prev matrix post)))]
-     (mapv tr-point points))))
+  ([points center matrix]
+   (if (and (d/not-empty? points) (gmt/matrix? matrix))
+     (let [prev (if center (gmt/translate-matrix center) (gmt/matrix))
+           post (if center (gmt/translate-matrix (gpt/negate center)) (gmt/matrix))
+
+           tr-point (fn [point]
+                      (gpt/transform point (gmt/multiply prev matrix post)))]
+       (mapv tr-point points))
+     points)))

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

@@ -9,7 +9,7 @@
    [app.common.geom.matrix :as gmt]
    [app.common.geom.point :as gpt]
    [app.common.geom.shapes.common :as gco]
-   [app.common.geom.shapes.transforms :as gtr]
+   [app.common.geom.shapes.rect :as gre]
    [app.common.math :as mth]
    [app.common.uuid :as uuid]))
 
@@ -77,18 +77,16 @@
 (defmethod constraint-modifier :fixed
   [_ axis parent child _ transformed-parent-rect]
   (let [parent-rect (:selrect parent)
-        child-rect (:selrect child)
+        child-rect (gre/points->rect (:points child))
 
         delta-start  (get-delta-start axis parent-rect transformed-parent-rect)
         delta-size   (get-delta-size axis parent-rect transformed-parent-rect)
-        child-size   (get-size axis child-rect)
-        child-center (gco/center-rect child-rect)]
+        child-size   (get-size axis child-rect)]
     (if (or (not (mth/almost-zero? delta-start))
             (not (mth/almost-zero? delta-size)))
 
       {:displacement (get-displacement axis delta-start)
-       :resize-origin (-> (get-displacement axis delta-start (:x1 child-rect) (:y1 child-rect))
-                          (gtr/transform-point-center child-center (:transform child (gmt/matrix))))
+       :resize-origin (get-displacement axis delta-start (:x child-rect) (:y child-rect))
        :resize-vector (get-scale axis (/ (+ child-size delta-size) child-size))}
       {})))
 
@@ -105,25 +103,25 @@
 (defmethod constraint-modifier :scale
   [_ axis _ _ modifiers _]
   (let [{:keys [resize-vector resize-vector-2 displacement]} modifiers]
-      (cond-> {}
-        (and (some? resize-vector)
-             (not (mth/close? (axis resize-vector) 1)))
-        (assoc :resize-origin (:resize-origin modifiers)
-               :resize-vector (if (= :x axis)
-                                (gpt/point (:x resize-vector) 1)
-                                (gpt/point 1 (:y resize-vector))))
+    (cond-> {}
+      (and (some? resize-vector)
+           (not= (axis resize-vector) 1))
+      (assoc :resize-origin (:resize-origin modifiers)
+             :resize-vector (if (= :x axis)
+                              (gpt/point (:x resize-vector) 1)
+                              (gpt/point 1 (:y resize-vector))))
 
-        (and (= :y axis) (some? resize-vector-2)
-             (not (mth/close? (:y resize-vector-2) 1)))
-        (assoc :resize-origin (:resize-origin-2 modifiers)
-               :resize-vector (gpt/point 1 (:y resize-vector-2)))
+      (and (= :y axis) (some? resize-vector-2)
+           (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)
-                                          (gpt/transform displacement)
-                                          (gpt/transform (:resize-transform-inverse modifiers (gmt/matrix)))
-                                          axis))))))
+      (some? displacement)
+      (assoc :displacement
+             (get-displacement axis (-> (gpt/point 0 0)
+                                        (gpt/transform displacement)
+                                        (gpt/transform (:resize-transform-inverse modifiers (gmt/matrix)))
+                                        axis))))))
 
 (defmethod constraint-modifier :default [_ _ _ _ _]
   {})
@@ -154,45 +152,74 @@
       :top
       :scale)))
 
+(defn clean-modifiers
+  "Remove redundant modifiers"
+  [{:keys [displacement resize-vector resize-vector-2] :as modifiers}]
+
+  (cond-> modifiers
+    ;; Displacement with value 0. We don't move in any direction
+    (and (some? displacement)
+         (mth/almost-zero? (:e displacement))
+         (mth/almost-zero? (:f displacement)))
+    (dissoc :displacement)
+
+    ;; Resize with value very close to 1 means no resize
+    (and (some? resize-vector)
+         (mth/almost-zero? (- 1.0 (:x resize-vector)))
+         (mth/almost-zero? (- 1.0 (:y resize-vector))))
+    (dissoc :resize-origin :resize-vector)
+
+    (and (some? resize-vector)
+         (mth/almost-zero? (- 1.0 (:x resize-vector-2)))
+         (mth/almost-zero? (- 1.0 (:y resize-vector-2))))
+    (dissoc :resize-origin-2 :resize-vector-2)))
+
 (defn calc-child-modifiers
   [parent child modifiers ignore-constraints transformed-parent-rect]
-  (let [constraints-h
-        (if-not ignore-constraints
-          (:constraints-h child (default-constraints-h child))
-          :scale)
 
-        constraints-v
-        (if-not ignore-constraints
-          (:constraints-v child (default-constraints-v child))
-          :scale)
+  (if (and (nil? (:resize-vector modifiers))
+           (nil? (:resize-vector-2 modifiers)))
+    ;; If we don't have a resize modifier we return the same modifiers
+    modifiers
+    (let [constraints-h
+          (if-not ignore-constraints
+            (:constraints-h child (default-constraints-h child))
+            :scale)
 
-        modifiers-h (constraint-modifier (constraints-h const->type+axis) :x parent child modifiers transformed-parent-rect)
-        modifiers-v (constraint-modifier (constraints-v const->type+axis) :y parent child modifiers transformed-parent-rect)]
+          constraints-v
+          (if-not ignore-constraints
+            (:constraints-v child (default-constraints-v child))
+            :scale)
 
-    ;; Build final child modifiers. Apply transform again to the result, to get the
-    ;; real modifiers that need to be applied to the child, including rotation as needed.
-    (cond-> {}
-      (or (contains? modifiers-h :displacement)
-          (contains? modifiers-v :displacement))
-      (assoc :displacement (cond-> (gpt/point (get-in modifiers-h [:displacement :x] 0)
-                                              (get-in modifiers-v [:displacement :y] 0))
-                             (some? (:resize-transform modifiers))
-                             (gpt/transform (:resize-transform modifiers))
+          modifiers-h (constraint-modifier (constraints-h const->type+axis) :x parent child modifiers transformed-parent-rect)
+          modifiers-v (constraint-modifier (constraints-v const->type+axis) :y parent child modifiers transformed-parent-rect)]
 
-                             :always
-                             (gmt/translate-matrix)))
+      ;; Build final child modifiers. Apply transform again to the result, to get the
+      ;; real modifiers that need to be applied to the child, including rotation as needed.
+      (cond-> {}
+        (or (contains? modifiers-h :displacement)
+            (contains? modifiers-v :displacement))
+        (assoc :displacement (cond-> (gpt/point (get-in modifiers-h [:displacement :x] 0)
+                                                (get-in modifiers-v [:displacement :y] 0))
+                               (some? (:resize-transform modifiers))
+                               (gpt/transform (:resize-transform modifiers))
 
-      (:resize-vector modifiers-h)
-      (assoc :resize-origin (:resize-origin modifiers-h)
-             :resize-vector (gpt/point (get-in modifiers-h [:resize-vector :x] 1)
-                                       (get-in modifiers-h [:resize-vector :y] 1)))
+                               :always
+                               (gmt/translate-matrix)))
 
-      (:resize-vector modifiers-v)
-      (assoc :resize-origin-2 (:resize-origin modifiers-v)
-             :resize-vector-2 (gpt/point (get-in modifiers-v [:resize-vector :x] 1)
-                                         (get-in modifiers-v [:resize-vector :y] 1)))
+        (:resize-vector modifiers-h)
+        (assoc :resize-origin (:resize-origin modifiers-h)
+               :resize-vector (gpt/point (get-in modifiers-h [:resize-vector :x] 1)
+                                         (get-in modifiers-h [:resize-vector :y] 1)))
 
-      (:resize-transform modifiers)
-      (assoc :resize-transform (:resize-transform modifiers)
-             :resize-transform-inverse (:resize-transform-inverse modifiers)))))
+        (:resize-vector modifiers-v)
+        (assoc :resize-origin-2 (:resize-origin modifiers-v)
+               :resize-vector-2 (gpt/point (get-in modifiers-v [:resize-vector :x] 1)
+                                           (get-in modifiers-v [:resize-vector :y] 1)))
 
+        (:resize-transform modifiers)
+        (assoc :resize-transform (:resize-transform modifiers)
+               :resize-transform-inverse (:resize-transform-inverse modifiers))
+
+        :always
+        (clean-modifiers)))))

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

@@ -0,0 +1,56 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.common.geom.shapes.corners
+  (:require
+   [app.common.math :as mth]))
+
+(defn- zero-div
+  [a b]
+  (if (mth/almost-zero? b)
+    ##Inf
+    (/ a b)))
+
+(defn fix-radius
+  ;; https://www.w3.org/TR/css-backgrounds-3/#corner-overlap
+  ;;
+  ;; > Corner curves must not overlap: When the sum of any two adjacent border radii exceeds the size of the border box,
+  ;; > UAs must proportionally reduce the used values of all border radii until none of them overlap.
+  ;;
+  ;; > The algorithm for reducing radii is as follows: Let f = min(Li/Si), where i ∈ {top, right, bottom, left}, Si is
+  ;; > the sum of the two corresponding radii of the corners on side i, and Ltop = Lbottom = the width of the box, and
+  ;; > Lleft = Lright = the height of the box. If f < 1, then all corner radii are reduced by multiplying them by f.
+  ([width height r]
+   (let [f (min 1
+                (zero-div width  (* 2 r))
+                (zero-div height (* 2 r)))]
+     (if (< f 1)
+       (* r f)
+       r)))
+
+  ([width height r1 r2 r3 r4]
+   (let [f (min 1
+                (zero-div width  (+ r1 r2))
+                (zero-div height (+ r2 r3))
+                (zero-div width  (+ r3 r4))
+                (zero-div height (+ r4 r1)))]
+     (if (< f 1)
+       [(* r1 f) (* r2 f) (* r3 f) (* r4 f)]
+       [r1 r2 r3 r4]))))
+
+(defn shape-corners-1
+  "Retrieve the effective value for the corner given a single value for corner."
+  [{:keys [width height rx] :as shape}]
+  (if (and (some? rx) (not (mth/almost-zero? rx)))
+    (fix-radius width height rx)
+    0))
+
+(defn shape-corners-4
+  "Retrieve the effective value for the corner given four values for the corners."
+  [{:keys [width height r1 r2 r3 r4]}]
+  (if (and (some? r1) (some? r2) (some? r3) (some? r4))
+    (fix-radius width height r1 r2 r3 r4)
+    [r1 r2 r3 r4]))

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

@@ -9,8 +9,10 @@
    [app.common.data :as d]
    [app.common.geom.matrix :as gmt]
    [app.common.geom.point :as gpt]
+   [app.common.geom.shapes.common :as gco]
    [app.common.geom.shapes.path :as gpp]
    [app.common.geom.shapes.rect :as gpr]
+   [app.common.geom.shapes.text :as gte]
    [app.common.math :as mth]))
 
 (defn orientation
@@ -283,6 +285,23 @@
         (is-point-inside-ellipse? (first rect-points) ellipse-data)
         (intersects-lines-ellipse? rect-lines ellipse-data))))
 
+(defn overlaps-text?
+  [{:keys [position-data] :as shape} rect]
+
+  (if (and (some? position-data) (d/not-empty? position-data))
+    (let [center    (gco/center-shape shape)
+
+          transform-rect
+          (fn [rect-points]
+            (gco/transform-points rect-points center (:transform shape)))]
+
+      (->> position-data
+           (map (comp transform-rect
+                      gpr/rect->points
+                      gte/position-data->rect))
+           (some #(overlaps-rect-points? rect %))))
+    (overlaps-rect-points? rect (:points shape))))
+
 (defn overlaps?
   "General case to check for overlapping between shapes and a rectangle"
   [shape rect]
@@ -291,14 +310,25 @@
                  (update :x - stroke-width)
                  (update :y - stroke-width)
                  (update :width + (* 2 stroke-width))
-                 (update :height + (* 2 stroke-width))
-                 )]
+                 (update :height + (* 2 stroke-width)))]
     (or (not shape)
         (let [path? (= :path (:type shape))
-              circle? (= :circle (:type shape))]
-          (and (overlaps-rect-points? rect (:points shape))
-               (or (not path?)   (overlaps-path? shape rect))
-               (or (not circle?) (overlaps-ellipse? shape rect)))))))
+              circle? (= :circle (:type shape))
+              text? (= :text (:type shape))]
+          (cond
+            path?
+            (and (overlaps-rect-points? rect (:points shape))
+                 (overlaps-path? shape rect))
+
+            circle?
+            (and (overlaps-rect-points? rect (:points shape))
+                 (overlaps-ellipse? shape rect))
+
+            text?
+            (overlaps-text? shape rect)
+
+            :else
+            (overlaps-rect-points? rect (:points shape)))))))
 
 (defn has-point-rect?
   [rect point]

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

@@ -333,11 +333,8 @@
                                                (command->point command :c2)]]
                                     (->> (curve-extremities curve)
                                          (mapv #(curve-values curve %)))))
-                  [])
-         selrect (gpr/points->selrect points)]
-     (-> selrect
-         (update :width #(if (mth/almost-zero? %) 1 %))
-         (update :height #(if (mth/almost-zero? %) 1 %))))))
+                  [])]
+     (gpr/points->selrect points))))
 
 (defn content->selrect [content]
   (let [calc-extremities
@@ -362,13 +359,8 @@
 
         extremities (mapcat calc-extremities
                             content
-                            (concat [nil] content))
-
-        selrect (gpr/points->selrect extremities)]
-
-    (-> selrect
-        (update :width #(if (mth/almost-zero? %) 1 %))
-        (update :height #(if (mth/almost-zero? %) 1 %)))))
+                            (concat [nil] content))]
+    (gpr/points->selrect extremities)))
 
 (defn move-content [content move-vec]
   (let [dx (:x move-vec)
@@ -376,40 +368,49 @@
 
         set-tr
         (fn [params px py]
-          (-> params
-              (update px + dx)
-              (update py + dy)))
+          (cond-> params
+            (d/num? dx)
+            (update px + dx)
+
+            (d/num? dy)
+            (update py + dy)))
 
         transform-params
-        (fn [{:keys [x c1x c2x] :as params}]
+        (fn [{:keys [x y c1x c1y c2x c2y] :as params}]
           (cond-> params
-            (some? x)   (set-tr :x :y)
-            (some? c1x) (set-tr :c1x :c1y)
-            (some? c2x) (set-tr :c2x :c2y)))]
+            (d/num? x y)   (set-tr :x :y)
+            (d/num? c1x c1y) (set-tr :c1x :c1y)
+            (d/num? c2x c2y) (set-tr :c2x :c2y)))
 
-    (into []
-          (map #(update % :params transform-params))
-          content)))
+        update-command
+        (fn [command]
+          (update command :params transform-params))]
+
+    (->> content
+         (into [] (map update-command)))))
 
 (defn transform-content
   [content transform]
-  (let [set-tr (fn [params px py]
-                 (let [tr-point (-> (gpt/point (get params px) (get params py))
-                                    (gpt/transform transform))]
-                   (assoc params
-                          px (:x tr-point)
-                          py (:y tr-point))))
+  (if (some? transform)
+    (let [set-tr
+          (fn [params px py]
+            (let [tr-point (-> (gpt/point (get params px) (get params py))
+                               (gpt/transform transform))]
+              (assoc params
+                     px (:x tr-point)
+                     py (:y tr-point))))
 
-        transform-params
-        (fn [{:keys [x c1x c2x] :as params}]
-          (cond-> params
-            (some? x)   (set-tr :x :y)
-            (some? c1x) (set-tr :c1x :c1y)
-            (some? c2x) (set-tr :c2x :c2y)))]
+          transform-params
+          (fn [{:keys [x c1x c2x] :as params}]
+            (cond-> params
+              (some? x)   (set-tr :x :y)
+              (some? c1x) (set-tr :c1x :c1y)
+              (some? c2x) (set-tr :c2x :c2y)))]
 
-    (into []
-          (map #(update % :params transform-params))
-          content)))
+      (into []
+            (map #(update % :params transform-params))
+            content))
+    content))
 
 (defn segments->content
   ([segments]
@@ -980,7 +981,6 @@
                     (gpr/points->selrect))]
     [points selrect]))
 
-
 (defn open-path?
   [shape]
 

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

@@ -6,81 +6,119 @@
 
 (ns app.common.geom.shapes.rect
   (:require
+   [app.common.data :as d]
    [app.common.geom.point :as gpt]
-   [app.common.geom.shapes.common :as gco]
    [app.common.math :as mth]))
 
+(defn make-rect
+  [x y width height]
+  (when (d/num? x y width height)
+    (let [width (max width 0.01)
+          height (max height 0.01)]
+      {:x x
+       :y y
+       :width width
+       :height height})))
+
+(defn make-selrect
+  [x y width height]
+  (when (d/num? x y width height)
+    (let [width (max width 0.01)
+          height (max height 0.01)]
+      {:x x
+       :y y
+       :x1 x
+       :y1 y
+       :x2 (+ x width)
+       :y2 (+ y height)
+       :width width
+       :height height})))
+
+(defn close-rect?
+  [rect1 rect2]
+  (and (mth/close? (:x rect1) (:x rect2))
+       (mth/close? (:y rect1) (:y rect2))
+       (mth/close? (:width rect1) (:width rect2))
+       (mth/close? (:height rect1) (:height rect2))))
+
+(defn close-selrect?
+  [selrect1 selrect2]
+  (and (mth/close? (:x selrect1) (:x selrect2))
+       (mth/close? (:y selrect1) (:y selrect2))
+       (mth/close? (:x1 selrect1) (:x1 selrect2))
+       (mth/close? (:y1 selrect1) (:y1 selrect2))
+       (mth/close? (:x2 selrect1) (:x2 selrect2))
+       (mth/close? (:y2 selrect1) (:y2 selrect2))
+       (mth/close? (:width selrect1) (:width selrect2))
+       (mth/close? (:height selrect1) (:height selrect2))))
+
 (defn rect->points [{:keys [x y width height]}]
-  ;; (assert (number? x))
-  ;; (assert (number? y))
-  ;; (assert (and (number? width) (> width 0)))
-  ;; (assert (and (number? height) (> height 0)))
-  [(gpt/point x y)
-   (gpt/point (+ x width) y)
-   (gpt/point (+ x width) (+ y height))
-   (gpt/point x (+ y height))])
+  (when (d/num? x y)
+    (let [width  (max width 0.01)
+          height (max height 0.01)]
+      [(gpt/point x y)
+       (gpt/point (+ x width) y)
+       (gpt/point (+ x width) (+ y height))
+       (gpt/point x (+ y height))])))
 
 (defn rect->lines [{:keys [x y width height]}]
-  [[(gpt/point x y) (gpt/point (+ x width) y)]
-   [(gpt/point (+ x width) y) (gpt/point (+ x width) (+ y height))]
-   [(gpt/point (+ x width) (+ y height)) (gpt/point x (+ y height))]
-   [(gpt/point x (+ y height)) (gpt/point x y)]])
+  (when (d/num? x y)
+    (let [width (max width 0.01)
+          height (max height 0.01)]
+      [[(gpt/point x y) (gpt/point (+ x width) y)]
+       [(gpt/point (+ x width) y) (gpt/point (+ x width) (+ y height))]
+       [(gpt/point (+ x width) (+ y height)) (gpt/point x (+ y height))]
+       [(gpt/point x (+ y height)) (gpt/point x y)]])))
 
 (defn points->rect
   [points]
-  (let [minx (transduce gco/map-x-xf min ##Inf points)
-        miny (transduce gco/map-y-xf min ##Inf points)
-        maxx (transduce gco/map-x-xf max ##-Inf points)
-        maxy (transduce gco/map-y-xf max ##-Inf points)]
-    {:x minx
-     :y miny
-     :width (- maxx minx)
-     :height (- maxy miny)}))
+  (when (d/not-empty? points)
+    (let [minx (transduce (keep :x) min ##Inf points)
+          miny (transduce (keep :y) min ##Inf points)
+          maxx (transduce (keep :x) max ##-Inf points)
+          maxy (transduce (keep :y) max ##-Inf points)]
+      (when (d/num? minx miny maxx maxy)
+        (make-rect minx miny (- maxx minx) (- maxy miny))))))
 
 (defn points->selrect [points]
-  (let [{:keys [x y width height] :as rect} (points->rect points)]
-    (assoc rect
-           :x1 x
-           :x2 (+ x width)
-           :y1 y
-           :y2 (+ y height))))
+  (when-let [rect (points->rect points)]
+    (let [{:keys [x y width height]} rect]
+      (make-selrect x y width height))))
 
 (defn rect->selrect [rect]
   (-> rect rect->points points->selrect))
 
 (defn join-rects [rects]
-  (let [minx (transduce (comp (map :x) (remove nil?)) min ##Inf rects)
-        miny (transduce (comp (map :y) (remove nil?)) min ##Inf rects)
-        maxx (transduce (comp (map #(+ (:x %) (:width %))) (remove nil?)) max ##-Inf rects)
-        maxy (transduce (comp (map #(+ (:y %) (:height %))) (remove nil?)) max ##-Inf rects)]
-    {:x minx
-     :y miny
-     :width (- maxx minx)
-     :height (- maxy miny)}))
+  (when (d/not-empty? rects)
+    (let [minx (transduce (keep :x) min ##Inf rects)
+          miny (transduce (keep :y) min ##Inf rects)
+          maxx (transduce (keep #(when (and (:x %) (:width %)) (+ (:x %) (:width %))))  max ##-Inf rects)
+          maxy (transduce (keep #(when (and (:y %) (:height %))(+ (:y %) (:height %)))) max ##-Inf rects)]
+      (when (d/num? minx miny maxx maxy)
+        (make-rect minx miny (- maxx minx) (- maxy miny))))))
 
 (defn join-selrects [selrects]
-  (let [minx (transduce (comp (map :x1) (remove nil?)) min ##Inf selrects)
-        miny (transduce (comp (map :y1) (remove nil?)) min ##Inf selrects)
-        maxx (transduce (comp (map :x2) (remove nil?)) max ##-Inf selrects)
-        maxy (transduce (comp (map :y2) (remove nil?)) max ##-Inf selrects)]
-    {:x minx
-     :y miny
-     :x1 minx
-     :y1 miny
-     :x2 maxx
-     :y2 maxy
-     :width (- maxx minx)
-     :height (- maxy miny)}))
+  (when (d/not-empty? selrects)
+    (let [minx (transduce (keep :x1) min ##Inf selrects)
+          miny (transduce (keep :y1) min ##Inf selrects)
+          maxx (transduce (keep :x2) max ##-Inf selrects)
+          maxy (transduce (keep :y2) max ##-Inf selrects)]
+      (when (d/num? minx miny maxx maxy)
+        (make-selrect minx miny (- maxx minx) (- maxy miny))))))
 
-(defn center->rect [center width height]
-  (assert (gpt/point center))
-  (assert (and (number? width) (> width 0)))
-  (assert (and (number? height) (> height 0)))
+(defn center->rect [{:keys [x y]} width height]
+  (when (d/num? x y width height)
+    (make-rect (- x (/ width 2))
+               (- y (/ height 2))
+               width
+               height)))
 
-  {:x (- (:x center) (/ width 2))
-   :y (- (:y center) (/ height 2))
-   :width width
-   :height height})
+(defn center->selrect [{:keys [x y]} width height]
+  (when (d/num? x y width height)
+    (make-selrect (- x (/ width 2))
+                  (- y (/ height 2))
+                  width
+                  height)))
 
 (defn s=
   [a b]
@@ -130,10 +168,3 @@
        (>= (:y1 sr2) (:y1 sr1))
        (<= (:y2 sr2) (:y2 sr1))))
 
-(defn round-selrect
-  [selrect]
-  (-> selrect
-      (update :x mth/round)
-      (update :y mth/round)
-      (update :width mth/round)
-      (update :height mth/round)))

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

@@ -0,0 +1,30 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.common.geom.shapes.text
+  (:require
+   [app.common.geom.shapes.common :as gco]
+   [app.common.geom.shapes.rect :as gpr]
+   [app.common.geom.shapes.transforms :as gtr]))
+
+(defn position-data->rect
+  [{:keys [x y width height]}]
+  {:x x
+   :y (- y height)
+   :width width
+   :height height})
+
+(defn position-data-points
+  [{:keys [position-data] :as shape}]
+  (let [points    (->> position-data
+                       (mapcat (comp gpr/rect->points position-data->rect)))
+        transform (gtr/transform-matrix shape)]
+    (gco/transform-points points transform)))
+
+(defn position-data-bounding-box
+  [shape]
+  (gpr/points->selrect (position-data-points shape)))
+

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

@@ -6,7 +6,6 @@
 
 (ns app.common.geom.shapes.transforms
   (:require
-   [app.common.attrs :as attrs]
    [app.common.data :as d]
    [app.common.geom.matrix :as gmt]
    [app.common.geom.point :as gpt]
@@ -21,30 +20,38 @@
 
 ;; --- Relative Movement
 
-(defn- move-selrect [selrect pt]
-  (when (and (some? selrect) (some? pt))
-    (let [dx (.-x pt)
-          dy (.-y pt)
-          {:keys [x y x1 y1 x2 y2 width height]} selrect]
-      {:x     (if (some? x) (+ dx x) x)
-       :y     (if (some? y) (+ dy y) y)
-       :x1    (if (some? x1) (+ dx x1) x1)
-       :y1    (if (some? y1) (+ dy y1) y1)
-       :x2    (if (some? x2) (+ dx x2) x2)
-       :y2    (if (some? y2) (+ dy y2) y2)
-       :width width
-       :height height})))
+(defn- move-selrect [{:keys [x y x1 y1 x2 y2 width height] :as selrect} {dx :x dy :y :as pt}]
+  (if (and (some? selrect) (some? pt) (d/num? dx dy))
+    {:x      (if (d/num? x)  (+ dx x)  x)
+     :y      (if (d/num? y)  (+ dy y)  y)
+     :x1     (if (d/num? x1) (+ dx x1) x1)
+     :y1     (if (d/num? y1) (+ dy y1) y1)
+     :x2     (if (d/num? x2) (+ dx x2) x2)
+     :y2     (if (d/num? y2) (+ dy y2) y2)
+     :width  width
+     :height height}
+    selrect))
 
 (defn- move-points [points move-vec]
-  (->> points
-       (mapv #(gpt/add % move-vec))))
+  (cond->> points
+    (d/num? (:x move-vec) (:y move-vec))
+    (mapv #(gpt/add % move-vec))))
+
+(defn move-position-data
+  [position-data dx dy]
+
+  (cond->> position-data
+    (d/num? dx dy)
+    (mapv #(-> %
+               (update :x + dx)
+               (update :y + dy)))))
 
 (defn move
   "Move the shape relatively to its current
   position applying the provided delta."
   [{:keys [type] :as shape} {dx :x dy :y}]
-  (let [dx       (d/check-num dx)
-        dy       (d/check-num dy)
+  (let [dx       (d/check-num dx 0)
+        dy       (d/check-num dy 0)
         move-vec (gpt/point dx dy)]
 
     (-> shape
@@ -52,6 +59,7 @@
         (update :points move-points move-vec)
         (d/update-when :x + dx)
         (d/update-when :y + dy)
+        (d/update-when :position-data move-position-data dx dy)
         (cond-> (= :bool type) (update :bool-content gpa/move-content move-vec))
         (cond-> (= :path type) (update :content gpa/move-content move-vec)))))
 
@@ -129,9 +137,12 @@
 (defn transform-matrix
   "Returns a transformation matrix without changing the shape properties.
   The result should be used in a `transform` attribute in svg"
-  ([shape] (transform-matrix shape nil))
-  ([shape params] (transform-matrix shape params (or (gco/center-shape shape)
-                                                     (gpt/point 0 0))))
+  ([shape]
+   (transform-matrix shape nil))
+
+  ([shape params]
+   (transform-matrix shape params (or (gco/center-shape shape) (gpt/point 0 0))))
+
   ([{:keys [flip-x flip-y] :as shape} {:keys [no-flip]} shape-center]
    (-> (gmt/matrix)
        (gmt/translate shape-center)
@@ -159,12 +170,13 @@
 (defn transform-point-center
   "Transform a point around the shape center"
   [point center matrix]
-  (when point
+  (if (and (some? point) (some? matrix) (some? center))
     (gpt/transform
      point
      (gmt/multiply (gmt/translate-matrix center)
                    matrix
-                   (gmt/translate-matrix (gpt/negate center))))))
+                   (gmt/translate-matrix (gpt/negate center))))
+    point))
 
 (defn transform-rect
   "Transform a rectangles and changes its attributes"
@@ -240,9 +252,9 @@
 
         ;; This rectangle is the new data for the current rectangle. We want to change our rectangle
         ;; to have this width, height, x, y
-        new-width  (max 1 (:width points-temp-dim))
-        new-height (max 1 (:height points-temp-dim))
-        selrect    (gco/make-centered-selrect center new-width new-height)
+        new-width  (max 0.01 (:width points-temp-dim))
+        new-height (max 0.01 (:height points-temp-dim))
+        selrect    (gpr/center->selrect center new-width new-height)
 
         rect-points  (gpr/rect->points selrect)
         [matrix matrix-inverse] (calculate-adjust-matrix points-temp rect-points flip-x flip-y)]
@@ -254,7 +266,7 @@
 (defn- apply-transform
   "Given a new set of points transformed, set up the rectangle so it keeps
   its properties. We adjust de x,y,width,height and create a custom transform"
-  [shape transform-mtx round-coords?]
+  [shape transform-mtx]
 
   (let [points'  (:points shape)
         points   (gco/transform-points points' transform-mtx)
@@ -267,10 +279,6 @@
           [(gpr/points->selrect points) nil nil]
           (adjust-rotated-transform shape points))
 
-        selrect (cond-> selrect
-                  round-coords? gpr/round-selrect)
-
-        ;; Redondear los points?
         base-rotation  (or (:rotation shape) 0)
         modif-rotation (or (get-in shape [:modifiers :rotation]) 0)
         rotation       (mod (+ base-rotation modif-rotation) 360)]
@@ -287,8 +295,10 @@
               (assoc :transform-inverse transform-inverse)))
         (cond-> (not transform)
           (dissoc :transform :transform-inverse))
-        (assoc :selrect selrect)
-        (assoc :points points)
+        (cond-> (some? selrect)
+          (assoc :selrect selrect))
+        (cond-> (d/not-empty? points)
+          (assoc :points points))
         (assoc :rotation rotation))))
 
 (defn- update-group-viewbox
@@ -309,7 +319,8 @@
                    (update :width + (:width deltas))
                    (update :height + (:height deltas)))))))
 
-(defn update-group-selrect [group children]
+(defn update-group-selrect
+  [group children]
   (let [shape-center (gco/center-shape group)
         ;; Points for every shape inside the group
         points (->> children (mapcat :points))
@@ -335,8 +346,20 @@
         ;; need to remove the flip flags
         (assoc :flip-x false)
         (assoc :flip-y false)
-        (apply-transform (gmt/matrix) true))))
+        (apply-transform (gmt/matrix)))))
 
+(defn update-mask-selrect
+  [masked-group children]
+  (let [mask (first children)]
+    (-> masked-group
+        (assoc :selrect (-> mask :selrect))
+        (assoc :points  (-> mask :points))
+        (assoc :x       (-> mask :selrect :x))
+        (assoc :y       (-> mask :selrect :y))
+        (assoc :width   (-> mask :selrect :width))
+        (assoc :height  (-> mask :selrect :height))
+        (assoc :flip-x  (-> mask :flip-x))
+        (assoc :flip-y  (-> mask :flip-y)))))
 
 ;; --- Modifiers
 
@@ -387,13 +410,14 @@
         width (:width new-size)
         height (:height new-size)
 
-        shape-transform (:transform shape (gmt/matrix))
-        shape-transform-inv (:transform-inverse shape (gmt/matrix))
+        shape-transform (:transform shape)
+        shape-transform-inv (:transform-inverse shape)
         shape-center (gco/center-shape shape)
         {sr-width :width sr-height :height} (:selrect shape)
 
-        origin (-> (gpt/point (:selrect shape))
-                   (transform-point-center shape-center shape-transform))
+        origin (cond-> (gpt/point (:selrect shape))
+                 (some? shape-transform)
+                 (transform-point-center shape-center shape-transform))
 
         scalev (gpt/divide (gpt/point width height)
                            (gpt/point sr-width sr-height))]
@@ -442,24 +466,28 @@
                                (normalize-scale (:y resize-v2))))
 
 
-         resize-transform (:resize-transform modifiers (gmt/matrix))
-         resize-transform-inverse (:resize-transform-inverse modifiers (gmt/matrix))
+         resize-transform (:resize-transform modifiers)
+         resize-transform-inverse (:resize-transform-inverse modifiers)
 
          rt-modif (:rotation modifiers)]
 
      (cond-> (gmt/matrix)
        (some? resize-1)
        (-> (gmt/translate origin-1)
-           (gmt/multiply resize-transform)
+           (cond-> (some? resize-transform)
+             (gmt/multiply resize-transform))
            (gmt/scale resize-1)
-           (gmt/multiply resize-transform-inverse)
+           (cond-> (some? resize-transform-inverse)
+             (gmt/multiply resize-transform-inverse))
            (gmt/translate (gpt/negate origin-1)))
 
        (some? resize-2)
        (-> (gmt/translate origin-2)
-           (gmt/multiply resize-transform)
+           (cond-> (some? resize-transform)
+             (gmt/multiply resize-transform))
            (gmt/scale resize-2)
-           (gmt/multiply resize-transform-inverse)
+           (cond-> (some? resize-transform-inverse)
+             (gmt/multiply resize-transform-inverse))
            (gmt/translate (gpt/negate origin-2)))
 
        (some? displacement)
@@ -503,9 +531,8 @@
                                             (d/parse-double)
                                             (* (get-in modifiers [:resize-vector :x] 1))
                                             (* (get-in modifiers [:resize-vector-2 :x] 1))
-                                            (mth/precision 2)
                                             (str))]
-                          (attrs/merge attrs {:font-size font-size})))]
+                          (d/txt-merge attrs {:font-size font-size})))]
       (update shape :content #(txt/transform-nodes
                                 txt/is-text-node?
                                 merge-attrs
@@ -513,64 +540,54 @@
     shape))
 
 (defn apply-modifiers
-  [shape modifiers round-coords?]
+  [shape modifiers]
   (let [center (gco/center-shape shape)
         transform (modifiers->transform center modifiers)]
-    (apply-transform shape transform round-coords?)))
+    (apply-transform shape transform)))
 
 (defn transform-shape
-  ([shape]
-   (transform-shape shape nil))
+  [shape]
+  (let [modifiers (:modifiers shape)]
+    (cond
+      (nil? modifiers)
+      shape
 
-  ([shape {:keys [round-coords?] :or {round-coords? true}}]
-   (let [modifiers (:modifiers shape)]
-     (cond
-       (nil? modifiers)
-       shape
+      (empty-modifiers? modifiers)
+      (dissoc shape :modifiers)
 
-       (empty-modifiers? modifiers)
-       (dissoc shape :modifiers)
+      :else
+      (let [shape     (apply-displacement shape)
+            modifiers (:modifiers shape)]
+        (cond-> shape
+          (not (empty-modifiers? modifiers))
+          (-> (set-flip modifiers)
+              (apply-modifiers modifiers)
+              (apply-text-resize modifiers))
 
-       :else
-       (let [shape     (apply-displacement shape)
-             modifiers (:modifiers shape)]
-         (cond-> shape
-           (not (empty-modifiers? modifiers))
-           (-> (set-flip modifiers)
-               (apply-modifiers modifiers round-coords?)
-               (apply-text-resize modifiers))
+          :always
+          (dissoc :modifiers))))))
 
-           :always
-           (dissoc :modifiers)))))))
-
-(defn transform-selrect
-  [selrect {:keys [displacement resize-transform-inverse resize-vector resize-origin resize-vector-2 resize-origin-2]}]
+(defn transform-bounds
+  [points center {: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))
 
         displacement
         (when (some? displacement)
-          (gmt/multiply resize-transform-inverse displacement)
-          #_(-> (gpt/point 0 0)
-              (gpt/transform displacement)
-              (gpt/transform resize-transform-inverse)
-              (gmt/translate-matrix)))
+          (gmt/multiply resize-transform-inverse displacement))
 
         resize-origin
         (when (some? resize-origin)
-          (transform-point-center resize-origin (gco/center-selrect selrect) resize-transform-inverse))
+          (transform-point-center resize-origin center resize-transform-inverse))
 
         resize-origin-2
         (when (some? resize-origin-2)
-          (transform-point-center resize-origin-2 (gco/center-selrect selrect) resize-transform-inverse))]
+          (transform-point-center resize-origin-2 center resize-transform-inverse))]
 
     (if (and (nil? displacement) (nil? resize-origin) (nil? resize-origin-2))
-      selrect
-
-      (cond-> selrect
-        :always
-        (gpr/rect->points)
+      points
 
+      (cond-> points
         (some? displacement)
         (gco/transform-points displacement)
 
@@ -578,11 +595,15 @@
         (gco/transform-points resize-origin (gmt/scale-matrix resize-vector))
 
         (some? resize-origin-2)
-        (gco/transform-points resize-origin-2 (gmt/scale-matrix resize-vector-2))
-
-        :always
-        (gpr/points->selrect)))))
+        (gco/transform-points resize-origin-2 (gmt/scale-matrix resize-vector-2))))))
 
+(defn transform-selrect
+  [selrect modifiers]
+  (let [center (gco/center-selrect selrect)]
+    (-> selrect
+        (gpr/rect->points)
+        (transform-bounds center modifiers)
+        (gpr/points->selrect))))
 
 (defn selection-rect
   "Returns a rect that contains all the shapes and is aware of the
@@ -591,3 +612,4 @@
   (->> shapes
        (map (comp gpr/points->selrect :points transform-shape))
        (gpr/join-selrects)))
+

common/src/app/common/logging.cljc

@@ -6,12 +6,13 @@
 
 (ns app.common.logging
   (:require
+   [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.uuid :as uuid]
-   [clojure.pprint :refer [pprint]]
+   [app.common.spec :as us]
    [cuerdas.core :as str]
+   [clojure.spec.alpha :as s]
    [fipp.edn :as fpp]
-   #?(:clj [io.aviso.exception :as ie])
    #?(:cljs [goog.log :as glog]))
   #?(:cljs (:require-macros [app.common.logging])
      :clj  (:import
@@ -20,7 +21,6 @@
             org.apache.logging.log4j.Logger
             org.apache.logging.log4j.ThreadContext
             org.apache.logging.log4j.CloseableThreadContext
-            org.apache.logging.log4j.message.MapMessage
             org.apache.logging.log4j.spi.LoggerContext)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -29,11 +29,22 @@
 
 #?(:clj (set! *warn-on-reflection* true))
 
-#?(:clj
-   (defn build-map-message
-     [m]
-     (let [message (MapMessage. (count m))]
-       (reduce-kv #(.with ^MapMessage %1 (name %2) %3) message m))))
+(def ^:private reserved-props
+  #{:level :cause ::logger ::async ::raw ::context})
+
+(def ^:private props-xform
+  (comp (partition-all 2)
+        (remove (fn [[k]] (contains? reserved-props k)))
+        (map vec)))
+
+(defn build-message
+  [props]
+  (loop [pairs  (sequence props-xform props)
+         result []]
+    (if-let [[k v] (first pairs)]
+      (recur (rest pairs)
+             (conj result (str/concat (d/name k) "=" (pr-str v))))
+      result)))
 
 #?(:clj
    (def logger-context
@@ -43,13 +54,6 @@
    (def logging-agent
      (agent nil :error-mode :continue)))
 
-(defn- simple-prune
-  ([s] (simple-prune s (* 1024 1024)))
-  ([s max-length]
-   (if (> (count s) max-length)
-     (str (subs s 0 max-length) " [...]")
-     s)))
-
 #?(:clj
    (defn stringify-data
      [val]
@@ -79,12 +83,6 @@
                          (stringify-data val)])))
            data)))
 
-#?(:clj
-   (defn set-context!
-     [data]
-     (ThreadContext/putAll (data->context-map data))
-     nil))
-
 #?(:clj
    (defmacro with-context
      [data & body]
@@ -137,35 +135,50 @@
 (defn write-log!
   [logger level exception message]
   #?(:clj
-     (if exception
-       (.log ^Logger    logger
-             ^Level     level
-             ^Object    message
-             ^Throwable exception)
-       (.log ^Logger logger
-             ^Level  level
-             ^Object message))
+     (let [message (if (string? message) message (str/join ", " message))]
+       (if exception
+         (.log ^Logger    logger
+               ^Level     level
+               ^Object    message
+               ^Throwable exception)
+         (.log ^Logger logger
+               ^Level  level
+               ^Object message)))
      :cljs
      (when glog/ENABLED
-       (when-let [l (get-logger logger)]
-         (let [level (get-level level)
-               record (glog/LogRecord. level message (.getName ^js l))]
-           (when exception (.setException record exception))
-           (glog/publishLogRecord l record))))))
+       (let [logger (get-logger logger)
+             level  (get-level level)]
+         (when (and logger (glog/isLoggable logger level))
+           (let [message (if (fn? message) (message) message)
+                 message (if (string? message) message (str/join ", " message))
+                 record  (glog/LogRecord. level message (.getName ^js logger))]
+             (when exception (.setException record exception))
+               (glog/publishLogRecord logger record)))))))
 
 #?(:clj
    (defn enabled?
      [logger level]
      (.isEnabled ^Logger logger ^Level level)))
 
+#?(:clj
+   (defn get-error-context
+     [error]
+     (when-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))}
+        (when (and data (::s/problems data))
+          {:spec-explain (us/pretty-explain data)})))))
+
 (defmacro log
-  [& {:keys [level cause ::logger ::async ::raw ::context] :or {async true} :as props}]
+  [& props]
   (if (:ns &env) ; CLJS
-    `(write-log! ~(or logger (str *ns*))
-                 ~level
-                 ~cause
-                 (or ~raw ~(dissoc props :level :cause ::logger ::raw ::context)))
-    (let [props      (dissoc props :level :cause ::logger ::async ::raw ::context)
+    (let [{:keys [level cause ::logger ::raw]} props]
+      `(write-log! ~(or logger (str *ns*)) ~level ~cause (or ~raw (fn [] (build-message ~(vec props))))))
+
+    (let [{:keys [level cause ::logger ::async ::raw ::context] :or {async true}} props
           logger     (or logger (str *ns*))
           logger-sym (gensym "log")
           level-sym  (gensym "log")]
@@ -173,15 +186,22 @@
              ~level-sym  (get-level ~level)]
          (when (enabled? ~logger-sym ~level-sym)
            ~(if async
-              `(->> (ThreadContext/getImmutableContext)
-                    (send-off logging-agent
-                              (fn [_# cdata#]
-                                (with-context (-> {:id (uuid/next)} (into cdata#) (into ~context))
-                                  (->> (or ~raw (build-map-message ~props))
-                                       (write-log! ~logger-sym ~level-sym ~cause))))))
-
-              `(let [message# (or ~raw (build-map-message ~props))]
-                 (write-log! ~logger-sym ~level-sym ~cause message#))))))))
+              `(do
+                 (send-off logging-agent
+                           (fn [_#]
+                             (let [message# (or ~raw (build-message ~(vec props)))]
+                               (with-context (-> {:id (uuid/next)}
+                                                 (into ~context)
+                                                 (into (get-error-context ~cause)))
+                                 (try
+                                   (write-log! ~logger-sym ~level-sym ~cause message#)
+                                   (catch Throwable cause#
+                                     (write-log! ~logger-sym (get-level :error) cause#
+                                                 "unexpected error on writting log")))))))
+                 nil)
+              `(let [message# (or ~raw (build-message ~(vec props)))]
+                 (write-log! ~logger-sym ~level-sym ~cause message#)
+                 nil)))))))
 
 (defmacro info
   [& params]
@@ -269,8 +289,8 @@
 #?(:cljs
    (defn- prepare-message
      [message]
-     (loop [kvpairs (seq message)
-            message (array-map)
+     (loop [kvpairs  (seq message)
+            message  []
             specials []]
        (if (nil? kvpairs)
          [message specials]
@@ -289,7 +309,7 @@
 
              :else
              (recur (next kvpairs)
-                    (assoc message k v)
+                    (conj message (str/concat (d/name k) "=" (pr-str v)))
                     specials)))))))
 
 #?(:cljs
@@ -305,7 +325,7 @@
            (js/console.log message header-styles normal-styles))
          (let [[message specials] (prepare-message message)]
            (if (seq specials)
-             (let [message (str header "%c" (pr-str message))]
+             (let [message (str header "%c" message)]
                (js/console.group message header-styles normal-styles)
                (doseq [[type n v] specials]
                  (case type
@@ -314,7 +334,7 @@
                             (js/console.error (pr-str v))
                             (js/console.error v))))
                (js/console.groupEnd message))
-             (let [message (str header "%c" (pr-str message))]
+             (let [message (str header "%c" message)]
                (js/console.log message header-styles normal-styles)))))
 
        (when exception
@@ -344,5 +364,3 @@
        (glog/removeHandler l default-console-handler)
        (glog/addHandler l default-console-handler)
        nil)))
-
-

common/src/app/common/math.cljc

@@ -106,6 +106,11 @@
   #?(:cljs (js/Math.round v)
      :clj (Math/round (float v))))
 
+(defn half-round
+  "Returns a value rounded to the next point or half point"
+  [v]
+  (/ (round (* v 2)) 2))
+
 (defn ceil
   "Returns the smallest integer greater than
   or equal to a given number."
@@ -115,7 +120,7 @@
 
 (defn precision
   [v n]
-  (when (and (number? v) (number? n))
+  (when (and (number? v) (integer? n))
     (let [d (pow 10 n)]
       (/ (round (* v d)) d))))
 
@@ -165,3 +170,7 @@
   [v0 v1 t]
   (+ (* (- 1 t) v0)
      (* t       v1)))
+
+(defn max-abs
+  [a b]
+  (max (abs a) (abs b)))

common/src/app/common/media.cljc

@@ -44,6 +44,21 @@
     "image/svg+xml" :svg
     nil))
 
+(defn mtype->extension [mtype]
+  ;; https://developer.mozilla.org/en-US/docs/Web/HTTP/Basics_of_HTTP/MIME_types
+  (case mtype
+    "image/apng"         ".apng"
+    "image/avif"         ".avif"
+    "image/gif"          ".gif"
+    "image/jpeg"         ".jpg"
+    "image/png"          ".png"
+    "image/svg+xml"      ".svg"
+    "image/webp"         ".webp"
+    "application/zip"    ".zip"
+    "application/penpot" ".penpot"
+    "application/pdf"    ".pdf"
+    nil))
+
 (def max-file-size (* 5 1024 1024))
 
 (s/def ::id uuid?)