⬆️ 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
    }}

.github/ISSUE_TEMPLATE/bug_report.md

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

.gitignore

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

CHANGES.md

@@ -1,5 +1,212 @@
 # 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
+
+### :sparkles: New features
+
+- Open feedback in a new window [Taiga #2901](https://tree.taiga.io/project/penpot/us/2901)
+- Improve usage of file menu [Taiga #2853](https://tree.taiga.io/project/penpot/us/2853)
+- Rotation to snap to 15º intervals with shift [Taiga #2437](https://tree.taiga.io/project/penpot/issue/2437)
+- Support border radius and stroke properties for images [Taiga #497](https://tree.taiga.io/project/penpot/us/497)
+- Disallow using same password as user email [Taiga #2454](https://tree.taiga.io/project/penpot/us/2454)
+- Add configurable nudge amount [Taiga #910](https://tree.taiga.io/project/penpot/us/910)
+- Add stroke properties for image shapes [Taiga #497](https://tree.taiga.io/project/penpot/us/497)
+- On user settings, hide the theme selector as long as we only have one theme [Taiga #2610](https://tree.taiga.io/project/penpot/us/2610)
+- Automatically open comments from dashboard notifications [Taiga #2605](https://tree.taiga.io/project/penpot/us/2605)
+- Enhance the behaviour of the artboards list on view mode [Taiga #2634](https://tree.taiga.io/project/penpot/us/2634)
+- Add recent used fonts in font selection widget [Taiga #1381](https://tree.taiga.io/project/penpot/us/1381)
+- Allow to align items relative to groups [Taiga #2533](https://tree.taiga.io/project/penpot/us/2533)
+- Scroll bars [Taiga #2550](https://tree.taiga.io/project/penpot/task/2550)
+- Add select layer option to context menu [Taiga #2474](https://tree.taiga.io/project/penpot/us/2474)
+- Guides [Taiga #290](https://tree.taiga.io/project/penpot/us/290)
+- Improve file menu by adding semantically groups [Github #1203](https://github.com/penpot/penpot/issues/1203)
+- Add update components in bulk option in context menu [Taiga #1975](https://tree.taiga.io/project/penpot/us/1975)
+- Create first E2E tests [Taiga #2608](https://tree.taiga.io/project/penpot/task/2608), [Taiga #2608](https://tree.taiga.io/project/penpot/task/2608)
+- Redesign of workspace toolbars [Taiga #2319](https://tree.taiga.io/project/penpot/us/2319)
+- Graphic Tablet usability improvements [Taiga #1913](https://tree.taiga.io/project/penpot/us/1913)
+- Improved mouse collision detection for groups and text shapes [Taiga #2452](https://tree.taiga.io/project/penpot/us/2452), [Taiga #2453](https://tree.taiga.io/project/penpot/us/2453)
+- Add support for alternative S3 storage providers and all aws regions [#1267](https://github.com/penpot/penpot/issues/1267)
+
+### :bug: Bugs fixed
+
+- Fixed ungroup typography when editing it [Taiga #2391](https://tree.taiga.io/project/penpot/issue/2391)
+- Fixed error when trying to post an empty comment [Taiga #2603](https://tree.taiga.io/project/penpot/issue/2603)
+- Fixed missing translation strings [Taiga #2786](https://tree.taiga.io/project/penpot/issue/2786)
+- Fixed color palette outside viewport [Taiga #2715](https://tree.taiga.io/project/penpot/issue/2715)
+- Fixed missing translate string [Taiga #2780](https://tree.taiga.io/project/penpot/issue/2780)
+- Fixed handoff shadow type text [Taiga #2717](https://tree.taiga.io/project/penpot/issue/2717)
+- Fixed components get "dirty" marker when moved [Taiga #2764](https://tree.taiga.io/project/penpot/issue/2764)
+- Fixed cannot align objects in a group that is not part of a frame [Taiga #2762](https://tree.taiga.io/project/penpot/issue/2762)
+- Fix problem with double click on exit path editing [Taiga #2906](https://tree.taiga.io/project/penpot/issue/2906)
+- Fixed alignment of layers with children [Taiga #2862](https://tree.taiga.io/project/penpot/issue/2862)
+
+### :heart: Community contributions by (Thank you!)
+
+- Cleanup unused static images (by @rhcarvalho) [#1561](https://github.com/penpot/penpot/pull/1561)
+- Compress static images to save space (by @rhcarvalho) [#1562](https://github.com/penpot/penpot/pull/1562)
+
 ## 1.11.2-beta
 
 ### :bug: Bugs fixed
@@ -18,7 +225,6 @@
 - Increase default max connection pool size to 60
 - Reduce resource usage of the error reporter.
 
-
 ## 1.11.1-beta
 
 ### :bug: Bugs fixed
@@ -30,11 +236,8 @@
 
 - Update nodejs version to 16.13.1 on docker images.
 
-
 ## 1.11.0-beta
 
-### :boom: Breaking changes
-
 ### :sparkles: New features
 
 - Add an option to hide artboards names on the viewport [Taiga #2034](https://tree.taiga.io/project/penpot/issue/2034)
@@ -112,7 +315,7 @@
 
 ### :arrow_up: Deps updates
 
-- Update devenv docker image dependencies.
+- Update devenv docker image dependencies
 
 ### :heart: Community contributions by (Thank you!)
 
@@ -124,13 +327,13 @@
 
 ### :sparkles: Enhacements
 
-- Allow parametrice file snapshoting interval.
+- Allow parametrice file snapshoting interval
 
 ### :bug: Bugs fixed
 
-- Fix issue on :mov-object change impl.
-- Minor fix on how file changes log is persisted.
-- Fix many issues on error reporting.
+- Fix issue on :mov-object change impl
+- Minor fix on how file changes log is persisted
+- Fix many issues on error reporting
 
 ## 1.10.3-beta
 

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.1-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.1"}
+  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"}
 
@@ -39,11 +40,14 @@
   org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
   integrant/integrant {:mvn/version "0.8.0"}
 
-  io.sentry/sentry {:mvn/version "5.5.2"}
+  io.sentry/sentry {:mvn/version "5.6.1"}
+
+  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.111"}}
+  software.amazon.awssdk/s3 {:mvn/version "2.17.136"}}
 
  :paths ["src" "resources" "target/classes"]
  :aliases
@@ -59,13 +63,10 @@
    :extra-paths ["test" "dev"]}
 
   :build
-  {:extra-deps {io.github.clojure/tools.build {:git/tag "v0.7.4" :git/sha "ac442da"}}
+  {:extra-deps
+   {io.github.clojure/tools.build {:git/tag "v0.7.7" :git/sha "1474ad6"}}
    :ns-default build}
 
-  :kaocha
-  {:extra-deps {lambdaisland/kaocha {:mvn/version "RELEASE"}}
-   :main-opts ["-m" "kaocha.runner"]}
-
   :test
   {:extra-paths ["test"]
    :extra-deps

backend/dev/user.clj

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

backend/scripts/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,13 +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-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,23 +41,22 @@
     data))
 
 (def defaults
-  {:http-server-port 6060
-   :http-server-host "0.0.0.0"
-   :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
 
@@ -65,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>"
 
@@ -92,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)
@@ -106,12 +100,21 @@
 (s/def ::file-change-snapshot-every ::us/integer)
 (s/def ::file-change-snapshot-timeout ::dt/duration)
 
+(s/def ::default-executor-parallelism ::us/integer)
+(s/def ::blocking-executor-parallelism ::us/integer)
+(s/def ::worker-executor-parallelism ::us/integer)
+
 (s/def ::secret-key ::us/string)
 (s/def ::allow-demo-users ::us/boolean)
 (s/def ::assets-path ::us/string)
+(s/def ::authenticated-cookie-domain ::us/string)
 (s/def ::database-password (s/nilable ::us/string))
 (s/def ::database-uri ::us/string)
 (s/def ::database-username (s/nilable ::us/string))
+(s/def ::database-readonly ::us/boolean)
+(s/def ::database-min-pool-size ::us/integer)
+(s/def ::database-max-pool-size ::us/integer)
+
 (s/def ::default-blob-version ::us/integer)
 (s/def ::error-report-webhook ::us/string)
 (s/def ::user-feedback-destination ::us/string)
@@ -131,9 +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-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)
@@ -162,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)
@@ -179,9 +189,11 @@
 (s/def ::storage-assets-fs-directory ::us/string)
 (s/def ::storage-assets-s3-bucket ::us/string)
 (s/def ::storage-assets-s3-region ::us/keyword)
+(s/def ::storage-assets-s3-endpoint ::us/string)
 (s/def ::storage-fdata-s3-bucket ::us/string)
 (s/def ::storage-fdata-s3-region ::us/keyword)
 (s/def ::storage-fdata-s3-prefix ::us/string)
+(s/def ::storage-fdata-s3-endpoint ::us/string)
 (s/def ::telemetry-uri ::us/string)
 (s/def ::telemetry-with-taiga ::us/boolean)
 (s/def ::tenant ::us/string)
@@ -198,11 +210,18 @@
                    ::allow-demo-users
                    ::audit-log-archive-uri
                    ::audit-log-gc-max-age
+                   ::authenticated-cookie-domain
                    ::database-password
                    ::database-uri
                    ::database-username
+                   ::database-readonly
+                   ::database-min-pool-size
+                   ::database-max-pool-size
                    ::default-blob-version
                    ::error-report-webhook
+                   ::default-executor-parallelism
+                   ::blocking-executor-parallelism
+                   ::worker-executor-parallelism
                    ::file-change-snapshot-every
                    ::file-change-snapshot-timeout
                    ::user-feedback-destination
@@ -221,10 +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-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
@@ -253,6 +278,7 @@
                    ::registration-domain-whitelist
                    ::registration-enabled
                    ::rlimit-font
+                   ::rlimit-file-update
                    ::rlimit-image
                    ::rlimit-password
                    ::sentry-dsn
@@ -274,10 +300,12 @@
                    ::storage-assets-fs-directory
                    ::storage-assets-s3-bucket
                    ::storage-assets-s3-region
+                   ::storage-assets-s3-endpoint
                    ::fdata-storage-backend
                    ::storage-fdata-s3-bucket
                    ::storage-fdata-s3-region
                    ::storage-fdata-s3-prefix
+                   ::storage-fdata-s3-endpoint
                    ::telemetry-enabled
                    ::telemetry-uri
                    ::telemetry-referer
@@ -285,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
@@ -317,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

@@ -47,13 +47,12 @@
 ;; Initialization
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(declare instrument-jdbc!)
 (declare apply-migrations!)
 
 (s/def ::connection-timeout ::us/integer)
-(s/def ::max-pool-size ::us/integer)
+(s/def ::max-size ::us/integer)
+(s/def ::min-size ::us/integer)
 (s/def ::migrations map?)
-(s/def ::min-pool-size ::us/integer)
 (s/def ::name keyword?)
 (s/def ::password ::us/string)
 (s/def ::read-only ::us/boolean)
@@ -62,38 +61,49 @@
 (s/def ::validation-timeout ::us/integer)
 
 (defmethod ig/pre-init-spec ::pool [_]
-  (s/keys :req-un [::uri ::name ::username ::password]
-          :opt-un [::min-pool-size
-                   ::max-pool-size
+  (s/keys :req-un [::uri ::name
+                   ::min-size
+                   ::max-size
                    ::connection-timeout
-                   ::validation-timeout
-                   ::migrations
+                   ::validation-timeout]
+          :opt-un [::migrations
+                   ::username
+                   ::password
                    ::mtx/metrics
                    ::read-only]))
 
+(defmethod ig/prep-key ::pool
+  [_ cfg]
+  (merge {:name :main
+          :min-size 0
+          :max-size 30
+          :connection-timeout 10000
+          :validation-timeout 10000
+          :idle-timeout 120000 ; 2min
+          :max-lifetime 1800000 ; 30m
+          :read-only false}
+         (d/without-nils cfg)))
+
 (defmethod ig/init-key ::pool
-  [_ {:keys [migrations metrics name] :as cfg}]
-  (l/info :action "initialize connection pool" :name (d/name name) :uri (:uri cfg))
-  (some-> metrics :registry instrument-jdbc!)
+  [_ {:keys [migrations name read-only] :as cfg}]
+  (l/info :hint "initialize connection pool"
+          :name (d/name name)
+          :uri (:uri cfg)
+          :read-only read-only
+          :with-credentials (and (contains? cfg :username)
+                                 (contains? cfg :password))
+          :min-size (:min-size cfg)
+          :max-size (:max-size cfg))
 
   (let [pool (create-pool cfg)]
-    (some->> (seq migrations) (apply-migrations! pool))
+    (when-not read-only
+      (some->> (seq migrations) (apply-migrations! pool)))
     pool))
 
 (defmethod ig/halt-key! ::pool
   [_ pool]
   (.close ^HikariDataSource pool))
 
-(defn- instrument-jdbc!
-  [registry]
-  (mtx/instrument-vars!
-   [#'next.jdbc/execute-one!
-    #'next.jdbc/execute!]
-   {:registry registry
-    :type :counter
-    :name "database_query_total"
-    :help "An absolute counter of database queries."}))
-
 (defn- apply-migrations!
   [pool migrations]
   (with-open [conn ^AutoCloseable (open pool)]
@@ -110,22 +120,19 @@
        "SET idle_in_transaction_session_timeout = 300000;"))
 
 (defn- create-datasource-config
-  [{:keys [metrics read-only] :or {read-only false} :as cfg}]
-  (let [dburi    (:uri cfg)
-        username (:username cfg)
-        password (:password cfg)
-        config   (HikariConfig.)]
+  [{:keys [metrics uri] :as cfg}]
+  (let [config (HikariConfig.)]
     (doto config
-      (.setJdbcUrl (str "jdbc:" dburi))
-      (.setPoolName (d/name (:name cfg)))
+      (.setJdbcUrl           (str "jdbc:" uri))
+      (.setPoolName          (d/name (:name cfg)))
       (.setAutoCommit true)
-      (.setReadOnly read-only)
-      (.setConnectionTimeout (:connection-timeout cfg 10000))  ;; 10seg
-      (.setValidationTimeout (:validation-timeout cfg 10000))  ;; 10seg
-      (.setIdleTimeout 120000)       ;; 2min
-      (.setMaxLifetime 1800000)      ;; 30min
-      (.setMinimumIdle     (:min-pool-size cfg 0))
-      (.setMaximumPoolSize (:max-pool-size cfg 50))
+      (.setReadOnly          (:read-only cfg))
+      (.setConnectionTimeout (:connection-timeout cfg))
+      (.setValidationTimeout (:validation-timeout cfg))
+      (.setIdleTimeout       (:idle-timeout cfg))
+      (.setMaxLifetime       (:max-lifetime cfg))
+      (.setMinimumIdle       (:min-size cfg))
+      (.setMaximumPoolSize   (:max-size cfg))
       (.setConnectionInitSql initsql)
       (.setInitializationFailTimeout -1))
 
@@ -135,8 +142,8 @@
            (PrometheusMetricsTrackerFactory.)
            (.setMetricsTrackerFactory config)))
 
-    (when username (.setUsername config username))
-    (when password (.setPassword config password))
+    (some->> ^String (:username cfg) (.setUsername config))
+    (some->> ^String (:password cfg) (.setPassword config))
 
     config))
 
@@ -146,10 +153,14 @@
 
 (s/def ::pool pool?)
 
-(defn pool-closed?
+(defn closed?
   [pool]
   (.isClosed ^HikariDataSource pool))
 
+(defn read-only?
+  [pool]
+  (.isReadOnly ^HikariDataSource pool))
+
 (defn create-pool
   [cfg]
   (let [dsc (create-datasource-config cfg)]
@@ -222,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,160 +7,176 @@
 (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.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)
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HTTP SERVER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (s/def ::handler fn?)
 (s/def ::router some?)
-(s/def ::port ::us/integer)
-(s/def ::host ::us/string)
-(s/def ::name ::us/string)
+(s/def ::port integer?)
+(s/def ::host string?)
+(s/def ::name string?)
 
-(defmethod ig/pre-init-spec ::server [_]
-  (s/keys :req-un [::port]
-          :opt-un [::name ::mtx/metrics ::router ::handler ::host]))
+(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"} (d/without-nils cfg)))
+  (merge {:name "http"
+          :port 6060
+          :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)))
 
-(defn- instrument-metrics
-  [^Server server metrics]
-  (let [stats (doto (StatisticsHandler.)
-                (.setHandler (.getHandler server)))]
-    (.setHandler server stats)
-    (mtx/instrument-jetty! (:registry metrics) stats)
-    server))
+(defmethod ig/pre-init-spec ::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 :msg "starting http server" :port port :host host :name name)
-  (let [options {:http/port port :http/host host}
-        handler (cond
-                  (fn? handler)  handler
-                  (some? router) (wrap-router router)
-                  :else (ex/raise :type :internal
-                                  :code :invalid-argument
-                                  :hint "Missing `handler` or `router` option."))
-        server  (-> (yt/server handler options)
-                    (cond-> metrics (instrument-metrics metrics)))]
-    (assoc opts :server (yt/start! server))))
+  [_ {: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
+                 :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 (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/server-timing]}
-        handler (rr/ring-handler router default options)]
-    (fn [request]
+  (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 _]
       (try
-        (handler request)
-        (catch Throwable e
-          (l/error :hint "unexpected error processing request"
-                   ::l/context (errors/get-error-context request e)
-                   :query-string (:query-string request)
-                   :cause e)
-          {:status 500 :body "internal server error"})))))
+        (handler request respond #(on-error % request respond))
+        (catch Throwable cause
+          (on-error cause request respond))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Http Router
+;; 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/etag]
-                          [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

@@ -14,8 +14,12 @@
    [app.metrics :as mtx]
    [app.storage :as sto]
    [app.util.time :as dt]
+   [app.worker :as wrk]
    [clojure.spec.alpha :as s]
-   [integrant.core :as ig]))
+   [integrant.core :as ig]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.response :as yrs]))
 
 (def ^:private cache-max-age
   (dt/duration {:hours 24}))
@@ -32,66 +36,83 @@
     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 [url (sto/get-object-url storage obj {:max-age signature-max-age})]
-        {:status 307
-         :headers {"location" (str url)
-                   "x-host"   (:host url)
-                   "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] :as cfg} _request id]
-  (let [obj (sto/get-object storage id)]
-    (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
-  [cfg request]
-  (let [id (get-in request [:path-params :id])]
-    (generic-handler cfg request (coerce-id id))))
+  "Handler that servers storage objects by id."
+  [{:keys [storage executor] :as cfg} request respond raise]
+  (-> (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)
+            (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
-  [{:keys [storage] :as cfg} request]
-  (let [id   (get-in request [:path-params :id])
-        mobj (get-file-media-object storage id)]
-    (generic-handler cfg request (:media-id mobj))))
+  "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
-  [{:keys [storage] :as cfg} request]
-  (let [id   (get-in request [:path-params :id])
-        mobj (get-file-media-object storage id)]
-    (generic-handler cfg request (or (:thumbnail-id mobj) (:media-id mobj)))))
-
+  "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)
+      (p/catch raise)))
 
 ;; --- Initialization
 
@@ -101,10 +122,16 @@
 (s/def ::signature-max-age ::dt/duration)
 
 (defmethod ig/pre-init-spec ::handlers [_]
-  (s/keys :req-un [::storage ::mtx/metrics ::assets-path ::cache-max-age ::signature-max-age]))
+  (s/keys :req-un [::storage
+                   ::wrk/executor
+                   ::mtx/metrics
+                   ::assets-path
+                   ::cache-max-age
+                   ::signature-max-age]))
 
 (defmethod ig/init-key ::handlers
   [_ cfg]
-  {:objects-handler #(objects-handler cfg %)
-   :file-objects-handler #(file-objects-handler cfg %)
-   :file-thumbnails-handler #(file-thumbnails-handler cfg %)})
+  {:objects-handler (partial objects-handler cfg)
+   :file-objects-handler (partial file-objects-handler cfg)
+   :file-thumbnails-handler (partial file-thumbnails-handler cfg)})
+

backend/src/app/http/awsns.clj

@@ -11,30 +11,41 @@
    [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]
-  (fn [request]
-    (let [body  (parse-json (slurp (:body request)))
+  [_ {:keys [executor] :as cfg}]
+  (fn [request respond _]
+    (let [data (slurp (:body request))]
+      (px/run! executor #(handle-request cfg data))
+      (respond (yrs/response 200)))))
+
+(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/send! {:uri surl :method :post :timeout 10000}))
+          (http-client {:uri surl :method :post :timeout 10000} {:sync? true}))
 
         (= mtype "Notification")
         (when-let [message (parse-json (get body "Message"))]
@@ -43,8 +54,11 @@
 
         :else
         (l/warn :hint "unexpected data received"
-                :report (pr-str body)))
-      {:status 200 :body ""})))
+                :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,16 +12,26 @@
    [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.blob :as blob]
    [app.util.template :as tmpl]
    [app.util.time :as dt]
+   [app.worker :as wrk]
    [clojure.java.io :as io]
+   [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [datoteka.core :as fs]
+   [emoji.core :as emj]
    [fipp.edn :as fpp]
-   [integrant.core :as ig]))
+   [integrant.core :as ig]
+   [markdown.core :as md]
+   [markdown.transformers :as mdt]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.request :as yrq]
+   [yetti.response :as yrs]))
 
 ;; (selmer.parser/cache-off!)
 
@@ -37,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
@@ -51,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))
@@ -79,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]
@@ -106,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
@@ -117,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 #":")
@@ -129,7 +154,8 @@
                                    (map :changes)
                                    (map blob/decode)
                                    (mapcat identity)
-                                   (vec))))
+                                   (vec))
+                          filename))
       :else
       (ex/raise :type :validation :code :invalid-arguments))))
 
@@ -150,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)
@@ -160,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
@@ -171,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")
@@ -188,25 +213,47 @@
               :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]
+    (-> (px/submit! executor #(f cfg request))
+        (p/then respond)
+        (p/catch raise))))
+
+(defmethod ig/pre-init-spec ::handlers [_]
+  (s/keys :req-un [::db/pool ::wrk/executor]))
 
 (defmethod ig/init-key ::handlers
   [_ cfg]
-  {:index (partial index cfg)
-   :health-check (partial health-check cfg)
-   :retrieve-file-data (partial retrieve-file-data cfg)
-   :retrieve-file-changes (partial retrieve-file-changes cfg)
-   :retrieve-error (partial retrieve-error cfg)
-   :retrieve-error-list (partial retrieve-error-list cfg)
-   :upload-file-data (partial upload-file-data cfg)})
+  {:index (wrap-async cfg index)
+   :health-check (wrap-async cfg health-check)
+   :retrieve-file-changes (wrap-async cfg retrieve-file-changes)
+   :retrieve-error (wrap-async cfg retrieve-error)
+   :retrieve-error-list (wrap-async cfg retrieve-error-list)
+   :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]
@@ -46,8 +47,8 @@
   [rpc]
   (let [context (prepare-context rpc)]
     (if (contains? cf/flags :backend-api-doc)
-      (fn [_]
-        {:status 200
-         :body (-> (io/resource "api-doc.tmpl")
-                   (tmpl/render context))})
-      (constantly {:status 404 :body ""}))))
+      (fn [_ respond _]
+        (respond (yrs/response 200 (-> (io/resource "api-doc.tmpl")
+                                       (tmpl/render context)))))
+      (fn [_ respond _]
+        (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

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

backend/src/app/http/middleware.clj

@@ -6,66 +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]
-   [buddy.core.codecs :as bc]
-   [buddy.core.hash :as bh]
-   [ring.core.protocols :as rp]
-   [ring.middleware.cookies :refer [wrap-cookies]]
-   [ring.middleware.keyword-params :refer [wrap-keyword-params]]
-   [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]
-  (let [seconds-from #(float (/ (- (System/nanoTime) %) 1000000000))]
-    (fn [request]
-      (let [start    (System/nanoTime)
-            response (handler request)]
-        (update response :headers
-                (fn [headers]
-                  (assoc headers "Server-Timing" (str "total;dur=" (seconds-from start)))))))))
+  (letfn [(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))))
 
-(defn wrap-parse-request-body
-  [handler]
-  (letfn [(parse-transit [body]
-            (let [reader (t/reader body)]
-              (t/read! reader)))
+                (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))))
 
-          (parse-json [body]
-            (json/read body))]
-    (fn [{:keys [headers body] :as request}]
-      (try
-        (let [ctype (get headers "content-type")]
-          (handler (case ctype
-                     "application/transit+json"
-                     (let [params (parse-transit body)]
-                       (-> request
-                           (assoc :body-params params)
-                           (update :params merge params)))
+                :else
+                request)))
 
-                     "application/json"
-                     (let [params (parse-json body)]
-                       (-> request
-                           (assoc :body-params params)
-                           (update :params merge params)))
+          (handle-error [raise cause]
+            (cond
+              (instance? RequestTooBigException cause)
+              (raise (ex/error :type :validation
+                               :code :request-body-too-large
+                               :hint (ex-message cause)))
 
-                     request)))
-        (catch Exception e
-          (let [data {:type :validation
-                      :code :unable-to-parse-request-body
-                      :hint "malformed params"}]
-            (l/error :hint (ex-message e) :cause e)
-            {:status 400
-             :headers {"content-type" "application/transit+json"}
-             :body (t/encode-str data {:type :json-verbose})}))))))
+              (instance? JsonEOFException cause)
+              (raise (ex/error :type :validation
+                               :code :malformed-json
+                               :hint (ex-message cause)))
+              :else
+              (raise cause)))]
 
-(def parse-request-body
-  {:name ::parse-request-body
-   :compile (constantly wrap-parse-request-body)})
+    (fn [request respond raise]
+      (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
+  {:name ::parse-request
+   :compile (constantly wrap-parse-request)})
 
 (defn buffered-output-stream
   "Returns a buffered output stream that ignores flush calls. This is
@@ -79,143 +90,105 @@
       (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- transit-streamable-body
-  [data opts]
-  (reify rp/StreamableResponseBody
-    (write-body-to-stream [_ _ output-stream]
-      ;; Use the same buffer as jetty output buffer size
-      (try
-        (with-open [bos (buffered-output-stream output-stream buffer-size)]
-          (let [tw (t/writer bos opts)]
-            (t/write! tw data)))
-        (catch org.eclipse.jetty.io.EofException _cause
-          ;; Do nothing, EOF means client closes connection abruptly
-          nil)
-        (catch Throwable cause
-          (l/warn :hint "unexpected error on encoding response"
-                  :cause cause))))))
-
-(defn- impl-format-response-body
-  [response {:keys [query-params] :as request}]
-  (let [body   (:body response)
-        opts   {:type (if (contains? query-params "transit_verbose") :json-verbose :json)}]
-
-    (cond
-      (:ws response)
-      response
-
-      (coll? body)
-      (-> response
-          (update :headers assoc "content-type" "application/transit+json")
-          (assoc :body (transit-streamable-body body opts)))
-
-      (nil? body)
-      (assoc response :status 204 :body "")
-
-      :else
-      response)))
-
-(defn- wrap-format-response-body
+(defn wrap-format-response
   [handler]
-  (fn [request]
-    (let [response (handler request)]
-      (cond-> response
-        (map? response) (impl-format-response-body request)))))
+  (letfn [(transit-streamable-body [data opts]
+            (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)))
 
-(def format-response-body
-  {:name ::format-response-body
-   :compile (constantly wrap-format-response-body)})
+                  (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))
+                  (finally
+                    (.close ^OutputStream output-stream))))))
+
+          (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)))
+
+          (process-response [response request]
+            (cond-> response
+              (map? response) (format-response request)))]
+
+    (fn [request respond raise]
+      (handler request
+               (fn [response]
+                 (let [response (process-response response request)]
+                   (respond response)))
+               raise))))
+
+(def format-response
+  {:name ::format-response
+   :compile (constantly wrap-format-response)})
 
 (defn wrap-errors
   [handler on-error]
-  (fn [request]
-    (try
-      (handler request)
-      (catch Throwable e
-        (on-error e request)))))
+  (fn [request respond _]
+    (handler request respond (fn [cause]
+                               (-> cause (on-error request) respond)))))
 
 (def errors
   {:name ::errors
    :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-etag
-  [handler]
-  (letfn [(encode [data]
-            (when (string? data)
-              (str "W/\"" (-> data bh/blake2b-128 bc/bytes->hex) "\"")))]
-    (fn [{method :request-method headers :headers :as request}]
-      (cond-> (handler request)
-        (= :get method)
-        (as-> $ (if-let [etag (-> $ :body meta :etag encode)]
-                  (cond-> (update $ :headers assoc "etag" etag)
-                    (= etag (get headers "if-none-match"))
-                    (-> (assoc :body "")
-                        (assoc :status 304)))
-                  $))))))
-
-(def etag
-  {:name ::etag
-   :compile (constantly wrap-etag)})
-
-(defn activity-logger
-  [handler]
-  (let [logger "penpot.profile-activity"]
-    (fn [{:keys [headers] :as request}]
-      (let [ip-addr    (get headers "x-forwarded-for")
-            profile-id (:profile-id request)
-            qstring    (:query-string request)]
-        (l/info ::l/async true
-                ::l/logger logger
-                :ip-addr ip-addr
-                :profile-id profile-id
-                :uri (str (:uri request) (when qstring (str "?" qstring)))
-                :method (name (:request-method request)))
-        (handler request)))))
-
-(defn- wrap-cors
+(defn wrap-cors
   [handler]
   (if-not (contains? cf/flags :cors)
     handler
-    (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"))))))]
-      (fn [request]
-        (if (= (:request-method request) :options)
-          (-> {:status 200 :body ""}
-              (add-cors-headers request))
-          (let [response (handler request)]
-            (add-cors-headers response request)))))))
+    (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 (= (yrq/method request) :options)
+          (-> (yrs/response 200)
+              (update-response request)
+              (respond))
+          (handler request
+                   (fn [response]
+                     (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,13 +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]))
+   [integrant.core :as ig]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.response :as yrs]))
 
 (defn- build-redirect-uri
   [{:keys [provider] :as cfg}]
@@ -40,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]
@@ -68,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
@@ -100,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]
@@ -199,6 +241,7 @@
 
       (->> (redirect-response uri)
            (sxf request)))
