Merge pull request #2213 from penpot/superalex-fix-export-simple-path

🐛 Fix export simple path

.circleci/config.yml

@@ -2,22 +2,16 @@ 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
+    resource_class: large
 
     environment:
       # Customize the JVM maximum heap limit
@@ -33,6 +27,8 @@ jobs:
            # fallback to using the latest cache if no exact match is found
            - v1-dependencies-
 
+      - run: cd .clj-kondo && cat config.edn
+
       - run:
           name: common lint
           working_directory: "./common"

.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
    }}
@@ -34,6 +38,9 @@
   :single-key-in
   {:level :warning}
 
+  :non-arg-vec-return-type-hint
+  {:level :off}
+
   :redundant-do
   {:level :off}
 

.clj-kondo/hooks/export.clj

@@ -53,24 +53,37 @@
   [{:keys [:node]}]
   (let [[rnode rtype ?meta & other] (:children node)
         rsym    (gensym (name (:k rtype)))
-        result  (api/list-node
-                 [(api/token-node (symbol "do"))
-                  (api/list-node
-                   [(api/token-node (symbol "declare"))
-                    (api/token-node rsym)])
-                  (if (= :map (:tag ?meta))
-                    (api/list-node
-                     [(api/token-node (symbol "reset-meta!"))
-                      (api/token-node rsym)
-                      ?meta])
-                    (api/list-node
-                     [(api/token-node (symbol "comment"))
-                      (api/token-node rsym)]))
-                  (api/list-node
-                   (into [(api/token-node (symbol "defmethod"))
-                          (api/token-node rsym)
-                          rtype]
-                         (cons ?meta other)))])]
-    ;; (prn "==============" rtype (into {} ?meta))
+
+        [?docs other] (if (api/string-node? ?meta)
+                        [?meta other]
+                        [nil (cons ?meta other)])
+
+        [?meta other] (let [?meta (first other)]
+                        (if (api/map-node? ?meta)
+                          [?meta (rest other)]
+                          [nil   other]))
+
+        nodes         [(api/token-node (symbol "do"))
+                       (api/list-node
+                        [(api/token-node (symbol "declare"))
+                         (api/token-node rsym)])
+
+                       (when ?docs
+                         (api/list-node
+                          [(api/token-node (symbol "comment")) ?docs]))
+
+                       (when ?meta
+                         (api/list-node
+                          [(api/token-node (symbol "reset-meta!"))
+                           (api/token-node rsym)
+                           ?meta]))
+                       (api/list-node
+                        (into [(api/token-node (symbol "defmethod"))
+                               (api/token-node rsym)
+                               rtype]
+                              other))]
+        result  (api/list-node (filterv some? nodes))]
+
+    ;; (prn "=====>" rtype)
     ;; (prn (api/sexpr result))
     {:node result}))

.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
@@ -22,6 +23,7 @@
 /backend/resources/public/assets
 /backend/resources/public/media
 /backend/target/
+/backend/builtin-templates
 /bundle*
 /cd.md
 /clj-profiler/
@@ -33,13 +35,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,377 @@
 # CHANGELOG
 