+
     (let [info   (assoc info
                         :iss :prepared-register
                         :is-active true
@@ -213,28 +256,33 @@
       (redirect-response uri))))
 
 (defn- auth-handler
-  [{:keys [tokens] :as cfg} {:keys [params] :as request}]
-  (let [invitation (:invitation-token params)
-        props      (extract-utm-props params)
-        state      (tokens :generate
-                           {:iss :oauth
-                            :invitation-token invitation
-                            :props props
-                            :exp (dt/in-future "15m")})
-        uri        (build-auth-uri cfg state)]
-    {:status 200
-     :body {:redirect-uri uri}}))
+  [{:keys [tokens] :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
-  [cfg request]
-  (try
-    (let [info     (retrieve-info cfg request)
-          profile  (retrieve-profile cfg info)]
-      (generate-redirect cfg request info profile))
-    (catch Exception e
-      (l/warn :hint "error on oauth process"
-              :cause e)
-      (generate-error-redirect cfg e))))
+  [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
 
@@ -250,15 +298,19 @@
 
 (defn wrap-handler
   [cfg handler]
-  (fn [request]
+  (fn [request respond raise]
     (let [provider (get-in request [:path-params :provider])
           provider (get-in @cfg [:providers provider])]
-      (when-not provider
-        (ex/raise :type :not-found
-                  :context {:provider provider}
-                  :hint "provider not configured"))
-      (-> (assoc @cfg :provider provider)
-          (handler request)))))
+      (if provider
+        (handler (assoc @cfg :provider provider)
+                 request
+                 respond
+                 raise)
+        (raise
+         (ex/error
+          :type :not-found
+          :provider provider
+          :hint "provider not configured"))))))
 
 (defmethod ig/init-key ::handler
   [_ cfg]
@@ -267,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
@@ -280,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
@@ -311,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)))
@@ -325,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')))
@@ -350,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
@@ -367,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

@@ -11,107 +11,209 @@
    [app.common.logging :as l]
    [app.config :as cfg]
    [app.db :as db]
+   [app.db.sql :as sql]
    [app.metrics :as mtx]
    [app.util.async :as aa]
    [app.util.time :as dt]
    [app.worker :as wrk]
    [clojure.core.async :as a]
    [clojure.spec.alpha :as s]
-   [integrant.core :as ig]))
+   [integrant.core :as ig]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.request :as yrq]))
 
-;; A default cookie name for storing the session. We don't allow
-;; configure it.
-(def cookie-name "auth-token")
+;; A default cookie name for storing the session. We don't allow to configure it.
+(def token-cookie-name "auth-token")
+
+;; A cookie that we can use to check from other sites of the same domain if a user
+;; is registered. Is not intended for on premise installations, although nothing
+;; prevents using it if some one wants to.
+(def authenticated-cookie-name "authenticated")
+
+(defprotocol ISessionStore
+  (read-session [store key])
+  (write-session [store key data])
+  (delete-session [store key]))
+
+(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}))))
+
+    (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})
+
+              now        (dt/now)
+              params     {:user-agent user-agent
+                          :profile-id profile-id
+                          :created-at now
+                          :updated-at now
+                          :id token}]
+          (db/insert! pool :http-session params)
+          token)))
+
+    (delete-session [_ token]
+      (px/with-dispatch executor
+        (db/delete! pool :http-session {:id token})
+        nil))))
+
+(defn make-inmemory-store
+  [{:keys [tokens]}]
+  (let [cache (atom {})]
+    (reify ISessionStore
+      (read-session [_ token]
+        (p/do (get @cache 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}]
+
+            (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
-  [{:keys [conn tokens] :as cfg} {:keys [profile-id headers] :as request}]
-  (let [token  (tokens :generate {:iss "authentication"
-                                  :iat (dt/now)
-                                  :uid profile-id})
-        now    (dt/now)
-        params {:user-agent (get headers "user-agent")
-                :profile-id profile-id
-                :created-at now
-                :updated-at now
-                :id token}]
-    (db/insert! conn :http-session params)))
+(defn- create-session!
+  [store request profile-id]
+  (let [params {:user-agent (yrq/get-header request "user-agent")
+                :profile-id profile-id}]
+    (write-session store nil params)))
 
-(defn- delete-session
-  [{:keys [conn] :as cfg} {:keys [cookies] :as request}]
-  (when-let [token (get-in cookies [cookie-name :value])]
-    (db/delete! conn :http-session {:id token}))
-  nil)
+(defn- delete-session!
+  [store {:keys [cookies] :as request}]
+  (when-let [token (get-in cookies [token-cookie-name :value])]
+    (delete-session store token)))
 
 (defn- retrieve-session
-  [{:keys [conn] :as cfg} id]
-  (when id
-    (db/exec-one! conn ["select id, profile_id from http_session where id = ?" id])))
-
-(defn- retrieve-from-request
-  [cfg {:keys [cookies] :as request}]
-  (->> (get-in cookies [cookie-name :value])
-       (retrieve-session cfg)))
+  [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 {:keys [id] :as session}]
+  [response token]
   (let [cors?   (contains? cfg/flags :cors)
-        secure? (contains? cfg/flags :secure-session-cookies)]
-    (assoc response :cookies {cookie-name {:path "/"
-                                           :http-only true
-                                           :value id
-                                           :same-site (if cors? :none :lax)
-                                           :secure secure?}})))
+        secure? (contains? cfg/flags :secure-session-cookies)
+        authenticated-cookie-domain (cfg/get :authenticated-cookie-domain)]
+    (update response :cookies
+            (fn [cookies]
+              (cond-> cookies
+                :always
+                (assoc token-cookie-name {:path "/"
+                                          :http-only true
+                                          :value token
+                                          :same-site (if cors? :none :lax)
+                                          :secure secure?})
+
+                (some? authenticated-cookie-domain)
+                (assoc authenticated-cookie-name {:domain authenticated-cookie-domain
+                                                  :path "/"
+                                                  :value true
+                                                  :same-site :strict
+                                                  :secure secure?}))))))
 
 (defn- clear-cookies
   [response]
-  (assoc response :cookies {cookie-name {:value "" :max-age -1}}))
+  (let [authenticated-cookie-domain (cfg/get :authenticated-cookie-domain)]
+    (assoc response :cookies
+           {token-cookie-name {:path "/"
+                               :value ""
+                               :max-age -1}
+            authenticated-cookie-name {:domain authenticated-cookie-domain
+                                       :path "/"
+                                       :value ""
+                                       :max-age -1}})))
+
+(defn- 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
-  [cfg handler]
-  (fn [request]
-    (if-let [{:keys [id profile-id] :as session} (retrieve-from-request cfg request)]
-      (do
-        (a/>!! (::events-ch cfg) id)
-        (l/set-context! {:profile-id profile-id})
-        (handler (assoc request :profile-id profile-id :session-id id)))
-      (handler request))))
 
 ;; --- STATE INIT: SESSION
 
-(defmethod ig/pre-init-spec ::session [_]
-  (s/keys :req-un [::db/pool]))
+(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)))
+  (d/merge {:buffer-size 128}
+           (d/without-nils cfg)))
+
+(defmethod ig/init-key :app.http/session
+  [_ {:keys [store] :as cfg}]
+  (let [events-ch (a/chan (a/dropping-buffer (:buffer-size cfg)))
+        cfg       (assoc cfg ::events-ch events-ch)]
 
-(defmethod ig/init-key ::session
-  [_ {:keys [pool] :as cfg}]
-  (let [events (a/chan (a/dropping-buffer (:buffer-size cfg)))
-        cfg    (-> cfg
-                   (assoc :conn pool)
-                   (assoc ::events-ch events))]
     (-> cfg
-        (assoc :middleware #(middleware cfg %))
+        (assoc :middleware (make-middleware cfg))
         (assoc :create (fn [profile-id]
                          (fn [request response]
-                           (let [request (assoc request :profile-id profile-id)
-                                 session (create-session cfg request)]
-                             (add-cookies response session)))))
+                           (p/let [token (create-session! store request profile-id)]
+                             (add-cookies response token)))))
         (assoc :delete (fn [request response]
-                         (delete-session cfg 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)
@@ -122,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]
@@ -138,16 +239,11 @@
           :max-batch-size (str (:max-batch-size cfg)))
   (let [input (aa/batch (::events-ch session)
                         {:max-batch-size (:max-batch-size cfg)
-                         :max-batch-age (inst-ms (:max-batch-age cfg))})
-        mcnt  (mtx/create
-               {:name "http_session_update_total"
-                :help "A counter of session update batch events."
-                :registry (:registry metrics)
-                :type :counter})]
+                         :max-batch-age (inst-ms (:max-batch-age cfg))})]
     (a/go-loop []
       (when-let [[reason batch] (a/<! input)]
         (let [result (a/<! (update-sessions cfg batch))]
-          (mcnt :inc)
+          (mtx/run! metrics {:id :session-update-total :inc 1})
           (cond
             (ex/exception? result)
             (l/error :task "updater"
@@ -159,6 +255,7 @@
                      :hint "update sessions"
                      :reason (name reason)
                      :count result))
+
           (recur))))))
 
 (defn- update-sessions

backend/src/app/http/websocket.clj

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

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

@@ -27,8 +27,9 @@
 (defonce enabled (atom true))
 
 (defn- persist-on-database!
-  [{:keys [pool]} {:keys [id] :as event}]
-  (db/insert! pool :server-error-report {:id id :content (db/tjson event)}))
+  [{:keys [pool] :as cfg} {:keys [id] :as event}]
+  (when-not (db/read-only? pool)
+    (db/insert! pool :server-error-report {:id id :content (db/tjson event)})))
 
 (defn- parse-event-data
   [event]

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

@@ -17,11 +17,42 @@
    {:uri        (cf/get :database-uri)
     :username   (cf/get :database-username)
     :password   (cf/get :database-password)
+    :read-only  (cf/get :database-readonly false)
     :metrics    (ig/ref :app.metrics/metrics)
     :migrations (ig/ref :app.migrations/all)
-    :name :main
-    :min-pool-size 0
-    :max-pool-size 60}
+    :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 resources
+   ;; demanding operations.
+   [::blocking :app.worker/executor]
+   {:parallelism (cf/get :blocking-executor-parallelism 10)
+    :prefix :blocking}
+
+   ;; Dedicated thread pool for backround tasks execution.
+   [::worker :app.worker/executor]
+   {: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])
+    :blocking (ig/ref [::blocking :app.worker/executor])}
+
+   :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
    {}
@@ -32,9 +63,9 @@
    :app.migrations/all
    {:main (ig/ref :app.migrations/migrations)}
 
-
    :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
@@ -43,18 +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.storage/recheck-task
+   :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)
-    :storage  (ig/ref :app.storage/storage)}
-
-   :app.http.session/session
-   {: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)
@@ -63,42 +98,49 @@
    :app.http.session/updater
    {:pool           (ig/ref :app.db/pool)
     :metrics        (ig/ref :app.metrics/metrics)
-    :executor       (ig/ref :app.worker/executor)
-    :session        (ig/ref :app.http.session/session)
+    :executor       (ig/ref [::worker :app.worker/executor])
+    :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)}
+   {:port        (cf/get :http-server-port)
+    :host        (cf/get :http-server-host)
+    :router      (ig/ref :app.http/router)
+    :metrics     (ig/ref :app.metrics/metrics)
+    :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)}
+   {:pool (ig/ref :app.db/pool)
+    :executor (ig/ref [::worker :app.worker/executor])}
 
    :app.http.websocket/handler
    {:pool     (ig/ref :app.db/pool)
-    :executor (ig/ref :app.worker/executor)
     :metrics  (ig/ref :app.metrics/metrics)
     :msgbus   (ig/ref :app.msgbus/msgbus)}
 
@@ -106,49 +148,50 @@
    {:metrics           (ig/ref :app.metrics/metrics)
     :assets-path       (cf/get :assets-path)
     :storage           (ig/ref :app.storage/storage)
+    :executor          (ig/ref [::default :app.worker/executor])
     :cache-max-age     (dt/duration {:hours 24})
     :signature-max-age (dt/duration {:hours 24 :minutes 5})}
 
    :app.http.feedback/handler
-   {:pool (ig/ref :app.db/pool)}
+   {:pool     (ig/ref :app.db/pool)
+    :executor (ig/ref [::default :app.worker/executor])}
 
    :app.http.oauth/handler
-   {:rpc        (ig/ref :app.rpc/rpc)
-    :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)
-    :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)}
-
-   :app.worker/executor
-   {:min-threads 0
-    :max-threads 256
-    :idle-timeout 60000
-    :name :worker}
+   {: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 :app.worker/executor)
+   {:executor (ig/ref [::worker :app.worker/executor])
     :tasks    (ig/ref :app.worker/registry)
     :metrics  (ig/ref :app.metrics/metrics)
     :pool     (ig/ref :app.db/pool)}
 
-   :app.worker/scheduler
-   {:executor   (ig/ref :app.worker/executor)
+   :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}
@@ -162,15 +205,15 @@
      {:cron #app/cron "0 0 0 * * ?"  ;; daily
       :task :session-gc}
 
-     {:cron #app/cron "0 0 * * * ?"  ;; hourly
-      :task :storage-recheck}
-
      {:cron #app/cron "0 0 0 * * ?"  ;; daily
       :task :objects-gc}
 
      {: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})
@@ -181,23 +224,17 @@
 
      (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)
-     :storage-recheck    (ig/ref :app.storage/recheck-task)
      :tasks-gc           (ig/ref :app.tasks.tasks-gc/handler)
      :telemetry          (ig/ref :app.tasks.telemetry/handler)
      :session-gc         (ig/ref :app.http.session/gc-task)
@@ -225,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}
 
@@ -243,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)
@@ -261,69 +299,65 @@
 
    :app.loggers.audit/http-handler
    {:pool     (ig/ref :app.db/pool)
-    :executor (ig/ref :app.worker/executor)}
+    :executor (ig/ref [::default :app.worker/executor])}
 
    :app.loggers.audit/collector
    {:pool     (ig/ref :app.db/pool)
-    :executor (ig/ref :app.worker/executor)}
+    :executor (ig/ref [::worker :app.worker/executor])}
 
    :app.loggers.audit/archive-task
-   {:uri      (cf/get :audit-log-archive-uri)
-    :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 :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 :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)
     :pool     (ig/ref :app.db/pool)