+## 1.15.2-beta
+
+### :bug: Bugs fixed
+
+- Fix problem with multi-user text editing [Taiga #3446](https://tree.taiga.io/project/penpot/issue/3446)
+- Fix path tools blocking elements underneath [#2050](https://github.com/penpot/penpot/issues/2050)
+- Fix frame titles deforming when resize [#2207](https://github.com/penpot/penpot/issues/2207)
+- Fix export simple line path [#3890](https://tree.taiga.io/project/penpot/issue/3890)
+
+## 1.15.1-beta
+
+### :bug: Bugs fixed
+
+- Fix shadows doesn't work on nested artboards [Taiga #3886](https://tree.taiga.io/project/penpot/issue/3886)
+- Fix problems with double-click and selection [Taiga #4005](https://tree.taiga.io/project/penpot/issue/4005)
+- Fix mismatch between editor and displayed text in workspace [Taiga #3975](https://tree.taiga.io/project/penpot/issue/3975)
+- Fix validation error on text position [Taiga #4010](https://tree.taiga.io/project/penpot/issue/4010)
+- Fix objects jitter while scrolling [Github #2167](https://github.com/penpot/penpot/issues/2167)
+- Fix on color-picker, click+drag adds lots of recent colors [Taiga #4013](https://tree.taiga.io/project/penpot/issue/4013)
+- Fix opening profile URL while signed out takes to "your account" section[Taiga #3976](https://tree.taiga.io/project/penpot/issue/3976)
+
+## 1.15.0-beta
+
+### :boom: Breaking changes & Deprecations
+
+- The `PENPOT_LOGIN_WITH_LDAP` environment variable is finally removed (after
+  many version with deprecation). It is replaced with the
+  `enable-login-with-ldap` flag.
+- The `PENPOT_LDAP_ATTRS_PHOTO` finally removed, it was unused for many
+  versions.
+- If you are using social login (google, github, gitlab or generic OIDC) you
+  will need to ensure to add the following flags respectivelly to let them
+  enabled: `enable-login-with-google`, `enable-login-with-github`,
+  `enable-login-with-gitlab` and `enable-login-with-oidc`. If not, they will
+  remain disabled after application start independently if you set the client-id
+  and client-sectet options.
+- The `PENPOT_REGISTRATION_ENABLED` is finally removed in favour of
+  `<enable|disable>-registration` flag.
+- The OIDC providers are now initialized synchronously, and if you are using the
+  discovery mechanism of the generic OIDC integration, the start time of the
+  application will depend on how fast the OIDC provider responds to the
+  discovery http request.
+
+### :sparkles: New features
+
+- Add some cosmetic changes in viewer mode [Taiga #3688](https://tree.taiga.io/project/penpot/us/3688)
+- Allow for nested and rotated boards inside other boards and groups [Taiga #2874](https://tree.taiga.io/project/penpot/us/2874?milestone=319982)
+- View mode improvements to enable access and use in different conditions [Taiga #3023](https://tree.taiga.io/project/penpot/us/3023)
+- Improved share link options. Now you can allow non-team members to comment and/or inspect [Taiga #3056] (https://tree.taiga.io/project/penpot/us/3056)
+- Signin/Signup from shared link [Taiga #3472](https://tree.taiga.io/project/penpot/us/3472)
+- Support for import/export binary format [Taiga #2991](https://tree.taiga.io/project/penpot/us/2991)
+- Comments positioning [Taiga #2007](https://tree.taiga.io/project/penpot/us/2007)
+- Select all inside a group select only the objects at this group level [Taiga #2382](https://tree.taiga.io/project/penpot/issue/2382)
+- Make the media maximum upload size configurable
+
+### :bug: Bugs fixed
+
+- Fix viewer scroll problems [Taiga 3403](https://tree.taiga.io/project/penpot/issue/3403)
+- Fix hide html options on handoff [Taiga 3533](https://tree.taiga.io/project/penpot/issue/3533)
+- Fix share prototypes overlay and stroke [Taiga #3994](https://tree.taiga.io/project/penpot/issue/3994)
+- Fix border radious on boolean operations [Taiga #3959](https://tree.taiga.io/project/penpot/issue/3959)
+- Fix inconsistent representation of rectangles [Taiga #3977](https://tree.taiga.io/project/penpot/issue/3977)
+- Fix recent fonts info [Taiga #3953](https://tree.taiga.io/project/penpot/issue/3953)
+- Fix clipped elements affect boards and centering [Taiga #3666](https://tree.taiga.io/project/penpot/issue/3666)
+- Fix intro action in multi input [Taiga #3541](https://tree.taiga.io/project/penpot/issue/3541)
+- Fix team default image [Taiga #3919](https://tree.taiga.io/project/penpot/issue/3919)
+- Fix problem with group coordinates [#2008](https://github.com/penpot/penpot/issues/2008)
+- Fix problem with line-height and texts [Taiga #3578](https://tree.taiga.io/project/penpot/issue/3578)
+- Fix moving frame-guides outside frames [Taiga #3839](https://tree.taiga.io/project/penpot/issue/3839)
+- Fix problem with 180 degree rotations [#2082](https://github.com/penpot/penpot/issues/2082)
+- Fix font rendering on grid thumbnails [Taiga #3473](https://tree.taiga.io/project/penpot/issue/3473)
+- Fix Drag and drop font assets in groups [Taiga #3763](https://tree.taiga.io/project/penpot/issue/3763)
+- Fix copy and paste layers order [Taiga #1617](https://tree.taiga.io/project/penpot/issue/1617)
+- Fix unexpected removal of guides on copy&paste frames [Taiga #3887](https://tree.taiga.io/project/penpot/issue/3887) by @andrewzhurov
+- Fix props preserving on copy&paste texts [Taiga #3629](https://tree.taiga.io/project/penpot/issue/3629) by @andrewzhurov
+- Fix unexpected layers ungrouping on moving it [Taiga #3932](https://tree.taiga.io/project/penpot/issue/3932) by @andrewzhurov
+- Fix unexpected exception and behavior on colorpicker with gradients [Taiga #3448](https://tree.taiga.io/project/penpot/issue/3448)
+- Fix multiselection with shift not working inside a library group [Taiga #3532](https://tree.taiga.io/project/penpot/issue/3532)
+- Fix drag and drop graphic assets in groups [Taiga #4002](https://tree.taiga.io/project/penpot/issue/4002)
+- Fix bringing complete file data when launching the export dialog [Taiga #4006](https://tree.taiga.io/project/penpot/issue/4006)
+
+
+
+### :arrow_up: Deps updates
+### :heart: Community contributions by (Thank you!)
+
+## 1.14.2-beta
+
+### :bug: Bugs fixed
+
+- Fix colors from unlinked libs in color selected widget [Taiga #3712](https://tree.taiga.io/project/penpot/issue/3712)
+- Fix fill information not complete when paste plain text [Taiga #3680](https://tree.taiga.io/project/penpot/issue/3680)
+- Fix problem when resizing groups [Taiga #3702](https://tree.taiga.io/project/penpot/issue/3702)
+- Fix issues on typographies assets grouping [#2073](https://github.com/penpot/penpot/issues/2073)
+- Fix text positioning inconsistencies between browsers
+
+## 1.14.1-beta
+
+### :bug: Bugs fixed
+
+- Fix shortcut access in main menu [Taiga #3672](https://tree.taiga.io/project/penpot/issue/3672)
+- Fix modify colors in a row in selected colors [Taiga #3653](https://tree.taiga.io/project/penpot/issue/3653)
+- Fix crash when double click on viewer assets [Taiga #3625](https://tree.taiga.io/project/penpot/issue/3625)
+- Fix right click on typographies assets [Taiga #3638](https://tree.taiga.io/project/penpot/issue/3638)
+
+## 1.14.0-beta
+
+### :sparkles: New features
+
+- Added shortcut panel in workspace [Taiga #36](https://tree.taiga.io/project/penpot/us/36)
+- Added selected colors widget in right sidebar [Taiga #2485](https://tree.taiga.io/project/penpot/us/2485)
+- Added fixed elements when scrolling [Taiga #1533](https://tree.taiga.io/project/penpot/us/1533)
+- Multiple team invitations on onboarding [Taiga #3084](https://tree.taiga.io/project/penpot/us/3084)
+- Change text properties position at the sidebar [Taiga #3047](https://tree.taiga.io/project/penpot/us/3047)
+- Group assets by drag and drop [Taiga #2831](https://tree.taiga.io/project/penpot/us/2831)
+- Navigate to the original link after log in [Taiga #3624](https://tree.taiga.io/project/penpot/issue/3624)
+
+### :bug: Bugs fixed
+
+- Fix menu file not accessible in certain conditions [Taiga #3385](https://tree.taiga.io/project/penpot/issue/3385)
+- Remove deprecated menu options [Taiga #3333](https://tree.taiga.io/project/penpot/issue/3333)
+- Prototype connection should be under the rules [Taiga #3384](https://tree.taiga.io/project/penpot/issue/3384)
+- Fix problem with empty text boxes events [Taiga #3627](https://tree.taiga.io/project/penpot/issue/3627)
+
+
+## 1.13.5-beta
+
+### :bug: Bugs fixed
+- Fix orientation artboard preset not working with differently sized artboards [Taiga #3548](https://tree.taiga.io/project/penpot/issue/3548)
+- Fix background on export arboards [Taiga #1991](https://tree.taiga.io/project/penpot/issue/1991)
+
+## 1.13.4-beta
+
+### :bug: Bugs fixed
+
+- Fix undo when drawing curves [Taiga #3523](https://tree.taiga.io/project/penpot/issue/3523)
+- Fix issue with text edition and certain fonts (WorkSans, Raleway, ...) and foreign objects [Taiga #3521](https://tree.taiga.io/project/penpot/issue/3521)
+- Fix thumbnail generation when concurrent edition [Taiga #3522](https://tree.taiga.io/project/penpot/issue/3522)
+- Fix environment imporot for exporter in Docker
+- Fix auto scroll layers in Firefox [Taiga #3531](https://tree.taiga.io/project/penpot/issue/3531)
+- Fix base background not visible for imported SVG
+
+## 1.13.3-beta
+
+### :bug: Bugs fixed
+
+- Fix docker dependencies
+- Sets invitations expirations to 7 days
+- Add safety measure for text positions
+- Fix old texts with opacity and no fill
+- Remove default font on team change
+- Fix github auth without name
+- Fix problems with font loading in Firefox 95
+
+## 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)
+- Round the size values on handoff to two decimals [Taiga #3227](https://tree.taiga.io/project/penpot/issue/3227)
+- 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
+
+- Fix issue on handling empty content on boolean shapes
+- Fix race condition issue on component renaming
+- Handle EOF errors on writting streamed response
+- Handle EOF errors on websocket send/ping methods
+- Disable parallel upload of file media on import (causes too much
+  contention on the rlimit subsistem that does not works as expected
+  on high load).
+
+### :sparkles: New features
+
+- Add health check endpoint on API
+- Increase default max connection pool size to 60
+- Reduce resource usage of the error reporter.
+
 ## 1.11.1-beta
 
 ### :bug: Bugs fixed
@@ -11,11 +383,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)
@@ -93,7 +462,7 @@
 
 ### :arrow_up: Deps updates
 
-- Update devenv docker image dependencies.
+- Update devenv docker image dependencies
 
 ### :heart: Community contributions by (Thank you!)
 
@@ -105,13 +474,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

SECURITY.md

@@ -0,0 +1,5 @@
+# Security Policy
+
+## Reporting a Vulnerability
+
+Please report security issues to `support@penpot.app`

backend/deps.edn

@@ -1,49 +1,56 @@
 {:deps
  {penpot/common {:local/root "../common"}
+  org.clojure/clojure {:mvn/version "1.11.1"}
   org.clojure/core.async {:mvn/version "1.5.648"}
 
   ;; Logging
   org.zeromq/jeromq {:mvn/version "0.5.2"}
 
   com.taoensso/nippy {:mvn/version "3.1.1"}
-  com.github.luben/zstd-jni {:mvn/version "1.5.1-1"}
+  com.github.luben/zstd-jni {:mvn/version "1.5.2-3"}
   org.clojure/data.fressian {:mvn/version "1.0.0"}
 
-  io.prometheus/simpleclient {:mvn/version "0.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"}
+  io.lettuce/lettuce-core {:mvn/version "6.1.8.RELEASE"}
   java-http-clj/java-http-clj {:mvn/version "0.4.3"}
 
-  funcool/yetti {:git/tag "v4.0" :git/sha "59ed2a7"
+  funcool/yetti {:git/tag "v9.8" :git/sha "fbe1d7d"
                  :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.780"}
+  metosin/reitit-core {:mvn/version "0.5.18"}
+  org.postgresql/postgresql {:mvn/version "42.4.0"}
   com.zaxxer/HikariCP {:mvn/version "5.0.1"}
-  funcool/datoteka {:mvn/version "2.0.0"}
+
+  funcool/datoteka {:mvn/version "3.0.64"}
 
   buddy/buddy-hashers {:mvn/version "1.8.158"}
   buddy/buddy-sign {:mvn/version "3.4.333"}
 
-  org.jsoup/jsoup {:mvn/version "1.14.3"}
-  org.im4java/im4java {:mvn/version "1.4.0"}
+  org.jsoup/jsoup {:mvn/version "1.15.1"}
+  org.im4java/im4java {:git/tag "1.4.0-penpot-2" :git/sha "e2b3e16"
+                       :git/url "https://github.com/penpot/im4java"}
+
   org.lz4/lz4-java {:mvn/version "1.8.0"}
 
   org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
   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.1"}
 
   ;; Pretty Print specs
   pretty-spec/pretty-spec {:mvn/version "0.1.4"}
-  software.amazon.awssdk/s3 {:mvn/version "2.17.111"}}
+  software.amazon.awssdk/s3 {:mvn/version "2.17.209"}}
 
  :paths ["src" "resources" "target/classes"]
  :aliases
@@ -59,13 +66,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.8.2" :git/sha "ba1a2bf"}}
    :ns-default build}
 
-  :kaocha
-  {:extra-deps {lambdaisland/kaocha {:mvn/version "RELEASE"}}
-   :main-opts ["-m" "kaocha.runner"]}
-
   :test
   {:extra-paths ["test"]
    :extra-deps

backend/dev/script-fix-sobjects.clj

@@ -0,0 +1,114 @@
+;; 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
+
+;; This is an example on how it can be executed:
+;; clojure -Scp $(cat classpath) -M dev/script-fix-sobjects.clj
+
+(require
+ '[app.common.logging :as l]
+ '[app.common.data :as d]
+ '[app.common.pprint]
+ '[app.db :as db]
+ '[app.storage :as sto]
+ '[app.storage.impl :as impl]
+ '[app.util.time :as dt]
+ '[integrant.core :as ig])
+
+;; --- HELPERS
+
+(l/info :hint "initializing script" :args *command-line-args*)
+
+(def noop? (some #(= % "noop") *command-line-args*))
+(def chunk-size 10)
+
+(def sql:retrieve-sobjects-chunk
+  "SELECT * FROM storage_object
+    WHERE created_at < ? AND deleted_at is NULL
+    ORDER BY created_at desc LIMIT ?")
+
+(defn get-chunk
+  [conn cursor]
+  (let [rows (db/exec! conn [sql:retrieve-sobjects-chunk cursor chunk-size])]
+    [(some->> rows peek :created-at) (seq rows)]))
+
+(defn get-candidates
+  [conn]
+  (->> (d/iteration (partial get-chunk conn)
+                    :vf second
+                    :kf first
+                    :initk (dt/now))
+       (sequence cat)))
+
+(def modules
+  [:app.db/pool
+   :app.storage/storage
+   [:app.main/default :app.worker/executor]
+   [:app.main/assets :app.storage.s3/backend]
+   [:app.main/assets :app.storage.fs/backend]])
+
+(def system
+  (let [config (select-keys app.main/system-config modules)
+        config (-> config
+                   (assoc :app.migrations/all {})
+                   (assoc :app.metrics/metrics nil))]
+    (ig/load-namespaces config)
+    (-> config ig/prep ig/init)))
+
+(defn update-fn
+  [{:keys [conn] :as storage} {:keys [id backend] :as row}]
+  (cond
+    (= backend "s3")
+    (do
+      (l/info :hint "rename storage object backend"
+              :id id
+              :from-backend backend
+              :to-backend :assets-s3)
+      (assoc row :backend "assets-s3"))
+
+    (= backend "assets-s3")
+    (do
+      (l/info :hint "ignoring storage object" :id id :backend backend)
+      nil)
+
+    (or (= backend "fs")
+        (= backend "assets-fs"))
+    (let [sobj (sto/row->storage-object row)
+          path (-> (sto/get-object-path storage sobj) deref)]
+      (l/info :hint "change storage object backend"
+              :id id
+              :from-backend backend
+              :to-backend :assets-s3)
+      (when-not noop?
+        (-> (impl/resolve-backend storage :assets-s3)
+            (impl/put-object sobj (sto/content path))
+            (deref)))
+      (assoc row :backend "assets-s3"))
+
+    :else
+    (throw (IllegalArgumentException. "unexpected backend found"))))
+
+(try
+  (db/with-atomic [conn (:app.db/pool system)]
+    (let [storage (:app.storage/storage system)
+          storage (assoc storage :conn conn)]
+      (loop [items (get-candidates conn)]
+        (when-let [item (first items)]
+          (when-let [{:keys [id] :as row} (update-fn storage item)]
+          (db/update! conn :storage-object (dissoc row :id) {:id (:id item)}))
+          (recur (rest items))))
+      (when noop?
+        (throw (ex-info "explicit rollback" {})))))
+
+  (catch Throwable cause
+    (cond
+      (= "explicit rollback" (ex-message cause))
+      (l/warn :hint "transaction aborted")
+
+      :else
+      (l/error :hint "unexpected exception" :cause cause))))
+
+(ig/halt! system)
+(System/exit 0)

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]
@@ -24,7 +25,6 @@
    [clojure.spec.alpha :as s]
    [clojure.spec.gen.alpha :as sgen]
    [clojure.test :as test]
-   [clojure.test :as test]
    [clojure.tools.namespace.repl :as repl]
    [clojure.walk :refer [macroexpand-all]]
    [datoteka.core]

backend/resources/api-doc-entry.tmpl

@@ -0,0 +1,54 @@
+<li class="rpc-item">
+  <div class="rpc-row-info">
+    {# <div class="type">{{item.type}}</div> #}
+    <div class="module">{{item.module}}:</div>
+    <div class="name">{{item.name}}</div>
+    <div class="tags">
+      {% if item.deprecated %}
+        <span class="tag">
+          <span>Deprecated:</span>
+          <span>since v{{item.deprecated}}</span>,
+        </span>
+      {% endif %}
+      <span class="tag">
+        <span>Auth:</span>
+        <span>{% if item.auth %}YES{% else %}NO{% endif %}</span>
+      </span>
+    </div>
+  </div>
+  <div class="rpc-row-detail hidden">
+    <h3>DOCSTRING:</h3>
+
+    <section class="padded-section">
+
+      {% if item.added %}
+        <p class="small"><strong>Added:</strong> on v{{item.added}}</p>
+      {% endif %}
+
+      {% if item.deprecated %}
+        <p class="small"><strong>Deprecated:</strong> since v{{item.deprecated}}</p>
+      {% endif %}
+
+      {% if item.docs %}
+        <p class="docstring"> {{item.docs}}</p>
+      {% endif %}
+    </section>
+
+    {% if item.changes %}
+      <h3>CHANGES:</h3>
+      <section class="padded-section">
+
+        <ul class="changes">
+          {% for change in item.changes %}
+            <li><strong>{{change.0}}</strong> - {{change.1}}</li>
+          {% endfor %}
+        </ul>
+      </section>
+    {% endif %}
+
+    <h3>SPEC EXPLAIN:</h3>
+    <section class="padded-section">
+      <pre class="spec-explain">{{item.spec}}</pre>
+    </section>
+  </div>
+</li>

backend/resources/api-doc.css

@@ -53,7 +53,7 @@ header {
 
 .rpc-item {
   /* border: 1px solid red; */
-  cursor: pointer;
+  /* cursor: pointer; */
   display: flex;
   flex-direction: column;
 }
@@ -85,6 +85,16 @@ header {
 .rpc-row-info > .name {
   width: 280px;
   /* font-weight: bold; */
+  border-right: 1px dotted #777;
+  padding-right: 10px;
+}
+
+.rpc-row-info > .module {
+  width: 120px;
+  font-weight: bold;
+  border-right: 1px dotted #777;
+  text-align: right;
+  padding-right: 10px;
 }
 
 .rpc-row-info > .tags > .tag > span:first-child {
@@ -99,3 +109,37 @@ header {
   padding: 5px 10px;
   padding-bottom: 20px;
 }
+
+.rpc-row-detail p {
+  font-weight: 200;
+}
+
+.rpc-row-detail p.small {
+  margin-top: 2px;
+  margin-bottom: 2px;
+  font-size: 10px;
+}
+
+.rpc-row-detail p.small {
+  margin-top: 2px;
+  margin-bottom: 2px;
+  font-size: 10px;
+}
+
+.rpc-row-detail strong {
+  font-weight: 500;
+}
+
+.rpc-row-detail .changes {
+  font-weight: 200;
+  list-style: none;
+  padding: 0px;
+}
+
+.rpc-row-detail .padded-section {
+  padding: 0px 10px;
+}
+
+p.small strong {
+  font-size: 10px;
+}

backend/resources/api-doc.tmpl

@@ -5,7 +5,10 @@
     <meta name="robots" content="noindex,nofollow">
     <meta http-equiv="x-ua-compatible" content="ie=edge" />
     <title>Builtin API Documentation - Penpot</title>
-    <link rel="stylesheet" href="https://fonts.googleapis.com/css2?family=JetBrains+Mono">
+
+    <link rel="preconnect" href="https://fonts.googleapis.com">
+    <link rel="preconnect" href="https://fonts.gstatic.com" crossorigin>
+    <link href="https://fonts.googleapis.com/css2?family=JetBrains+Mono:wght@200;300;400;500;700&display=swap" rel="stylesheet">
     <style>
       {% include "api-doc.css" %}
     </style>
@@ -16,61 +19,28 @@
   <body>
     <main>
       <header>
-        <h1>Penpot API Documentation</h1>
+        <h1>Penpot API Documentation (v{{version}})</h1>
       </header>
       <section class="rpc-doc-content">
 
+        <h2>RPC COMMAND METHODS:</h2>
+        <ul class="rpc-items">
+          {% for item in command-methods %}
+            {% include "api-doc-entry.tmpl" with item=item %}
+          {% endfor %}
+        </ul>
+
         <h2>RPC QUERY METHODS:</h2>
         <ul class="rpc-items">
           {% for item in query-methods %}
-            <li class="rpc-item">
-              <div class="rpc-row-info">
-                {# <div class="type">{{item.type}}</div> #}
-                <div class="name">{{item.name}}</div>
-                <div class="tags">
-                  <span class="tag">
-                    <span>Auth:</span>
-                    <span>{% if item.auth %}YES{% else %}NO{% endif %}</span>
-                  </span>
-                </div>
-              </div>
-              <div class="rpc-row-detail hidden">
-                {% if item.docs %}
-                  <h3>DOCSTRING:</h3>
-                  <p>{{item.docs}}</p>
-                {% endif %}
-
-                <h3>SPEC EXPLAIN:</h3>
-                <pre>{{item.spec}}</pre>
-              </div>
-            </li>
+            {% include "api-doc-entry.tmpl" with item=item %}
           {% endfor %}
         </ul>
 
         <h2>RPC MUTATION METHODS:</h2>
         <ul class="rpc-items">
           {% for item in mutation-methods %}
-            <li class="rpc-item">
-              <div class="rpc-row-info">
-                {# <div class="type">{{item.type}}</div> #}
-                <div class="name">{{item.name}}</div>
-                <div class="tags">
-                  <span class="tag">
-                    <span>Auth:</span>
-                    <span>{% if item.auth %}YES{% else %}NO{% endif %}</span>
-                  </span>
-                </div>
-              </div>
-              <div class="rpc-row-detail hidden">
-                {% if item.docs %}
-                  <h3>DOCSTRING:</h3>
-                  <p>{{item.docs}}</p>
-                {% endif %}
-
-                <h3>SPEC EXPLAIN:</h3>
-                <pre>{{item.spec}}</pre>
-              </div>
-            </li>
+            {% include "api-doc-entry.tmpl" with item=item %}
           {% endfor %}
         </ul>
       </section>

backend/resources/emails-mjml/change-email/en.mjml

@@ -37,7 +37,7 @@
     <mj-section padding="24px 0 0 0">
       <mj-column width="425px">
         <mj-text align="center" font-size="14px" color="#64666A">
-          Penpot is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.
+          Penpot is the first Open Source design and prototyping platform meant for cross-domain teams.
         </mj-text>
       </mj-column>
     </mj-section>

backend/resources/emails-mjml/invite-to-team/en.mjml

@@ -30,7 +30,7 @@
     <mj-section padding="24px 0 0 0">
       <mj-column width="425px">
         <mj-text align="center" font-size="14px" color="#64666A">
-          Penpot is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.
+          Penpot is the first Open Source design and prototyping platform meant for cross-domain teams.
         </mj-text>
       </mj-column>
     </mj-section>

backend/resources/emails-mjml/password-recovery/en.mjml

@@ -39,7 +39,7 @@
     <mj-section padding="24px 0 0 0">
       <mj-column width="425px">
         <mj-text align="center" font-size="14px" color="#64666A">
-          Penpot is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.
+          Penpot is the first Open Source design and prototyping platform meant for cross-domain teams.
         </mj-text>
       </mj-column>
     </mj-section>

backend/resources/emails-mjml/register/en.mjml

@@ -36,7 +36,7 @@
     <mj-section padding="24px 0 0 0">
       <mj-column width="425px">
         <mj-text align="center" font-size="14px" color="#64666A">
-          Penpot is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.
+          Penpot is the first Open Source design and prototyping platform meant for cross-domain teams.
         </mj-text>
       </mj-column>
     </mj-section>

backend/resources/emails/change-email/en.html

@@ -250,7 +250,7 @@
                 <table border="0" cellpadding="0" cellspacing="0" role="presentation" style="vertical-align:top;" width="100%">
                   <tr>
                     <td align="center" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot is the first Open Source design and prototyping platform meant for cross-domain teams.</div>
                     </td>
                   </tr>
                 </table>
@@ -450,7 +450,7 @@
                 <table border="0" cellpadding="0" cellspacing="0" role="presentation" style="vertical-align:top;" width="100%">
                   <tr>
                     <td align="center" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot @ 2021 | Made with &lt;3 and Open Source</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot | Made with &lt;3 and Open Source</div>
                     </td>
                   </tr>
                 </table>

backend/resources/emails/invite-to-team/en.html

@@ -240,7 +240,7 @@
                 <table border="0" cellpadding="0" cellspacing="0" role="presentation" style="vertical-align:top;" width="100%">
                   <tr>
                     <td align="center" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot is the first Open Source design and prototyping platform meant for cross-domain teams.</div>
                     </td>
                   </tr>
                 </table>
@@ -440,7 +440,7 @@
                 <table border="0" cellpadding="0" cellspacing="0" role="presentation" style="vertical-align:top;" width="100%">
                   <tr>
                     <td align="center" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot @ 2021 | Made with &lt;3 and Open Source</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot | Made with &lt;3 and Open Source</div>
                     </td>
                   </tr>
                 </table>

backend/resources/emails/password-recovery/en.html

@@ -245,7 +245,7 @@
                 <table border="0" cellpadding="0" cellspacing="0" role="presentation" style="vertical-align:top;" width="100%">
                   <tr>
                     <td align="center" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot is the first Open Source design and prototyping platform meant for cross-domain teams.</div>
                     </td>
                   </tr>
                 </table>
@@ -445,7 +445,7 @@
                 <table border="0" cellpadding="0" cellspacing="0" role="presentation" style="vertical-align:top;" width="100%">
                   <tr>
                     <td align="center" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot @ 2021 | Made with &lt;3 and Open Source</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot | Made with &lt;3 and Open Source</div>
                     </td>
                   </tr>
                 </table>

backend/resources/emails/register/en.html

@@ -240,7 +240,7 @@
                 <table border="0" cellpadding="0" cellspacing="0" role="presentation" style="vertical-align:top;" width="100%">
                   <tr>
                     <td align="center" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot is the first Open Source design and prototyping platform meant for cross-domain teams.</div>
                     </td>
                   </tr>
                 </table>
@@ -440,7 +440,7 @@
                 <table border="0" cellpadding="0" cellspacing="0" role="presentation" style="vertical-align:top;" width="100%">
                   <tr>
                     <td align="center" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot @ 2021 | Made with &lt;3 and Open Source</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot | Made with &lt;3 and Open Source</div>
                     </td>
                   </tr>
                 </table>

backend/resources/log4j2-devenv.xml

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

backend/resources/log4j2.xml

@@ -7,14 +7,11 @@
   </Appenders>
 
   <Loggers>
+    <Logger name="io.lettuce" level="error" />
     <Logger name="com.zaxxer.hikari" level="error" />
-    <Logger name="org.eclipse.jetty" level="error" />
+    <Logger name="org.postgresql" level="error" />
 
-    <Logger name="app" level="debug" additivity="false">
-      <AppenderRef ref="console" />
-    </Logger>
-
-    <Logger name="penpot" level="fatal" additivity="false">
+    <Logger name="app" level="info" additivity="false">
       <AppenderRef ref="console" />
     </Logger>
 

backend/resources/templates/debug.tmpl

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

backend/resources/templates/styles.css

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

backend/scripts/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,19 +12,36 @@
 # export PENPOT_DATABASE_URI="postgresql://172.17.0.1:5432/penpot_pre"
 # export PENPOT_DATABASE_USERNAME="penpot_pre"
 # export PENPOT_DATABASE_PASSWORD="penpot_pre"
-# export PENPOT_FLAGS="enable-asserts enable-audit-log $PENPOT_FLAGS"
+
+# export PENPOT_LOGGERS_LOKI_URI="http://172.17.0.1:3100/loki/api/v1/push"
+# export PENPOT_AUDIT_LOG_ARCHIVE_URI="http://localhost:6070/api/audit"
+
+# Initialize MINIO config
+mc alias set penpot-s3/ http://minio:9000 minioadmin minioadmin
+mc admin user add penpot-s3 penpot-devenv penpot-devenv
+mc admin policy set penpot-s3 readwrite user=penpot-devenv
+mc mb penpot-s3/penpot -p
+
+export AWS_ACCESS_KEY_ID=penpot-devenv
+export AWS_SECRET_ACCESS_KEY=penpot-devenv
+export PENPOT_ASSETS_STORAGE_BACKEND=assets-s3
+export PENPOT_STORAGE_ASSETS_S3_ENDPOINT=http://minio:9000
+export PENPOT_STORAGE_ASSETS_S3_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 \
        -J-XX:+UnlockDiagnosticVMOptions \
        -J-XX:+DebugNonSafepoints";
 
+# Uncomment for use the ImageMagick v7.x
+# export OPTIONS="-J-Dim4java.useV7=true $OPTIONS";
+
 export OPTIONS_EVAL="nil"
 # export OPTIONS_EVAL="(set! *warn-on-reflection* true)"
 

backend/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/auth/ldap.clj

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

backend/src/app/auth/oidc.clj

@@ -0,0 +1,538 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.auth.oidc
+  "OIDC client implementation."
+  (:require
+   [app.common.data :as d]
+   [app.common.data.macros :as dm]
+   [app.common.exceptions :as ex]
+   [app.common.logging :as l]
+   [app.common.spec :as us]
+   [app.common.uri :as u]
+   [app.config :as cf]
+   [app.db :as db]
+   [app.http.middleware :as hmw]
+   [app.loggers.audit :as audit]
+   [app.rpc.queries.profile :as profile]
+   [app.util.json :as json]
+   [app.util.time :as dt]
+   [app.worker :as wrk]
+   [clojure.set :as set]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [integrant.core :as ig]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.response :as yrs]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HELPERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- obfuscate-string
+  [s]
+  (if (< (count s) 10)
+    (apply str (take (count s) (repeat "*")))
+    (str (subs s 0 5)
+         (apply str (take (- (count s) 5) (repeat "*"))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; OIDC PROVIDER (GENERIC)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- discover-oidc-config
+  [{:keys [http-client]} {:keys [base-uri] :as opts}]
+  (let [discovery-uri (u/join base-uri ".well-known/openid-configuration")
+        response      (ex/try (http-client {:method :get :uri (str discovery-uri)} {:sync? true}))]
+    (cond
+      (ex/exception? response)
+      (do
+        (l/warn :hint "unable to discover oidc configuration"
+                :discover-uri (str discovery-uri)
+                :cause response)
+        nil)
+
+      (= 200 (:status response))
+      (let [data (json/read (:body response))]
+        {:token-uri (get data :token_endpoint)
+         :auth-uri  (get data :authorization_endpoint)
+         :user-uri  (get data :userinfo_endpoint)})
+
+      :else
+      (do
+        (l/warn :hint "unable to discover OIDC configuration"
+                :uri (str discovery-uri)
+                :response-status-code (:status response))
+        nil))))
+
+(defn- prepare-oidc-opts
+  [cfg]
+  (let [opts {:base-uri      (:base-uri cfg)
+              :client-id     (:client-id cfg)
+              :client-secret (:client-secret cfg)
+              :token-uri     (:token-uri cfg)
+              :auth-uri      (:auth-uri cfg)
+              :user-uri      (:user-uri cfg)
+              :scopes        (:scopes cfg #{"openid" "profile" "email"})
+              :roles-attr    (:roles-attr cfg)
+              :roles         (:roles cfg)
+              :name          "oidc"}
+
+        opts (d/without-nils opts)]
+
+    (when (and (string? (:base-uri opts))
+               (string? (:client-id opts))
+               (string? (:client-secret opts)))
+      (if (and (string? (:token-uri opts))
+               (string? (:user-uri opts))
+               (string? (:auth-uri opts)))
+        opts
+        (some-> (discover-oidc-config cfg opts)
+                (merge opts {:discover? true}))))))
+
+(defmethod ig/prep-key ::generic-provider
+  [_ cfg]
+  (d/without-nils cfg))
+
+(defmethod ig/init-key ::generic-provider
+  [_ cfg]
+  (when (:enabled? cfg)
+    (if-let [opts (prepare-oidc-opts cfg)]
+      (do
+        (l/info :hint "provider initialized"
+                :provider :oidc
+                :method (if (:discover? opts) "discover" "manual")
+                :client-id (:client-id opts)
+                :client-secret (obfuscate-string (:client-secret opts))
+                :scopes (str/join "," (:scopes opts))
+                :auth-uri (:auth-uri opts)
+                :user-uri (:user-uri opts)
+                :token-uri (:token-uri opts)
+                :roles-attr (:roles-attr opts)
+                :roles      (:roles opts))
+        opts)
+      (do
+        (l/warn :hint "unable to initialize auth provider, missing configuration" :provider :oidc)
+        nil))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; GOOGLE AUTH PROVIDER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod ig/prep-key ::google-provider
+  [_ cfg]
+  (d/without-nils cfg))
+
+(defmethod ig/init-key ::google-provider
+  [_ cfg]
+  (let [opts {:client-id     (:client-id cfg)
+              :client-secret (:client-secret cfg)
+              :scopes        #{"openid" "email" "profile"}
+              :auth-uri      "https://accounts.google.com/o/oauth2/v2/auth"
+              :token-uri     "https://oauth2.googleapis.com/token"
+              :user-uri      "https://openidconnect.googleapis.com/v1/userinfo"
+              :name          "google"}]
+
+    (when (:enabled? cfg)
+      (if (and (string? (:client-id opts))
+               (string? (:client-secret opts)))
+        (do
+          (l/info :hint "provider initialized"
+                  :provider :google
+                  :client-id (:client-id opts)
+                  :client-secret (obfuscate-string (:client-secret opts)))
+          opts)
+
+        (do
+          (l/warn :hint "unable to initialize auth provider, missing configuration" :provider :google)
+          nil)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; GITHUB AUTH PROVIDER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- retrieve-github-email
+  [{:keys [http-client]} tdata info]
+  (or (some-> info :email p/resolved)
+      (-> (http-client {:uri "https://api.github.com/user/emails"
+                        :headers {"Authorization" (dm/str (:type tdata) " " (:token tdata))}
+                        :timeout 6000
+                        :method :get})
+          (p/then (fn [{:keys [status body] :as response}]
+                    (when-not (s/int-in-range? 200 300 status)
+                      (ex/raise :type :internal
+                                :code :unable-to-retrieve-github-emails
+                                :hint "unable to retrieve github emails"
+                                :http-status status
+                                :http-body body))
+                    (->> response :body json/read (filter :primary) first :email))))))
+
+(defmethod ig/prep-key ::github-provider
+  [_ cfg]
+  (d/without-nils cfg))
+
+(defmethod ig/init-key ::github-provider
+  [_ cfg]
+  (let [opts {:client-id     (:client-id cfg)
+              :client-secret (:client-secret cfg)
+              :scopes        #{"read:user" "user:email"}
+              :auth-uri      "https://github.com/login/oauth/authorize"
+              :token-uri     "https://github.com/login/oauth/access_token"
+              :user-uri      "https://api.github.com/user"
+              :name          "github"
+
+              ;; Additional hooks for provider specific way of
+              ;; retrieve emails.
+              :get-email-fn           (partial retrieve-github-email cfg)}]
+
+    (when (:enabled? cfg)
+      (if (and (string? (:client-id opts))
+               (string? (:client-secret opts)))
+        (do
+          (l/info :hint "provider initialized"
+                  :provider :github
+                  :client-id (:client-id opts)
+                  :client-secret (obfuscate-string (:client-secret opts)))
+          opts)
+
+        (do
+          (l/warn :hint "unable to initialize auth provider, missing configuration" :provider :github)
+          nil)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; GITLAB AUTH PROVIDER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod ig/prep-key ::gitlab-provider
+  [_ cfg]
+  (d/without-nils cfg))
+
+(defmethod ig/init-key ::gitlab-provider
+  [_ cfg]
+  (let [base (:base-uri cfg "https://gitlab.com")
+        opts {:base-uri      base
+              :client-id     (:client-id cfg)
+              :client-secret (:client-secret cfg)
+              :scopes        #{"openid" "profile" "email"}
+              :auth-uri      (str base "/oauth/authorize")
+              :token-uri     (str base "/oauth/token")
+              :user-uri      (str base "/oauth/userinfo")
+              :name          "gitlab"}]
+    (when (:enabled? cfg)
+      (if (and (string? (:client-id opts))
+               (string? (:client-secret opts)))
+        (do
+          (l/info :hint "provider initialized"
+                  :provider :gitlab
+                  :base-uri base
+                  :client-id (:client-id opts)
+                  :client-secret (obfuscate-string (:client-secret opts)))
+          opts)
+
+        (do
+          (l/warn :hint "unable to initialize auth provider, missing configuration" :provider :gitlab)
+          nil)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HANDLERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- build-redirect-uri
+  [{:keys [provider] :as cfg}]
+  (let [public (u/uri (:public-uri cfg))]
+    (str (assoc public :path (str "/api/auth/oauth/" (:name provider) "/callback")))))
+
+(defn- build-auth-uri
+  [{:keys [provider] :as cfg} state]
+  (let [params {:client_id (:client-id provider)
+                :redirect_uri (build-redirect-uri cfg)
+                :response_type "code"
+                :state state
+                :scope (str/join " " (:scopes provider []))}
+        query  (u/map->query-string params)]
+    (-> (u/uri (:auth-uri provider))
+        (assoc :query query)
+        (str))))
+
+(defn- qualify-props
+  [provider props]
+  (reduce-kv (fn [result k v]
+               (assoc result (keyword (:name provider) (name k)) v))
+             {}
+             props))
+
+(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))))))
+
+(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}))
+
+          (validate-response [response]
+            (when-not (s/int-in-range? 200 300 (:status response))
+              (ex/raise :type :internal
+                        :code :unable-to-retrieve-user-info
+                        :hint "unable to retrieve user info"
+                        :http-status (:status response)
+                        :http-body (:body response)))
+            response)
+
+          (get-email [info]
+            ;; Allow providers hook into this for custom email
+            ;; retrieval method.
+            (if-let [get-email-fn (:get-email-fn provider)]
+              (get-email-fn tdata info)
+              (let [attr-kw (cf/get :oidc-email-attr :email)]
+                (get info attr-kw))))
+
+          (get-name [info]
+            (let [attr-kw (cf/get :oidc-name-attr :name)]
+              (get info attr-kw)))
+
+          (process-response [response]
+            (p/let [info  (-> response :body json/read)
+                    email (get-email info)]
+              {:backend  (:name provider)
+               :email    email
+               :fullname (or (get-name info) email)
+               :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)]
+
+    (-> (retrieve)
+        (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
+                   ::fullname
+                   ::props]))
+
+(defn retrieve-info
+  [{: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 #{}))]
+
+                ;; 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 :error-on-retrieving-code
+                :error-id error
+                :error-desc (get params :error_description)))
+
+    (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))))))
+
+(defn- retrieve-profile
+  [{: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]
+  (yrs/response :status 302 :headers {"location" (str uri)}))
+
+(defn- generate-error-redirect
+  [cfg error]
+  (let [uri (-> (u/uri (:public-uri cfg))
+                (assoc :path "/#/auth/login")
+                (assoc :query (u/map->query-string {:error "unable-to-auth" :hint (ex-message error)})))]
+    (redirect-response uri)))
+
+(defn- generate-redirect
+  [{:keys [tokens session audit] :as cfg} request info profile]
+  (if profile
+    (let [sxf    ((:create session) (:id profile))
+          token  (or (:invitation-token info)
+                     (tokens :generate {:iss :auth
+                                        :exp (dt/in-future "15m")
+                                        :profile-id (:id profile)}))
+          params {:token token}
+
+          uri    (-> (u/uri (:public-uri cfg))
+                     (assoc :path "/#/auth/verify-token")
+                     (assoc :query (u/map->query-string params)))]
+
+      (when (fn? audit)
+        (audit :cmd :submit
+               :type "mutation"
+               :name "login"
+               :profile-id (:id profile)
+               :ip-addr (audit/parse-client-ip request)
+               :props (audit/profile->props profile)))
+
+      (->> (redirect-response uri)
+           (sxf request)))
+
+    (let [info   (assoc info
+                        :iss :prepared-register
+                        :is-active true
+                        :exp (dt/in-future {:hours 48}))
+          token  (tokens :generate info)
+          params (d/without-nils
+                  {:token token
+                   :fullname (:fullname info)})
+          uri    (-> (u/uri (:public-uri cfg))
+                     (assoc :path "/#/auth/register/validate")
+                     (assoc :query (u/map->query-string params)))]
+      (redirect-response uri))))
+
+(defn- auth-handler
+  [{:keys [tokens] :as cfg} {:keys [params] :as request}]
+  (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)]
+    (yrs/response 200 {:redirect-uri uri})))
+
+(defn- callback-handler
+  [cfg request]
+  (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)
+            (generate-error-redirect cfg cause))]
+
+    (-> (process-request)
+        (p/catch handle-error))))
+
+(def provider-lookup
+  {:compile
+   (fn [& _]
+     (fn [handler]
+       (fn [{:keys [providers] :as cfg} request]
+         (let [provider (some-> request :path-params :provider keyword)]
+           (if-let [provider (get providers provider)]
+             (handler (assoc cfg :provider provider) request)
+             (ex/raise :type :restriction
+                       :code :provider-not-configured
+                       :provider provider
+                       :hint "provider not configured"))))))})
+
+(s/def ::public-uri ::us/not-empty-string)
+(s/def ::http-client fn?)
+(s/def ::session map?)
+(s/def ::tokens fn?)
+(s/def ::providers map?)
+
+(defmethod ig/pre-init-spec ::routes
+  [_]
+  (s/keys :req-un [::public-uri
+                   ::session
+                   ::tokens
+                   ::http-client
+                   ::providers
+                   ::db/pool
+                   ::wrk/executor]))
+
+(defmethod ig/init-key ::routes
+  [_ {:keys [executor session] :as cfg}]
+  (let [cfg (update cfg :provider d/without-nils)]
+    ["" {:middleware [[(:middleware session)]
+                      [hmw/with-promise-async executor]
+                      [hmw/with-config cfg]
+                      [provider-lookup]
+                      ]}
+     ;; We maintain the both URI prefixes for backward compatibility.
+
+     ["/auth/oauth"
+      ["/:provider"
+       {:handler auth-handler
+        :allowed-methods #{:post}}]
+      ["/:provider/callback"
+       {:handler callback-handler
+        :allowed-methods #{:get}}]]
+
+     ["/auth/oidc"
+      ["/:provider"
+       {:handler auth-handler
+        :allowed-methods #{:post}}]
+      ["/:provider/callback"
+       {:handler callback-handler
+        :allowed-methods #{:get}}]]]))

backend/src/app/cli/manage.clj

@@ -10,6 +10,7 @@
    [app.common.logging :as l]
    [app.db :as db]
    [app.main :as main]
+   [app.rpc.commands.auth :as cmd.auth]
    [app.rpc.mutations.profile :as profile]
    [app.rpc.queries.profile :refer [retrieve-profile-data-by-email]]
    [clojure.string :as str]
@@ -54,13 +55,13 @@
                                          :type :password}))]
     (try
       (db/with-atomic [conn (:app.db/pool system)]
-        (->> (profile/create-profile conn
+        (->> (cmd.auth/create-profile conn
                                      {:fullname fullname
                                       :email email
                                       :password password
                                       :is-active true
                                       :is-demo false})
-             (profile/create-profile-relations conn)))
+             (cmd.auth/create-profile-relations conn)))
 
       (when (pos? (:verbosity options))
         (println "User created successfully."))
@@ -140,7 +141,6 @@
   indicating the action the program should take and the options provided."
   [args]
   (let [{:keys [options arguments errors summary] :as opts} (parse-opts args cli-options)]
-    ;; (pp/pprint opts)
     (cond
       (:help options) ; help => exit OK with usage summary
       {:exit-message (usage summary) :ok? true}

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

@@ -11,6 +11,7 @@
    [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.flags :as flags]
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.common.version :as v]
    [app.util.time :as dt]
@@ -41,23 +42,21 @@
     data))
 
 (def defaults
-  {:http-server-port 6060
-   :http-server-host "0.0.0.0"
-   :host "devenv"
-   :tenant "dev"
-   :database-uri "postgresql://postgres/penpot"
+  {: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>"
 
@@ -85,33 +79,42 @@
    :ldap-attrs-username "uid"
    :ldap-attrs-email "mail"
    :ldap-attrs-fullname "cn"
-   :ldap-attrs-photo "jpegPhoto"
 
    ;; a server prop key where initial project is stored.
    :initial-project-skey "initial-project"})
 
-(s/def ::flags ::us/set-of-keywords)
 
-;; DEPRECATED PROPERTIES: should be removed in 1.10
-(s/def ::registration-enabled ::us/boolean)
-(s/def ::smtp-enabled ::us/boolean)
+(s/def ::media-max-file-size ::us/integer)
+
+(s/def ::flags ::us/vec-of-valid-keywords)
 (s/def ::telemetry-enabled ::us/boolean)
-(s/def ::asserts-enabled ::us/boolean)
-;; END DEPRECATED
 
 (s/def ::audit-log-archive-uri ::us/string)
 (s/def ::audit-log-gc-max-age ::dt/duration)
 
-(s/def ::admins ::us/set-of-str)
+(s/def ::admins ::us/set-of-non-empty-strings)
 (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 ::authenticated-cookie-domain ::us/string)
+(s/def ::authenticated-cookie-name ::us/string)
+(s/def ::auth-token-cookie-name ::us/string)
+(s/def ::auth-token-cookie-max-age ::dt/duration)
+
 (s/def ::secret-key ::us/string)
 (s/def ::allow-demo-users ::us/boolean)
 (s/def ::assets-path ::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)
@@ -128,19 +131,21 @@
 (s/def ::oidc-token-uri ::us/string)
 (s/def ::oidc-auth-uri ::us/string)
 (s/def ::oidc-user-uri ::us/string)
-(s/def ::oidc-scopes ::us/set-of-str)
-(s/def ::oidc-roles ::us/set-of-str)
+(s/def ::oidc-scopes ::us/set-of-non-empty-strings)
+(s/def ::oidc-roles ::us/set-of-non-empty-strings)
 (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-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)
+(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 ::initial-project-skey ::us/string)
 (s/def ::ldap-attrs-email ::us/string)
 (s/def ::ldap-attrs-fullname ::us/string)
-(s/def ::ldap-attrs-photo ::us/string)
 (s/def ::ldap-attrs-username ::us/string)
 (s/def ::ldap-base-dn ::us/string)
 (s/def ::ldap-bind-dn ::us/string)
@@ -160,8 +165,9 @@
 (s/def ::profile-complaint-threshold ::us/integer)
 (s/def ::public-uri ::us/string)
 (s/def ::redis-uri ::us/string)
-(s/def ::registration-domain-whitelist ::us/set-of-str)
+(s/def ::registration-domain-whitelist ::us/set-of-non-empty-strings)
 (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 +185,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 +206,21 @@
                    ::allow-demo-users
                    ::audit-log-archive-uri
                    ::audit-log-gc-max-age
+                   ::auth-token-cookie-name
+                   ::auth-token-cookie-max-age
+                   ::authenticated-cookie-name
+                   ::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,17 +239,19 @@
                    ::oidc-user-uri
                    ::oidc-scopes
                    ::oidc-roles-attr
+                   ::oidc-email-attr
+                   ::oidc-name-attr
                    ::oidc-roles
                    ::host
                    ::http-server-host
                    ::http-server-port
-                   ::http-session-idle-max-age
-                   ::http-session-updater-batch-max-age
-                   ::http-session-updater-batch-max-size
+                   ::http-server-max-body-size
+                   ::http-server-max-multipart-body-size
+                   ::http-server-io-threads
+                   ::http-server-worker-threads
                    ::initial-project-skey
                    ::ldap-attrs-email
                    ::ldap-attrs-fullname
-                   ::ldap-attrs-photo
                    ::ldap-attrs-username
                    ::ldap-base-dn
                    ::ldap-bind-dn
@@ -244,6 +264,7 @@
                    ::local-assets-uri
                    ::loggers-loki-uri
                    ::loggers-zmq-uri
+                   ::media-max-file-size
                    ::profile-bounce-max-age
                    ::profile-bounce-threshold
                    ::profile-complaint-max-age
@@ -251,8 +272,8 @@
                    ::public-uri
                    ::redis-uri
                    ::registration-domain-whitelist
-                   ::registration-enabled
                    ::rlimit-font
+                   ::rlimit-file-update
                    ::rlimit-image
                    ::rlimit-password
                    ::sentry-dsn
@@ -261,7 +282,6 @@
                    ::sentry-trace-sample-rate
                    ::smtp-default-from
                    ::smtp-default-reply-to
-                   ::smtp-enabled
                    ::smtp-host
                    ::smtp-password
                    ::smtp-port
@@ -274,10 +294,12 @@
                    ::storage-assets-fs-directory
                    ::storage-assets-s3-bucket
                    ::storage-assets-s3-region
+                   ::storage-assets-s3-endpoint
                    ::fdata-storage-backend
                    ::storage-fdata-s3-bucket
                    ::storage-fdata-s3-region
                    ::storage-fdata-s3-prefix
+                   ::storage-fdata-s3-endpoint
                    ::telemetry-enabled
                    ::telemetry-uri
                    ::telemetry-referer
@@ -285,8 +307,8 @@
                    ::tenant]))
 
 (def default-flags
-  [:enable-backend-asserts
-   :enable-backend-api-doc
+  [:enable-backend-api-doc
+   :enable-backend-worker
    :enable-secure-session-cookies])
 
 (defn- parse-flags
@@ -317,8 +339,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
@@ -327,8 +349,12 @@
                        (str/trim))
                "%version%")))
 
-(def ^:dynamic config (read-config))
-(def ^:dynamic flags  (parse-flags config))
+(defonce ^:dynamic config (read-config))
+
+(defonce ^:dynamic flags
+  (let [flags (parse-flags config)]
+    (l/info :hint "flags initialized" :flags (str/join "," (map name flags)))
+    flags))
 
 (def deletion-delay
   (dt/duration {:days 7}))

backend/src/app/db.clj

@@ -47,42 +47,74 @@
 ;; Initialization
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(declare instrument-jdbc!)
 (declare apply-migrations!)
 
-(s/def ::name keyword?)
-(s/def ::uri ::us/not-empty-string)
-(s/def ::min-pool-size ::us/integer)
-(s/def ::max-pool-size ::us/integer)
+(s/def ::connection-timeout ::us/integer)
+(s/def ::max-size ::us/integer)
+(s/def ::min-size ::us/integer)
 (s/def ::migrations map?)
-(s/def ::read-only ::us/boolean)
+(s/def ::name keyword?)
+(s/def ::password ::us/string)
+(s/def ::uri ::us/not-empty-string)
+(s/def ::username ::us/string)
+(s/def ::validation-timeout ::us/integer)
+(s/def ::read-only? ::us/boolean)
 
-(defmethod ig/pre-init-spec ::pool [_]
-  (s/keys :req-un [::uri ::name ::min-pool-size ::max-pool-size]
-          :opt-un [::migrations ::mtx/metrics ::read-only]))
+(s/def ::pool-options
+  (s/keys :opt-un [::uri ::name
+                   ::min-size
+                   ::max-size
+                   ::connection-timeout
+                   ::validation-timeout
+                   ::migrations
+                   ::username
+                   ::password
+                   ::mtx/metrics
+                   ::read-only?]))
+
+(def defaults
+  {:name :main
+   :min-size 0
+   :max-size 30
+   :connection-timeout 10000
+   :validation-timeout 10000
+   :idle-timeout 120000 ; 2min
+   :max-lifetime 1800000 ; 30m
+   :read-only? false})
+
+(defmethod ig/prep-key ::pool
+  [_ cfg]
+  (merge defaults (d/without-nils cfg)))
+
+;; Don't validate here, just validate that a map is received.
+(defmethod ig/pre-init-spec ::pool [_] ::pool-options)
 
 (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 read-only? uri] :as cfg}]
+  (if uri
+    (let [pool (create-pool cfg)]
+      (l/info :hint "initialize connection pool"
+              :name (d/name (:name cfg))
+              :uri uri
+              :read-only read-only?
+              :with-credentials (and (contains? cfg :username)
+                                     (contains? cfg :password))
+              :min-size (:min-size cfg)
+              :max-size (:max-size cfg))
+      (when-not read-only?
+        (some->> (seq migrations) (apply-migrations! pool)))
+      pool)
 
-  (let [pool (create-pool cfg)]
-    (some->> (seq migrations) (apply-migrations! pool))
-    pool))
+    (do
+      (l/warn :hint "unable to initialize pool, missing url"
+              :name (d/name (:name cfg))
+              :read-only read-only?)
+      nil)))
 
 (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."}))
+  (when pool
+    (.close ^HikariDataSource pool)))
 
 (defn- apply-migrations!
   [pool migrations]
@@ -100,22 +132,19 @@
        "SET idle_in_transaction_session_timeout = 300000;"))
 
 (defn- create-datasource-config
-  [{:keys [metrics read-only] :or {read-only false} :as cfg}]
-  (let [dburi    (:uri cfg)
-        username (:username cfg)
-        password (:password cfg)
-        config   (HikariConfig.)]
+  [{:keys [metrics uri] :as cfg}]
+  (let [config (HikariConfig.)]
     (doto config
-      (.setJdbcUrl (str "jdbc:" dburi))
-      (.setPoolName (d/name (:name cfg)))
+      (.setJdbcUrl           (str "jdbc:" uri))
+      (.setPoolName          (d/name (:name cfg)))
       (.setAutoCommit true)
-      (.setReadOnly read-only)
-      (.setConnectionTimeout 10000)  ;; 10seg
-      (.setValidationTimeout 10000)  ;; 10seg
-      (.setIdleTimeout 120000)       ;; 2min
-      (.setMaxLifetime 1800000)      ;; 30min
-      (.setMinimumIdle (:min-pool-size cfg 0))
-      (.setMaximumPoolSize (:max-pool-size cfg 50))
+      (.setReadOnly          (:read-only? cfg))
+      (.setConnectionTimeout (:connection-timeout cfg))
+      (.setValidationTimeout (:validation-timeout cfg))
+      (.setIdleTimeout       (:idle-timeout cfg))
+      (.setMaxLifetime       (:max-lifetime cfg))
+      (.setMinimumIdle       (:min-size cfg))
+      (.setMaximumPoolSize   (:max-size cfg))
       (.setConnectionInitSql initsql)
       (.setInitializationFailTimeout -1))
 
@@ -125,8 +154,8 @@
            (PrometheusMetricsTrackerFactory.)
            (.setMetricsTrackerFactory config)))
 
-    (when username (.setUsername config username))
-    (when password (.setPassword config password))
+    (some->> ^String (:username cfg) (.setUsername config))
+    (some->> ^String (:password cfg) (.setPassword config))
 
     config))
 
@@ -136,10 +165,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)]
@@ -192,7 +225,7 @@
   [& args]
   `(jdbc/with-transaction ~@args))
 
-(defn ^Connection open
+(defn open
   [pool]
   (jdbc/get-connection pool))
 
@@ -212,21 +245,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))
@@ -290,9 +323,9 @@
   (and (pgarray? v) (= "uuid" (.getBaseTypeName ^PgArray v))))
 
 (defn decode-pgarray
-  ([v] (into [] (.getArray ^PgArray v)))
-  ([v in] (into in (.getArray ^PgArray v)))
-  ([v in xf] (into in xf (.getArray ^PgArray v))))
+  ([v] (some->> ^PgArray v .getArray vec))
+  ([v in] (some->> ^PgArray v .getArray (into in)))
+  ([v in xf]  (some->> ^PgArray v .getArray (into in xf))))
 
 (defn pgarray->set
   [v]

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,173 @@
 (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.http.doc :as doc]
+   [app.common.transit :as t]
    [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/with-context (errors/get-error-context request e)
-            (l/error :hint "unexpected error processing request"
-                     :query-string (:query-string request)
-                     :cause e)
-            {:status 500 :body "internal server error"}))))))
+        (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 ::debug map?)
+(s/def ::audit-handler fn?)
+(s/def ::awsns-handler fn?)
+(s/def ::session map?)
+(s/def ::rpc-routes (s/nilable vector?))
+(s/def ::debug-routes (s/nilable vector?))
+(s/def ::oidc-routes (s/nilable vector?))
+(s/def ::doc-routes (s/nilable vector?))
 
 (defmethod ig/pre-init-spec ::router [_]
-  (s/keys :req-un [::rpc ::session ::mtx/metrics ::ws
-                   ::oauth ::storage ::assets ::feedback
-                   ::debug ::audit-http-handler]))
+  (s/keys :req-un [::mtx/metrics
+                   ::ws
+                   ::storage
+                   ::assets
+                   ::session
+                   ::feedback
+                   ::awsns-handler
+                   ::debug-routes
+                   ::oidc-routes
+                   ::audit-handler
+                   ::rpc-routes
+                   ::doc-routes]))
 
 (defmethod ig/init-key ::router
-  [_ {:keys [ws session rpc oauth metrics assets feedback debug] :as cfg}]
+  [_ {:keys [ws session metrics assets feedback] :as cfg}]
   (rr/router
-   [["/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]]}
 
-    ["/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)}]]
+     ["/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)}]]
 
-    ["/webhooks"
-     ["/sns" {:post (:sns-webhook cfg)}]]
+     (:debug-routes cfg)
 
-    ["/ws/notifications"
-     {:middleware [[middleware/params]
-                   [middleware/keyword-params]
-                   [middleware/format-response-body]
-                   [middleware/errors errors/handle]
-                   [middleware/cookies]
-                   [(:middleware session)]]
-      :get ws}]
+     ["/webhooks"
+      ["/sns" {:handler (:awsns-handler cfg)
+               :allowed-methods #{:post}}]]
 
-    ["/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]]}
+     ["/ws/notifications" {:middleware [(:middleware session)]
+                           :handler ws
+                           :allowed-methods #{:get}}]
 
-     ["/_doc" {:get (doc/handler rpc)}]
+     ["/api" {:middleware [[middleware/cors]
+                           [(:middleware session)]]}
+      ["/audit/events" {:handler (:audit-handler cfg)
+                        :allowed-methods #{:post}}]
+      ["/feedback" {:handler feedback
+                    :allowed-methods #{:post}}]
+      (:doc-routes cfg)
+      (:oidc-routes cfg)
+      (:rpc-routes cfg)]]]))
 
-     ["/feedback" {:middleware [(:middleware session)]
-                   :post feedback}]
-     ["/auth/oauth/:provider" {:post (:handler oauth)}]
-     ["/auth/oauth/:provider/callback" {:get (:callback-handler oauth)}]
-
-     ["/audit/events" {:middleware [(:middleware session)]
-                       :post (:audit-http-handler cfg)}]
-
-     ["/rpc" {:middleware [(:middleware session)]}
-      ["/query/:type" {:get (:query-handler rpc)
-                       :post (:query-handler rpc)}]
-      ["/mutation/:type" {:post (:mutation-handler rpc)}]]]]))

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}))
@@ -25,73 +29,90 @@
 
 (defn coerce-id
   [id]
-  (let [res (us/uuid-conformer id)]
+  (let [res (parse-uuid id)]
     (when-not (uuid? res)
       (ex/raise :type :not-found
                 :hint "object not found"))
     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,42 @@
    [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.request :as yrq]
+   [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 (-> request yrq/body slurp)]
+      (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 +55,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

@@ -5,26 +5,38 @@
 ;; Copyright (c) UXBOX Labs SL
 
 (ns app.http.debug
+  (:refer-clojure :exclude [error-handler])
   (:require
-   [app.common.data :as d]
    [app.common.exceptions :as ex]
-   [app.common.spec :as us]
+   [app.common.pprint :as pp]
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
-   [app.rpc.mutations.files :as m.files]
+   [app.http.middleware :as mw]
+   [app.rpc.commands.binfile :as binf]
+   [app.rpc.mutations.files :refer [create-file]]
    [app.rpc.queries.profile :as profile]
    [app.util.blob :as blob]
+   [app.util.bytes :as bs]
    [app.util.template :as tmpl]
    [app.util.time :as dt]
+   [app.worker :as wrk]
    [clojure.java.io :as io]
-   [clojure.pprint :as ppr]
+   [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
-   [datoteka.core :as fs]
-   [integrant.core :as ig]))
+   [emoji.core :as emj]
+   [integrant.core :as ig]
+   [markdown.core :as md]
+   [markdown.transformers :as mdt]
+   [yetti.request :as yrq]
+   [yetti.response :as yrs]))
 
 ;; (selmer.parser/cache-off!)
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HELPERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (defn authorized?
   [pool {:keys [profile-id]}]
   (or (= "devenv" (cf/get :host))
@@ -32,17 +44,34 @@
             admins  (or (cf/get :admins) #{})]
         (contains? admins (:email profile)))))
 
-(defn index
+(defn prepare-response
+  [body]
+  (let [headers {"content-type" "application/transit+json"}]
+    (yrs/response :status 200 :body body :headers headers)))
+
+(defn prepare-download-response
+  [body filename]
+  (let [headers {"content-disposition" (str "attachment; filename=" filename)
+                 "content-type" "application/octet-stream"}]
+    (yrs/response :status 200 :body body :headers headers)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; INDEX
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn index-handler
   [{:keys [pool]} request]
   (when-not (authorized? pool request)
     (ex/raise :type :authentication
               :code :only-admins-allowed))
+  (yrs/response :status  200
+                :headers {"content-type" "text/html"}
+                :body    (-> (io/resource "templates/debug.tmpl")
+                             (tmpl/render {}))))
 
-  {:status 200
-   :headers {"content-type" "text/html"}
-   :body (-> (io/resource "templates/debug.tmpl")
-             (tmpl/render {}))})
-
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; FILE CHANGES
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (def sql:retrieve-range-of-changes
   "select revn, changes from file_change where file_id=? and revn >= ? and revn <= ? order by revn")
@@ -50,27 +79,16 @@
 (def sql:retrieve-single-change
   "select revn, changes, data from file_change where file_id=? and revn = ?")
 
-(defn prepare-response
-  [{:keys [params] :as request} body]
-  (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}
-    (contains? params :download)
-    (update :headers assoc "content-disposition" "attachment")))
-
-(defn retrieve-file-data
-  [{:keys [pool]} {:keys [params] :as request}]
+(defn- retrieve-file-data
+  [{:keys [pool]} {:keys [params profile-id] :as request}]
   (when-not (authorized? pool request)
     (ex/raise :type :authentication
               :code :only-admins-allowed))
 
-  (let [file-id (some-> (get-in request [:params :file-id]) uuid/uuid)
-        revn    (some-> (get-in request [:params :revn]) d/parse-integer)]
+  (let [file-id  (some-> params :file-id parse-uuid)
+        revn     (some-> params :revn parse-long)
+        filename (str file-id)]
+
     (when-not file-id
       (ex/raise :type :validation
                 :code :missing-arguments))
@@ -78,67 +96,115 @@
     (let [data (if (integer? revn)
                  (some-> (db/exec-one! pool [sql:retrieve-single-change file-id revn]) :data)
                  (some-> (db/get-by-id pool :file file-id) :data))]
-      (if (contains? params :download)
-        (-> (prepare-response request data)
-            (update :headers assoc "content-type" "application/octet-stream"))
-        (prepare-response request (some-> data blob/decode))))))
 
-(defn upload-file-data
+      (when-not data
+        (ex/raise :type :not-found
+                  :code :enpty-data
+                  :hint "empty response"))
+      (cond
+        (contains? params :download)
+        (prepare-download-response data filename)
+
+        (contains? params :clone)
+        (let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)
+              data       (some-> data blob/decode)]
+          (create-file pool {:id (uuid/next)
+                             :name (str "Cloned file: " filename)
+                             :project-id project-id
+                             :profile-id profile-id
+                             :data data})
+          (yrs/response 201 "OK CREATED"))
+
+        :else
+        (prepare-response (some-> data blob/decode))))))
+
+(defn- is-file-exists?
+  [pool id]
+  (let [sql "select exists (select 1 from file where id=?) as exists;"]
+    (-> (db/exec-one! pool [sql id]) :exists)))
+
+(defn- upload-file-data
   [{:keys [pool]} {:keys [profile-id params] :as request}]
   (let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)
-        data       (some-> params :file :tempfile fs/slurp-bytes blob/decode)]
+        data       (some-> params :file :path bs/read-as-bytes blob/decode)]
 
     (if (and data project-id)
-      (let [fname (str "imported-file-" (dt/now))]
-        (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))
+            overwrite? (contains? params :overwrite?)
+            file-id    (or (and overwrite? (ex/ignoring (-> params :file :filename parse-uuid)))
+                           (uuid/next))]
 
-(defn retrieve-file-changes
-  [{:keys [pool]} request]
+        (if (and overwrite? file-id
+                 (is-file-exists? pool file-id))
+          (do
+            (db/update! pool :file
+                        {:data (blob/encode data)}
+                        {:id file-id})
+            (yrs/response 200 "OK UPDATED"))
+
+          (do
+            (create-file pool {:id file-id
+                               :name fname
+                               :project-id project-id
+                               :profile-id profile-id
+                               :data data})
+            (yrs/response 201 "OK CREATED"))))
+
+      (yrs/response 500 "ERROR"))))
+
+(defn file-data-handler
+  [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 file-changes-handler
+  [{:keys [pool]} {:keys [params] :as request}]
   (when-not (authorized? pool request)
     (ex/raise :type :authentication
               :code :only-admins-allowed))
 
-  (let [file-id (some-> (get-in request [:params :id]) uuid/uuid)
-        revn    (or (get-in request [:params :revn]) "latest")]
+  (letfn [(retrieve-changes [file-id revn]
+            (if (str/includes? revn ":")
+              (let [[start end] (->> (str/split revn #":")
+                                     (map str/trim)
+                                     (map parse-long))]
+                (some->> (db/exec! pool [sql:retrieve-range-of-changes file-id start end])
+                         (map :changes)
+                         (map blob/decode)
+                         (mapcat identity)
+                         (vec)))
 
-    (when (or (not file-id) (not revn))
-      (ex/raise :type :validation
-                :code :invalid-arguments
-                :hint "missing arguments"))
+              (if-let [revn (parse-long revn)]
+                (let [item (db/exec-one! pool [sql:retrieve-single-change file-id revn])]
+                  (some-> item :changes blob/decode vec))
+                (ex/raise :type :validation :code :invalid-arguments))))]
 
-    (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)))
+    (let [file-id  (some-> params :id parse-uuid)
+          revn     (or (some-> params :revn parse-long) "latest")
+          filename (str file-id)]
 
-      (str/includes? revn ":")
-      (let [[start end] (->> (str/split revn #":")
-                             (map str/trim)
-                             (map d/parse-integer))
-            items       (db/exec! pool [sql:retrieve-range-of-changes file-id start end])]
-        (prepare-response request
-                          (some->> items
-                                   (map :changes)
-                                   (map blob/decode)
-                                   (mapcat identity)
-                                   (vec))))
-      :else
-      (ex/raise :type :validation :code :invalid-arguments))))
+      (when (or (not file-id) (not revn))
+        (ex/raise :type :validation
+                  :code :invalid-arguments
+                  :hint "missing arguments"))
 
+      (let [data (retrieve-changes file-id revn)]
+        (if (contains? params :download)
+          (prepare-download-response data filename)
+          (prepare-response data))))))
 
-(defn retrieve-error
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ERROR BROWSER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn error-handler
   [{:keys [pool]} request]
   (letfn [(parse-id [request]
             (let [id (get-in request [:path-params :id])
-                  id (us/uuid-conformer id)]
+                  id (parse-uuid id)]
               (when (uuid? id)
                 id)))
 
@@ -147,22 +213,20 @@
              (some-> (db/get-by-id pool :server-error-report id) :content db/decode-transit-pgobject)))
 
           (render-template [report]
-            (binding [ppr/*print-right-margin* 300]
-              (let [context (dissoc report
-                                    :trace :cause :params :data :spec-problems
-                                    :spec-explain :spec-value :error :explain :hint)
-                    params  {:context (with-out-str (ppr/pprint context))
-                             :hint    (:hint report)
-                             :spec-explain  (:spec-explain report)
-                             :spec-problems (:spec-problems report)
-                             :spec-value    (:spec-value report)
-                             :data          (:data report)
-                             :trace         (or (:trace report)
-                                                (some-> report :error :trace))
-                             :params        (:params report)}]
-                (-> (io/resource "templates/error-report.tmpl")
-                    (tmpl/render params)))))
-          ]
+            (let [context (dissoc report
+                                  :trace :cause :params :data :spec-problems
+                                  :spec-explain :spec-value :error :explain :hint)
+                  params  {:context       (pp/pprint-str context :width 200)
+                           :hint          (:hint report)
+                           :spec-explain  (:spec-explain report)
+                           :spec-problems (:spec-problems report)
+                           :spec-value    (:spec-value report)
+                           :data          (:data report)
+                           :trace         (or (:trace report)
+                                              (some-> report :error :trace))
+                           :params        (:params report)}]
+              (-> (io/resource "templates/error-report.tmpl")
+                  (tmpl/render params))))]
 
     (when-not (authorized? pool request)
       (ex/raise :type :authentication
@@ -172,34 +236,160 @@
                          (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")
 
-(defn retrieve-error-list
+(defn error-list-handler
   [{:keys [pool]} request]
   (when-not (authorized? pool request)
     (ex/raise :type :authentication
               :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"})))
 
-(defmethod ig/init-key ::handlers
-  [_ cfg]
-  {:index (partial index cfg)
-   :retrieve-file-data (partial retrieve-file-data cfg)
-   :retrieve-file-changes (partial retrieve-file-changes cfg)
-   :retrieve-error (partial retrieve-error cfg)
-   :retrieve-error-list (partial retrieve-error-list cfg)
-   :upload-file-data (partial upload-file-data cfg)})
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; EXPORT/IMPORT
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn export-handler
+  [{:keys [pool] :as cfg} {:keys [params profile-id] :as request}]
+
+  (let [file-ids (->> (:file-ids params)
+                      (remove empty?)
+                      (mapv parse-uuid))
+        libs?    (contains? params :includelibs)
+        clone?   (contains? params :clone)
+        embed?   (contains? params :embedassets)]
+
+    (when-not (seq file-ids)
+      (ex/raise :type :validation
+                :code :missing-arguments))
+
+    (let [path (-> cfg
+                   (assoc ::binf/file-ids file-ids)
+                   (assoc ::binf/embed-assets? embed?)
+                   (assoc ::binf/include-libraries? libs?)
+                   (binf/export!))]
+      (if clone?
+        (let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)]
+          (binf/import!
+           (assoc cfg
+                  ::binf/input path
+                  ::binf/overwrite? false
+                  ::binf/ignore-index-errors? true
+                  ::binf/profile-id profile-id
+                  ::binf/project-id project-id))
+
+          (yrs/response
+           :status  200
+           :headers {"content-type" "text/plain"}
+           :body    "OK CLONED"))
+
+        (yrs/response
+         :status  200
+         :headers {"content-type" "application/octet-stream"
+                   "content-disposition" (str "attachmen; filename=" (first file-ids) ".penpot")}
+         :body    (io/input-stream path))))))
+
+
+(defn import-handler
+  [{:keys [pool] :as cfg} {:keys [params profile-id] :as request}]
+  (when-not (contains? params :file)
+    (ex/raise :type :validation
+              :code :missing-upload-file
+              :hint "missing upload file"))
+
+  (let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)
+        overwrite? (contains? params :overwrite)
+        migrate? (contains? params :migrate)
+        ignore-index-errors? (contains? params :ignore-index-errors)]
+
+    (when-not project-id
+      (ex/raise :type :validation
+                :code :missing-project
+                :hint "project not found"))
+
+    (binf/import!
+     (assoc cfg
+            ::binf/input (-> params :file :path)
+            ::binf/overwrite? overwrite?
+            ::binf/migrate? migrate?
+            ::binf/ignore-index-errors? ignore-index-errors?
+            ::binf/profile-id profile-id
+            ::binf/project-id project-id))
+
+    (yrs/response
+     :status  200
+     :headers {"content-type" "text/plain"}
+     :body    "OK")))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; OTHER SMALL VIEWS/HANDLERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn health-handler
+  "Mainly a task that performs a health check."
+  [{:keys [pool]} _]
+  (db/with-atomic [conn pool]
+    (db/exec-one! conn ["select count(*) as count from server_prop;"])
+    (yrs/response 200 "OK")))
+
+(defn changelog-handler
+  [_ _]
+  (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"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; INIT
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def with-authorization
+  {:compile
+   (fn [& _]
+     (fn [handler pool]
+       (fn [request respond raise]
+         (if (authorized? pool request)
+           (handler request respond raise)
+           (raise (ex/error :type :authentication
+                            :code :only-admins-allowed))))))})
+
+
+(s/def ::session map?)
+
+(defmethod ig/pre-init-spec ::routes [_]
+  (s/keys :req-un [::db/pool ::wrk/executor ::session]))
+
+(defmethod ig/init-key ::routes
+  [_ {:keys [session pool executor] :as cfg}]
+  ["/dbg" {:middleware [[(:middleware session)]
+                        [with-authorization pool]
+                        [mw/with-promise-async executor]
+                        [mw/with-config cfg]]}
+   ["" {:handler index-handler}]
+   ["/health" {:handler health-handler}]
+   ["/changelog" {:handler changelog-handler}]
+   ;; ["/error-by-id/:id" {:handler error-handler}]
+   ["/error/:id" {:handler error-handler}]
+   ["/error" {:handler error-list-handler}]
+   ["/file/export" {:handler export-handler}]
+   ["/file/import" {:handler import-handler}]
+   ["/file/data" {:handler file-data-handler}]
+   ["/file/changes" {:handler file-changes-handler}]])

backend/src/app/http/doc.clj

@@ -1,53 +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.http.doc
-  "API autogenerated documentation."
-  (:require
-   [app.common.data :as d]
-   [app.config :as cf]
-   [app.util.services :as sv]
-   [app.util.template :as tmpl]
-   [clojure.java.io :as io]
-   [clojure.spec.alpha :as s]
-   [pretty-spec.core :as ps]))
-
-(defn get-spec-str
-  [k]
-  (with-out-str
-    (ps/pprint (s/form k)
-               {:ns-aliases {"clojure.spec.alpha" "s"
-                             "clojure.core.specs.alpha" "score"
-                             "clojure.core" nil}})))
-
-(defn prepare-context
-  [rpc]
-  (letfn [(gen-doc [type [name f]]
-            (let [mdata (meta f)]
-              ;; (prn name mdata)
-              {:type (d/name type)
-               :name (d/name name)
-               :auth (:auth mdata true)
-               :docs (::sv/docs mdata)
-               :spec (get-spec-str (::sv/spec mdata))}))]
-    {:query-methods
-     (into []
-           (map (partial gen-doc :query))
-           (->> rpc :methods :query (sort-by first)))
-     :mutation-methods
-     (into []
-           (map (partial gen-doc :mutation))
-           (->> rpc :methods :mutation (sort-by first)))}))
-
-(defn handler
-  [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 ""}))))

backend/src/app/http/errors.clj

@@ -9,41 +9,32 @@
   (:require
    [app.common.exceptions :as ex]
    [app.common.logging :as l]
-   [app.common.uuid :as uuid]
-   [clojure.pprint]
+   [app.common.spec :as us]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
-   [expound.alpha :as expound]))
+   [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
-     {:id            (uuid/next)
-      :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 (binding [s/*explain-out* expound/printer]
-                        (with-out-str
-                          (s/explain-out (update data ::s/problems #(take 10 %)))))}))))
+(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]
@@ -53,97 +44,115 @@
 
 (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)})
-
-(defn- explain-spec-error-data
-  [data]
-  (when (and (::s/problems data)
-             (::s/value data)
-             (::s/spec data))
-    (binding [s/*explain-out* expound/printer]
-      (with-out-str
-        (s/explain-out (update data ::s/problems #(take 10 %)))))))
-
+  (yrs/response 400 (ex-data err)))
 
 (defmethod handle-exception :validation
   [err _]
-  (let [data    (ex-data err)
-        explain (explain-spec-error-data 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)]
-    (l/with-context (get-error-context request error)
-      (l/error ::l/raw (ex-message error) :cause error))
-    {:status 500
-     :body {:type :server-error
-            :code :assertion
-            :data (dissoc edata ::s/problems ::s/value ::s/spec)}}))
+  (let [edata (ex-data error)
+        explain (us/pretty-explain edata)]
+    (l/error ::l/raw (str (ex-message error) "\n" explain)
+             ::l/context (get-context request)
+             :cause error)
+    (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/with-context (get-error-context request error)
-          (l/error ::l/raw (ex-message 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/with-context (get-error-context request error)
-      (l/error ::l/raw (ex-message error) :cause error))
-
+    (l/error ::l/raw (ex-message error)
+             ::l/context (get-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,79 @@
 
 (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]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [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 (yrq/body request)]
+                  (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 (yrq/body request)]
+                  (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,140 +92,123 @@
       (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 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 (or (boolean? body) (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})
+
+(def with-promise-async
+  {:compile
+   (fn [& _]
+     (fn [handler executor]
+       (fn [request respond raise]
+         (-> (px/submit! executor #(handler request))
+             (p/bind p/wrap)
+             (p/then respond)
+             (p/catch raise)))))})
+
+(def with-config
+  {:compile
+   (fn [& _]
+     (fn [handler config]
+       (fn
+         ([request] (handler config request))
+         ([request respond raise] (handler config request respond raise)))))})

backend/src/app/http/oauth.clj

@@ -1,397 +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.http.oauth
-  (:require
-   [app.common.data :as d]
-   [app.common.exceptions :as ex]
-   [app.common.logging :as l]
-   [app.common.spec :as us]
-   [app.common.uri :as u]
-   [app.config :as cf]
-   [app.db :as db]
-   [app.loggers.audit :as audit]
-   [app.rpc.queries.profile :as profile]
-   [app.util.http :as http]
-   [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]))
-
-(defn- build-redirect-uri
-  [{:keys [provider] :as cfg}]
-  (let [public (u/uri (:public-uri cfg))]
-    (str (assoc public :path (str "/api/auth/oauth/" (:name provider) "/callback")))))
-
-(defn- build-auth-uri
-  [{:keys [provider] :as cfg} state]
-  (let [params {:client_id (:client-id provider)
-                :redirect_uri (build-redirect-uri cfg)
-                :response_type "code"
-                :state state
-                :scope (str/join " " (:scopes provider []))}
-        query  (u/map->query-string params)]
-    (-> (u/uri (:auth-uri provider))
-        (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]
-               (assoc result (keyword (:name provider) (name k)) v))
-             {}
-             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)]
-
-      (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)))
-
-(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
-                   ::fullname
-                   ::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))]
-
-    (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 :unable-to-auth
-                :hint "no user 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 #{}))]
-
-        ;; 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)))))
-
-;; --- 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))))
-
-(defn- redirect-response
-  [uri]
-  {:status 302
-   :headers {"location" (str uri)}
-   :body ""})
-
-(defn- generate-error-redirect
-  [cfg error]
-  (let [uri (-> (u/uri (:public-uri cfg))
-                (assoc :path "/#/auth/login")
-                (assoc :query (u/map->query-string {:error "unable-to-auth" :hint (ex-message error)})))]
-    (redirect-response uri)))
-
-(defn- generate-redirect
-  [{:keys [tokens session audit] :as cfg} request info profile]
-  (if profile
-    (let [sxf    ((:create session) (:id profile))
-          token  (or (:invitation-token info)
-                     (tokens :generate {:iss :auth
-                                        :exp (dt/in-future "15m")
-                                        :profile-id (:id profile)}))
-          params {:token token}
-
-          uri    (-> (u/uri (:public-uri cfg))
-                     (assoc :path "/#/auth/verify-token")
-                     (assoc :query (u/map->query-string params)))]
-
-      (when (fn? audit)
-        (audit :cmd :submit
-               :type "mutation"
-               :name "login"
-               :profile-id (:id profile)
-               :ip-addr (audit/parse-client-ip request)
-               :props (audit/profile->props profile)))
-
-      (->> (redirect-response uri)
-           (sxf request)))
-    (let [info   (assoc info
-                        :iss :prepared-register
-                        :is-active true
-                        :exp (dt/in-future {:hours 48}))
-          token  (tokens :generate info)
-          params (d/without-nils
-                  {:token token
-                   :fullname (:fullname info)})
-          uri    (-> (u/uri (:public-uri cfg))
-                     (assoc :path "/#/auth/register/validate")
-                     (assoc :query (u/map->query-string params)))]
-      (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}}))
-
-(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))))
-
-;; --- INIT
-
-(declare initialize)
-
-(s/def ::public-uri ::us/not-empty-string)
-(s/def ::session map?)
-(s/def ::tokens fn?)
-(s/def ::rpc map?)
-
-(defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::public-uri ::session ::tokens ::rpc ::db/pool]))
-
-(defn wrap-handler
-  [cfg handler]
-  (fn [request]
-    (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)))))
-
-(defmethod ig/init-key ::handler
-  [_ cfg]
-  (let [cfg (initialize cfg)]
-    {:handler (wrap-handler cfg auth-handler)
-     :callback-handler (wrap-handler cfg callback-handler)}))
-
-(defn- discover-oidc-config
-  [{: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)}))]
-    (cond
-      (ex/exception? response)
-      (do
-        (l/warn :hint "unable to discover oidc configuration"
-                :discover-uri (str discovery-uri)
-                :cause response)
-        nil)
-
-      (= 200 (:status response))
-      (let [data (json/read-str (:body response))]
-        {:token-uri (get data "token_endpoint")
-         :auth-uri  (get data "authorization_endpoint")
-         :user-uri  (get data "userinfo_endpoint")})
-
-      :else
-      (do
-        (l/warn :hint "unable to discover OIDC configuration"
-                :uri (str discovery-uri)
-                :response-status-code (:status response))
-        nil))))
-
-(defn- obfuscate-string
-  [s]
-  (if (< (count s) 10)
-    (apply str (take (count s) (repeat "*")))
-    (str (subs s 0 5)
-         (apply str (take (- (count s) 5) (repeat "*"))))))
-
-(defn- initialize-oidc-provider
-  [cfg]
-  (let [opts {:base-uri      (cf/get :oidc-base-uri)
-              :client-id     (cf/get :oidc-client-id)
-              :client-secret (cf/get :oidc-client-secret)
-              :token-uri     (cf/get :oidc-token-uri)
-              :auth-uri      (cf/get :oidc-auth-uri)
-              :user-uri      (cf/get :oidc-user-uri)
-              :scopes        (cf/get :oidc-scopes #{"openid" "profile" "email"})
-              :roles-attr    (cf/get :oidc-roles-attr)
-              :roles         (cf/get :oidc-roles)
-              :name          "oidc"}]
-    (if (and (string? (:base-uri opts))
-             (string? (:client-id opts))
-             (string? (:client-secret opts)))
-      (do
-        (l/debug :hint "initialize oidc provider" :name "generic-oidc"
-                 :opts (update opts :client-secret obfuscate-string))
-        (if (and (string? (:token-uri opts))
-                 (string? (:user-uri opts))
-                 (string? (:auth-uri opts)))
-          (do
-            (l/debug :hint "initialized with user provided configuration")
-            (assoc-in cfg [:providers "oidc"] opts))
-          (do
-            (l/debug :hint "trying to discover oidc provider configuration using BASE_URI")
-            (if-let [opts' (discover-oidc-config opts)]
-              (do
-                (l/debug :hint "discovered opts" :additional-opts opts')
-                (assoc-in cfg [:providers "oidc"] (merge opts opts')))
-
-              cfg))))
-      cfg)))
-
-(defn- initialize-google-provider
-  [cfg]
-  (let [opts {:client-id     (cf/get :google-client-id)
-              :client-secret (cf/get :google-client-secret)
-              :scopes        #{"openid" "email" "profile"}
-              :auth-uri      "https://accounts.google.com/o/oauth2/v2/auth"
-              :token-uri     "https://oauth2.googleapis.com/token"
-              :user-uri      "https://openidconnect.googleapis.com/v1/userinfo"
-              :name          "google"}]
-    (if (and (string? (:client-id opts))
-             (string? (:client-secret opts)))
-      (do
-        (l/info :action "initialize" :provider "google"
-                :opts (pr-str (update opts :client-secret obfuscate-string)))
-        (assoc-in cfg [:providers "google"] opts))
-      cfg)))
-
-(defn- 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"}]
-    (if (and (string? (:client-id opts))
-             (string? (:client-secret opts)))
-      (do
-        (l/info :action "initialize" :provider "github"
-                :opts (pr-str (update opts :client-secret obfuscate-string)))
-        (assoc-in cfg [:providers "github"] opts))
-      cfg)))
-
-
-(defn- initialize-gitlab-provider
-  [cfg]
-  (let [base (cf/get :gitlab-base-uri "https://gitlab.com")
-        opts {:base-uri      base
-              :client-id     (cf/get :gitlab-client-id)
-              :client-secret (cf/get :gitlab-client-secret)
-              :scopes        #{"read_user"}
-              :auth-uri      (str base "/oauth/authorize")
-              :token-uri     (str base "/oauth/token")
-              :user-uri      (str base "/api/v4/user")
-              :name          "gitlab"}]
-    (if (and (string? (:client-id opts))
-             (string? (:client-secret opts)))
-      (do
-        (l/info :action "initialize" :provider "gitlab"
-                :opts (pr-str (update opts :client-secret obfuscate-string)))
-        (assoc-in cfg [:providers "gitlab"] opts))
-      cfg)))
-
-(defn- initialize
-  [cfg]
-  (let [cfg (agent cfg :error-mode :continue)]
-    (send-off cfg initialize-google-provider)
-    (send-off cfg initialize-gitlab-provider)
-    (send-off cfg initialize-github-provider)
-    (send-off cfg initialize-oidc-provider)
-    cfg))

backend/src/app/http/session.clj

@@ -7,164 +7,273 @@
 (ns app.http.session
   (:require
    [app.common.data :as d]
-   [app.common.exceptions :as ex]
    [app.common.logging :as l]
-   [app.config :as cfg]
+   [app.config :as cf]
    [app.db :as db]
-   [app.metrics :as mtx]
-   [app.util.async :as aa]
+   [app.db.sql :as sql]
    [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.
+(def default-auth-token-cookie-name "auth-token")
+
+;; A cookie that we can use to check from other sites of the same
+;; domain if a user is authenticated.
+(def default-authenticated-cookie-name "authenticated")
+
+;; Default value for cookie max-age
+(def default-cookie-max-age (dt/duration {:days 7}))
+
+;; Default age for automatic session renewal
+(def default-renewal-max-age (dt/duration {:hours 6}))
+
+(defprotocol ISessionStore
+  (read-session [store key])
+  (write-session [store key data])
+  (update-session [store 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)
+              created-at (or (:created-at data) (dt/now))
+              token      (tokens :generate {:iss "authentication"
+                                            :iat created-at
+                                            :uid profile-id})
+              params     {:user-agent user-agent
+                          :profile-id profile-id
+                          :created-at created-at
+                          :updated-at created-at
+                          :id token}]
+          (db/insert! pool :http-session params))))
+
+    (update-session [_ data]
+      (let [updated-at (dt/now)]
+        (px/with-dispatch executor
+          (db/update! pool :http-session
+                      {:updated-at updated-at}
+                      {:id (:id data)})
+          (assoc data :updated-at updated-at))))
+
+
+    (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)
+                created-at (or (:created-at data) (dt/now))
+                token      (tokens :generate {:iss "authentication"
+                                              :iat created-at
+                                              :uid profile-id})
+                params     {:user-agent user-agent
+                            :created-at created-at
+                            :updated-at created-at
+                            :profile-id profile-id
+                            :id token}]
+
+            (swap! cache assoc token params)
+            params)))
+
+      (update-session [_ data]
+        (let [updated-at (dt/now)]
+          (swap! cache update (:id data) assoc :updated-at updated-at)
+          (assoc data :updated-at updated-at)))
+
+      (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})
-        params {:user-agent (get headers "user-agent")
-                :profile-id profile-id
-                :id token}]
-    (db/insert! conn :http-session params)))
+(defn- create-session!
+  [store profile-id user-agent]
+  (let [params {:user-agent 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- update-session!
+  [store session]
+  (update-session store session))
+
+(defn- delete-session!
+  [store {:keys [cookies] :as request}]
+  (let [name (cf/get :auth-token-cookie-name default-auth-token-cookie-name)]
+    (when-let [token (get-in cookies [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])))
+  [store request]
+  (let [cookie-name (cf/get :auth-token-cookie-name default-auth-token-cookie-name)]
+    (when-let [cookie (yrq/get-cookie request cookie-name)]
+      (read-session store (:value cookie)))))
 
-(defn- retrieve-from-request
-  [cfg {:keys [cookies] :as request}]
-  (->> (get-in cookies [cookie-name :value])
-       (retrieve-session cfg)))
+(defn assign-auth-token-cookie
+  [response {token :id updated-at :updated-at}]
+  (let [max-age    (cf/get :auth-token-cookie-max-age default-cookie-max-age)
+        created-at (or updated-at (dt/now))
+        renewal    (dt/plus created-at default-renewal-max-age)
+        expires    (dt/plus created-at max-age)
+        secure?    (contains? cf/flags :secure-session-cookies)
+        cors?      (contains? cf/flags :cors)
+        name       (cf/get :auth-token-cookie-name default-auth-token-cookie-name)
+        comment    (str "Renewal at: " (dt/format-instant renewal :rfc1123))
+        cookie     {:path "/"
+                    :http-only true
+                    :expires expires
+                    :value token
+                    :comment comment
+                    :same-site (if cors? :none :lax)
+                    :secure secure?}]
+    (update response :cookies assoc name cookie)))
 
-(defn- add-cookies
-  [response {:keys [id] :as session}]
-  (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?}})))
+(defn assign-authenticated-cookie
+  [response {updated-at :updated-at}]
+  (let [max-age    (cf/get :auth-token-cookie-max-age default-cookie-max-age)
+        created-at (or updated-at (dt/now))
+        renewal    (dt/plus created-at default-renewal-max-age)
+        expires    (dt/plus created-at max-age)
+        comment    (str "Renewal at: " (dt/format-instant renewal :rfc1123))
+        secure?    (contains? cf/flags :secure-session-cookies)
+        domain     (cf/get :authenticated-cookie-domain)
+        name       (cf/get :authenticated-cookie-name "authenticated")
+        cookie     {:domain domain
+                    :expires expires
+                    :path "/"
+                    :comment comment
+                    :value true
+                    :same-site :strict
+                    :secure secure?}]
+    (cond-> response
+      (string? domain)
+      (update :cookies assoc name cookie))))
 
-(defn- clear-cookies
+(defn clear-auth-token-cookie
   [response]
-  (assoc response :cookies {cookie-name {:value "" :max-age -1}}))
+  (let [name (cf/get :auth-token-cookie-name default-auth-token-cookie-name)]
+    (update response :cookies assoc name {:path "/" :value "" :max-age -1})))
+
+(defn- clear-authenticated-cookie
+  [response]
+  (let [name   (cf/get :authenticated-cookie-name default-authenticated-cookie-name)
+        domain (cf/get :authenticated-cookie-domain)]
+    (cond-> response
+      (string? domain)
+      (update :cookies assoc name {:domain domain :path "/" :value "" :max-age -1}))))
+
+(defn- make-middleware
+  [{:keys [store] :as cfg}]
+  (letfn [;; Check if time reached for automatic session renewal
+          (renew-session? [{:keys [updated-at] :as session}]
+            (and (dt/instant? updated-at)
+                 (let [elapsed (dt/diff updated-at (dt/now))]
+                   (neg? (compare default-renewal-max-age elapsed)))))
+
+          ;; Wrap respond with session renewal code
+          (wrap-respond [respond session]
+            (fn [response]
+              (p/let [session (update-session! store session)]
+                (-> response
+                    (assign-auth-token-cookie session)
+                    (assign-authenticated-cookie session)
+                    (respond)))))]
+
+    {:name :session
+     :compile (fn [& _]
+                (fn [handler]
+                  (fn [request respond raise]
+                    (try
+                      (-> (retrieve-session store request)
+                          (p/finally (fn [session cause]
+                                       (cond
+                                         (some? cause)
+                                         (raise cause)
+
+                                         (nil? session)
+                                         (handler request respond raise)
+
+                                         :else
+                                         (let [request    (-> request
+                                                              (assoc :profile-id (:profile-id session))
+                                                              (assoc :session-id (:id session)))
+                                               respond    (cond-> respond
+                                                            (renew-session? session)
+                                                            (wrap-respond session))]
+
+                                           (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 64}
+  (d/merge {:buffer-size 128}
            (d/without-nils cfg)))
 
-(defmethod ig/init-key ::session
-  [_ {:keys [pool] :as cfg}]
-  (let [events (a/chan (a/dropping-buffer (:buffer-size cfg)))
-        cfg    (-> cfg
-                   (assoc :conn pool)
-                   (assoc ::events-ch events))]
-    (-> cfg
-        (assoc :middleware #(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)))))
-        (assoc :delete (fn [request response]
-                         (delete-session cfg request)
+(defmethod ig/init-key :app.http/session
+  [_ {:keys [store] :as cfg}]
+  (-> cfg
+      (assoc :middleware (make-middleware cfg))
+      (assoc :create (fn [profile-id]
+                       (fn [request response]
+                         (p/let [uagent  (yrq/get-header request "user-agent")
+                                 session (create-session! store profile-id uagent)]
+                           (-> response
+                               (assign-auth-token-cookie session)
+                               (assign-authenticated-cookie session))))))
+      (assoc :delete (fn [request response]
+                       (p/do
+                         (delete-session! store request)
                          (-> response
                              (assoc :status 204)
-                             (assoc :body "")
-                             (clear-cookies)))))))
-
-(defmethod ig/halt-key! ::session
-  [_ data]
-  (a/close! (::events-ch data)))
-
-
-;; --- STATE INIT: SESSION UPDATER
-
-(declare update-sessions)
-
-(s/def ::session map?)
-(s/def ::max-batch-age ::cfg/http-session-updater-batch-max-age)
-(s/def ::max-batch-size ::cfg/http-session-updater-batch-max-size)
-
-(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]))
-
-(defmethod ig/prep-key ::updater
-  [_ cfg]
-  (merge {:max-batch-age (dt/duration {:minutes 5})
-          :max-batch-size 200}
-         (d/without-nils cfg)))
-
-(defmethod ig/init-key ::updater
-  [_ {:keys [session metrics] :as cfg}]
-  (l/info :action "initialize session updater"
-          :max-batch-age (str (:max-batch-age cfg))
-          :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})]
-    (a/go-loop []
-      (when-let [[reason batch] (a/<! input)]
-        (let [result (a/<! (update-sessions cfg batch))]
-          (mcnt :inc)
-          (cond
-            (ex/exception? result)
-            (l/error :task "updater"
-                     :hint "unexpected error on update sessions"
-                     :cause result)
-
-            (= :size reason)
-            (l/debug :task "updater"
-                     :action "update sessions"
-                     :reason (name reason)
-                     :count result))
-          (recur))))))
-
-(defn- update-sessions
-  [{:keys [pool executor]} ids]
-  (aa/with-thread executor
-    (db/exec-one! pool ["update http_session set updated_at=now() where id = ANY(?)"
-                        (into-array String ids)])
-    (count ids)))
+                             (assoc :body nil)
+                             (clear-auth-token-cookie)
+                             (clear-authenticated-cookie)))))))
 
 ;; --- STATE INIT: SESSION GC
 
@@ -178,22 +287,25 @@
 
 (defmethod ig/prep-key ::gc-task
   [_ cfg]
-  (merge {:max-age (dt/duration {:days 15})}
+  (merge {:max-age default-cookie-max-age}
          (d/without-nils cfg)))
 
 (defmethod ig/init-key ::gc-task
   [_ {:keys [pool max-age] :as cfg}]
+  (l/debug :hint "initializing session gc task" :max-age max-age)
   (fn [_]
     (db/with-atomic [conn pool]
       (let [interval (db/interval max-age)
-            result   (db/exec-one! conn [sql:delete-expired interval])
+            result   (db/exec-one! conn [sql:delete-expired interval interval])
             result   (:next.jdbc/update-count result)]
         (l/debug :task "gc"
-                 :action "clean http sessions"
-                 :count result)
+                 :hint "clean http sessions"
+                 :deleted result)
         result))))
 
 (def ^:private
   sql:delete-expired
   "delete from http_session
-    where updated_at < now() - ?::interval")
+    where updated_at < now() - ?::interval
+       or (updated_at is null and
+           created_at < now() - ?::interval)")

backend/src/app/http/websocket.clj

@@ -9,137 +9,333 @@
   (:require
    [app.common.exceptions :as ex]
    [app.common.logging :as l]
+   [app.common.pprint :as pp]
    [app.common.spec :as us]
    [app.db :as db]
    [app.metrics :as mtx]
+   [app.util.time :as dt]
    [app.util.websocket :as ws]
-   [app.worker :as wrk]
    [clojure.core.async :as a]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]
    [yetti.websocket :as yws]))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; WEBSOCKET HOOKS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def state (atom {}))
+
+(defn- on-connect
+  [{:keys [metrics]} wsp]
+  (let [created-at (dt/now)]
+    (swap! state assoc (::ws/id @wsp) wsp)
+    (mtx/run! metrics {:id :websocket-active-connections :inc 1})
+    (fn []
+      (swap! state dissoc (::ws/id @wsp))
+      (mtx/run! metrics {:id :websocket-active-connections :dec 1})
+      (mtx/run! metrics {:id :websocket-session-timing
+                         :val (/ (inst-ms (dt/diff created-at (dt/now))) 1000.0)}))))
+
+(defn- on-rcv-message
+  [{:keys [metrics]} _ message]
+  (mtx/run! metrics {:id :websocket-messages-total :labels ["recv"] :inc 1})
+  message)
+
+(defn- on-snd-message
+  [{:keys [metrics]} _ message]
+  (mtx/run! metrics {:id :websocket-messages-total :labels ["send"] :inc 1})
+  message)
+
+;; REPL HELPERS
+
+(defn repl-get-connections-for-file
+  [file-id]
+  (->> (vals @state)
+       (filter #(= file-id (-> % deref ::file-subscription :file-id)))
+       (map deref)
+       (map ::ws/id)))
+
+(defn repl-get-connections-for-team
+  [team-id]
+  (->> (vals @state)
+       (filter #(= team-id (-> % deref ::team-subscription :team-id)))
+       (map deref)
+       (map ::ws/id)))
+
+(defn repl-close-connection
+  [id]
+  (when-let [wsp (get @state id)]
+    (a/>!! (::ws/close-ch @wsp) [8899 "closed from server"])
+    (a/close! (::ws/close-ch @wsp))))
+
+(defn repl-get-connection-info
+  [id]
+  (when-let [wsp (get @state id)]
+    {:id id
+     :created-at (dt/instant id)
+     :profile-id (::profile-id @wsp)
+     :session-id (::session-id @wsp)
+     :user-agent (::ws/user-agent @wsp)
+     :ip-addr    (::ws/remote-addr @wsp)
+     :last-activity-at (::ws/last-activity-at @wsp)
+     :http-session-id  (::ws/http-session-id @wsp)
+     :subscribed-file  (-> wsp deref ::file-subscription :file-id)
+     :subscribed-team  (-> wsp deref ::team-subscription :team-id)}))
+
+(defn repl-print-connection-info
+  [id]
+  (some-> id repl-get-connection-info pp/pprint))
+
+(defn repl-print-connection-info-for-file
+  [file-id]
+  (some->> (repl-get-connections-for-file file-id)
+           (map repl-get-connection-info)
+           (pp/pprint)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; WEBSOCKET HANDLER
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(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))]
+  [cfg wsp _]
 
-    (swap! wsp assoc :sub-ch sub-ch)
+  (let [msgbus-fn  (:msgbus cfg)
+        conn-id    (::ws/id @wsp)
+        profile-id (::profile-id @wsp)
+        session-id (::session-id @wsp)
+        output-ch  (::ws/output-ch @wsp)
 
-    ;; 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)))
+    (l/trace :fn "handle-message" :event :connect :conn-id conn-id)
 
-    (a/go
-      (a/<! (msgbus :sub {:topics [file-id team-id] :chan sub-ch}))
-      (a/<! (send-presence! @wsp :connect)))))
+    ;; Subscribe to the profile channel and forward all messages to
+    ;; websocket output channel (send them to the client).
+    (swap! wsp assoc ::profile-subscription channel)
+    (a/pipe channel output-ch false)
+    (msgbus-fn :cmd :sub :topic profile-id :chan channel)))
 
 (defmethod handle-message :disconnect
-  [wsp _]
-  (a/close! (:sub-ch @wsp))
-  (send-presence! @wsp :disconnect))
+  [cfg wsp _]
+  (let [msgbus-fn  (:msgbus cfg)
+        conn-id    (::ws/id @wsp)
+        profile-id (::profile-id @wsp)
+        session-id (::session-id @wsp)
+        profile-ch (::profile-subscription @wsp)
+        fsub       (::file-subscription @wsp)
+        tsub       (::team-subscription @wsp)
+
+        message    {:type :disconnect
+                    :subs-id profile-id
+                    :profile-id profile-id
+                    :session-id session-id}]
+
+    (l/trace :fn "handle-message"
+             :event :disconnect
+             :conn-id conn-id)
+
+    (a/go
+      ;; Close the main profile subscription
+      (a/close! profile-ch)
+      (a/<! (msgbus-fn :cmd :purge :chans [profile-ch]))
+
+      ;; Close tram subscription if exists
+      (when-let [channel (:channel tsub)]
+        (a/close! channel)
+        (a/<! (msgbus-fn :cmd :purge :chans [channel])))
+
+      (when-let [{:keys [topic channel]} fsub]
+        (a/close! channel)
+        (a/<! (msgbus-fn :cmd :purge :chans [channel]))
+        (a/<! (msgbus-fn :cmd :pub :topic topic :message message))))))
+
+(defmethod handle-message :subscribe-team
+  [cfg wsp {:keys [team-id] :as params}]
+  (let [msgbus-fn  (:msgbus cfg)
+        conn-id    (::ws/id @wsp)
+        session-id (::session-id @wsp)
+        output-ch  (::ws/output-ch @wsp)
+        prev-subs  (get @wsp ::team-subscription)
+        xform      (comp
+                    (remove #(= (:session-id %) session-id))
+                    (map #(assoc % :subs-id team-id)))
+
+        channel    (a/chan (a/dropping-buffer 64) xform)]
+
+    (l/trace :fn "handle-message"
+             :event :subscribe-team
+             :team-id team-id
+             :conn-id conn-id)
+
+    (a/pipe channel output-ch false)
+
+    (let [state {:team-id team-id :channel channel :topic team-id}]
+      (swap! wsp assoc ::team-subscription state))
+
+    (a/go
+      ;; Close previous subscription if exists
+      (when-let [channel (:channel prev-subs)]
+        (a/close! channel)
+        (a/<! (msgbus-fn :cmd :purge :chans [channel]))))
+
+    (a/go
+      (a/<! (msgbus-fn :cmd :sub :topic team-id :chan channel)))))
+
+(defmethod handle-message :subscribe-file
+  [cfg wsp {:keys [file-id] :as params}]
+  (let [msgbus-fn  (:msgbus cfg)
+        conn-id    (::ws/id @wsp)
+        profile-id (::profile-id @wsp)
+        session-id (::session-id @wsp)
+        output-ch  (::ws/output-ch @wsp)
+        prev-subs  (::file-subscription @wsp)
+        xform      (comp (remove #(= (:session-id %) session-id))
+                         (map #(assoc % :subs-id file-id)))
+        channel    (a/chan (a/dropping-buffer 64) xform)]
+
+    (l/trace :fn "handle-message"
+             :event :subscribe-file
+             :file-id file-id
+             :conn-id conn-id)
+
+    (let [state {:file-id file-id :channel channel :topic file-id}]
+      (swap! wsp assoc ::file-subscription state))
+
+    (a/go
+      ;; Close previous subscription if exists
+      (when-let [channel (:channel prev-subs)]
+        (a/close! channel)
+        (a/<! (msgbus-fn :cmd :purge :chans [channel]))))
+
+    ;; Message forwarding
+    (a/go
+      (loop []
+        (when-let [{:keys [type] :as message} (a/<! channel)]
+          (when (or (= :join-file type)
+                    (= :leave-file type)
+                    (= :disconnect type))
+            (let [message {:type :presence
+                           :file-id file-id
+                           :session-id session-id
+                           :profile-id profile-id}]
+              (a/<! (msgbus-fn :cmd :pub
+                               :topic file-id
+                               :message message))))
+          (a/>! output-ch message)
+          (recur))))
+
+    (a/go
+      ;; Subscribe to file topic
+      (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
+                     :subs-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
+  [cfg wsp {:keys [file-id] :as params}]
+  (let [msgbus-fn  (:msgbus cfg)
+        conn-id    (::ws/id @wsp)
+        session-id (::session-id @wsp)
+        profile-id (::profile-id @wsp)
+        subs       (::file-subscription @wsp)
+
+        message    {:type :leave-file
+                    :file-id file-id
+                    :session-id session-id
+                    :profile-id profile-id}]
+
+    (l/trace :fn "handle-message"
+             :event :unsubscribe-file
+             :file-id file-id
+             :conn-id conn-id)
+
+    (a/go
+      (when (= (:file-id subs) file-id)
+        (let [channel (:channel subs)]
+          (a/close! channel)
+          (a/<! (msgbus-fn :cmd :purge :chans [channel]))
+          (a/<! (msgbus-fn :cmd :pub :topic file-id :message message)))))))
 
 (defmethod handle-message :keepalive
-  [_ _]
+  [_ _ _]
+  (l/trace :fn "handle-message" :event :keepalive)
   (a/go :nothing))
 
 (defmethod handle-message :pointer-update
-  [wsp 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)})))
+  [cfg wsp {:keys [file-id] :as message}]
+  (let [msgbus-fn  (:msgbus cfg)
+        profile-id (::profile-id @wsp)
+        session-id (::session-id @wsp)
+        subs       (::file-subscription @wsp)
+        message    (-> message
+                       (assoc :subs-id file-id)
+                       (assoc :profile-id profile-id)
+                       (assoc :session-id session-id))]
+    (a/go
+      ;; Only allow receive pointer updates when active subscription
+      (when subs
+        (a/<! (msgbus-fn :cmd :pub
+                         :topic file-id
+                         :message message))))))
 
 (defmethod handle-message :default
-  [_ message]
-  (a/go
-    (l/log :level :warn
-           :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}})))
+  [_ wsp message]
+  (let [conn-id (::ws/id @wsp)]
+    (l/warn :hint "received unexpected message"
+            :message message
+            :conn-id conn-id)
+    (a/go :none)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; 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)]
+      (cond
+        (not profile-id)
+        (raise (ex/error :type :authentication
+                         :hint "Authentication required."))
 
-        (when-not profile-id
-          (ex/raise :type :authentication
-                    :hint "Authentication required."))
+        (not (yws/upgrade-request? req))
+        (raise (ex/error :type :validation
+                         :code :websocket-request-expected
+                         :hint "this endpoint only accepts websocket connections"))
 
-        (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"))
-
-        (->> (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]))
+        :else
+        (do
+          (l/trace :hint "websocket request" :profile-id profile-id :session-id session-id)
 
+          (->> (ws/handler
+                ::ws/on-rcv-message (partial on-rcv-message cfg)
+                ::ws/on-snd-message (partial on-snd-message cfg)
+                ::ws/on-connect (partial on-connect cfg)
+                ::ws/handler (partial handle-message cfg)
+                ::profile-id profile-id
+                ::session-id session-id)
+               (yws/upgrade req)
+               (respond)))))))

backend/src/app/loggers/audit.clj

@@ -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,50 +23,60 @@
    [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")
+      (some-> (yrq/remote-addr request) str)))
+
+(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]
   (-> profile
-      (select-keys [:is-active :is-muted :auth-backend :email :default-team-id :default-project-id :fullname :lang])
+      (select-keys [:id :is-active :is-muted :auth-backend :email :default-team-id :default-project-id :fullname :lang])
       (merge (:props profile))
       (d/without-nils)))
 
 (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,36 +160,53 @@
 (defmethod ig/pre-init-spec ::collector [_]
   (s/keys :req-un [::db/pool ::wrk/executor]))
 
-(def event-xform
+(s/def ::ip-addr string?)
+(s/def ::backend-event
+  (s/keys :req-un [::type ::name ::profile-id]
+          :opt-un [::ip-addr ::props]))
+
+(def ^:private backend-event-xform
   (comp
-   (filter :profile-id)
+   (filter #(us/valid? ::backend-event %))
    (map clean-props)))
 
 (defmethod ig/init-key ::collector
-  [_ cfg]
-  (when (contains? cf/flags :audit-log)
-    (l/info :msg "initializing audit log collector")
-    (let [input  (a/chan 512 event-xform)
+  [_ {:keys [pool] :as cfg}]
+  (cond
+    (not (contains? cf/flags :audit-log))
+    (do
+      (l/info :hint "audit log collection disabled")
+      (constantly nil))
+
+    (db/read-only? pool)
+    (do
+      (l/warn :hint "audit log collection disabled, db is read-only")
+      (constantly nil))
+
+    :else
+    (let [input  (a/chan 512 backend-event-xform)
           buffer (aa/batch input {:max-batch-size 100
                                   :max-batch-age (* 10 1000) ; 10s
                                   :init []})]
+      (l/info :hint "audit log collector initialized")
       (a/go-loop []
         (when-let [[_type events] (a/<! buffer)]
           (let [res (a/<! (persist-events cfg events))]
             (when (ex/exception? res)
-              (l/error :hint "error on persisting events"
-                       :cause res)))
-          (recur)))
+              (l/error :hint "error on persisting events" :cause res))
+            (recur))))
 
       (fn [& {:keys [cmd] :as params}]
-        (let [params (-> params
-                         (dissoc :cmd)
-                         (assoc :tracked-at (dt/now)))]
-          (case cmd
-            :stop   (a/close! input)
-            :submit (when-not (a/offer! input params)
-                      (l/warn :msg "activity channel is full"))))))))
+        (case cmd
+          :stop
+          (a/close! input)
 
+          :submit
+          (let [params (-> params
+                           (dissoc :cmd)
+                           (assoc :tracked-at (dt/now)))]
+            (when-not (a/offer! input params)
+              (l/warn :hint "activity channel is full"))))))))
 
 (defn- persist-events
   [{:keys [pool executor] :as cfg} events]
@@ -189,7 +224,7 @@
         (db/with-atomic [conn pool]
           (db/insert-multi! conn :audit-log
                             [:id :name :type :profile-id :tracked-at :ip-addr :props :source]
-                            (sequence (map event->row) events)))))))
+                            (sequence (keep event->row) events)))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Archive Task
@@ -200,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
@@ -216,26 +252,31 @@
                       (: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
                   :hint "archive task not configured, missing uri"))
+
       (when enabled
-        (loop []
-          (let [res (archive-events cfg)]
-            (when (= res :continue)
-              (aa/thread-sleep 200)
-              (recur))))))))
+        (loop [total 0]
+          (let [n (archive-events cfg)]
+            (if n
+              (do
+                (aa/thread-sleep 200)
+                (recur (+ total n)))
+              (when (pos? total)
+                (l/trace :hint "events chunk archived" :num total)))))))))
 
 (def sql:retrieve-batch-of-audit-log
   "select * from audit_log
     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)
@@ -271,12 +312,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]
@@ -294,7 +336,7 @@
           (l/debug :action "archive-events" :uri uri :events (count events))
           (when (send events)
             (mark-as-archived conn rows)
-            :continue))))))
+            (count events)))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; GC Task

backend/src/app/loggers/database.clj

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

backend/src/app/loggers/loki.clj

@@ -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/sentry.clj

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

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

@@ -6,6 +6,7 @@
 
 (ns app.main
   (:require
+   [app.auth.oidc]
    [app.common.logging :as l]
    [app.config :as cf]
    [app.util.time :as dt]
@@ -17,11 +18,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 30}
+    :name       :main
+    :min-size   (cf/get :database-min-pool-size 0)
+    :max-size   (cf/get :database-max-pool-size 30)}
+
+   ;; Default thread pool for IO operations
+   [::default :app.worker/executor]
+   {:parallelism (cf/get :default-executor-parallelism 60)
+    :prefix :default}
+
+   ;; Constrained thread pool. Should only be used from high 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,73 +64,142 @@
    :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
    {:keys (ig/ref :app.setup/keys)}
 
+   :app.storage.tmp/cleaner
+   {:executor (ig/ref [::worker :app.worker/executor])
+    :scheduler (ig/ref :app.worker/scheduler)}
+
    :app.storage/gc-deleted-task
    {:pool     (ig/ref :app.db/pool)
     :storage  (ig/ref :app.storage/storage)
-    :min-age  (dt/duration {:hours 2})}
+    :executor (ig/ref [::worker :app.worker/executor])}
 
    :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)
-    :max-age     (cf/get :http-session-idle-max-age)}
-
-   :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)
-    :max-batch-age  (cf/get :http-session-updater-batch-max-age)
-    :max-batch-size (cf/get :http-session-updater-batch-max-size)}
+    :max-age     (cf/get :auth-token-cookie-max-age)}
 
    :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.auth.ldap/provider
+   {:host           (cf/get :ldap-host)
+    :port           (cf/get :ldap-port)
+    :ssl            (cf/get :ldap-ssl)
+    :tls            (cf/get :ldap-starttls)
+    :query          (cf/get :ldap-user-query)
+    :attrs-email    (cf/get :ldap-attrs-email)
+    :attrs-fullname (cf/get :ldap-attrs-fullname)
+    :attrs-username (cf/get :ldap-attrs-username)
+    :base-dn        (cf/get :ldap-base-dn)
+    :bind-dn        (cf/get :ldap-bind-dn)
+    :bind-password  (cf/get :ldap-bind-password)
+    :enabled?       (contains? cf/flags :login-with-ldap)}
+
+   :app.auth.oidc/google-provider
+   {:enabled?      (contains? cf/flags :login-with-google)
+    :client-id     (cf/get :google-client-id)
+    :client-secret (cf/get :google-client-secret)}
+
+   :app.auth.oidc/github-provider
+   {:enabled?      (contains? cf/flags :login-with-github)
+    :http-client   (ig/ref :app.http/client)
+    :client-id     (cf/get :github-client-id)
+    :client-secret (cf/get :github-client-secret)}
+
+   :app.auth.oidc/gitlab-provider
+   {:enabled?      (contains? cf/flags :login-with-gitlab)
+    :base-uri      (cf/get :gitlab-base-uri "https://gitlab.com")
+    :client-id     (cf/get :gitlab-client-id)
+    :client-secret (cf/get :gitlab-client-secret)}
+
+   :app.auth.oidc/generic-provider
+   {:enabled?      (contains? cf/flags :login-with-oidc)
+    :http-client   (ig/ref :app.http/client)
+
+    :client-id     (cf/get :oidc-client-id)
+    :client-secret (cf/get :oidc-client-secret)
+
+    :base-uri      (cf/get :oidc-base-uri)
+
+    :token-uri     (cf/get :oidc-token-uri)
+    :auth-uri      (cf/get :oidc-auth-uri)
+    :user-uri      (cf/get :oidc-user-uri)
+
+    :scopes        (cf/get :oidc-scopes)
+    :roles-attr    (cf/get :oidc-roles-attr)
+    :roles         (cf/get :oidc-roles)}
+
+   :app.auth.oidc/routes
+   {:providers   {:google (ig/ref :app.auth.oidc/google-provider)
+                  :github (ig/ref :app.auth.oidc/github-provider)
+                  :gitlab (ig/ref :app.auth.oidc/gitlab-provider)
+                  :oidc   (ig/ref :app.auth.oidc/generic-provider)}
+    :tokens      (ig/ref :app.tokens/tokens)
+    :http-client (ig/ref :app.http/client)
+    :pool        (ig/ref :app.db/pool)
+    :session     (ig/ref :app.http/session)
+    :public-uri  (cf/get :public-uri)
+    :executor    (ig/ref [::default :app.worker/executor])}
 
    :app.http/router
-   {:assets               (ig/ref :app.http.assets/handlers)
-    :feedback             (ig/ref :app.http.feedback/handler)
-    :session              (ig/ref :app.http.session/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)
+    :debug-routes  (ig/ref :app.http.debug/routes)
+    :oidc-routes   (ig/ref :app.auth.oidc/routes)
+    :ws            (ig/ref :app.http.websocket/handler)
+    :metrics       (ig/ref :app.metrics/metrics)
+    :public-uri    (cf/get :public-uri)
+    :storage       (ig/ref :app.storage/storage)
+    :tokens        (ig/ref :app.tokens/tokens)
+    :audit-handler (ig/ref :app.loggers.audit/http-handler)
+    :rpc-routes    (ig/ref :app.rpc/routes)
+    :doc-routes    (ig/ref :app.rpc.doc/routes)
+    :executor      (ig/ref [::default :app.worker/executor])}
 
-   :app.http.debug/handlers
-   {:pool (ig/ref :app.db/pool)}
+   :app.http.debug/routes
+   {:pool     (ig/ref :app.db/pool)
+    :executor (ig/ref [::worker :app.worker/executor])
+    :storage  (ig/ref :app.storage/storage)
+    :session  (ig/ref :app.http/session)}
 
    :app.http.websocket/handler
    {:pool     (ig/ref :app.db/pool)
-    :executor (ig/ref :app.worker/executor)
     :metrics  (ig/ref :app.metrics/metrics)
     :msgbus   (ig/ref :app.msgbus/msgbus)}
 
@@ -106,102 +207,45 @@
    {: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)}
+   :app.rpc/methods
+   {: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)
+    :ldap        (ig/ref :app.auth.ldap/provider)
+    :http-client (ig/ref :app.http/client)
+    :executors   (ig/ref :app.worker/executors)}
 
-   :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.rpc.doc/routes
+   {:methods (ig/ref :app.rpc/methods)}
 
-   :app.worker/executor
-   {:min-threads 0
-    :max-threads 256
-    :idle-timeout 60000
-    :name :worker}
-
-   :app.worker/worker
-   {:executor (ig/ref :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)
-    :tasks      (ig/ref :app.worker/registry)
-    :pool       (ig/ref :app.db/pool)
-    :schedule
-    [{:cron #app/cron "0 0 0 * * ?" ;; daily
-      :task :file-media-gc}
-
-     {:cron #app/cron "0 0 * * * ?"  ;; hourly
-      :task :file-xlog-gc}
-
-     {:cron #app/cron "0 0 0 * * ?"  ;; daily
-      :task :storage-deleted-gc}
-
-     {:cron #app/cron "0 0 0 * * ?"  ;; daily
-      :task :storage-touched-gc}
-
-     {: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}
-
-     (when (cf/get :fdata-storage-backed)
-       {:cron #app/cron "0 0 * * * ?"  ;; hourly
-        :task :file-offload})
-
-     (when (contains? cf/flags :audit-log-archive)
-       {:cron #app/cron "0 */3 * * * ?" ;; every 3m
-        :task :audit-log-archive})
-
-     (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 0 */6 * * ?" ;; every 6h
-        :task :telemetry})]}
+   :app.rpc/routes
+   {:methods (ig/ref :app.rpc/methods)}
 
    :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)
+     :storage-gc-deleted (ig/ref :app.storage/gc-deleted-task)
+     :storage-gc-touched (ig/ref :app.storage/gc-touched-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)
-     :file-offload       (ig/ref :app.tasks.file-offload/handler)
      :audit-log-archive  (ig/ref :app.loggers.audit/archive-task)
      :audit-log-gc       (ig/ref :app.loggers.audit/gc-task)}}
 
@@ -222,28 +266,20 @@
 
    :app.tasks.objects-gc/handler
    {:pool    (ig/ref :app.db/pool)
-    :storage (ig/ref :app.storage/storage)
-    :max-age cf/deletion-delay}
+    :storage (ig/ref :app.storage/storage)}
 
-   :app.tasks.file-media-gc/handler
-   {:pool    (ig/ref :app.db/pool)
-    :max-age cf/deletion-delay}
+   :app.tasks.file-gc/handler
+   {:pool (ig/ref :app.db/pool)}
 
    :app.tasks.file-xlog-gc/handler
-   {:pool    (ig/ref :app.db/pool)
-    :max-age (dt/duration {:hours 72})}
-
-   :app.tasks.file-offload/handler
-   {:pool    (ig/ref :app.db/pool)
-    :max-age (dt/duration {:seconds 5})
-    :storage (ig/ref :app.storage/storage)
-    :backend (cf/get :fdata-storage-backed :fdata-s3)}
+   {:pool (ig/ref :app.db/pool)}
 
    :app.tasks.telemetry/handler
    {: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,87 +297,115 @@
 
    :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-fs (ig/ref [::assets :app.storage.fs/backend])
 
-               ;; keep this for backward compatibility
-               :s3        (ig/ref [::assets :app.storage.s3/backend])
-               :fs        (ig/ref [::assets :app.storage.fs/backend])}}
-
-   [::fdata :app.storage.s3/backend]
-   {:region (cf/get :storage-fdata-s3-region)
-    :bucket (cf/get :storage-fdata-s3-bucket)
-    :prefix (cf/get :storage-fdata-s3-prefix)}
+     ;; keep this for backward compatibility
+     :s3        (ig/ref [::assets :app.storage.s3/backend])
+     :fs        (ig/ref [::assets :app.storage.fs/backend])}}
 
    [::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)}
+   })
 
-   [::tmp :app.storage.fs/backend]
-   {:directory "/tmp/penpot"}
 
-   [::assets :app.storage.db/backend]
-   {:pool (ig/ref :app.db/pool)}})
+(def worker-config
+  {   :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)
+    :entries
+    [{:cron #app/cron "0 0 0 * * ?" ;; daily
+      :task :file-gc}
+
+     {:cron #app/cron "0 0 * * * ?"  ;; hourly
+      :task :file-xlog-gc}
+
+     {:cron #app/cron "0 0 0 * * ?"  ;; daily
+      :task :storage-gc-deleted}
+
+     {:cron #app/cron "0 0 0 * * ?"  ;; daily
+      :task :storage-gc-touched}
+
+     {:cron #app/cron "0 0 0 * * ?"  ;; daily
+      :task :session-gc}
+
+     {: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 (contains? cf/flags :audit-log-archive)
+       {:cron #app/cron "0 */5 * * * ?" ;; every 5m
+        :task :audit-log-archive})
+
+     (when (contains? cf/flags :audit-log-gc)
+       {:cron #app/cron "0 0 0 * * ?" ;; daily
+        :task :audit-log-gc})]}
+
+   :app.worker/worker
+   {: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)}})
 
 (def system nil)
 
 (defn start
   []
-  (ig/load-namespaces system-config)
+  (ig/load-namespaces (merge system-config worker-config))
   (alter-var-root #'system (fn [sys]
                              (when sys (ig/halt! sys))
                              (-> system-config
+                                 (cond-> (contains? cf/flags :backend-worker)
+                                   (merge worker-config))
                                  (ig/prep)
                                  (ig/init))))
   (l/info :msg "welcome to penpot"

backend/src/app/media.clj

@@ -12,43 +12,44 @@
    [app.common.media :as cm]
    [app.common.spec :as us]
    [app.config :as cf]
+   [app.storage.tmp :as tmp]
+   [app.util.bytes :as bs]
    [app.util.svg :as svg]
    [buddy.core.bytes :as bb]
    [buddy.core.codecs :as bc]
-   [clojure.java.io :as io]
    [clojure.java.shell :as sh]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [datoteka.core :as fs])
   (:import
-   java.io.ByteArrayInputStream
-   java.io.OutputStream
-   org.apache.commons.io.IOUtils
    org.im4java.core.ConvertCmd
    org.im4java.core.IMOperation
    org.im4java.core.Info))
 
-(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 +72,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/
@@ -100,18 +91,16 @@
   (let [{:keys [path mtype]} input
         format (or (cm/mtype->format mtype) format)
         ext    (cm/format->extension format)
-        tmp    (fs/create-tempfile :suffix ext)]
+        tmp    (tmp/tempfile :prefix "penpot.media." :suffix ext)]
 
     (doto (ConvertCmd.)
       (.run operation (into-array (map str [path tmp]))))
 
-    (let [thumbnail-data (fs/slurp-bytes tmp)]
-      (fs/delete tmp)
-      (assoc params
-             :format format
-             :mtype  (cm/format->mtype format)
-             :size   (alength ^bytes thumbnail-data)
-             :data   (ByteArrayInputStream. thumbnail-data)))))
+    (assoc params
+           :format format
+           :mtype  (cm/format->mtype format)
+           :size   (fs/size tmp)
+           :data   tmp)))
 
 (defmethod process :generic-thumbnail
   [{:keys [quality width height] :as params}]
@@ -177,7 +166,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 +179,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,65 +191,60 @@
             :cause error))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Fonts Generation
+;; FONTS
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defmethod process :generate-fonts
   [{:keys [input] :as params}]
   (letfn [(ttf->otf [data]
-            (let [input-file  (fs/create-tempfile :prefix "penpot")
-                  output-file (fs/path (str input-file ".otf"))
-                  _           (with-open [out (io/output-stream input-file)]
-                                (IOUtils/writeChunked ^bytes data ^OutputStream out)
-                                (.flush ^OutputStream out))
-                  res         (sh/sh "fontforge" "-lang=ff" "-c"
-                                     (str/fmt "Open('%s'); Generate('%s')"
-                                              (str input-file)
-                                              (str output-file)))]
+            (let [finput  (tmp/tempfile :prefix "penpot.font." :suffix "")
+                  foutput (fs/path (str finput ".otf"))
+                  _       (bs/write-to-file! data finput)
+                  res     (sh/sh "fontforge" "-lang=ff" "-c"
+                                 (str/fmt "Open('%s'); Generate('%s')"
+                                          (str finput)
+                                          (str foutput)))]
               (when (zero? (:exit res))
-                (fs/slurp-bytes output-file))))
-
+                foutput)))
 
           (otf->ttf [data]
-            (let [input-file  (fs/create-tempfile :prefix "penpot")
-                  output-file (fs/path (str input-file ".ttf"))
-                  _           (with-open [out (io/output-stream input-file)]
-                                (IOUtils/writeChunked ^bytes data ^OutputStream out)
-                                (.flush ^OutputStream out))
-                  res         (sh/sh "fontforge" "-lang=ff" "-c"
-                                     (str/fmt "Open('%s'); Generate('%s')"
-                                              (str input-file)
-                                              (str output-file)))]
+            (let [finput  (tmp/tempfile :prefix "penpot.font." :suffix "")
+                  foutput (fs/path (str finput ".ttf"))
+                  _       (bs/write-to-file! data finput)
+                  res     (sh/sh "fontforge" "-lang=ff" "-c"
+                                 (str/fmt "Open('%s'); Generate('%s')"
+                                          (str finput)
+                                          (str foutput)))]
               (when (zero? (:exit res))
-                (fs/slurp-bytes output-file))))
+                foutput)))
 
           (ttf-or-otf->woff [data]
-            (let [input-file  (fs/create-tempfile :prefix "penpot" :suffix "")
-                  output-file (fs/path (str input-file ".woff"))
-                  _           (with-open [out (io/output-stream input-file)]
-                                (IOUtils/writeChunked ^bytes data ^OutputStream out)
-                                (.flush ^OutputStream out))
-                  res         (sh/sh "sfnt2woff" (str input-file))]
+            ;; NOTE: foutput is not used directly, it represents the
+            ;; default output of the exection of the underlying
+            ;; command.
+            (let [finput  (tmp/tempfile :prefix "penpot.font." :suffix "")
+                  foutput (fs/path (str finput ".woff"))
+                  _       (bs/write-to-file! data finput)
+                  res     (sh/sh "sfnt2woff" (str finput))]
               (when (zero? (:exit res))
-                (fs/slurp-bytes output-file))))
+                foutput)))
 
           (ttf-or-otf->woff2 [data]
-            (let [input-file  (fs/create-tempfile :prefix "penpot" :suffix "")
-                  output-file (fs/path (str input-file ".woff2"))
-                  _           (with-open [out (io/output-stream input-file)]
-                                (IOUtils/writeChunked ^bytes data ^OutputStream out)
-                                (.flush ^OutputStream out))
-                  res         (sh/sh "woff2_compress" (str input-file))]
+            ;; NOTE: foutput is not used directly, it represents the
+            ;; default output of the exection of the underlying
+            ;; command.
+            (let [finput  (tmp/tempfile :prefix "penpot.font." :suffix ".tmp")
+                  foutput (fs/path (str (fs/base finput) ".woff2"))
+                  _       (bs/write-to-file! data finput)
+                  res      (sh/sh "woff2_compress" (str finput))]
               (when (zero? (:exit res))
-                (fs/slurp-bytes output-file))))
+                foutput)))
 
           (woff->sfnt [data]
-            (let [input-file  (fs/create-tempfile :prefix "penpot" :suffix "")
-                  _           (with-open [out (io/output-stream input-file)]
-                                (IOUtils/writeChunked ^bytes data ^OutputStream out)
-                                (.flush ^OutputStream out))
-                  res         (sh/sh "woff2sfnt" (str input-file)
-                                     :out-enc :bytes)]
+            (let [finput  (tmp/tempfile :prefix "penpot" :suffix "")
+                  _       (bs/write-to-file! data finput)
+                  res     (sh/sh "woff2sfnt" (str finput)
+                                 :out-enc :bytes)]
               (when (zero? (:exit res))
                 (:out res))))
 
@@ -325,9 +309,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,24 @@
     :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-command-timing
+   {:name "rpc_command_timing"
+    :help "RPC command 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 +78,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 +153,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 +203,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 +216,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 +257,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 +268,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

@@ -6,7 +6,7 @@
 
 (ns app.migrations
   (:require
-   [app.migrations.migration-0023 :as mg0023]
+   [app.migrations.clj.migration-0023 :as mg0023]
    [app.util.migrations :as mg]
    [integrant.core :as ig]))
 
@@ -205,6 +205,45 @@
 
    {: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")}
+
+   {:name "0073-mod-file-media-object-constraints"
+    :fn (mg/resource "app/migrations/sql/0073-mod-file-media-object-constraints.sql")}
+
+   {:name "0074-mod-file-library-rel-constraints"
+    :fn (mg/resource "app/migrations/sql/0074-mod-file-library-rel-constraints.sql")}
+
+   {:name "0075-mod-share-link-table"
+    :fn (mg/resource "app/migrations/sql/0075-mod-share-link-table.sql")}
+
+   {:name "0076-mod-storage-object-table"
+    :fn (mg/resource "app/migrations/sql/0076-mod-storage-object-table.sql")}
+
+   {:name "0077-mod-comment-thread-table"
+    :fn (mg/resource "app/migrations/sql/0077-mod-comment-thread-table.sql")}
+
+   {:name "0078-mod-file-media-object-table-drop-cascade"
+    :fn (mg/resource "app/migrations/sql/0078-mod-file-media-object-table-drop-cascade.sql")}
    ])
 
 

backend/src/app/migrations/clj/migration_0023.clj

@@ -4,7 +4,7 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.migrations.migration-0023
+(ns app.migrations.clj.migration-0023
   (:require
    [app.db :as db]
    [app.util.blob :as blob]))

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/migrations/sql/0073-mod-file-media-object-constraints.sql

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

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

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

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

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

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

@@ -0,0 +1,10 @@
+-- Renames the old, already deprecated backend name with new one on
+-- all storage object rows.
+
+UPDATE storage_object
+   SET backend = 'assets-fs'
+ WHERE backend = 'fs';
+
+UPDATE storage_object
+   SET backend = 'assets-s3'
+ WHERE backend = 's3';

backend/src/app/migrations/sql/0077-mod-comment-thread-table.sql

@@ -0,0 +1,3 @@
+--- Add frame_id field.
+ALTER TABLE comment_thread
+  ADD COLUMN frame_id uuid NULL DEFAULT '00000000-0000-0000-0000-000000000000';

backend/src/app/migrations/sql/0078-mod-file-media-object-table-drop-cascade.sql

@@ -0,0 +1,9 @@
+ALTER TABLE file_media_object
+ DROP CONSTRAINT file_media_object_media_id_fkey,
+  ADD CONSTRAINT file_media_object_media_id_fkey
+         FOREIGN KEY (media_id) REFERENCES storage_object(id) ON DELETE NO ACTION DEFERRABLE;
+
+ALTER TABLE file_media_object
+ DROP CONSTRAINT file_media_object_thumbnail_id_fkey,
+  ADD CONSTRAINT file_media_object_thumbnail_id_fkey
+         FOREIGN KEY (thumbnail_id) REFERENCES storage_object(id) ON DELETE NO ACTION DEFERRABLE;

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,253 @@
   [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]
+  (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)))
-
-            (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))
-
-            (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))]
-
-      ;; 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)))
-
-      ;; 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))
-
-            (recur))
-
-          ;; 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!)))))))))
+(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]
+  (aa/with-closing done-ch
+    (reduce #(unsubscribe-single-channel %1 cfg %2) state channels)))
 
 
-(defn- impl-redis-open?
-  [^StatefulConnection conn]
-  (.isOpen conn))
+(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/debug :hint "subscribe" :topics topics)
+    (send-via executor state subscribe-to-topics cfg topics chan done-ch)
+    done-ch))
 
-(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))
+(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))
+
+(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])))
+
+(defn start-io-loop
+  [{:keys [::sconn ::rcv-ch ::pub-ch ::state executor] :as cfg}]
+
+  ;; Add a single listener to the pubsub connection
+  (.addListener ^StatefulRedisPubSubConnection sconn
+                ^RedisPubSubListener (create-listener rcv-ch))
+
+  (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))))
+          ]
+
+  (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)))
+
+        (= 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

@@ -6,132 +6,210 @@
 
 (ns app.rpc
   (:require
-   [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.logging :as l]
    [app.common.spec :as us]
    [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- rpc-command-handler
+  "Ring handler that dispatches cmd requests and convert between
+  internal async flow into ring async flow."
+  [methods {:keys [profile-id session-id params] :as request} respond raise]
+  (letfn [(handle-response [result]
+            (let [mdata (meta result)]
+              (p/-> (yrs/response 200 result)
+                    (handle-response-transformation request mdata)
+                    (handle-before-comple-hook mdata))))]
 
-(defn- wrap-with-metrics
-  [cfg f mdata]
-  (mtx/wrap-summary f (::mobj cfg) [(::sv/name mdata)]))
+    (let [cmd    (keyword (:command params))
+          data   (into {::request request} params)
+          data   (if profile-id
+                   (assoc data :profile-id profile-id ::session-id session-id)
+                   (dissoc data :profile-id))
 
-(defn- wrap-impl
+          method (get methods cmd default-handler)]
+      (-> (method data)
+          (p/then handle-response)
+          (p/then respond)
+          (p/catch (fn [cause]
+                     (let [context {:profile-id profile-id}]
+                       (raise (ex/wrap-with-context cause context)))))))))
+
+(defn- wrap-metrics
+  "Wrap service method with metrics measurement."
+  [{:keys [metrics ::metrics-id]} f mdata]
+  (let [labels (into-array String [(::sv/name mdata)])]
+    (fn [cfg params]
+      (let [start (System/nanoTime)]
+        (p/finally
+          (f cfg params)
+          (fn [_ _]
+            (mtx/run! metrics
+                      {:id metrics-id
+                       :val (/ (- (System/nanoTime) start) 1000000)
+                       :labels labels})))))))
+
+(defn- wrap-dispatch
+  "Wraps service method into async flow, with the ability to dispatching
+  it to a preconfigured executor service."
+  [{:keys [executors] :as cfg} f mdata]
+  (let [dname (::async/dispatch mdata :default)]
+    (if (= :none dname)
+      (with-meta
+        (fn [cfg params]
+          (p/do (f cfg params)))
+        mdata)
+
+      (let [executor (get executors dname)]
+        (when-not executor
+          (ex/raise :type :internal
+                    :code :executor-not-configured
+                    :hint (format "executor %s not configured" dname)))
+        (with-meta
+          (fn [cfg params]
+            (-> (px/submit! executor #(f cfg params))
+                (p/bind p/wrap)))
+          mdata)))))
+
+(defn- wrap-audit
   [{:keys [audit] :as cfg} f mdata]
+  (if audit
+    (with-meta
+      (fn [cfg {:keys [::request] :as params}]
+        (p/finally (f cfg params)
+                   (fn [result _]
+                     (when result
+                       (let [resultm    (meta result)
+                             profile-id (or (::audit/profile-id resultm)
+                                            (:profile-id result)
+                                            (:profile-id params))
+                             props      (or (::audit/replace-props resultm)
+                                            (-> params
+                                                (merge (::audit/props resultm))
+                                                (dissoc :type)))]
+                         (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))
+    (l/debug :hint "register method" :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 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,41 +222,84 @@
 
 (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")]
-    (->> (sv/scan-ns 'app.rpc.mutations.demo
-                     'app.rpc.mutations.media
+  (let [cfg (assoc cfg ::type "mutation" ::metrics-id :rpc-mutation-timing)]
+    (->> (sv/scan-ns 'app.rpc.mutations.media
                      'app.rpc.mutations.profile
                      'app.rpc.mutations.files
                      'app.rpc.mutations.comments
                      'app.rpc.mutations.projects
                      'app.rpc.mutations.teams
                      'app.rpc.mutations.management
-                     'app.rpc.mutations.ldap
                      'app.rpc.mutations.fonts
                      'app.rpc.mutations.share-link
                      'app.rpc.mutations.verify-token)
          (map (partial process-method cfg))
          (into {}))))
 
-(s/def ::storage some?)
-(s/def ::session map?)
-(s/def ::tokens fn?)
+(defn- resolve-command-methods
+  [cfg]
+  (let [cfg (assoc cfg ::type "command" ::metrics-id :rpc-command-timing)]
+    (->> (sv/scan-ns 'app.rpc.commands.binfile
+                     'app.rpc.commands.comments
+                     'app.rpc.commands.auth
+                     'app.rpc.commands.ldap
+                     'app.rpc.commands.demo
+                     'app.rpc.commands.files)
+         (map (partial process-method cfg))
+         (into {}))))
+
 (s/def ::audit (s/nilable fn?))
+(s/def ::executors (s/map-of keyword? ::wrk/executor))
+(s/def ::executors map?)
+(s/def ::http-client fn?)
+(s/def ::ldap (s/nilable map?))
+(s/def ::msgbus fn?)
+(s/def ::public-uri ::us/not-empty-string)
+(s/def ::session map?)
+(s/def ::storage some?)
+(s/def ::tokens fn?)
 
-(defmethod ig/pre-init-spec ::rpc [_]
-  (s/keys :req-un [::storage ::session ::tokens ::audit
-                   ::mtx/metrics ::db/pool]))
+(defmethod ig/pre-init-spec ::methods [_]
+  (s/keys :req-un [::storage
+                   ::session
+                   ::tokens
+                   ::audit
+                   ::executors
+                   ::public-uri
+                   ::msgbus
+                   ::http-client
+                   ::mtx/metrics
+                   ::db/pool
+                   ::ldap]))
 
-(defmethod ig/init-key ::rpc
+(defmethod ig/init-key ::methods
   [_ cfg]
-  (let [mq (resolve-query-methods cfg)
-        mm (resolve-mutation-methods cfg)]
-    {:methods {:query mq :mutation mm}
-     :query-handler #(rpc-query-handler mq %)
-     :mutation-handler #(rpc-mutation-handler mm %)}))
+  {:mutations (resolve-mutation-methods cfg)
+   :queries   (resolve-query-methods cfg)
+   :commands  (resolve-command-methods cfg)})
+
+(s/def ::mutations
+  (s/map-of keyword? fn?))
+
+(s/def ::queries
+  (s/map-of keyword? fn?))
+
+(s/def ::commands
+  (s/map-of keyword? fn?))
+
+(s/def ::methods
+  (s/keys :req-un [::mutations
+                   ::queries
+                   ::commands]))
+
+(defmethod ig/pre-init-spec ::routes [_]
+  (s/keys :req-un [::methods]))
+
+(defmethod ig/init-key ::routes
+  [_ {:keys [methods] :as cfg}]
+  [["/rpc"
+    ["/command/:command" {:handler (partial rpc-command-handler (:commands methods))}]
+    ["/query/:type" {:handler (partial rpc-query-handler (:queries methods))}]
+    ["/mutation/:type" {:handler (partial rpc-mutation-handler (:mutations methods))
+                        :allowed-methods #{:post}}]]])
+

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

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

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

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

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

@@ -0,0 +1,532 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.rpc.commands.comments
+  (:require
+   [app.common.exceptions :as ex]
+   [app.common.geom.point :as gpt]
+   [app.common.spec :as us]
+   [app.db :as db]
+   [app.rpc.doc :as-alias doc]
+   [app.rpc.queries.files :as files]
+   [app.rpc.queries.teams :as teams]
+   [app.rpc.retry :as retry]
+   [app.util.blob :as blob]
+   [app.util.services :as sv]
+   [app.util.time :as dt]
+   [clojure.spec.alpha :as s]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; QUERY COMMANDS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn decode-row
+  [{:keys [participants position] :as row}]
+  (cond-> row
+    (db/pgpoint? position) (assoc :position (db/decode-pgpoint position))
+    (db/pgobject? participants) (assoc :participants (db/decode-transit-pgobject participants))))
+
+;; --- COMMAND: Get Comment Threads
+
+(declare retrieve-comment-threads)
+
+(s/def ::team-id ::us/uuid)
+(s/def ::file-id ::us/uuid)
+(s/def ::share-id (s/nilable ::us/uuid))
+
+(s/def ::get-comment-threads
+  (s/and (s/keys :req-un [::profile-id]
+                 :opt-un [::file-id ::share-id ::team-id])
+         #(or (:file-id %) (:team-id %))))
+
+(sv/defmethod ::get-comment-threads
+  [{:keys [pool] :as cfg} params]
+  (with-open [conn (db/open pool)]
+    (retrieve-comment-threads conn params)))
+
+(def sql:comment-threads
+  "select distinct on (ct.id)
+          ct.*,
+          f.name as file_name,
+          f.project_id as project_id,
+          first_value(c.content) over w as content,
+          (select count(1)
+             from comment as c
+            where c.thread_id = ct.id) as count_comments,
+          (select count(1)
+             from comment as c
+            where c.thread_id = ct.id
+              and c.created_at >= coalesce(cts.modified_at, ct.created_at)) as count_unread_comments
+     from comment_thread as ct
+    inner join comment as c on (c.thread_id = ct.id)
+    inner join file as f on (f.id = ct.file_id)
+     left join comment_thread_status as cts
+            on (cts.thread_id = ct.id and
+                cts.profile_id = ?)
+    where ct.file_id = ?
+   window w as (partition by c.thread_id order by c.created_at asc)")
+
+(defn retrieve-comment-threads
+  [conn {:keys [profile-id file-id share-id]}]
+  (files/check-comment-permissions! conn profile-id file-id share-id)
+  (->> (db/exec! conn [sql:comment-threads profile-id file-id])
+       (into [] (map decode-row))))
+
+;; --- COMMAND: Get Unread Comment Threads
+
+(declare retrieve-unread-comment-threads)
+
+(s/def ::team-id ::us/uuid)
+(s/def ::get-unread-comment-threads
+  (s/keys :req-un [::profile-id ::team-id]))
+
+(sv/defmethod ::get-unread-comment-threads
+  [{:keys [pool] :as cfg} {:keys [profile-id team-id] :as params}]
+  (with-open [conn (db/open pool)]
+    (teams/check-read-permissions! conn profile-id team-id)
+    (retrieve-unread-comment-threads conn params)))
+
+(def sql:comment-threads-by-team
+  "select distinct on (ct.id)
+          ct.*,
+          f.name as file_name,
+          f.project_id as project_id,
+          first_value(c.content) over w as content,
+          (select count(1)
+             from comment as c
+            where c.thread_id = ct.id) as count_comments,
+          (select count(1)
+             from comment as c
+            where c.thread_id = ct.id
+              and c.created_at >= coalesce(cts.modified_at, ct.created_at)) as count_unread_comments
+     from comment_thread as ct
+    inner join comment as c on (c.thread_id = ct.id)
+    inner join file as f on (f.id = ct.file_id)
+    inner join project as p on (p.id = f.project_id)
+     left join comment_thread_status as cts
+            on (cts.thread_id = ct.id and
+                cts.profile_id = ?)
+    where p.team_id = ?
+   window w as (partition by c.thread_id order by c.created_at asc)")
+
+(def sql:unread-comment-threads-by-team
+  (str "with threads as (" sql:comment-threads-by-team ")"
+       "select * from threads where count_unread_comments > 0"))
+
+(defn retrieve-unread-comment-threads
+  [conn {:keys [profile-id team-id]}]
+  (->> (db/exec! conn [sql:unread-comment-threads-by-team profile-id team-id])
+       (into [] (map decode-row))))
+
+
+;; --- COMMAND: Get Single Comment Thread
+
+(s/def ::id ::us/uuid)
+(s/def ::share-id (s/nilable ::us/uuid))
+(s/def ::get-comment-thread
+  (s/keys :req-un [::profile-id ::file-id ::id]
+          :opt-un [::share-id]))
+
+(sv/defmethod ::get-comment-thread
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id id share-id] :as params}]
+  (with-open [conn (db/open pool)]
+    (files/check-comment-permissions! conn profile-id file-id share-id)
+    (let [sql (str "with threads as (" sql:comment-threads ")"
+                   "select * from threads where id = ?")]
+      (-> (db/exec-one! conn [sql profile-id file-id id])
+          (decode-row)))))
+
+(defn get-comment-thread
+  [conn {:keys [profile-id file-id id] :as params}]
+  (let [sql (str "with threads as (" sql:comment-threads ")"
+                 "select * from threads where id = ?")]
+    (-> (db/exec-one! conn [sql profile-id file-id id])
+        (decode-row))))
+
+;; --- COMMAND: Retrieve Comments
+
+(declare get-comments)
+
+(s/def ::file-id ::us/uuid)
+(s/def ::share-id (s/nilable ::us/uuid))
+(s/def ::thread-id ::us/uuid)
+(s/def ::get-comments
+  (s/keys :req-un [::profile-id ::thread-id]
+          :opt-un [::share-id]))
+
+(sv/defmethod ::get-comments
+  [{:keys [pool] :as cfg} {:keys [profile-id thread-id share-id] :as params}]
+  (with-open [conn (db/open pool)]
+    (let [thread (db/get-by-id conn :comment-thread thread-id)]
+      (files/check-comment-permissions! conn profile-id (:file-id thread) share-id))
+    (get-comments conn thread-id)))
+
+(def sql:comments
+  "select c.* from comment as c
+    where c.thread_id = ?
+    order by c.created_at asc")
+
+(defn get-comments
+  [conn thread-id]
+  (->> (db/query conn :comment
+                 {:thread-id thread-id}
+                 {:order-by [[:created-at :asc]]})
+       (into [] (map decode-row))))
+
+;; --- COMMAND: Get file comments users
+
+(declare get-file-comments-users)
+
+(s/def ::file-id ::us/uuid)
+(s/def ::share-id (s/nilable ::us/uuid))
+
+(s/def ::get-profiles-for-file-comments
+  (s/keys :req-un [::profile-id ::file-id]
+          :opt-un [::share-id]))
+
+(sv/defmethod ::get-profiles-for-file-comments
+  "Retrieves a list of profiles with limited set of properties of all
+  participants on comment threads of the file."
+  {::doc/added "1.15"
+   ::doc/changes ["1.15" "Imported from queries and renamed."]}
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id share-id]}]
+  (with-open [conn (db/open pool)]
+    (files/check-comment-permissions! conn profile-id file-id share-id)
+    (get-file-comments-users conn file-id profile-id)))
+
+;; All the profiles that had comment the file, plus the current
+;; profile.
+
+(def sql:file-comment-users
+  "WITH available_profiles AS (
+     SELECT DISTINCT owner_id AS id
+       FROM comment
+      WHERE thread_id IN (SELECT id FROM comment_thread WHERE file_id=?)
+  )
+  SELECT p.id,
+         p.email,
+         p.fullname AS name,
+         p.fullname AS fullname,
+         p.photo_id,
+         p.is_active
+    FROM profile AS p
+   WHERE p.id IN (SELECT id FROM available_profiles) OR p.id=?")
+
+(defn get-file-comments-users
+  [conn file-id profile-id]
+  (db/exec! conn [sql:file-comment-users file-id profile-id]))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; MUTATION COMMANDS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; --- COMMAND: Create Comment Thread
+
+(declare upsert-comment-thread-status!)
+(declare create-comment-thread)
+(declare retrieve-page-name)
+
+(s/def ::page-id ::us/uuid)
+(s/def ::file-id ::us/uuid)
+(s/def ::share-id (s/nilable ::us/uuid))
+(s/def ::profile-id ::us/uuid)
+(s/def ::position ::gpt/point)
+(s/def ::content ::us/string)
+(s/def ::frame-id ::us/uuid)
+
+(s/def ::create-comment-thread
+  (s/keys :req-un [::profile-id ::file-id ::position ::content ::page-id ::frame-id]
+          :opt-un [::share-id]))
+
+(sv/defmethod ::create-comment-thread
+  {::retry/max-retries 3
+   ::retry/matches retry/conflict-db-insert?
+   ::doc/added "1.15"}
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id share-id] :as params}]
+  (db/with-atomic [conn pool]
+    (files/check-comment-permissions! conn profile-id file-id share-id)
+    (create-comment-thread conn params)))
+
+(defn- retrieve-next-seqn
+  [conn file-id]
+  (let [sql "select (f.comment_thread_seqn + 1) as next_seqn from file as f where f.id = ?"
+        res (db/exec-one! conn [sql file-id])]
+    (:next-seqn res)))
+
+(defn create-comment-thread
+  [conn {:keys [profile-id file-id page-id position content frame-id] :as params}]
+  (let [seqn    (retrieve-next-seqn conn file-id)
+        now     (dt/now)
+        pname   (retrieve-page-name conn params)
+        thread  (db/insert! conn :comment-thread
+                           {:file-id file-id
+                            :owner-id profile-id
+                            :participants (db/tjson #{profile-id})
+                            :page-name pname
+                            :page-id page-id
+                            :created-at now
+                            :modified-at now
+                            :seqn seqn
+                            :position (db/pgpoint position)
+                            :frame-id frame-id})]
+
+
+    ;; Create a comment entry
+    (db/insert! conn :comment
+                {:thread-id (:id thread)
+                 :owner-id profile-id
+                 :created-at now
+                 :modified-at now
+                 :content content})
+
+    ;; Make the current thread as read.
+    (upsert-comment-thread-status! conn profile-id (:id thread))
+
+    ;; Optimistic update of current seq number on file.
+    (db/update! conn :file
+                {:comment-thread-seqn seqn}
+                {:id file-id})
+
+    (select-keys thread [:id :file-id :page-id])))
+
+(defn- retrieve-page-name
+  [conn {:keys [file-id page-id]}]
+  (let [{:keys [data]} (db/get-by-id conn :file file-id)
+        data           (blob/decode data)]
+    (get-in data [:pages-index page-id :name])))
+
+
+;; --- COMMAND: Update Comment Thread Status
+
+(s/def ::id ::us/uuid)
+(s/def ::share-id (s/nilable ::us/uuid))
+
+(s/def ::update-comment-thread-status
+  (s/keys :req-un [::profile-id ::id]
+          :opt-un [::share-id]))
+
+(sv/defmethod ::update-comment-thread-status
+  {::doc/added "1.15"}
+  [{:keys [pool] :as cfg} {:keys [profile-id id share-id] :as params}]
+  (db/with-atomic [conn pool]
+    (let [cthr (db/get-by-id conn :comment-thread id {:for-update true})]
+      (when-not cthr
+        (ex/raise :type :not-found))
+
+      (files/check-comment-permissions! conn profile-id (:file-id cthr) share-id)
+      (upsert-comment-thread-status! conn profile-id (:id cthr)))))
+
+(def sql:upsert-comment-thread-status
+  "insert into comment_thread_status (thread_id, profile_id)
+   values (?, ?)
+       on conflict (thread_id, profile_id)
+       do update set modified_at = clock_timestamp()
+   returning modified_at;")
+
+(defn upsert-comment-thread-status!
+  [conn profile-id thread-id]
+  (db/exec-one! conn [sql:upsert-comment-thread-status thread-id profile-id]))
+
+
+;; --- COMMAND: Update Comment Thread
+
+(s/def ::is-resolved ::us/boolean)
+(s/def ::update-comment-thread
+  (s/keys :req-un [::profile-id ::id ::is-resolved]
+          :opt-un [::share-id]))
+
+(sv/defmethod ::update-comment-thread
+  {::doc/added "1.15"}
+  [{:keys [pool] :as cfg} {:keys [profile-id id is-resolved share-id] :as params}]
+  (db/with-atomic [conn pool]
+    (let [thread (db/get-by-id conn :comment-thread id {:for-update true})]
+      (when-not thread
+        (ex/raise :type :not-found))
+
+      (files/check-comment-permissions! conn profile-id (:file-id thread) share-id)
+
+      (db/update! conn :comment-thread
+                  {:is-resolved is-resolved}
+                  {:id id})
+      nil)))
+
+
+;; --- COMMAND: Add Comment
+
+(declare create-comment)
+
+(s/def ::create-comment
+  (s/keys :req-un [::profile-id ::thread-id ::content]
+          :opt-un [::share-id]))
+
+(sv/defmethod ::create-comment
+  {::doc/added "1.15"}
+  [{:keys [pool] :as cfg} params]
+  (db/with-atomic [conn pool]
+    (create-comment conn params)))
+
+(defn create-comment
+  [conn {:keys [profile-id thread-id content share-id] :as params}]
+  (let [thread (-> (db/get-by-id conn :comment-thread thread-id {:for-update true})
+                   (decode-row))
+        pname  (retrieve-page-name conn thread)]
+
+    ;; Standard Checks
+    (when-not thread (ex/raise :type :not-found))
+
+    ;; Permission Checks
+    (files/check-comment-permissions! conn profile-id (:file-id thread) share-id)
+
+    ;; Update the page-name cachedattribute on comment thread table.
+    (when (not= pname (:page-name thread))
+      (db/update! conn :comment-thread
+                  {:page-name pname}
+                  {:id thread-id}))
+
+    ;; NOTE: is important that all timestamptz related fields are
+    ;; created or updated on the database level for avoid clock
+    ;; inconsistencies (some user sees something read that is not
+    ;; read, etc...)
+    (let [ppants  (:participants thread #{})
+          comment (db/insert! conn :comment
+                              {:thread-id thread-id
+                               :owner-id profile-id
+                               :content content})]
+
+      ;; NOTE: this is done in SQL instead of using db/update!
+      ;; helper because currently the helper does not allow pass raw
+      ;; function call parameters to the underlying prepared
+      ;; statement; in a future when we fix/improve it, this can be
+      ;; changed to use the helper.
+
+      ;; Update thread modified-at attribute and assoc the current
+      ;; profile to the participant set.
+      (let [ppants (conj ppants profile-id)
+            sql    "update comment_thread
+                         set modified_at = clock_timestamp(),
+                             participants = ?
+                       where id = ?"]
+        (db/exec-one! conn [sql (db/tjson ppants) thread-id]))
+
+      ;; Update the current profile status in relation to the
+      ;; current thread.
+      (upsert-comment-thread-status! conn profile-id thread-id)
+
+      ;; Return the created comment object.
+      comment)))
+
+;; --- COMMAND: Update Comment
+
+(declare update-comment)
+
+(s/def ::update-comment
+  (s/keys :req-un [::profile-id ::id ::content]
+          :opt-un [::share-id]))
+
+(sv/defmethod ::update-comment
+  {::doc/added "1.15"}
+  [{:keys [pool] :as cfg} params]
+  (db/with-atomic [conn pool]
+    (update-comment conn params)))
+
+(defn update-comment
+  [conn {:keys [profile-id id content share-id] :as params}]
+  (let [comment (db/get-by-id conn :comment id {:for-update true})
+        _       (when-not comment (ex/raise :type :not-found))
+        thread  (db/get-by-id conn :comment-thread (:thread-id comment) {:for-update true})
+        _       (when-not thread (ex/raise :type :not-found))
+        pname   (retrieve-page-name conn thread)]
+
+    (files/check-comment-permissions! conn profile-id (:file-id thread) share-id)
+
+    ;; Don't allow edit comments to not owners
+    (when-not (= (:owner-id thread) profile-id)
+      (ex/raise :type :validation
+                :code :not-allowed))
+
+    (db/update! conn :comment
+                {:content content
+                 :modified-at (dt/now)}
+                {:id (:id comment)})
+
+    (db/update! conn :comment-thread
+                {:modified-at (dt/now)
+                 :page-name pname}
+                {:id (:id thread)})
+    nil))
+
+
+;; --- COMMAND: Delete Comment Thread
+
+(s/def ::delete-comment-thread
+  (s/keys :req-un [::profile-id ::id]))
+
+(sv/defmethod ::delete-comment-thread
+  {::doc/added "1.15"}
+  [{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
+  (db/with-atomic [conn pool]
+    (let [thread (db/get-by-id conn :comment-thread id {:for-update true})]
+      (when-not (= (:owner-id thread) profile-id)
+        (ex/raise :type :validation
+                  :code :not-allowed))
+      (db/delete! conn :comment-thread {:id id})
+      nil)))
+
+
+;; --- COMMAND: Delete comment
+
+(s/def ::delete-comment
+  (s/keys :req-un [::profile-id ::id]))
+
+(sv/defmethod ::delete-comment
+  {::doc/added "1.15"}
+  [{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
+  (db/with-atomic [conn pool]
+    (let [comment (db/get-by-id conn :comment id {:for-update true})]
+      (when-not (= (:owner-id comment) profile-id)
+        (ex/raise :type :validation
+                  :code :not-allowed))
+
+      (db/delete! conn :comment {:id id}))))
+
+;; --- COMMAND: Update comment thread position
+
+(s/def ::update-comment-thread-position
+  (s/keys :req-un [::profile-id ::id ::position ::frame-id]
+          :opt-un [::share-id]))
+
+(sv/defmethod ::update-comment-thread-position
+  {::doc/added "1.15"}
+  [{:keys [pool] :as cfg} {:keys [profile-id id position frame-id share-id] :as params}]
+  (db/with-atomic [conn pool]
+    (let [thread (db/get-by-id conn :comment-thread id {:for-update true})]
+      (files/check-comment-permissions! conn profile-id (:file-id thread) share-id)
+      (db/update! conn :comment-thread
+                  {:modified-at (dt/now)
+                   :position (db/pgpoint position)
+                   :frame-id frame-id}
+                  {:id (:id thread)})
+      nil)))
+
+;; --- COMMAND: Update comment frame
+
+(s/def ::update-comment-thread-frame
+  (s/keys :req-un [::profile-id ::id ::frame-id]
+          :opt-un [::share-id]))
+
+(sv/defmethod ::update-comment-thread-frame
+  {::doc/added "1.15"}
+  [{:keys [pool] :as cfg} {:keys [profile-id id frame-id share-id] :as params}]
+  (db/with-atomic [conn pool]
+    (let [thread (db/get-by-id conn :comment-thread id {:for-update true})]
+      (files/check-comment-permissions! conn profile-id (:file-id thread) share-id)
+      (db/update! conn :comment-thread
+                  {:modified-at (dt/now)
+                   :frame-id frame-id}
+                  {:id (:id thread)})
+      nil)))
+

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

@@ -4,7 +4,7 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.rpc.mutations.demo
+(ns app.rpc.commands.demo
   "A demo specific mutations."
   (:require
    [app.common.exceptions :as ex]
@@ -12,7 +12,8 @@
    [app.config :as cf]
    [app.db :as db]
    [app.loggers.audit :as audit]
-   [app.rpc.mutations.profile :as profile]
+   [app.rpc.commands.auth :as cmd.auth]
+   [app.rpc.doc :as-alias doc]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [buddy.core.codecs :as bc]
@@ -21,7 +22,13 @@
 
 (s/def ::create-demo-profile any?)
 
-(sv/defmethod ::create-demo-profile {:auth false}
+(sv/defmethod ::create-demo-profile
+  "A command that is responsible of creating a demo purpose
+  profile. It only works if the `demo-users` flag is inabled in the
+  configuration."
+  {:auth false
+   ::doc/added "1.15"
+   ::doc/changes ["1.15" "This methos is migrated from mutations to commands."]}
   [{:keys [pool] :as cfg} _]
   (let [id       (uuid/next)
         sem      (System/currentTimeMillis)
@@ -45,8 +52,8 @@
                 :hint "Demo users are disabled by config."))
 
     (db/with-atomic [conn pool]
-      (->> (#'profile/create-profile conn params)
-           (#'profile/create-profile-relations conn))
+      (->> (cmd.auth/create-profile conn params)
+           (cmd.auth/create-profile-relations conn))
 
       (with-meta {:email email
                   :password password}

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

@@ -0,0 +1,50 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.rpc.commands.files
+  (:require
+   [app.common.spec :as us]
+   [app.db :as db]
+   [app.rpc.doc :as-alias doc]
+   [app.rpc.queries.files :as files]
+   [app.util.services :as sv]
+   [clojure.spec.alpha :as s]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; QUERY COMMANDS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; --- Query: File Libraries used by a File
+
+(declare retrieve-has-file-libraries)
+
+(s/def ::file-id ::us/uuid)
+(s/def ::profile-id ::us/uuid)
+
+(s/def ::has-file-libraries
+  (s/keys :req-un [::profile-id ::file-id]))
+
+(sv/defmethod ::has-file-libraries
+  "Checks if the file has libraries. Returns a boolean"
+  {::doc/added "1.15.1"}
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
+  (with-open [conn (db/open pool)]
+    (files/check-read-permissions! pool profile-id file-id)
+    (retrieve-has-file-libraries conn params)))
+
+(def ^:private sql:has-file-libraries
+  "SELECT COUNT(*) > 0 AS has_libraries
+     FROM file_library_rel AS flr
+     JOIN file AS fl ON (flr.library_file_id = fl.id)
+    WHERE flr.file_id = ?::uuid
+      AND (fl.deleted_at IS NULL OR
+           fl.deleted_at > now())")
+
+(defn- retrieve-has-file-libraries
+  [conn {:keys [file-id]}]
+  (let [row (db/exec-one! conn [sql:has-file-libraries file-id])]
+    (:has-libraries row)))
+

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

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

backend/src/app/rpc/doc.clj

@@ -0,0 +1,77 @@
+;; 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.doc
+  "API autogenerated documentation."
+  (:require
+   [app.common.data :as d]
+   [app.config :as cf]
+   [app.rpc :as-alias rpc]
+   [app.util.services :as sv]
+   [app.util.template :as tmpl]
+   [clojure.java.io :as io]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [integrant.core :as ig]
+   [pretty-spec.core :as ps]
+   [yetti.response :as yrs]))
+
+(defn- get-spec-str
+  [k]
+  (with-out-str
+    (ps/pprint (s/form k)
+               {:ns-aliases {"clojure.spec.alpha" "s"
+                             "clojure.core.specs.alpha" "score"
+                             "clojure.core" nil}})))
+
+(defn- prepare-context
+  [methods]
+  (letfn [(gen-doc [type [name f]]
+            (let [mdata (meta f)]
+              {:type (d/name type)
+               :name (d/name name)
+               :module (-> (:ns mdata) (str/split ".") last)
+               :auth (:auth mdata true)
+               :docs (::sv/docstring mdata)
+               :deprecated (::deprecated mdata)
+               :added (::added mdata)
+               :changes (some->> (::changes mdata) (partition-all 2) (map vec))
+               :spec (get-spec-str (::sv/spec mdata))}))]
+
+    {:version (:main cf/version)
+     :command-methods
+     (->> (:commands methods)
+          (map (partial gen-doc :command))
+          (sort-by (juxt :module :name)))
+
+     :query-methods
+     (->> (:queries methods)
+          (map (partial gen-doc :query))
+          (sort-by (juxt :module :name)))
+     :mutation-methods
+     (->> (:mutations methods)
+          (map (partial gen-doc :query))
+          (sort-by (juxt :module :name)))}))
+
+(defn- handler
+  [methods]
+  (if (contains? cf/flags :backend-api-doc)
+    (let [context (prepare-context methods)]
+      (fn [_ respond _]
+        (respond (yrs/response 200 (-> (io/resource "api-doc.tmpl")
+                                       (tmpl/render context))))))
+    (fn [_ respond _]
+      (respond (yrs/response 404)))))
+
+
+(defmethod ig/pre-init-spec ::routes [_]
+  (s/keys :req-un [::rpc/methods]))
+
+(defmethod ig/init-key ::routes
+  [_ {:keys [methods] :as cfg}]
+  ["/_doc" {:handler (handler methods)
+            :allowed-methods #{:get}}])
+

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

@@ -9,130 +9,59 @@
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.db :as db]
-   [app.rpc.queries.comments :as comments]
+   [app.rpc.commands.comments :as cmd.comments]
+   [app.rpc.doc :as-alias doc]
    [app.rpc.queries.files :as files]
-   [app.util.blob :as blob]
-   [app.util.retry :as retry]
+   [app.rpc.retry :as retry]
    [app.util.services :as sv]
-   [app.util.time :as dt]
    [clojure.spec.alpha :as s]))
 
 ;; --- Mutation: Create Comment Thread
 
-(declare upsert-comment-thread-status!)
-(declare create-comment-thread)
-(declare retrieve-page-name)
-
-(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 ::content ::us/string)
-
-(s/def ::create-comment-thread
-  (s/keys :req-un [::profile-id ::file-id ::position ::content ::page-id]))
+(s/def ::create-comment-thread ::cmd.comments/create-comment-thread)
 
 (sv/defmethod ::create-comment-thread
-  {::retry/enabled true
-   ::retry/max-retries 3
-   ::retry/matches retry/conflict-db-insert?}
-  [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
+  {::retry/max-retries 3
+   ::retry/matches retry/conflict-db-insert?
+   ::doc/added "1.0"
+   ::doc/deprecated "1.15"}
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id share-id] :as params}]
   (db/with-atomic [conn pool]
-    (files/check-read-permissions! conn profile-id file-id)
-    (create-comment-thread conn params)))
-
-(defn- retrieve-next-seqn
-  [conn file-id]
-  (let [sql "select (f.comment_thread_seqn + 1) as next_seqn from file as f where f.id = ?"
-        res (db/exec-one! conn [sql file-id])]
-    (:next-seqn res)))
-
-(defn- create-comment-thread
-  [conn {:keys [profile-id file-id page-id position content] :as params}]
-  (let [seqn    (retrieve-next-seqn conn file-id)
-        now     (dt/now)
-        pname   (retrieve-page-name conn params)
-        thread  (db/insert! conn :comment-thread
-                           {:file-id file-id
-                            :owner-id profile-id
-                            :participants (db/tjson #{profile-id})
-                            :page-name pname
-                            :page-id page-id
-                            :created-at now
-                            :modified-at now
-                            :seqn seqn
-                            :position (db/pgpoint position)})]
-
-
-    ;; Create a comment entry
-    (db/insert! conn :comment
-                {:thread-id (:id thread)
-                 :owner-id profile-id
-                 :created-at now
-                 :modified-at now
-                 :content content})
-
-    ;; Make the current thread as read.
-    (upsert-comment-thread-status! conn profile-id (:id thread))
-
-    ;; Optimistic update of current seq number on file.
-    (db/update! conn :file
-                {:comment-thread-seqn seqn}
-                {:id file-id})
-
-    (select-keys thread [:id :file-id :page-id])))
-
-(defn- retrieve-page-name
-  [conn {:keys [file-id page-id]}]
-  (let [{:keys [data]} (db/get-by-id conn :file file-id)
-        data           (blob/decode data)]
-    (get-in data [:pages-index page-id :name])))
-
+    (files/check-comment-permissions! conn profile-id file-id share-id)
+    (cmd.comments/create-comment-thread conn params)))
 
 ;; --- Mutation: Update Comment Thread Status
 
 (s/def ::id ::us/uuid)
+(s/def ::share-id (s/nilable ::us/uuid))
 
-(s/def ::update-comment-thread-status
-  (s/keys :req-un [::profile-id ::id]))
+(s/def ::update-comment-thread-status ::cmd.comments/update-comment-thread-status)
 
 (sv/defmethod ::update-comment-thread-status
-  [{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
+  {::doc/added "1.0"
+   ::doc/deprecated "1.15"}
+  [{:keys [pool] :as cfg} {:keys [profile-id id share-id] :as params}]
   (db/with-atomic [conn pool]
     (let [cthr (db/get-by-id conn :comment-thread id {:for-update true})]
-      (when-not cthr
-        (ex/raise :type :not-found))
-
-      (files/check-read-permissions! conn profile-id (:file-id cthr))
-      (upsert-comment-thread-status! conn profile-id (:id cthr)))))
-
-(def sql:upsert-comment-thread-status
-  "insert into comment_thread_status (thread_id, profile_id)
-   values (?, ?)
-       on conflict (thread_id, profile_id)
-       do update set modified_at = clock_timestamp()
-   returning modified_at;")
-
-(defn- upsert-comment-thread-status!
-  [conn profile-id thread-id]
-  (db/exec-one! conn [sql:upsert-comment-thread-status thread-id profile-id]))
+      (when-not cthr (ex/raise :type :not-found))
+      (files/check-comment-permissions! conn profile-id (:file-id cthr) share-id)
+      (cmd.comments/upsert-comment-thread-status! conn profile-id (:id cthr)))))
 
 
 ;; --- Mutation: Update Comment Thread
 
-(s/def ::is-resolved ::us/boolean)
-(s/def ::update-comment-thread
-  (s/keys :req-un [::profile-id ::id ::is-resolved]))
+(s/def ::update-comment-thread ::cmd.comments/update-comment-thread)
 
 (sv/defmethod ::update-comment-thread
-  [{:keys [pool] :as cfg} {:keys [profile-id id is-resolved] :as params}]
+  {::doc/added "1.0"
+   ::doc/deprecated "1.15"}
+  [{:keys [pool] :as cfg} {:keys [profile-id id is-resolved share-id] :as params}]
   (db/with-atomic [conn pool]
     (let [thread (db/get-by-id conn :comment-thread id {:for-update true})]
       (when-not thread
         (ex/raise :type :not-found))
 
-      (files/check-read-permissions! conn profile-id (:file-id thread))
-
+      (files/check-comment-permissions! conn profile-id (:file-id thread) share-id)
       (db/update! conn :comment-thread
                   {:is-resolved is-resolved}
                   {:id id})
@@ -141,121 +70,54 @@
 
 ;; --- Mutation: Add Comment
 
-(s/def ::add-comment
-  (s/keys :req-un [::profile-id ::thread-id ::content]))
+(s/def ::add-comment ::cmd.comments/create-comment)
 
 (sv/defmethod ::add-comment
-  [{:keys [pool] :as cfg} {:keys [profile-id thread-id content] :as params}]
+  {::doc/added "1.0"
+   ::doc/deprecated "1.15"}
+  [{:keys [pool] :as cfg} params]
   (db/with-atomic [conn pool]
-    (let [thread (-> (db/get-by-id conn :comment-thread thread-id {:for-update true})
-                     (comments/decode-row))
-          pname  (retrieve-page-name conn thread)]
-
-      ;; Standard Checks
-      (when-not thread (ex/raise :type :not-found))
-
-      ;; Permission Checks
-      (files/check-read-permissions! conn profile-id (:file-id thread))
-
-      ;; Update the page-name cachedattribute on comment thread table.
-      (when (not= pname (:page-name thread))
-        (db/update! conn :comment-thread
-                    {:page-name pname}
-                    {:id thread-id}))
-
-      ;; NOTE: is important that all timestamptz related fields are
-      ;; created or updated on the database level for avoid clock
-      ;; inconsistencies (some user sees something read that is not
-      ;; read, etc...)
-      (let [ppants  (:participants thread #{})
-            comment (db/insert! conn :comment
-                                {:thread-id thread-id
-                                 :owner-id profile-id
-                                 :content content})]
-
-        ;; NOTE: this is done in SQL instead of using db/update!
-        ;; helper because currently the helper does not allow pass raw
-        ;; function call parameters to the underlying prepared
-        ;; statement; in a future when we fix/improve it, this can be
-        ;; changed to use the helper.
-
-        ;; Update thread modified-at attribute and assoc the current
-        ;; profile to the participant set.
-        (let [ppants (conj ppants profile-id)
-              sql    "update comment_thread
-                         set modified_at = clock_timestamp(),
-                             participants = ?
-                       where id = ?"]
-          (db/exec-one! conn [sql (db/tjson ppants) thread-id]))
-
-        ;; Update the current profile status in relation to the
-        ;; current thread.
-        (upsert-comment-thread-status! conn profile-id thread-id)
-
-        ;; Return the created comment object.
-        comment))))
+    (cmd.comments/create-comment conn params)))
 
 
 ;; --- Mutation: Update Comment
 
-(s/def ::update-comment
-  (s/keys :req-un [::profile-id ::id ::content]))
+(s/def ::update-comment ::cmd.comments/update-comment)
 
 (sv/defmethod ::update-comment
-  [{:keys [pool] :as cfg} {:keys [profile-id id content] :as params}]
+  {::doc/added "1.0"
+   ::doc/deprecated "1.15"}
+  [{:keys [pool] :as cfg} params]
   (db/with-atomic [conn pool]
-    (let [comment (db/get-by-id conn :comment id {:for-update true})
-          _       (when-not comment (ex/raise :type :not-found))
-          thread  (db/get-by-id conn :comment-thread (:thread-id comment) {:for-update true})
-          _       (when-not thread (ex/raise :type :not-found))
-          pname   (retrieve-page-name conn thread)]
-
-      (files/check-read-permissions! conn profile-id (:file-id thread))
-
-      ;; Don't allow edit comments to not owners
-      (when-not (= (:owner-id thread) profile-id)
-        (ex/raise :type :validation
-                  :code :not-allowed))
-
-      (db/update! conn :comment
-                  {:content content
-                   :modified-at (dt/now)}
-                  {:id (:id comment)})
-
-      (db/update! conn :comment-thread
-                  {:modified-at (dt/now)
-                   :page-name pname}
-                  {:id (:id thread)})
-      nil)))
+    (cmd.comments/update-comment conn params)))
 
 
 ;; --- Mutation: Delete Comment Thread
 
-(s/def ::delete-comment-thread
-  (s/keys :req-un [::profile-id ::id]))
+(s/def ::delete-comment-thread ::cmd.comments/delete-comment-thread)
 
 (sv/defmethod ::delete-comment-thread
+  {::doc/added "1.0"
+   ::doc/deprecated "1.15"}
   [{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
   (db/with-atomic [conn pool]
     (let [thread (db/get-by-id conn :comment-thread id {:for-update true})]
       (when-not (= (:owner-id thread) profile-id)
-        (ex/raise :type :validation
-                  :code :not-allowed))
+        (ex/raise :type :validation :code :not-allowed))
       (db/delete! conn :comment-thread {:id id})
       nil)))
 
 
 ;; --- Mutation: Delete comment
 
-(s/def ::delete-comment
-  (s/keys :req-un [::profile-id ::id]))
+(s/def ::delete-comment ::cmd.comments/delete-comment)
 
 (sv/defmethod ::delete-comment
+  {::doc/added "1.0"
+   ::doc/deprecated "1.15"}
   [{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
   (db/with-atomic [conn pool]
     (let [comment (db/get-by-id conn :comment id {:for-update true})]
       (when-not (= (:owner-id comment) profile-id)
-        (ex/raise :type :validation
-                  :code :not-allowed))
-
+        (ex/raise :type :validation :code :not-allowed))
       (db/delete! conn :comment {:id id}))))

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

@@ -6,6 +6,7 @@
 
 (ns app.rpc.mutations.files
   (:require
+   [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.pages :as cp]
    [app.common.pages.migrations :as pmg]
@@ -13,20 +14,26 @@
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
+   [app.loggers.audit :as audit]
    [app.metrics :as mtx]
    [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)
+(declare retrieve-team-id)
 
 ;; --- 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)
@@ -43,8 +50,11 @@
 (sv/defmethod ::create-file
   [{:keys [pool] :as cfg} {:keys [profile-id project-id] :as params}]
   (db/with-atomic [conn pool]
-    (proj/check-edition-permissions! conn profile-id project-id)
-    (create-file conn params)))
+    (let [team-id (retrieve-team-id conn project-id)]
+      (proj/check-edition-permissions! conn profile-id project-id)
+      (with-meta
+        (create-file conn params)
+        {::audit/props {:team-id team-id}}))))
 
 (defn create-file-role
   [conn {:keys [file-id profile-id role]}]
@@ -54,19 +64,23 @@
          (db/insert! conn :file-profile-rel))))
 
 (defn create-file
-  [conn {:keys [id name project-id is-shared data deleted-at]
-         :or {is-shared false
-              deleted-at nil}
+  [conn {:keys [id name project-id is-shared data revn
+                modified-at deleted-at ignore-sync-until]
+         :or {is-shared false revn 0}
          :as params}]
   (let [id   (or id (:id data) (uuid/next))
         data (or data (cp/make-file-data id))
         file (db/insert! conn :file
-                         {:id id
-                          :project-id project-id
-                          :name name
-                          :is-shared is-shared
-                          :data (blob/encode data)
-                          :deleted-at deleted-at})]
+                         (d/without-nils
+                          {:id id
+                           :project-id project-id
+                           :name name
+                           :revn revn
+                           :is-shared is-shared
+                           :data (blob/encode data)
+                           :ignore-sync-until ignore-sync-until
+                           :modified-at modified-at
+                           :deleted-at deleted-at}))]
 
     (->> (assoc params :file-id id :role :owner)
          (create-file-role conn))
@@ -123,7 +137,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
@@ -240,7 +253,6 @@
 
 (declare insert-change)
 (declare retrieve-lagged-changes)
-(declare retrieve-team-id)
 (declare send-notifications)
 (declare update-file)
 
@@ -270,13 +282,18 @@
          (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)
-    (let [{:keys [id] :as file} (db/get-by-id conn :file id {:for-key-share true})]
+    (let [{:keys [id] :as file} (db/get-by-id conn :file id {:for-key-share true})
+          team-id (retrieve-team-id conn (:project-id file))]
       (files/check-edition-permissions! conn profile-id id)
-      (update-file (assoc cfg :conn  conn)
-                   (assoc params :file file)))))
+      (with-meta
+        (update-file (assoc cfg :conn  conn)
+                     (assoc params :file file))
+        {::audit/props {:project-id (:project-id file)
+                        :team-id team-id}}))))
 
 (defn- take-snapshot?
   "Defines the rule when file `data` snapshot should be saved."
@@ -291,8 +308,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 +323,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 +367,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 +399,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 +487,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,18 +6,22 @@
 
 (ns app.rpc.mutations.fonts
   (:require
+   [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
    [app.config :as cf]
    [app.db :as db]
    [app.media :as media]
+   [app.rpc.doc :as-alias doc]
    [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 +35,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 +44,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 [resource (get data mtype)]
+              (p/let [hash    (calculate-hash resource)
+                      content (-> (sto/content resource)
+                                  (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
 
@@ -125,6 +152,7 @@
   (s/keys :req-un [::profile-id ::team-id ::id]))
 
 (sv/defmethod ::delete-font-variant
+  {::doc/added "1.3"}
   [{:keys [pool] :as cfg} {:keys [id team-id profile-id] :as params}]
   (db/with-atomic [conn pool]
     (teams/check-edition-permissions! conn profile-id team-id)

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

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

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

@@ -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,18 @@
    [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.storage.tmp :as tmp]
+   [app.util.bytes :as bs]
    [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]))
+
+(def default-max-file-size (* 1024 1024 10)) ; 10 MiB
 
 (def thumbnail-options
   {:width 100
@@ -39,9 +45,7 @@
 (declare create-file-media-object)
 (declare select-file)
 
-(s/def ::content-type ::media/image-content-type)
-(s/def ::content (s/and ::media/upload (s/keys :req-un [::content-type])))
-
+(s/def ::content ::media/upload)
 (s/def ::is-local ::us/boolean)
 
 (s/def ::upload-file-media-object
@@ -50,12 +54,21 @@
 
 (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)))))
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id content] :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))
+    (media/validate-media-type! content)
+
+    (when (> (:size content) (cf/get :media-max-file-size default-max-file-size))
+      (ex/raise :type :restriction
+                :code :media-max-file-size-reached
+                :hint (str/ffmt "the uploaded file size % is greater than the maximum %"
+                                (:size content)
+                                default-max-file-size)))
+
+    (create-file-media-object cfg params)))
 
 (defn- big-enough-for-thumbnail?
   "Checks if the provided image info is big enough for
@@ -68,30 +81,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 +91,154 @@
        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}]
+  (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})))
 
-        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})))
+          ;; 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)))
 
-        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 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))))
 
-        thumb        (when thumb
-                       (sto/put-object storage {:content (sto/content (:data thumb) (:size thumb))
-                                                :content-type (:mtype thumb)}))]
+          (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"}))))
 
-    (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-image [info]
+            (p/let [data    (:path info)
+                    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)))
 
+(defn- create-file-media-object-from-url
+  [{:keys [http-client] :as cfg} {:keys [url name] :as params}]
+  (letfn [(parse-and-validate-size [headers]
+            (let [size     (some-> (get headers "content-length") d/parse-integer)
+                  mtype    (get headers "content-type")
+                  format   (cm/mtype->format mtype)
+                  max-size (cf/get :media-max-file-size default-max-file-size)]
+
+              (when-not size
+                (ex/raise :type :validation
+                          :code :unknown-size
+                          :hint "seems like the url points to resource with unknown size"))
+
+              (when (> size max-size)
+                (ex/raise :type :validation
+                          :code :file-too-large
+                          :hint (str/ffmt "the file size % is greater than the maximum %"
+                                          size
+                                          default-max-file-size)))
+
+              (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}))
+
+          (download-media [uri]
+            (-> (http-client {:method :get :uri uri} {:response-type :input-stream})
+                (p/then process-response)))
+
+          (process-response [{:keys [body headers] :as response}]
+            (let [{:keys [size mtype]} (parse-and-validate-size headers)
+                  path                 (tmp/tempfile :prefix "penpot.media.download.")
+                  written              (bs/write-to-file! body path :size size)]
+
+              (when (not= written size)
+                (ex/raise :type :internal
+                          :code :mismatch-write-size
+                          :hint "unexpected state: unable to write to file"))
+
+              {:filename "tempfile"
+               :size size
+               :path path
+               :mtype mtype}))]
+
+    (p/let [content (download-media url)]
+      (->> (merge params {:content content :name (or name (:filename content))})
+           (create-file-media-object cfg)))))
 
 ;; --- Clone File Media object (Upload and create from url)
 
@@ -171,7 +252,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 +269,6 @@
                  :height (:height mobj)
                  :mtype  (:mtype mobj)})))
 
-
 ;; --- HELPERS
 
 (def ^:private

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

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

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

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

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-valid-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 "168h") ;; 7 days
+        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,18 +441,18 @@
                 :token itoken
                 :extra-data ptoken})))
 
-
 ;; --- Mutation: Create Team & Invite Members
 
-(s/def ::emails ::us/set-of-emails)
+(s/def ::emails ::us/set-of-valid-emails)
 (s/def ::create-team-and-invite-members
   (s/and ::create-team (s/keys :req-un [::emails ::role])))
 
 (sv/defmethod ::create-team-and-invite-members
   [{:keys [pool] :as cfg} {:keys [profile-id emails role] :as params}]
   (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/permissions.clj

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

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

@@ -6,8 +6,9 @@
 
 (ns app.rpc.queries.comments
   (:require
-   [app.common.spec :as us]
    [app.db :as db]
+   [app.rpc.commands.comments :as cmd.comments]
+   [app.rpc.doc :as-alias doc]
    [app.rpc.queries.files :as files]
    [app.rpc.queries.teams :as teams]
    [app.util.services :as sv]
@@ -19,137 +20,63 @@
     (db/pgpoint? position) (assoc :position (db/decode-pgpoint position))
     (db/pgobject? participants) (assoc :participants (db/decode-transit-pgobject participants))))
 
-;; --- Query: Comment Threads
+;; --- QUERY: Comment Threads
 
-(declare retrieve-comment-threads)
-
-(s/def ::team-id ::us/uuid)
-(s/def ::file-id ::us/uuid)
-
-(s/def ::comment-threads
-  (s/and (s/keys :req-un [::profile-id]
-                 :opt-un [::file-id ::team-id])
-         #(or (:file-id %) (:team-id %))))
+(s/def ::comment-threads ::cmd.comments/get-comment-threads)
 
 (sv/defmethod ::comment-threads
-  [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
+  {::doc/added "1.0"
+   ::doc/deprecated "1.15"}
+  [{:keys [pool] :as cfg} params]
   (with-open [conn (db/open pool)]
-    (files/check-read-permissions! conn profile-id file-id)
-    (retrieve-comment-threads conn params)))
+    (cmd.comments/retrieve-comment-threads conn params)))
 
-(def sql:comment-threads
-  "select distinct on (ct.id)
-          ct.*,
-          f.name as file_name,
-          f.project_id as project_id,
-          first_value(c.content) over w as content,
-          (select count(1)
-             from comment as c
-            where c.thread_id = ct.id) as count_comments,
-          (select count(1)
-             from comment as c
-            where c.thread_id = ct.id
-              and c.created_at >= coalesce(cts.modified_at, ct.created_at)) as count_unread_comments
-     from comment_thread as ct
-    inner join comment as c on (c.thread_id = ct.id)
-    inner join file as f on (f.id = ct.file_id)
-     left join comment_thread_status as cts
-            on (cts.thread_id = ct.id and
-                cts.profile_id = ?)
-    where ct.file_id = ?
-   window w as (partition by c.thread_id order by c.created_at asc)")
+;; --- QUERY: Unread Comment Threads
 
-(defn- retrieve-comment-threads
-  [conn {:keys [profile-id file-id]}]
-  (files/check-read-permissions! conn profile-id file-id)
-  (->> (db/exec! conn [sql:comment-threads profile-id file-id])
-       (into [] (map decode-row))))
-
-
-;; --- Query: Unread Comment Threads
-
-(declare retrieve-unread-comment-threads)
-
-(s/def ::team-id ::us/uuid)
-(s/def ::unread-comment-threads
-  (s/keys :req-un [::profile-id ::team-id]))
+(s/def ::unread-comment-threads ::cmd.comments/get-unread-comment-threads)
 
 (sv/defmethod ::unread-comment-threads
+  {::doc/added "1.0"
+   ::doc/deprecated "1.15"}
   [{:keys [pool] :as cfg} {:keys [profile-id team-id] :as params}]
   (with-open [conn (db/open pool)]
     (teams/check-read-permissions! conn profile-id team-id)
-    (retrieve-unread-comment-threads conn params)))
+    (cmd.comments/retrieve-unread-comment-threads conn params)))
 
-(def sql:comment-threads-by-team
-  "select distinct on (ct.id)
-          ct.*,
-          f.name as file_name,
-          f.project_id as project_id,
-          first_value(c.content) over w as content,
-          (select count(1)
-             from comment as c
-            where c.thread_id = ct.id) as count_comments,
-          (select count(1)
-             from comment as c
-            where c.thread_id = ct.id
-              and c.created_at >= coalesce(cts.modified_at, ct.created_at)) as count_unread_comments
-     from comment_thread as ct
-    inner join comment as c on (c.thread_id = ct.id)
-    inner join file as f on (f.id = ct.file_id)
-    inner join project as p on (p.id = f.project_id)
-     left join comment_thread_status as cts
-            on (cts.thread_id = ct.id and
-                cts.profile_id = ?)
-    where p.team_id = ?
-   window w as (partition by c.thread_id order by c.created_at asc)")
+;; --- QUERY: Single Comment Thread
 
-(def sql:unread-comment-threads-by-team
-  (str "with threads as (" sql:comment-threads-by-team ")"
-       "select * from threads where count_unread_comments > 0"))
-
-(defn retrieve-unread-comment-threads
-  [conn {:keys [profile-id team-id]}]
-  (->> (db/exec! conn [sql:unread-comment-threads-by-team profile-id team-id])
-       (into [] (map decode-row))))
-
-
-;; --- Query: Single Comment Thread
-
-(s/def ::id ::us/uuid)
-(s/def ::comment-thread
-  (s/keys :req-un [::profile-id ::file-id ::id]))
+(s/def ::comment-thread ::cmd.comments/get-comment-thread)
 
 (sv/defmethod ::comment-thread
-  [{:keys [pool] :as cfg} {:keys [profile-id file-id id] :as params}]
+  {::doc/added "1.0"
+   ::doc/deprecated "1.15"}
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id share-id] :as params}]
   (with-open [conn (db/open pool)]
-    (files/check-read-permissions! conn profile-id file-id)
-    (let [sql (str "with threads as (" sql:comment-threads ")"
-                   "select * from threads where id = ?")]
-      (-> (db/exec-one! conn [sql profile-id file-id id])
-          (decode-row)))))
+    (files/check-comment-permissions! conn profile-id file-id share-id)
+    (cmd.comments/get-comment-thread conn params)))
 
-;; --- Query: Comments
+;; --- QUERY: Comments
 
-(declare retrieve-comments)
-
-(s/def ::file-id ::us/uuid)
-(s/def ::thread-id ::us/uuid)
-(s/def ::comments
-  (s/keys :req-un [::profile-id ::thread-id]))
+(s/def ::comments ::cmd.comments/get-comments)
 
 (sv/defmethod ::comments
-  [{:keys [pool] :as cfg} {:keys [profile-id thread-id] :as params}]
+  {::doc/added "1.0"
+   ::doc/deprecated "1.15"}
+  [{:keys [pool] :as cfg} {:keys [profile-id thread-id share-id] :as params}]
   (with-open [conn (db/open pool)]
     (let [thread (db/get-by-id conn :comment-thread thread-id)]
-      (files/check-read-permissions! conn profile-id (:file-id thread))
-      (retrieve-comments conn thread-id))))
+      (files/check-comment-permissions! conn profile-id (:file-id thread) share-id))
+    (cmd.comments/get-comments conn thread-id)))
 
-(def sql:comments
-  "select c.* from comment as c
-    where c.thread_id = ?
-    order by c.created_at asc")
 
-(defn- retrieve-comments
-  [conn thread-id]
-  (->> (db/exec! conn [sql:comments thread-id])
-       (into [] (map decode-row))))
+;; --- QUERY: Get file comments users
+
+(s/def ::file-comments-users ::cmd.comments/get-profiles-for-file-comments)
+
+(sv/defmethod ::file-comments-users
+  {::doc/deprecated "1.15"
+   ::doc/added "1.13"}
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id share-id]}]
+  (with-open [conn (db/open pool)]
+    (files/check-comment-permissions! conn profile-id file-id share-id)
+    (cmd.comments/get-file-comments-users conn file-id profile-id)))

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

@@ -7,25 +7,30 @@
 (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.geom.shapes :as gsh]
+   [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 +39,6 @@
 (s/def ::team-id ::us/uuid)
 (s/def ::search-term ::us/string)
 
-
 ;; --- Query: File Permissions
 
 (def ^:private sql:file-permissions
@@ -81,7 +85,8 @@
         :is-owner is-owner
         :is-admin (or is-owner is-admin)
         :can-edit (or is-owner is-admin can-edit)
-        :can-read true})))
+        :can-read true
+        :is-logged (some? profile-id)})))
   ([conn profile-id file-id share-id]
    (let [perms  (get-permissions conn profile-id file-id)
          ldata  (retrieve-share-link conn file-id share-id)]
@@ -94,7 +99,9 @@
        (some? perms) perms
        (some? ldata) {:type :share-link
                       :can-read true
-                      :flags (:flags ldata)}))))
+                      :is-logged (some? profile-id)
+                      :who-comment (:who-comment ldata)
+                      :who-inspect (:who-inspect ldata)}))))
 
 (def has-edit-permissions?
   (perms/make-edition-predicate-fn get-permissions))
@@ -102,12 +109,26 @@
 (def has-read-permissions?
   (perms/make-read-predicate-fn get-permissions))
 
+(def has-comment-permissions?
+  (perms/make-comment-predicate-fn get-permissions))
+
 (def check-edition-permissions!
   (perms/make-check-fn has-edit-permissions?))
 
 (def check-read-permissions!
   (perms/make-check-fn has-read-permissions?))
 
+;; A user has comment permissions if she has read permissions, or comment permissions
+(defn check-comment-permissions!
+  [conn profile-id file-id share-id]
+   (let [can-read (has-read-permissions? conn profile-id file-id)
+         can-comment  (has-comment-permissions? conn profile-id file-id share-id)
+         ]
+     (when-not (or can-read can-comment)
+       (ex/raise :type :not-found
+                 :code :object-not-found
+                 :hint "not found"))))
+
 ;; --- Query: Files search
 
 ;; TODO: this query need to a good refactor
@@ -185,21 +206,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 +237,153 @@
 (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 structure 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))
+
+                      children-ids
+                      (cph/get-children-ids objects frame-id)
+
+                      bounds
+                      (when (:show-content frame)
+                        (gsh/selection-rect (concat [frame] (->> children-ids (map (d/getf objects))))))
+
+                      frame
+                      (cond-> frame
+                        (some? bounds)
+                        (assoc :children-bounds bounds))]
+
+                  (if (:thumbnail frame)
+                    (recur (-> objects
+                               (assoc frame-id frame)
+                               (d/without-keys children-ids))
+                           (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 +439,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 +475,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/share_link.clj

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

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

@@ -9,31 +9,32 @@
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.db :as db]
+   [app.rpc.commands.comments :as comments]
    [app.rpc.queries.files :as files]
    [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 profile-id]
+  (p/let [file    (files/retrieve-file cfg file-id)
+          project (retrieve-project pool (:project-id file))
+          libs    (files/retrieve-file-libraries cfg false file-id)
+          users   (comments/get-file-comments-users pool file-id profile-id)
 
-        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,33 @@
 
 (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)
+          thumbs (files/retrieve-object-thumbnails cfg file-id)
+          bundle (p/-> (retrieve-bundle cfg file-id profile-id)
+                       (assoc :permissions perms)
+                       (assoc-in [:file :thumbnails] thumbs))]
 
-          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))
+
+