-    :executor (ig/ref :app.worker/executor)}
-
-   :app.loggers.sentry/reporter
-   {:dsn                (cf/get :sentry-dsn)
-    :trace-sample-rate  (cf/get :sentry-trace-sample-rate 1.0)
-    :attach-stack-trace (cf/get :sentry-attach-stack-trace false)
-    :debug              (cf/get :sentry-debug false)
-    :receiver (ig/ref :app.loggers.zmq/receiver)
-    :pool     (ig/ref :app.db/pool)
-    :executor (ig/ref :app.worker/executor)}
+    :executor (ig/ref [::worker :app.worker/executor])}
 
    :app.storage/storage
    {:pool     (ig/ref :app.db/pool)
-    :executor (ig/ref :app.worker/executor)
+    :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])
-               :assets-fs (ig/ref [::assets :app.storage.fs/backend])
-               :tmp       (ig/ref [::tmp  :app.storage.fs/backend])
-               :fdata-s3  (ig/ref [::fdata :app.storage.s3/backend])
+    :backends
+    {:assets-s3 (ig/ref [::assets :app.storage.s3/backend])
+     :assets-db (ig/ref [::assets :app.storage.db/backend])
+     :assets-fs (ig/ref [::assets :app.storage.fs/backend])
 
-               ;; keep this for backward compatibility
-               :s3        (ig/ref [::assets :app.storage.s3/backend])
-               :fs        (ig/ref [::assets :app.storage.fs/backend])}}
+     :tmp       (ig/ref [::tmp  :app.storage.fs/backend])
+     :fdata-s3  (ig/ref [::fdata :app.storage.s3/backend])
+
+     ;; keep this for backward compatibility
+     :s3        (ig/ref [::assets :app.storage.s3/backend])
+     :fs        (ig/ref [::assets :app.storage.fs/backend])}}
 
    [::fdata :app.storage.s3/backend]
-   {:region (cf/get :storage-fdata-s3-region)
-    :bucket (cf/get :storage-fdata-s3-bucket)
-    :prefix (cf/get :storage-fdata-s3-prefix)}
+   {:region   (cf/get :storage-fdata-s3-region)
+    :bucket   (cf/get :storage-fdata-s3-bucket)
+    :endpoint (cf/get :storage-fdata-s3-endpoint)
+    :prefix   (cf/get :storage-fdata-s3-prefix)
+    :executor (ig/ref [::default :app.worker/executor])}
 
    [::assets :app.storage.s3/backend]
-   {:region (cf/get :storage-assets-s3-region)
-    :bucket (cf/get :storage-assets-s3-bucket)}
+   {:region   (cf/get :storage-assets-s3-region)
+    :endpoint (cf/get :storage-assets-s3-endpoint)
+    :bucket   (cf/get :storage-assets-s3-bucket)
+    :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,9 +318,10 @@
 
 (defn configure-assets-storage
   "Given storage map, returns a storage configured with the appropriate
-  backend for assets."
-  [storage conn]
-  (-> storage
-      (assoc :conn conn)
-      (assoc :backend (cf/get :assets-storage-backend :assets-fs))))
-
+  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

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

backend/src/app/migrations.clj

@@ -205,6 +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

@@ -0,0 +1,13 @@
+CREATE TABLE file_frame_thumbnail (
+  file_id uuid NOT NULL REFERENCES file(id) ON DELETE CASCADE,
+  frame_id uuid NOT NULL,
+  created_at timestamptz NOT NULL DEFAULT now(),
+  updated_at timestamptz NOT NULL DEFAULT clock_timestamp(),
+
+  data text NULL,
+
+  PRIMARY KEY(file_id, frame_id)
+);
+
+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,18 +7,20 @@
 (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]
    [promesa.core :as p])
   (:import
-   java.time.Duration
    io.lettuce.core.RedisClient
    io.lettuce.core.RedisURI
    io.lettuce.core.api.StatefulConnection
@@ -29,7 +31,12 @@
    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))
 
@@ -37,266 +44,254 @@
   [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 [_])
+(defn- redis-connect
+  [{:keys [redis-uri timeout] :as cfg}]
+  (let [codec     (RedisCodec/of StringCodec/UTF8 ByteArrayCodec/INSTANCE)
 
-(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)))
+        resources (.. (DefaultClientResources/builder)
+                      (ioThreadPoolSize 4)
+                      (computationThreadPoolSize 4)
+                      (build))
 
-        (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))
+        uri       (RedisURI/create redis-uri)
+        rclient   (RedisClient/create ^ClientResources resources ^RedisURI uri)
 
-        :else
-        (->> (vals state)
-             (mapcat identity)
-             (run! a/close!))))))
+        pconn     (.connect ^RedisClient rclient ^RedisCodec codec)
+        sconn     (.connectPubSub ^RedisClient rclient ^RedisCodec codec)]
 
-
-;; 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)
-
-        uri      (RedisURI/create redis-uri)
-        rclient  (RedisClient/create ^RedisURI uri)
-
-        pub-conn (.connect ^RedisClient rclient ^RedisCodec codec)
-        sub-conn (.connectPubSub ^RedisClient rclient ^RedisCodec codec)]
-
-    (.setTimeout ^StatefulRedisConnection pub-conn ^Duration (dt/duration {:seconds 10}))
-    (.setTimeout ^StatefulRedisPubSubConnection sub-conn ^Duration (dt/duration {:seconds 10}))
+    (.setTimeout ^StatefulRedisConnection pconn ^Duration timeout)
+    (.setTimeout ^StatefulRedisPubSubConnection sconn ^Duration timeout)
 
     (-> cfg
-        (assoc ::pub-conn pub-conn)
-        (assoc ::sub-conn sub-conn))))
+        (assoc ::resources resources)
+        (assoc ::pconn pconn)
+        (assoc ::sconn sconn))))
 
-(defmethod stop-backend :redis
-  [{:keys [::pub-conn ::sub-conn] :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

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

backend/src/app/rpc/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/comments.clj

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

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

@@ -17,16 +17,20 @@
    [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.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)
 
 ;; --- Helpers & Specs
 
+(s/def ::frame-id ::us/uuid)
+(s/def ::file-id ::us/uuid)
 (s/def ::id ::us/uuid)
 (s/def ::name ::us/string)
 (s/def ::profile-id ::us/uuid)
@@ -54,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))
@@ -64,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})]
@@ -123,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
@@ -270,6 +275,7 @@
          (contains? o :changes-with-metadata)))))
 
 (sv/defmethod ::update-file
+  {::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)
@@ -291,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}]
@@ -305,24 +312,21 @@
               :context {:incoming-revn (:revn params)
                         :stored-revn (:revn file)}))
 
-  (let [mtx1    (get-in metrics [:definitions :update-file-changes])
-        mtx2    (get-in metrics [:definitions :update-file-bytes-processed])
-
-        changes (if changes-with-metadata
+  (let [changes (if changes-with-metadata
                   (mapcat :changes changes-with-metadata)
                   changes)
 
         changes (vec changes)
 
         ;; Trace the number of changes processed
-        _       ((::mtx/fn mtx1) {:by (count changes)})
+        _       (mtx/run! metrics {:id :update-file-changes :inc (count changes)})
 
         ts      (dt/now)
-        file    (-> (files/retrieve-data cfg file)
+        file    (-> file
                     (update :revn inc)
                     (update :data (fn [data]
                                     ;; Trace the length of bytes of processed data
-                                    ((::mtx/fn mtx2) {:by (alength data)})
+                                    (mtx/run! metrics {:id :update-file-bytes-processed :inc (alength data)})
                                     (-> data
                                         (blob/decode)
                                         (assoc :id (:id file))
@@ -352,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}
@@ -384,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]
@@ -470,5 +476,48 @@
                        :revn revn
                        :data (blob/encode data)}
                       {:id id})))
-
+      nil)))
+
+;; --- Mutation: upsert object thumbnail
+
+(def sql:upsert-object-thumbnail
+  "insert into file_object_thumbnail(file_id, object_id, data)
+   values (?, ?, ?)
+       on conflict(file_id, object_id) do
+          update set 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-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)
+    (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,6 +6,7 @@
 
 (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]
@@ -13,11 +14,13 @@
    [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.rlimit :as rlimit]
    [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)
 
@@ -31,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
@@ -41,50 +43,74 @@
 (sv/defmethod ::create-font-variant
   {::rlimit/permits (cf/get :rlimit-font)}
   [{:keys [pool] :as cfg} {:keys [team-id profile-id] :as params}]
-  (db/with-atomic [conn pool]
-    (let [cfg (assoc cfg :conn conn)]
-      (teams/check-edition-permissions! conn profile-id team-id)
-      (create-font-variant cfg params))))
+  (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 [conn storage] :as cfg} {:keys [data] :as params}]
-  (let [data    (media/run {:cmd :generate-fonts :input data})
-        storage (media/configure-assets-storage storage conn)
+  [{: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})))
 
-        otf     (when-let [fdata (get data "font/otf")]
-                  (sto/put-object storage {:content (sto/content fdata)
-                                           :content-type "font/otf"}))
+          ;; 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)))
 
-        ttf     (when-let [fdata (get data "font/ttf")]
-                  (sto/put-object storage {:content (sto/content fdata)
-                                           :content-type "font/ttf"}))
+          (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)
 
-        woff1   (when-let [fdata (get data "font/woff")]
-                  (sto/put-object storage {:content (sto/content fdata)
-                                           :content-type "font/woff"}))
+          (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"}))))
 
-        woff2   (when-let [fdata (get data "font/woff2")]
-                  (sto/put-object storage {:content (sto/content fdata)
-                                           :content-type "font/woff2"}))]
+          (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")]
 
-    (when (and (nil? otf)
-               (nil? ttf)
-               (nil? woff1)
-               (nil? woff2))
-      (ex/raise :type :validation
-                :code :invalid-font-upload))
+              (d/without-nils
+               {:otf otf
+                :ttf ttf
+                :woff1 woff1
+                :woff2 woff2})))
 
-    (db/insert! conn :team-font-variant
-                {:id (uuid/next)
-                 :team-id (:team-id params)
-                 :font-id (:font-id params)
-                 :font-family (:font-family params)
-                 :font-weight (:font-weight params)
-                 :font-style (:font-style params)
-                 :woff1-file-id (:id woff1)
-                 :woff2-file-id (:id woff2)
-                 :otf-file-id (:id otf)
-                 :ttf-file-id (:id ttf)})))
+          (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/ldap.clj

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

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

@@ -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]
@@ -14,13 +15,13 @@
    [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.http :as http]
-   [app.util.rlimit :as rlimit]
    [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
@@ -39,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
@@ -51,11 +50,10 @@
 (sv/defmethod ::upload-file-media-object
   {::rlimit/permits (cf/get :rlimit-image)}
   [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
-  (db/with-atomic [conn pool]
-    (let [file (select-file conn file-id)]
-      (teams/check-edition-permissions! conn profile-id (:team-id file))
-      (-> (assoc cfg :conn conn)
-          (create-file-media-object params)))))
+  (let [file (select-file pool file-id)
+        cfg  (update cfg :storage media/configure-assets-storage)]
+    (teams/check-edition-permissions! pool profile-id (:team-id file))
+    (create-file-media-object cfg params)))
 
 (defn- big-enough-for-thumbnail?
   "Checks if the provided image info is big enough for
@@ -68,30 +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))))
-
-(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
-                         :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.
@@ -102,62 +76,155 @@
        on conflict (id) do update set created_at=file_media_object.created_at
        returning *")
 
+;; NOTE: the following function executes without a transaction, this
+;; means that if something fails in the middle of this function, it
+;; will probably leave leaked/unreferenced objects in the database and
+;; probably in the storage layer. For handle possible object leakage,
+;; we create all media objects marked as touched, this ensures that if
+;; something fails, all leaked (already created storage objects) will
+;; be eventually marked as deleted by the touched-gc task.
+;;
+;; The touched-gc task, performs periodic analisis of all touched
+;; storage objects and check references of it. This is the reason why
+;; `reference` metadata exists: it indicates the name of the table
+;; witch holds the reference to storage object (it some kind of
+;; inverse, soft referential integrity).
+
 (defn create-file-media-object
-  [{:keys [conn storage] :as cfg} {:keys [id file-id is-local name content] :as params}]
-  (media/validate-media-type (:content-type content))
-  (let [storage      (media/configure-assets-storage storage conn)
-        source-path  (fs/path (:tempfile content))
-        source-mtype (:content-type content)
-        source-info  (media/run {:cmd :info :input {:path source-path :mtype source-mtype}})
+  [{: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)}))
-                       (sto/put-object storage {:content (sto/content source-path)
-                                                :content-type (:mtype source-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)))
 
-        thumb        (when thumb
-                       (sto/put-object storage {:content (sto/content (:data thumb) (:size thumb))
-                                                :content-type (:mtype thumb)}))]
+          ;; 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! conn [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
-  [{:keys [pool storage] :as cfg} {:keys [profile-id file-id url name] :as params}]
-  (db/with-atomic [conn pool]
-    (let [file (select-file conn file-id)]
-      (teams/check-edition-permissions! conn profile-id (:team-id file))
-      (let [mobj    (download-media cfg url)
-            content {:filename "tempfile"
-                     :size (:size mobj)
-                     :tempfile (sto/get-object-path storage mobj)
-                     :content-type (:content-type (meta mobj))}
-            params' (merge params {:content content
-                                   :name (or name (:filename content))})]
-        (-> (assoc cfg :conn conn)
-            (create-file-media-object params'))))))
+  {::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))
+    (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)))))
 
 ;; --- Clone File Media object (Upload and create from url)
 
@@ -171,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)))))
 
@@ -189,7 +255,6 @@
                  :height (:height mobj)
                  :mtype  (:mtype mobj)})))
 
-
 ;; --- HELPERS
 
 (def ^:private

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.metrics :as mtx]
    [app.rpc.mutations.teams :as teams]
    [app.rpc.queries.profile :as profile]
+   [app.rpc.rlimit :as rlimit]
    [app.storage :as sto]
-   [app.util.rlimit :as rlimit]
    [app.util.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)
@@ -38,7 +39,6 @@
 (s/def ::theme ::us/string)
 (s/def ::invitation-token ::us/not-empty-string)
 
-(declare annotate-profile-register)
 (declare check-profile-existence!)
 (declare create-profile)
 (declare create-profile-relations)
@@ -100,8 +100,15 @@
 (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))
       (ex/raise :type :validation
@@ -116,10 +123,19 @@
 
   (check-profile-existence! pool params)
 
-  (let [params (assoc params
-                      :backend "penpot"
-                      :iss :prepared-register
-                      :exp (dt/in-future "48h"))
+  (when (= (str/lower (:email params))
+           (str/lower (:password params)))
+    (ex/raise :type :validation
+              :code :email-as-password
+              :hint "you can't use your email as password"))
+
+  (let [params {:email (:email params)
+                :password (:password params)
+                :invitation-token (:invitation-token params)
+                :backend "penpot"
+                :iss :prepared-register
+                :exp (dt/in-future "48h")}
+
         token  (tokens :generate params)]
     {:token token}))
 
@@ -136,43 +152,29 @@
     (-> (assoc cfg :conn conn)
         (register-profile params))))
 
-(defn- annotate-profile-register
-  "A helper for properly increase the profile-register metric once the
-  transaction is completed."
-  [metrics]
-  (fn []
-    (let [mobj (get-in metrics [:definitions :profile-register])]
-      ((::mtx/fn mobj) {:by 1}))))
-
 (defn register-profile
-  [{:keys [conn tokens session metrics] :as cfg} {:keys [token] :as params}]
+  [{:keys [conn tokens session] :as cfg} {:keys [token] :as params}]
   (let [claims    (tokens :verify {:token token :iss :prepared-register})
         params    (merge params claims)]
-
     (check-profile-existence! conn params)
-
-    (let [is-active (or (:is-active params)
-                        (contains? cf/flags :insecure-register))
-          profile   (->> (assoc params :is-active is-active)
-                         (create-profile conn)
-                         (create-profile-relations conn)
-                         (decode-profile-row))]
+    (let [is-active  (or (:is-active params)
+                         (contains? cf/flags :insecure-register))
+          profile    (->> (assoc params :is-active is-active)
+                          (create-profile conn)
+                          (create-profile-relations conn)
+                          (decode-profile-row))
+          invitation (when-let [token (:invitation-token params)]
+                       (tokens :verify {:token token :iss :team-invitation}))]
       (cond
-        ;; If invitation token comes in params, this is because the
-        ;; user comes from team-invitation process; in this case,
-        ;; regenerate token and send back to the user a new invitation
-        ;; token (and mark current session as logged).
-        (some? (:invitation-token params))
-        (let [token (:invitation-token params)
-              claims (tokens :verify {:token token :iss :team-invitation})
-              claims (assoc claims
-                            :member-id  (:id profile)
-                            :member-email (:email profile))
+        ;; If invitation token comes in params, this is because the user comes from team-invitation process;
+        ;; in this case, regenerate token and send back to the user a new invitation token (and mark current
+        ;; session as logged). This happens only if the invitation email matches with the register email.
+        (and (some? invitation) (= (:email profile) (:member-email invitation)))
+        (let [claims (assoc invitation :member-id  (:id profile))
               token  (tokens :generate claims)
               resp   {:invitation-token token}]
           (with-meta resp
             {:transform-response ((:create session) (:id profile))
-             :before-complete (annotate-profile-register metrics)
              ::audit/props (audit/profile->props profile)
              ::audit/profile-id (:id profile)}))
 
@@ -182,7 +184,6 @@
         (not= "penpot" (:auth-backend profile))
         (with-meta (profile/strip-private-attrs profile)
           {:transform-response ((:create session) (:id profile))
-           :before-complete (annotate-profile-register metrics)
            ::audit/props (audit/profile->props profile)
            ::audit/profile-id (:id profile)})
 
@@ -191,7 +192,6 @@
         (true? is-active)
         (with-meta (profile/strip-private-attrs profile)
           {:transform-response ((:create session) (:id profile))
-           :before-complete (annotate-profile-register metrics)
            ::audit/props (audit/profile->props profile)
            ::audit/profile-id (:id profile)})
 
@@ -214,8 +214,7 @@
                       :extra-data ptoken})
 
           (with-meta profile
-            {:before-complete (annotate-profile-register metrics)
-             ::audit/props (audit/profile->props profile)
+            {::audit/props (audit/profile->props profile)
              ::audit/profile-id (:id profile)}))))))
 
 (defn create-profile
@@ -224,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))
 
@@ -286,6 +285,12 @@
 (sv/defmethod ::login
   {:auth false ::rlimit/permits (cf/get :rlimit-password)}
   [{:keys [pool session tokens] :as cfg} {:keys [email password] :as params}]
+
+  (when-not (contains? cf/flags :login)
+    (ex/raise :type :restriction
+              :code :login-disabled
+              :hint "login is disabled in this instance"))
+
   (letfn [(check-password [profile password]
             (when (= (:password profile) "!")
               (ex/raise :type :validation
@@ -305,32 +310,26 @@
             profile)]
 
     (db/with-atomic [conn pool]
-      (let [profile (->> (profile/retrieve-profile-data-by-email conn email)
-                         (validate-profile)
-                         (profile/strip-private-attrs)
-                         (profile/populate-additional-data conn)
-                         (decode-profile-row))]
-        (if-let [token (:invitation-token params)]
-          ;; If the request comes with an invitation token, this means
-          ;; that user wants to accept it with different user. A very
-          ;; strange case but still can happen. In this case, we
-          ;; proceed in the same way as in register: regenerate the
-          ;; invitation token and return it to the user for proper
-          ;; invitation acceptation.
-          (let [claims (tokens :verify {:token token :iss :team-invitation})
-                claims (assoc claims
-                              :member-id  (:id profile)
-                              :member-email (:email profile))
-                token  (tokens :generate claims)]
-            (with-meta {:invitation-token token}
-              {:transform-response ((:create session) (:id profile))
-               ::audit/props (audit/profile->props profile)
-               ::audit/profile-id (:id profile)}))
+      (let [profile    (->> (profile/retrieve-profile-data-by-email conn email)
+                            (validate-profile)
+                            (profile/strip-private-attrs)
+                            (profile/populate-additional-data conn)
+                            (decode-profile-row))
 
-          (with-meta profile
-            {:transform-response ((:create session) (:id profile))
-             ::audit/props (audit/profile->props profile)
-             ::audit/profile-id (:id profile)}))))))
+            invitation (when-let [token (:invitation-token params)]
+                         (tokens :verify {:token token :iss :team-invitation}))
+
+            ;; If invitation member-id does not matches the profile-id, we just proceed to ignore the
+            ;; invitation because invitations matches exactly; and user can't loging with other email and
+            ;; accept invitation with other email
+            response   (if (and (some? invitation) (= (:id profile) (:member-id invitation)))
+                         {:invitation-token (:invitation-token params)}
+                         profile)]
+
+        (with-meta response
+          {:transform-response ((:create session) (:id profile))
+           ::audit/props (audit/profile->props profile)
+           ::audit/profile-id (:id profile)})))))
 
 ;; --- MUTATION: Logout
 
@@ -344,26 +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
-  [{: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
@@ -381,6 +395,11 @@
   (db/with-atomic [conn pool]
     (let [profile    (validate-password! conn params)
           session-id (:app.rpc/session-id params)]
+      (when (= (str/lower (:email profile))
+               (str/lower (:password params)))
+        (ex/raise :type :validation
+                  :code :email-as-password
+                  :hint "you can't use your email as password"))
       (update-profile-password! conn (assoc profile :password password))
       (invalidate-profile-session! conn (:id profile) session-id)
       nil)))
@@ -409,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
 
@@ -606,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,22 +8,26 @@
   (: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]
    [app.rpc.queries.profile :as profile]
    [app.rpc.queries.teams :as teams]
+   [app.rpc.rlimit :as rlimit]
    [app.storage :as sto]
-   [app.util.rlimit :as rlimit]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
-   [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,42 +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.
+    ;; 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)
@@ -395,7 +441,6 @@
                 :token itoken
                 :extra-data ptoken})))
 
-
 ;; --- Mutation: Create Team & Invite Members
 
 (s/def ::emails ::us/set-of-emails)
@@ -405,8 +450,9 @@
 (sv/defmethod ::create-team-and-invite-members
   [{: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]
@@ -417,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

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

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

@@ -7,25 +7,29 @@
 (ns app.rpc.queries.files
   (:require
    [app.common.data :as d]
-   [app.common.pages :as cp]
+   [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)
 
 ;; --- Helpers & Specs
 
+(s/def ::frame-id ::us/uuid)
 (s/def ::id ::us/uuid)
 (s/def ::name ::us/string)
 (s/def ::project-id ::us/uuid)
@@ -34,7 +38,6 @@
 (s/def ::team-id ::us/uuid)
 (s/def ::search-term ::us/string)
 
-
 ;; --- Query: File Permissions
 
 (def ^:private sql:file-permissions
@@ -185,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)))
 
@@ -209,98 +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 (->> (:objects page)
-                     (cp/get-object-with-children object-id)
-                     (map #(dissoc % :thumbnail)))
-
-        objects (d/index-by :id objects)
-        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
@@ -356,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
 
@@ -395,14 +443,44 @@
    )
    select * from recent_files where row_num <= 10;")
 
+
 (s/def ::team-recent-files
   (s/keys :req-un [::profile-id ::team-id]))
 
 (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
+
+(s/def ::revn ::us/integer)
+
+(s/def ::file-thumbnail
+  (s/keys :req-un [::profile-id ::file-id]
+          :opt-un [::revn]))
+
+(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]]})
+
+        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

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

backend/src/app/rpc/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/retry.clj

@@ -0,0 +1,45 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.rpc.retry
+  "A fault tolerance helpers. Allow retry some operations that we know
+  we can retry."
+  (:require
+   [app.common.logging :as l]
+   [app.util.services :as sv]
+   [promesa.core :as p]))
+
+(defn conflict-db-insert?
+  "Check if exception matches a insertion conflict on postgresql."
+  [e]
+  (and (instance? org.postgresql.util.PSQLException e)
+       (= "23505" (.getSQLState e))))
+
+(defn wrap-retry
+  [_ f {:keys [::matches ::sv/name]
+        :or {matches (constantly false)}
+        :as mdata}]
+
+  (when (::enabled mdata)
+    (l/debug :hint "wrapping retry" :name name))
+
+  (if-let [max-retries (::max-retries mdata)]
+    (fn [cfg params]
+      (letfn [(run [retry]
+                (-> (f cfg params)
+                    (p/catch (partial handle-error retry))))
+
+              (handle-error [retry cause]
+                (if (matches cause)
+                  (let [current-retry (inc retry)]
+                    (l/trace :hint "running retry algorithm" :retry current-retry)
+                    (if (<= current-retry max-retries)
+                      (run current-retry)
+                      (throw cause)))
+                  (throw cause)))]
+        (run 0)))
+    f))
+

backend/src/app/rpc/rlimit.clj

@@ -0,0 +1,67 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.rpc.rlimit
+  "Resource usage limits (in other words: semaphores)."
+  (:require
+   [app.common.data :as d]
+   [app.common.logging :as l]
+   [app.metrics :as mtx]
+   [app.util.services :as sv]
+   [promesa.core :as p]))
+
+(defprotocol IAsyncSemaphore
+  (acquire! [_])
+  (release! [_]))
+
+(defn semaphore
+  [{:keys [permits metrics name]}]
+  (let [name   (d/name name)
+        used   (volatile! 0)
+        queue  (volatile! (d/queue))
+        labels (into-array String [name])]
+    (reify IAsyncSemaphore
+      (acquire! [this]
+        (let [d (p/deferred)]
+          (locking this
+            (if (< @used permits)
+              (do
+                (vswap! used inc)
+                (p/resolve! d))
+              (vswap! queue conj d)))
+
+          (mtx/run! metrics {:id :rlimit-used-permits :val @used :labels labels })
+          (mtx/run! metrics {:id :rlimit-queued-submissions :val (count @queue) :labels labels})
+          (mtx/run! metrics {:id :rlimit-acquires-total :inc 1 :labels labels})
+          d))
+
+      (release! [this]
+        (locking this
+          (if-let [item (peek @queue)]
+            (do
+              (vswap! queue pop)
+              (p/resolve! item))
+            (when (pos? @used)
+              (vswap! used dec))))
+
+        (mtx/run! metrics {:id :rlimit-used-permits :val @used :labels labels})
+        (mtx/run! metrics {:id :rlimit-queued-submissions :val (count @queue) :labels labels})
+        ))))
+
+(defn wrap-rlimit
+  [{:keys [metrics executors] :as cfg} f mdata]
+  (if-let [permits (::permits mdata)]
+    (let [sem (semaphore {:permits permits
+                          :metrics metrics
+                          :name (::sv/name mdata)})]
+      (l/debug :hint "wrapping rlimit" :handler (::sv/name mdata) :permits permits)
+      (fn [cfg params]
+        (-> (acquire! sem)
+            (p/then (fn [_] (f cfg params)) (:default executors))
+            (p/finally (fn [_ _] (release! sem))))))
+    f))
+
+

backend/src/app/setup.clj

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

backend/src/app/srepl/main.clj

@@ -7,7 +7,7 @@
    [app.common.logging :as l]
    [app.common.pages :as cp]
    [app.common.pages.migrations :as pmg]
-   [app.common.pages.spec :as spec]
+   [app.common.spec.file :as spec.file]
    [app.common.uuid :as uuid]
    [app.config :as cfg]
    [app.db :as db]
@@ -17,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/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/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]
@@ -22,6 +23,7 @@
    [clojure.spec.alpha :as s]
    [datoteka.core :as fs]
    [integrant.core :as ig]
+   [promesa.core :as p]
    [promesa.exec :as px]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -40,7 +42,7 @@
                    :db ::sdb/backend))))
 
 (defmethod ig/pre-init-spec ::storage [_]
-  (s/keys :req-un [::wrk/executor ::db/pool ::backends]))
+  (s/keys :req-un [::db/pool ::wrk/executor ::backends]))
 
 (defmethod ig/prep-key ::storage
   [_ {:keys [backends] :as cfg}]
@@ -53,65 +55,70 @@
       (assoc :backends (d/without-nils backends))))
 
 (s/def ::storage
-  (s/keys :req-un [::backends ::wrk/executor ::db/pool]))
+  (s/keys :req-un [::backends ::db/pool]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Database Objects
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defrecord StorageObject [id size created-at expired-at backend])
+(defrecord StorageObject [id size created-at expired-at touched-at backend])
 
 (defn storage-object?
   [v]
   (instance? StorageObject v))
 
-(def ^:private
-  sql:insert-storage-object
-  "insert into storage_object (id, size, backend, metadata)
-   values (?, ?, ?, ?::jsonb)
-   returning *")
+(s/def ::storage-object storage-object?)
+(s/def ::storage-content impl/content?)
 
-(def ^:private
-  sql:insert-storage-object-with-expiration
-  "insert into storage_object (id, size, backend, metadata, deleted_at)
-   values (?, ?, ?, ?::jsonb, ?)
-   returning *")
+(defn get-metadata
+  [params]
+  (into {}
+        (remove (fn [[k _]] (qualified-keyword? k)))
+        params))
 
-(defn- insert-object
-  [conn id size backend mdata expiration]
-  (if expiration
-    (db/exec-one! conn [sql:insert-storage-object-with-expiration id size backend mdata expiration])
-    (db/exec-one! conn [sql:insert-storage-object id size backend mdata])))
+(defn- 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}]
-  (if (instance? StorageObject object)
-    ;; If we in this condition branch, this means we come from the
-    ;; clone-object, so we just need to clone it with a new backend.
+  [{:keys [conn backend executor]} {:keys [::content ::expired-at ::touched-at] :as params}]
+  (us/assert ::storage-content content)
+  (px/with-dispatch executor
     (let [id     (uuid/random)
-          mdata  (meta object)
-          result (insert-object conn
-                                id
-                                (:size object)
-                                (name backend)
-                                (db/tjson mdata)
-                                (:expired-at object))]
-      (assoc object
-             :id (:id result)
-             :backend backend
-             :created-at (:created-at result)))
-    (let [id     (uuid/random)
-          mdata  (dissoc object :content :expired-at)
-          result (insert-object conn
-                                id
-                                (count content)
-                                (name backend)
-                                (db/tjson mdata)
-                                (:expired-at object))]
+
+          mdata  (cond-> (get-metadata params)
+                   (satisfies? impl/IContentHash content)
+                   (assoc :hash (impl/get-hash content)))
+
+          ;; 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))))
@@ -120,11 +127,12 @@
   "select * from storage_object where id = ? and (deleted_at is null or deleted_at > now())")
 
 (defn row->storage-object [res]
-  (let [mdata (some-> (:metadata res) (db/decode-transit-pgobject))]
+  (let [mdata (or (some-> (:metadata res) (db/decode-transit-pgobject)) {})]
     (StorageObject. (:id res)
                     (:size res)
                     (:created-at res)
                     (:deleted-at res)
+                    (:touched-at res)
                     (keyword (:backend res))
                     mdata
                     nil)))
@@ -134,18 +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))))
-
-(defn- register-recheck
-  [{:keys [pool] :as storage} backend id]
-  (db/insert! pool :storage-pending {:id id :backend (name backend)}))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; API
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -158,28 +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 executor] :as storage} {:keys [content] :as params}]
+  [{:keys [pool conn backend] :as storage} {:keys [::content] :as params}]
   (us/assert ::storage storage)
-  (us/assert impl/content? content)
-  (let [storage (assoc storage :conn (or conn pool))
-        object  (create-database-object storage params)]
-
-    ;; Schedule to execute in background; in an other transaction and
-    ;; register the currently created storage object id for a later
-    ;; recheck.
-    (px/run! executor #(register-recheck storage backend (:id object)))
+  (us/assert ::storage-content content)
+  (us/assert ::us/keyword backend)
+  (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)
@@ -187,136 +179,138 @@
 
     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] :as storage} object]
-  (us/assert ::storage storage)
-  (let [storage (assoc storage :conn (or conn pool))
-        object* (create-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)
+(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}]
-  (letfn [(group-by-backend [rows]
-            (let [conj (fnil conj [])]
-              [(reduce (fn [acc {:keys [id backend]}]
-                         (update acc (keyword backend) conj id))
-                       {}
-                       rows)
-               (count rows)]))
+  (letfn [(retrieve-deleted-objects-chunk [conn cursor]
+            (let [min-age (db/interval min-age)
+                  rows    (db/exec! conn [sql:retrieve-deleted-objects-chunk min-age cursor])]
+              [(some-> rows peek :created-at)
+               (some->> (seq rows) (d/group-by #(-> % :backend keyword) :id #{}) seq)]))
 
           (retrieve-deleted-objects [conn]
-            (let [min-age (db/interval min-age)
-                  rows    (db/exec! conn [sql:retrieve-deleted-objects min-age])]
-              (some-> (seq rows) (group-by-backend))))
+            (->> (d/iteration (fn [cursor]
+                                (retrieve-deleted-objects-chunk conn cursor))
+                              :initk (dt/now)
+                              :vf second
+                              :kf first)
+                 (sequence cat)))
 
-          (delete-in-bulk [conn [backend ids]]
+          (delete-in-bulk [conn backend ids]
             (let [backend (impl/resolve-backend storage backend)
                   backend (assoc backend :conn conn)]
-              (impl/del-objects-in-bulk backend ids)))]
+              @(impl/del-objects-in-bulk backend ids)))]
 
     (fn [_]
       (db/with-atomic [conn pool]
-        (loop [n 0]
-          (if-let [[groups total] (retrieve-deleted-objects conn)]
+        (loop [total  0
+               groups (retrieve-deleted-objects conn)]
+          (if-let [[backend ids] (first groups)]
             (do
-              (run! (partial delete-in-bulk conn) groups)
-              (recur (+ n ^long total)))
+              (delete-in-bulk conn backend ids)
+              (recur (+ total (count ids))
+                     (rest groups)))
             (do
-              (l/info :task "gc-deleted"
-                      :hint "permanently delete items"
-                      :count n)
-              {:deleted n})))))))
+              (l/info :task "gc-deleted" :count total)
+              {:deleted total})))))))
 
-(def sql:retrieve-deleted-objects
+(def sql:retrieve-deleted-objects-chunk
   "with items_part as (
      select s.id
        from storage_object as s
       where s.deleted_at is not null
         and s.deleted_at < (now() - ?::interval)
-      order by s.deleted_at
-      limit 100
+        and s.created_at < ?
+      order by s.created_at desc
+      limit 25
    )
    delete from storage_object
     where id in (select id from items_part)
@@ -326,157 +320,131 @@
 ;; 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.
 ;;
-;; When file_media_object is deleted, the depending storage_object are
-;; marked as touched. This means that some files that depend on a
-;; concrete storage_object are no longer exists and maybe this
-;; storage_object is no longer necessary and can be eligible for
-;; elimination. This task periodically analyzes touched objects and
-;; mark them as freeze (means that has other references and the object
-;; is still valid) or deleted (no more references to this object so is
-;; ready to be deleted).
+;; For example: when file_media_object is deleted, the depending
+;; storage_object are marked as touched. This means that some files
+;; that depend on a concrete storage_object are no longer exists and
+;; maybe this storage_object is no longer necessary and can be
+;; eligible for elimination. This task periodically analyzes touched
+;; objects and mark them as freeze (means that has other references
+;; and the object is still valid) or deleted (no more references to
+;; this object so is ready to be deleted).
 
-(declare sql:retrieve-touched-objects)
+(declare sql:retrieve-touched-objects-chunk)
+(declare sql:retrieve-file-media-object-nrefs)
+(declare sql:retrieve-team-font-variant-nrefs)
+(declare sql:retrieve-profile-nrefs)
 
 (defmethod ig/pre-init-spec ::gc-touched-task [_]
   (s/keys :req-un [::db/pool]))
 
 (defmethod ig/init-key ::gc-touched-task
   [_ {:keys [pool] :as cfg}]
-  (letfn [(group-results [rows]
-            (let [conj (fnil conj [])]
-              (reduce (fn [acc {:keys [id nrefs]}]
-                        (if (pos? nrefs)
-                          (update acc :to-freeze conj id)
-                          (update acc :to-delete conj id)))
-                      {}
-                      rows)))
+  (letfn [(has-team-font-variant-nrefs? [conn id]
+            (-> (db/exec-one! conn [sql:retrieve-team-font-variant-nrefs id id id id]) :nrefs pos?))
 
-          (retrieve-touched [conn]
-            (let [rows (db/exec! conn [sql:retrieve-touched-objects])]
-              (some-> (seq rows) (group-results))))
+          (has-file-media-object-nrefs? [conn id]
+            (-> (db/exec-one! conn [sql:retrieve-file-media-object-nrefs id id]) :nrefs pos?))
 
-          (mark-delete-in-bulk [conn ids]
-            (db/exec-one! conn ["update storage_object set deleted_at=now(), touched_at=null where id = ANY(?)"
-                                (db/create-array conn "uuid" (into-array java.util.UUID ids))]))
+          (has-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" (into-array java.util.UUID ids))]))]
+                                (db/create-array conn "uuid" ids)]))
+
+          (mark-delete-in-bulk [conn ids]
+            (db/exec-one! conn ["update storage_object set deleted_at=now(), touched_at=null where id = ANY(?)"
+                                (db/create-array conn "uuid" ids)]))
+
+          ;; 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)))]
+              (when (seq rows)
+                [(-> rows peek :created-at)
+                 (d/group-by get-bucket :id #{} rows)])))
+
+          (retrieve-touched [conn]
+            (->> (d/iteration (fn [cursor]
+                                (retrieve-touched-chunk conn cursor))
+                              :initk (dt/now)
+                              :vf second
+                              :kf first)
+                 (sequence cat)))
+
+          (process-objects! [conn pred-fn ids]
+            (loop [to-freeze #{}
+                   to-delete #{}
+                   ids       (seq ids)]
+              (if-let [id (first ids)]
+                (if (pred-fn conn id)
+                  (recur (conj to-freeze id) to-delete (rest ids))
+                  (recur to-freeze (conj to-delete id) (rest ids)))
+
+                (do
+                  (some->> (seq to-freeze) (mark-freeze-in-bulk conn))
+                  (some->> (seq to-delete) (mark-delete-in-bulk conn))
+                  [(count to-freeze) (count to-delete)]))))
+          ]
 
     (fn [_]
       (db/with-atomic [conn pool]
-        (loop [cntf 0
-               cntd 0]
-          (if-let [{:keys [to-delete to-freeze]} (retrieve-touched conn)]
+        (loop [to-freeze 0
+               to-delete 0
+               groups    (retrieve-touched conn)]
+          (if-let [[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 (dm/fmt "unknown reference %" bucket)))]
+              (recur (+ to-freeze f)
+                     (+ to-delete d)
+                     (rest groups)))
             (do
-              (when (seq to-delete) (mark-delete-in-bulk conn to-delete))
-              (when (seq to-freeze) (mark-freeze-in-bulk conn to-freeze))
-              (recur (+ cntf (count to-freeze))
-                     (+ cntd (count to-delete))))
-            (do
-              (l/info :task "gc-touched"
-                      :hint "mark freeze"
-                      :count cntf)
-              (l/info :task "gc-touched"
-                      :hint "mark for deletion"
-                      :count cntd)
-              {:freeze cntf :delete cntd})))))))
+              (l/info :task "gc-touched" :to-freeze to-freeze :to-delete to-delete)
+              {:freeze to-freeze :delete to-delete})))))))
 
-(def sql:retrieve-touched-objects
-  "select so.id,
-          ((select count(*) from file_media_object where media_id = so.id) +
-           (select count(*) from file_media_object where thumbnail_id = so.id)) as nrefs
-     from storage_object as so
+(def sql:retrieve-touched-objects-chunk
+  "select so.* from storage_object as so
     where so.touched_at is not null
-    order by so.touched_at
-    limit 100;")
+      and so.created_at < ?
+    order by so.created_at desc
+    limit 500;")
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Recheck Stalled Task
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(def sql:retrieve-file-media-object-nrefs
+  "select ((select count(*) from file_media_object where media_id = ?) +
+           (select count(*) from file_media_object where thumbnail_id = ?)) as nrefs")
 
-;; Because the physical storage (filesystem, s3, ... except db) is not
-;; transactional, in some situations we can found physical object
-;; leakage. That situations happens when the transaction that writes
-;; the file aborts, leaving the file written to the underlying storage
-;; but the reference on the database is lost with the rollback.
-;;
-;; For this situations we need to write a "log" of inserted files that
-;; are checked in some time in future. If physical file exists but the
-;; database refence does not exists means that leaked file is found
-;; and is immediately deleted. The responsibility of this task is
-;; check that write log for possible leaked files.
+(def sql:retrieve-team-font-variant-nrefs
+  "select ((select count(*) from team_font_variant where woff1_file_id = ?) +
+           (select count(*) from team_font_variant where woff2_file_id = ?) +
+           (select count(*) from team_font_variant where otf_file_id = ?) +
+           (select count(*) from team_font_variant where ttf_file_id = ?)) as nrefs")
 
-(def recheck-min-age (dt/duration {:hours 1}))
-
-(declare sql:retrieve-pending-to-recheck)
-(declare sql:exists-storage-object)
-
-(defmethod ig/pre-init-spec ::recheck-task [_]
-  (s/keys :req-un [::storage ::db/pool]))
-
-(defmethod ig/init-key ::recheck-task
-  [_ {:keys [pool storage] :as cfg}]
-  (letfn [(group-results [rows]
-            (let [conj (fnil conj [])]
-              (reduce (fn [acc {:keys [id exist] :as row}]
-                        (cond-> (update acc :all conj id)
-                          (false? exist)
-                          (update :to-delete conj (dissoc row :exist))))
-                      {}
-                      rows)))
-
-          (group-by-backend [rows]
-            (let [conj (fnil conj [])]
-              (reduce (fn [acc {:keys [id backend]}]
-                        (update acc (keyword backend) conj id))
-                      {}
-                      rows)))
-
-          (retrieve-pending [conn]
-            (let [rows (db/exec! conn [sql:retrieve-pending-to-recheck (db/interval recheck-min-age)])]
-              (some-> (seq rows) (group-results))))
-
-          (delete-group [conn [backend ids]]
-            (let [backend (impl/resolve-backend storage backend)
-                  backend (assoc backend :conn conn)]
-              (impl/del-objects-in-bulk backend ids)))
-
-          (delete-all [conn ids]
-            (let [ids (db/create-array conn "uuid" (into-array java.util.UUID ids))]
-              (db/exec-one! conn ["delete from storage_pending where id = ANY(?)" ids])))]
-
-    (fn [_]
-      (db/with-atomic [conn pool]
-        (loop [n 0 d 0]
-          (if-let [{:keys [all to-delete]} (retrieve-pending conn)]
-            (let [groups (group-by-backend to-delete)]
-              (run! (partial delete-group conn) groups)
-              (delete-all conn all)
-              (recur (+ n (count all))
-                     (+ d (count to-delete))))
-            (do
-              (l/info :task "recheck"
-                      :hint "recheck items"
-                      :processed n
-                      :deleted d)
-              {:processed n :deleted d})))))))
-
-(def sql:retrieve-pending-to-recheck
-  "select sp.id,
-          sp.backend,
-          sp.created_at,
-          (case when count(so.id) > 0 then true
-                else false
-            end) as exist
-     from storage_pending as sp
-     left join storage_object as so
-            on (so.id = sp.id)
-    where sp.created_at < now() - ?::interval
-    group by 1,2,3
-    order by sp.created_at asc
-    limit 100")
+(def sql:retrieve-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)
@@ -56,9 +62,10 @@
 (s/def ::region #{:eu-central-1})
 (s/def ::bucket ::us/string)
 (s/def ::prefix ::us/string)
+(s/def ::endpoint ::us/string)
 
 (defmethod ig/pre-init-spec ::backend [_]
-  (s/keys :opt-un [::region ::bucket ::prefix]))
+  (s/keys :opt-un [::region ::bucket ::prefix ::endpoint ::wrk/executor]))
 
 (defmethod ig/prep-key ::backend
   [_ {:keys [prefix] :as cfg}]
@@ -74,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]
@@ -91,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))
@@ -117,75 +126,134 @@
 
 ;; --- HELPERS
 
+(def default-eventloop-threads 4)
+(def default-timeout
+  (dt/duration {:seconds 30}))
+
 (defn- ^Region lookup-region
   [region]
-  (case region
-    :eu-central-1 Region/EU_CENTRAL_1))
+  (Region/of (name region)))
 
 (defn build-s3-client
-  [{:keys [region]}]
-  (.. (S3Client/builder)
-      (region (lookup-region region))
-      (build)))
+  [{:keys [region endpoint 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]}]
-  (.. (S3Presigner/builder)
-      (region (lookup-region region))
-      (build)))
+  [{:keys [region endpoint]}]
+  (if (string? endpoint)
+    (let [uri (java.net.URI. endpoint)]
+      (.. (S3Presigner/builder)
+          (endpointOverride uri)
+          (region (lookup-region region))
+          (build)))
+    (.. (S3Presigner/builder)
+        (region (lookup-region region))
+        (build))))
+
+(defn- 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
@@ -194,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,116 +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.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)
-   (map (fn [{:keys [type] :as obj}]
-          (case type
-            :path (get-in obj [:fill-image :id])
-            :image (get-in obj [:metadata :id])
-            nil)))
-   (filter uuid?)))
-
-(defn- collect-used-media
-  [data]
-  (let [pages (concat
-               (vals (:pages-index data))
-               (vals (:components data)))]
-  (-> #{}
-      (into collect-media-xf pages)
-      (into (keys (:media data))))))
-
-(defn- process-file
-  [{:keys [conn] :as cfg} {:keys [id data age] :as file}]
-  (let [data   (-> (blob/decode data)
-                   (assoc :id id)
-                   (pmg/migrate-data))
-
-        used   (collect-used-media data)
-        unused (->> (db/query conn :file-media-object {:file-id id})
-                    (remove #(contains? used (:id %))))]
-
-    (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)}))
-
-    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,35 +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 [_]
-    ;; Sleep randomly between 0 to 10s
-    (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)]
-      (-> (get-stats pool version)
-          (assoc :instance-id instance-id)
-          (send! cfg)))))
+          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))
@@ -137,20 +170,35 @@
   (->> [sql:team-averages]
        (db/exec-one! conn)))
 
+(defn- retrieve-enabled-auth-providers
+  [conn]
+  (let [sql  (str "select auth_backend as backend, count(*) as total "
+                 "  from profile group by 1")
+        rows (db/exec! conn [sql])]
+    (->> rows
+         (map (fn [{:keys [backend total]}]
+                (let [backend (or backend "penpot")]
+                  [(keyword (str "auth-backend-" backend))
+                   total])))
+         (into {}))))
+
 (defn- retrieve-jvm-stats
   []
   (let [^Runtime runtime (Runtime/getRuntime)]
     {:jvm-heap-current (.totalMemory runtime)
      :jvm-heap-max     (.maxMemory runtime)
-     :jvm-cpus         (.availableProcessors runtime)}))
+     :jvm-cpus         (.availableProcessors runtime)
+     :os-arch          (System/getProperty "os.arch")
+     :os-name          (System/getProperty "os.name")
+     :os-version       (System/getProperty "os.version")
+     :user-tz          (System/getProperty "user.timezone")}))
 
 (defn 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)
@@ -161,6 +209,7 @@
          :total-touched-files (retrieve-num-touched-files conn)}
         (d/merge
          (retrieve-team-averages conn)
-         (retrieve-jvm-stats))
+         (retrieve-jvm-stats)
+         (retrieve-enabled-auth-providers conn))
         (d/without-nils))))
 

backend/src/app/tokens.clj

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

backend/src/app/util/async.clj

@@ -38,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)]
@@ -54,7 +61,6 @@
         (a/close! c)
         c))))
 
-
 (defmacro with-thread
   [executor & body]
   (if (= executor ::default)

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/retry.clj

@@ -1,43 +0,0 @@
-;; This Source Code Form is subject to the terms of the Mozilla Public
-;; License, v. 2.0. If a copy of the MPL was not distributed with this
-;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
-;;
-;; Copyright (c) UXBOX Labs SL
-
-(ns app.util.retry
-  "A fault tolerance helpers. Allow retry some operations that we know
-  we can retry."
-  (:require
-   [app.common.exceptions :as ex]
-   [app.common.logging :as l]
-   [app.util.async :as aa]
-   [app.util.services :as sv]))
-
-(defn conflict-db-insert?
-  "Check if exception matches a insertion conflict on postgresql."
-  [e]
-  (and (instance? org.postgresql.util.PSQLException e)
-       (= "23505" (.getSQLState e))))
-
-(defn wrap-retry
-  [_ f {:keys [::max-retries ::matches ::sv/name]
-        :or {max-retries 3
-             matches (constantly false)}
-        :as mdata}]
-  (when (::enabled mdata)
-    (l/debug :hint "wrapping retry" :name name))
-  (if (::enabled mdata)
-    (fn [cfg params]
-      (loop [retry 1]
-        (when (> retry 1)
-          (l/debug :hint "retrying controlled function" :retry retry :name name))
-        (let [res (ex/try (f cfg params))]
-          (if (ex/exception? res)
-            (if (and (matches res) (< retry max-retries))
-              (do
-                (aa/thread-sleep (* 100 retry))
-                (recur (inc retry)))
-              (throw res))
-            res))))
-    f))
-

backend/src/app/util/rlimit.clj

@@ -1,36 +0,0 @@
-;; This Source Code Form is subject to the terms of the Mozilla Public
-;; License, v. 2.0. If a copy of the MPL was not distributed with this
-;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
-;;
-;; Copyright (c) UXBOX Labs SL
-
-(ns app.util.rlimit
-  "Resource usage limits (in other words: semaphores)."
-  (:require
-   [app.common.logging :as l]
-   [app.util.services :as sv])
-  (:import
-   java.util.concurrent.Semaphore))
-
-(defn acquire!
-  [sem]
-  (.acquire ^Semaphore sem))
-
-(defn release!
-  [sem]
-  (.release ^Semaphore sem))
-
-(defn wrap-rlimit
-  [_cfg f mdata]
-  (if-let [permits (::permits mdata)]
-    (let [sem (Semaphore. permits)]
-      (l/debug :hint "wrapping rlimit" :handler (::sv/name mdata) :permits permits)
-      (fn [cfg params]
-        (try
-          (acquire! sem)
-          (f cfg params)
-          (finally
-            (release! sem)))))
-    f))
-
-

backend/src/app/util/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)
@@ -27,11 +26,6 @@
 (declare ws-ping!)
 (declare ws-send!)
 
-(defmacro call-mtx
-  [definitions name & args]
-  `(when-let [mtx-fn# (some-> ~definitions ~name ::mtx/fn)]
-     (mtx-fn# ~@args)))
-
 (def noop (constantly nil))
 
 (defn handler
@@ -49,30 +43,38 @@
   ([handle-message {:keys [::input-buff-size
                            ::output-buff-size
                            ::idle-timeout
-                           ::metrics]
+                           metrics]
                     :or {input-buff-size 64
                          output-buff-size 64
                          idle-timeout 30000}
                     :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)
-               (call-mtx metrics :connections {:cmd :dec :by 1})
-               (call-mtx metrics :sessions {:val (/ (inst-ms (dt/diff created-at (dt/now))) 1000.0)})
+               (mtx/run! metrics {:id :websocket-active-connections :dec 1})
+               (mtx/run! metrics {:id :websocket-session-timing :val (/ (inst-ms (dt/diff created-at (dt/now))) 1000.0)})
 
                (a/close! close-ch)
                (a/close! pong-ch)
@@ -82,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]
-             (call-mtx metrics :connections {:cmd :inc :by 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)]
-                   (call-mtx metrics :messages {:labels ["send"]})
-                   (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]
-             (call-mtx metrics :messages {:labels ["recv"]})
+             (mtx/run! metrics {:id :websocket-messages-total :labels ["recv"] :inc 1})
              (try
                (let [message (t/decode-str message)]
                  (a/offer! input-ch message))
@@ -122,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))
@@ -167,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)
@@ -184,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

@@ -22,44 +22,129 @@
    [integrant.core :as ig]
    [promesa.exec :as px])
   (:import
-   org.eclipse.jetty.util.thread.QueuedThreadPool
    java.util.concurrent.ExecutorService
    java.util.concurrent.Executors
-   java.util.concurrent.Executor))
+   java.util.concurrent.ForkJoinPool
+   java.util.concurrent.Future
+   java.util.concurrent.ForkJoinPool$ForkJoinWorkerThreadFactory
+   java.util.concurrent.ForkJoinWorkerThread
+   java.util.concurrent.ScheduledExecutorService
+   java.util.concurrent.ThreadFactory
+   java.util.concurrent.atomic.AtomicLong))
 
-(s/def ::executor #(instance? Executor %))
+(set! *warn-on-reflection* true)
+
+(s/def ::executor #(instance? ExecutorService %))
+(s/def ::scheduler #(instance? ScheduledExecutorService %))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Executor
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(s/def ::name keyword?)
-(s/def ::min-threads ::us/integer)
-(s/def ::max-threads ::us/integer)
+(declare ^:private get-fj-thread-factory)
+(declare ^:private get-thread-factory)
+
+(s/def ::prefix keyword?)
+(s/def ::parallelism ::us/integer)
 (s/def ::idle-timeout ::us/integer)
 
 (defmethod ig/pre-init-spec ::executor [_]
-  (s/keys :req-un [::min-threads ::max-threads ::idle-timeout ::name]))
+  (s/keys :req-un [::prefix]
+          :opt-un [::parallelism]))
 
 (defmethod ig/init-key ::executor
-  [_ {:keys [min-threads max-threads idle-timeout name]}]
-  (doto (QueuedThreadPool. (int max-threads)
-                           (int min-threads)
-                           (int idle-timeout))
-    (.setStopTimeout 500)
-    (.setName (d/name name))
-    (.start)))
+  [_ {:keys [parallelism prefix]}]
+  (let [counter  (AtomicLong. 0)]
+    (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]
-  (.stop ^QueuedThreadPool 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 "penpot/" (name prefix) "-" (.getAndIncrement ^AtomicLong counter))]
+        (.setName thread thread-name)
+        thread))))
+
+(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
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(s/def ::executors (s/map-of keyword? ::executor))
+
+(defmethod ig/pre-init-spec ::executors-monitor [_]
+  (s/keys :req-un [::executors ::scheduler ::mtx/metrics]))
+
+(defmethod ig/init-key ::executors-monitor
+  [_ {:keys [executors metrics interval scheduler] :or {interval 3000}}]
+  (letfn [(log-stats [state]
+            (doseq [[key ^ForkJoinPool executor] executors]
+              (let [labels  (into-array String [(name key)])
+                    running (.getRunningThreadCount executor)
+                    queued  (.getQueuedSubmissionCount executor)
+                    active  (.getPoolSize executor)
+                    steals  (.getStealCount executor)
+                    steals-increment (- steals (or (get-in @state [key :steals]) 0))
+                    steals-increment (if (neg? steals-increment) 0 steals-increment)]
+
+                (mtx/run! metrics {:id :executors-active-threads :labels labels :val active})
+                (mtx/run! metrics {:id :executors-running-threads :labels labels :val running})
+                (mtx/run! metrics {:id :executors-queued-submissions :labels labels :val queued})
+                (mtx/run! metrics {:id :executors-completed-tasks :labels labels :inc steals-increment})
+
+                (swap! state update key assoc
+                       :running running
+                       :active active
+                       :queued queued
+                       :steals steals)))
+
+            (when (and (not (.isShutdown scheduler))
+                       (not (:shutdown @state)))
+              (px/schedule! scheduler interval (partial log-stats state))))]
+
+    (let [state (atom {})]
+      (px/schedule! scheduler interval (partial log-stats state))
+      {:state state})))
+
+(defmethod ig/halt-key! ::executors-monitor
+  [_ {:keys [state]}]
+  (swap! state assoc :shutdown true))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Worker
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (declare event-loop-fn)
-(declare instrument-tasks)
+(declare event-loop)
 
 (s/def ::queue keyword?)
 (s/def ::parallelism ::us/integer)
@@ -85,13 +170,10 @@
             :queue :default}
            (d/without-nils cfg)))
 
-(defmethod ig/init-key ::worker
-  [_ {:keys [pool poll-interval name queue] :as cfg}]
-  (l/info :action "start worker"
-          :name (d/name name)
-          :queue (d/name queue))
-  (let [close-ch (a/chan 1)
-        poll-ms  (inst-ms poll-interval)]
+(defn- event-loop
+  "Main, worker eventloop"
+  [{:keys [pool poll-interval close-ch] :as cfg}]
+  (let [poll-ms (inst-ms poll-interval)]
     (a/go-loop []
       (let [[val port] (a/alts! [close-ch (event-loop-fn cfg)] :priority true)]
         (cond
@@ -100,7 +182,7 @@
           (or (= port close-ch) (nil? val))
           (l/debug :hint "stop condition found")
 
-          (db/pool-closed? pool)
+          (db/closed? pool)
           (do
             (l/debug :hint "eventloop aborted because pool is closed")
             (a/close! close-ch))
@@ -132,14 +214,27 @@
           (= ::empty val)
           (do
             (a/<! (a/timeout poll-ms))
-            (recur)))))
+            (recur)))))))
+
+(defmethod ig/init-key ::worker
+  [_ {:keys [pool name queue] :as cfg}]
+  (let [close-ch (a/chan 1)
+        cfg      (assoc cfg :close-ch close-ch)]
+    (if (db/read-only? pool)
+      (l/warn :hint "worker not started, db is read-only"
+              :name (d/name name)
+              :queue (d/name queue))
+      (do
+        (l/info :hint "worker started"
+                :name (d/name name)
+                :queue (d/name queue))
+        (event-loop cfg)))
 
     (reify
       java.lang.AutoCloseable
       (close [_]
         (a/close! close-ch)))))
 
-
 (defmethod ig/halt-key! ::worker
   [_ instance]
   (.close ^java.lang.AutoCloseable instance))
@@ -186,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
@@ -326,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?)
@@ -340,19 +433,21 @@
 (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] :as cfg}]
-  (let [scheduler (Executors/newScheduledThreadPool (int 1))
-        schedule  (->> 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}]
@@ -368,52 +463,55 @@
                                 (-> item
                                     (dissoc :task)
                                     (assoc :fn f))))))
-        cfg       (assoc cfg
-                         :scheduler scheduler
-                         :schedule schedule)]
 
-    (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 exception->string
-  [error]
-  (with-out-str
-    (.printStackTrace ^Throwable error (java.io.PrintWriter. *out*))))
-
-(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)))
 
@@ -426,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]
@@ -438,66 +536,40 @@
         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
 
-(defn instrument!
-  [registry]
-  (mtx/instrument-vars!
-   [#'submit!]
-   {:registry registry
-    :type :counter
-    :labels ["name"]
-    :name "tasks_submit_total"
-    :help "A counter of task submissions."
-    :wrap (fn [rootf mobj]
-            (let [mdata (meta rootf)
-                  origf (::original mdata rootf)]
-              (with-meta
-                (fn [conn params]
-                  (let [tname (:name params)]
-                    (mobj :inc [tname])
-                    (origf conn params)))
-                {::original origf})))})
-
-  (mtx/instrument-vars!
-   [#'app.worker/run-task]
-   {:registry registry
-    :type :summary
-    :quantiles []
-    :name "tasks_checkout_timing"
-    :help "Latency measured between scheduled_at and execution time."
-    :wrap (fn [rootf mobj]
-            (let [mdata (meta rootf)
-                  origf (::original mdata rootf)]
-              (with-meta
-                (fn [tasks item]
-                  (let [now (inst-ms (dt/now))
-                        sat (inst-ms (:scheduled-at item))]
-                    (mobj :observe (- now sat))
-                    (origf tasks item)))
-                {::original origf})))}))
-
+(defn- wrap-task-handler
+  [metrics tname f]
+  (let [labels (into-array String [tname])]
+    (fn [params]
+      (let [start (System/nanoTime)]
+        (try
+          (f params)
+          (finally
+            (mtx/run! metrics
+                      {:id :tasks-timing
+                       :val (/ (- (System/nanoTime) start) 1000000)
+                       :labels labels})))))))
 
 (defmethod ig/pre-init-spec ::registry [_]
   (s/keys :req-un [::mtx/metrics ::tasks]))
 
 (defmethod ig/init-key ::registry
   [_ {:keys [metrics tasks]}]
-  (let [mobj (mtx/create
-              {:registry (:registry metrics)
-               :type :summary
-               :labels ["name"]
-               :quantiles []
-               :name "tasks_timing"
-               :help "Background task execution timing."})]
-    (reduce-kv (fn [res k v]
-                 (let [tname (name k)]
-                   (l/debug :action "register task" :name tname)
-                   (assoc res k (mtx/wrap-summary v mobj [tname]))))
-               {}
-               tasks)))
+  (reduce-kv (fn [res k v]
+               (let [tname (name k)]
+                 (l/debug :hint "register task" :name tname)
+                 (assoc res k (wrap-task-handler metrics tname v))))
+             {}
+             tasks))

backend/test/app/services_files_test.clj

@@ -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,8 +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 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 (= 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))))
 
@@ -184,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))))
 
@@ -197,21 +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))))
 
-      ;; but if we pass the touched gc task two of them should disappear
+      ;; now, we have deleted the unused file-media-object, if we
+      ;; execute the touched-gc task, we should see that two of them
+      ;; are marked to be deleted.
       (let [task (:app.storage/gc-touched-task th/*system*)
             res  (task {})]
-        (t/is (= 0 (:freeze res)))
-        (t/is (= 2 (:delete res)))
+        (t/is (= 2 (:freeze res)))
+        (t/is (= 0 (:delete res))))
 
-        (t/is (nil? (sto/get-object storage (:media-id fmo2))))
-        (t/is (nil? (sto/get-object storage (:thumbnail-id fmo2))))
-        (t/is (some? (sto/get-object storage (:media-id fmo1))))
-        (t/is (some? (sto/get-object storage (:thumbnail-id fmo1)))))
+      ;; Finally, check that some of the objects that are marked as
+      ;; deleted we are unable to retrieve them using standard storage
+      ;; public api.
+      (t/is (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))))
 
       )))
 
@@ -323,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)
@@ -389,3 +412,302 @@
         (t/is (th/ex-info? error))
         (t/is (= (:type error-data) :not-found))))
     ))
+
+
+(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})
+        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)}]
+
+    (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)))))
+    ))
+
+

backend/test/app/services_management_test.clj

@@ -11,6 +11,7 @@
    [app.http :as http]
    [app.storage :as sto]
    [app.test-helpers :as th]
+   [app.storage-test :refer [configure-storage-backend]]
    [clojure.test :as t]
    [buddy.core.bytes :as b]
    [datoteka.core :as fs]))
@@ -19,10 +20,12 @@
 (t/use-fixtures :each th/database-reset)
 
 (t/deftest duplicate-file
-  (let [storage (:app.storage/storage th/*system*)
-        sobject (sto/put-object storage {:content (sto/content "content")
-                                         :content-type "text/plain"
-                                         :other "data"})
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
+
+        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)})
@@ -89,14 +92,17 @@
 
         ))))
 
-(t/deftest duplicate-file-with-deleted-rels
-  (let [storage (:app.storage/storage th/*system*)
-        sobject (sto/put-object storage {:content (sto/content "content")
-                                         :content-type "text/plain"
-                                         :other "data"})
+(t/deftest duplicate-file-with-deleted-relations
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
+        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)
@@ -108,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)
@@ -136,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))))
 
@@ -151,10 +151,13 @@
         ))))
 
 (t/deftest duplicate-project
-  (let [storage (:app.storage/storage th/*system*)
-        sobject (sto/put-object storage {:content (sto/content "content")
-                                         :content-type "text/plain"
-                                         :other "data"})
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
+
+        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)})
@@ -170,6 +173,7 @@
                                                :is-local false
                                                :media-id (:id sobject)})]
 
+
     (th/update-file*
      {:file-id (:id file1)
       :profile-id (:id profile)
@@ -221,10 +225,11 @@
           )))))
 
 (t/deftest duplicate-project-with-deleted-files
-  (let [storage (:app.storage/storage th/*system*)
-        sobject (sto/put-object storage {:content (sto/content "content")
-                                         :content-type "text/plain"
-                                         :other "data"})
+  (let [storage (-> (:app.storage/storage th/*system*)
+                    (configure-storage-backend))
+        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)})
@@ -240,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
@@ -425,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))))
@@ -603,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
@@ -240,6 +291,16 @@
       (t/is (nil? error))
       (t/is (string? (:token result))))))
 
+(t/deftest test-register-profile-with-email-as-password
+  (let [data  {::th/type :prepare-register-profile
+               :email "user@example.com"
+               :password "USER@example.com"}]
+
+    (let [{:keys [result error] :as out} (th/mutation! data)]
+      (t/is (th/ex-info? error))
+      (t/is (th/ex-of-type? error :validation))
+      (t/is (th/ex-of-code? error :email-as-password)))))
+
 (t/deftest test-email-change-request
   (with-mocks [email-send-mock {:target 'app.emails/send! :return nil}
                cfg-get-mock    {:target 'app.config/get
@@ -345,3 +406,39 @@
         (t/is (th/ex-of-code? error :email-has-permanent-bounces)))
 
       )))
+
+
+(t/deftest update-profile-password
+  (let [profile (th/create-profile* 1)
+        data  {::th/type :update-profile-password
+               :profile-id (:id profile)
+               :old-password "123123"
+               :password "foobarfoobar"}
+        out   (th/mutation! data)]
+    (t/is (nil? (:error out)))
+    (t/is (nil? (:result out)))
+  ))
+
+
+(t/deftest update-profile-password-bad-old-password
+  (let [profile (th/create-profile* 1)
+        data  {::th/type :update-profile-password
+               :profile-id (:id profile)
+               :old-password "badpassword"
+               :password "foobarfoobar"}
+        {:keys [result error] :as out} (th/mutation! data)]
+    (t/is (th/ex-info? error))
+    (t/is (th/ex-of-type? error :validation))
+    (t/is (th/ex-of-code? error :old-password-not-match))))
+
+
+(t/deftest update-profile-password-email-as-password
+  (let [profile (th/create-profile* 1)
+        data  {::th/type :update-profile-password
+               :profile-id (:id profile)
+               :old-password "123123"
+               :password "profile1.test@nodomain.com"}
+        {:keys [result error] :as out} (th/mutation! data)]
+    (t/is (th/ex-info? error))
+    (t/is (th/ex-of-type? error :validation))
+    (t/is (th/ex-of-code? error :email-as-password))))

backend/test/app/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

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

backend/test/app/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))
 
@@ -52,28 +54,38 @@
                    (assoc-in [:app.db/pool :uri] (:database-uri config))
                    (assoc-in [:app.db/pool :username] (:database-username config))
                    (assoc-in [:app.db/pool :password] (:database-password config))
-                   (assoc-in [[:app.main/main :app.storage.fs/backend] :directory] "/tmp/app/storage")
                    (dissoc :app.srepl/server
                            :app.http/server
                            :app.http/router
-                           :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.storage/storage {:backend :tmp}
-                     :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)))))
 
@@ -250,7 +262,7 @@
   [expr]
   `(try
      {:error nil
-      :result ~expr}
+      :result (deref ~expr)}
      (catch Exception e#
        {:error (handle-error e#)
         :result nil})))
@@ -274,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))
@@ -291,7 +304,7 @@
       (println "====> END ERROR"))
     (do
       (println "====> START RESPONSE")
-      (prn result)
+      (pp/pprint result)
       (println "====> END RESPONSE"))))
 
 (defn exception?
@@ -302,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)]
@@ -355,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,28 +3,28 @@
   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.49"}
+  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 "6.0.2"}
-  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.12.89"
+  lambdaisland/uri {:mvn/version "1.13.95"
                     :exclusions [org.clojure/data.json]}
 
   frankiesardo/linked {:mvn/version "1.3.0"}
@@ -42,9 +42,8 @@
   {:extra-deps
    {org.clojure/tools.namespace {:mvn/version "RELEASE"}
     org.clojure/test.check {:mvn/version "RELEASE"}
-    org.clojure/tools.deps.alpha {:mvn/version "RELEASE"}
+    thheller/shadow-cljs {:mvn/version "2.17.8"}
     com.bhauman/rebel-readline {:mvn/version "RELEASE"}
-    thheller/shadow-cljs {:mvn/version "2.16.12"}
     criterium/criterium {:mvn/version "RELEASE"}
     mockery/mockery {:mvn/version "RELEASE"}}
    :extra-paths ["test" "dev"]}

common/package.json

@@ -13,7 +13,7 @@
     "test": "yarn run compile-test && yarn run run-test"
   },
   "devDependencies": {
-    "shadow-cljs": "2.16.12",
+    "shadow-cljs": "2.17.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,9 +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])
+  (: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)
@@ -37,6 +37,27 @@
   #?(:cljs (instance? lks/LinkedSet o)
      :clj (instance? LinkedSet o)))
 
+#?(:clj
+   (defmethod print-method clojure.lang.PersistentQueue [q, w]
+     ;; Overload the printer for queues so they look like fish
+     (print-method '<- w)
+     (print-method (seq q) w)
+     (print-method '-< w)))
+
+(defn queue
+  ([] #?(:clj clojure.lang.PersistentQueue/EMPTY :cljs #queue []))
+  ([a] (into (queue) [a]))
+  ([a & more] (into (queue) (cons a more))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data Structures Manipulation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn editable-collection?
+  [m]
+  #?(:clj (instance? clojure.lang.IEditableCollection m)
+     :cljs (implements? core/IEditableCollection m)))
+
 (defn deep-merge
   ([a b]
    (if (map? a)
@@ -45,10 +66,6 @@
   ([a b & rest]
    (reduce deep-merge a (cons b rest))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data Structures Manipulation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
 (defn dissoc-in
   [m [k & ks]]
   (if ks
@@ -89,7 +106,6 @@
 
 (defn preconj
   [coll elem]
-  (assert (vector? coll))
   (into [elem] coll))
 
 (defn enumerate
@@ -117,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]
@@ -151,15 +168,22 @@
   "Given a map, return a map removing key-value
   pairs when value is `nil`."
   [data]
-  (into {} (remove (comp nil? second) data)))
+  (into {} (remove (comp nil? second)) data))
+
+(defn without-qualified
+  [data]
+  (into {} (remove (comp qualified-keyword? first)) data))
 
 (defn without-keys
   "Return a map without the keys provided
   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
@@ -182,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]
@@ -296,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]
@@ -310,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]
@@ -374,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"
@@ -391,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))
@@ -563,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
@@ -609,3 +633,72 @@
           (if (or (keyword? k) (string? k))
             [(keyword (str/kebab (name k))) v]
             [k v])))))
+
+
+(defn group-by
+  ([kf coll] (group-by kf identity [] coll))
+  ([kf vf coll] (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)))
+             {}
+             coll))))
+
+;; TEMPORAL COPY of clojure-1.11 iteration function, should be
+;; replaced with the builtin on when stable version is released.
+
+#?(:clj
+   (defn iteration
+     "Creates a seqable/reducible via repeated calls to step,
+     a function of some (continuation token) 'k'. The first call to step
+     will be passed initk, returning 'ret'. Iff (somef ret) is true,
+     (vf ret) will be included in the iteration, else iteration will
+     terminate and vf/kf will not be called. If (kf ret) is non-nil it
+     will be passed to the next step call, else iteration will terminate.
+     This can be used e.g. to consume APIs that return paginated or batched data.
+      step - (possibly impure) fn of 'k' -> 'ret'
+      :somef - fn of 'ret' -> logical true/false, default 'some?'
+      :vf - fn of 'ret' -> 'v', a value produced by the iteration, default 'identity'
+      :kf - fn of 'ret' -> 'next-k' or nil (signaling 'do not continue'), default 'identity'
+      :initk - the first value passed to step, default 'nil'
+     It is presumed that step with non-initk is unreproducible/non-idempotent.
+     If step with initk is unreproducible it is on the consumer to not consume twice."
+     {:added "1.11"}
+     [step & {:keys [somef vf kf initk]
+              :or {vf identity
+                   kf identity
+                   somef some?
+                   initk nil}}]
+     (reify
+       clojure.lang.Seqable
+       (seq [_]
+         ((fn next [ret]
+            (when (somef ret)
+              (cons (vf ret)
+                    (when-some [k (kf ret)]
+                      (lazy-seq (next (step k)))))))
+          (step initk)))
+       clojure.lang.IReduceInit
+       (reduce [_ rf init]
+         (loop [acc init
+                ret (step initk)]
+           (if (somef ret)
+             (let [acc (rf acc (vf ret))]
+               (if (reduced? acc)
+                 @acc
+                 (if-some [k (kf ret)]
+                   (recur acc (step k))
+                   acc)))
+             acc))))))
+
+(defn toggle-selection
+  ([set value]
+   (toggle-selection set value false))
+
+  ([set value toggle?]
+   (if-not toggle?
+     (conj (ordered-set) value)
+     (if (contains? set value)
+       (disj set value)
+       (conj set value)))))

common/src/app/common/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

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

common/src/app/common/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/align.cljc

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

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

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

@@ -11,7 +11,9 @@
       :clj  [clojure.pprint :as pp])
    #?(:cljs [cljs.core :as c]
       :clj [clojure.core :as c])
-   [app.common.math :as mth]))
+   [app.common.math :as mth]
+   [app.common.spec :as us]
+   [clojure.spec.alpha :as s]))
 
 ;; --- Point Impl
 
@@ -19,13 +21,19 @@
 
 (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)
       (and (map? v) (contains? v :x) (contains? v :y))))
 
-(defn ^boolean point-like?
+(s/def ::x ::us/safe-number)
+(s/def ::y ::us/safe-number)
+
+(s/def ::point
+  (s/and (s/keys :req-un [::x ::y]) point?))
+
+(defn point-like?
   [{:keys [x y] :as v}]
   (and (map? v)
        (not (nil? x))
@@ -52,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)))
@@ -87,7 +100,6 @@
   (assert (point? other))
   (Point. (/ x ox) (/ y oy)))
 
-
 (defn min
   ([] (min nil nil))
   ([p1] (min p1 nil))
@@ -123,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}]
@@ -159,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]
@@ -185,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,53 +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
+(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)