Merge branch 'staging' into main

Fixes many bugs related to the svgo removal and remove
unneded neesting of groups.

.github/ISSUE_TEMPLATE/bug_report.md

@@ -38,13 +38,13 @@ If applicable, add screenshots to help explain your problem.
 -   Version (e.g. 22)
 
 **Environment (please complete the following information):**
-Specify if using demo instance or self-hosted instance.
+Specify if using SAAS (https://design.penpot.app) or self-hosted instance.
 
 If self-hosted instance, add OS and runtime information to help explain your problem.
 
 -   OS Version: (e.g. Ubuntu 16.04)
 
-Also provide Docker commands or docker-compose file if possible.
+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)

.gitignore

@@ -15,6 +15,7 @@ node_modules
 /backend/target/
 /backend/resources/public/media
 /backend/resources/public/assets
+/backend/assets/
 /backend/dist/
 /backend/logs/
 /backend/-
@@ -26,7 +27,7 @@ node_modules
 /frontend/resources/public/*
 /exporter/target
 /exporter/.shadow-cljs
-/docker/images/bundle
+/docker/images/bundle*
 /.clj-kondo/.cache
 /bundle*
 /media

CHANGES.md

@@ -1,15 +1,136 @@
 # CHANGELOG #
 
-## Next
+## :rocket: Next
 
-### New features
+### :sparkles: New features
 
-### Bugs fixed
+### :bug: Bugs fixed
+
+### :arrow_up: Deps updates
+
+### :heart: Community contributions by (Thank you!)
+
+
+## 1.4.0-alpha
+
+### :sparkles: New features
+
+- Add blob-encoding v3 (uses ZSTD+transit) [#738](https://github.com/penpot/penpot/pull/738)
+- Add http caching layer on top of Query RPC.
+- Add layer opacity and blend mode to shapes [Taiga #937](https://tree.taiga.io/project/penpot/us/937)
+- Add more chinese translations [#726](https://github.com/penpot/penpot/pull/726)
+- Add native support for text-direction (RTL, LTR & auto).
+- Add several enhancements in shape selection [Taiga #1195](https://tree.taiga.io/project/penpot/us/1195)
+- Add thumbnail in memory caching mechanism.
+- Add turkish translation strings [#759](https://github.com/penpot/penpot/pull/759), [#794](https://github.com/penpot/penpot/pull/794)
+- Duplicate and move files and projects [Taiga #267](https://tree.taiga.io/project/penpot/us/267)
+- Hide viewer navbar on fullscreen [Taiga 1375](https://tree.taiga.io/project/penpot/us/1375)
+- Import SVG will create Penpot's shapes [Taiga #1006](https://tree.taiga.io/project/penpot/us/1066)
+- Improve french translations [#731](https://github.com/penpot/penpot/pull/731)
+- Reimplement workspace presence (remove database state).
+- Remember last visited team when you re-enter the application [Taiga #1376](https://tree.taiga.io/project/penpot/us/1376)
+- Rename artboard with double click on the title [Taiga #1392](https://tree.taiga.io/project/penpot/us/1392)
+- Replace Slate-Editor with DraftJS [Taiga #1346](https://tree.taiga.io/project/penpot/us/1346)
+- Set proper page title [Taiga #1377](https://tree.taiga.io/project/penpot/us/1377)
+
+
+### :bug: Bugs fixed
+
+- Disable buttons in view mode for users without permissions [Taiga #1328](https://tree.taiga.io/project/penpot/issue/1328)
+- Fix broken profile and profile options form.
+- Fix calculate size of some animated gifs [Taiga #1487](https://tree.taiga.io/project/penpot/issue/1487)
+- Fix error with the "Navigate to" button on prototypes [Taiga #1268](https://tree.taiga.io/project/penpot/issue/1268)
+- Fix issue when undo after changing the artboard of a shape [Taiga #1304](https://tree.taiga.io/project/penpot/issue/1304)
+- Fix issue with Alt key in distance measurement [#672](https://github.com/penpot/penpot/issues/672)
+- Fix issue with blending modes in masks [Taiga #1476](https://tree.taiga.io/project/penpot/issue/1476)
+- Fix issue with blocked shapes [Taiga #1480](https://tree.taiga.io/project/penpot/issue/1480)
+- Fix issue with comments styles on dashboard [Taiga #1405](https://tree.taiga.io/project/penpot/issue/1405)
+- Fix issue with default square grid [Taiga #1344](https://tree.taiga.io/project/penpot/issue/1344)
+- Fix issue with enter key shortcut [#775](https://github.com/penpot/penpot/issues/775)
+- Fix issue with enter to edit paths [Taiga #1481](https://tree.taiga.io/project/penpot/issue/1481)
+- Fix issue with mask and flip [#715](https://github.com/penpot/penpot/issues/715)
+- Fix issue with masks interactions outside bounds [#718](https://github.com/penpot/penpot/issues/718)
+- Fix issue with middle mouse button press moving the canvas when not moving mouse [#717](https://github.com/penpot/penpot/issues/717)
+- Fix issue with resolved comments [Taiga #1406](https://tree.taiga.io/project/penpot/issue/1406)
+- Fix issue with rotated blur [Taiga #1370](https://tree.taiga.io/project/penpot/issue/1370)
+- Fix issue with rotation degree input [#741](https://github.com/penpot/penpot/issues/741)
+- Fix issue with system shortcuts and application [#737](https://github.com/penpot/penpot/issues/737)
+- Fix issue with team management in dashboard [Taiga #1475](https://tree.taiga.io/project/penpot/issue/1475)
+- Fix issue with typographies panel cannot be collapsed [#707](https://github.com/penpot/penpot/issues/707)
+- Fix text selection in comments [#745](https://github.com/penpot/penpot/issues/745)
+- Update Work-Sans font [#744](https://github.com/penpot/penpot/issues/744)
+- Fix issue with recent files not showing [Taiga #1493](https://tree.taiga.io/project/penpot/issue/1493)
+- Fix issue when promoting to owner [Taiga #1494](https://tree.taiga.io/project/penpot/issue/1494)
+- Fix cannot click on blocked elements in viewer [Taiga #1430](https://tree.taiga.io/project/penpot/issue/1430)
+- Fix SVG not showing properties at code [Taiga #1437](https://tree.taiga.io/project/penpot/issue/1437)
+- Fix shadows when exporting groups [Taiga #1495](https://tree.taiga.io/project/penpot/issue/1495)
+- Fix drag-select when renaming layer text [Taiga #1307](https://tree.taiga.io/project/penpot/issue/1307)
+- Fix layout problem for editable selects [Taiga #1488](https://tree.taiga.io/project/penpot/issue/1488)
+- Fix artboard title wasn't move when resizing [Taiga #1479](https://tree.taiga.io/project/penpot/issue/1479)
+- Fix titles in viewer thumbnails too long [Taiga #1474](https://tree.taiga.io/project/penpot/issue/1474)
+- Fix when right click on a selected text shows artboard contextual menu [Taiga #1226](https://tree.taiga.io/project/penpot/issue/1226)
+
+
+### :arrow_up: Deps updates
+
+- Update backend to JDK16.
+- Update exporter nodejs to v14.16.0
+
+
+### :heart: Community contributions by (Thank you!)
+
+- iblueer [#726](https://github.com/penpot/penpot/pull/726)
+- gizembln [#759](https://github.com/penpot/penpot/pull/759)
+- girafic [#748](https://github.com/penpot/penpot/pull/748)
+- mbrksntrk [#794](https://github.com/penpot/penpot/pull/794)
+
+
+## 1.3.0-alpha
+
+### :sparkles: New features
+
+- Add emailcatcher and ldap test containers to devenv. [#506](https://github.com/penpot/penpot/pull/506)
+- Add major refactor of internal pubsub/redis code; improves scalability and performance [#640](https://github.com/penpot/penpot/pull/640)
+- Add more chinese transtions [#687](https://github.com/penpot/penpot/pull/687)
+- Add more presets for artboard [#654](https://github.com/penpot/penpot/pull/654)
+- Add optional loki integration [#645](https://github.com/penpot/penpot/pull/645)
+- Add proper http session lifecycle handling.
+- Allow to set border radius of each rect corner individually
+- Bounce & Complaint handling [#635](https://github.com/penpot/penpot/pull/635)
+- Disable groups interactions when holding "Ctrl" key (deep selection)
+- New action in context menu to "edit" some shapes (binded to key "Enter")
+
+
+### :bug: Bugs fixed
+
+- Add more improvements to french translation strings [#591](https://github.com/penpot/penpot/pull/591)
+- Add some missing database indexes (mainly improves performance on large databases on file-update rpc method, and some background tasks).
+- Disables filters in masking elements (issue with Firefox rendering)
+- Drawing tool will have priority over resize/rotate handlers [Taiga #1225](https://tree.taiga.io/project/penpot/issue/1225)
+- Fix broken bounding box on editing paths [Taiga #1254](https://tree.taiga.io/project/penpot/issue/1254)
+- Fix corner cases on invitation/signup flows.
+- Fix errors on onboarding file [Taiga #1287](https://tree.taiga.io/project/penpot/issue/1287)
+- Fix infinite recursion on logout.
+- Fix issues with frame selection [Taiga #1300](https://tree.taiga.io/project/penpot/issue/1300), [Taiga #1255](https://tree.taiga.io/project/penpot/issue/1255)
+- Fix local fonts error [#691](https://github.com/penpot/penpot/issues/691)
+- Fix issue width handoff code generation [Taiga #1204](https://tree.taiga.io/project/penpot/issue/1204)
+- Fix issue with indices refreshing on page changes [#646](https://github.com/penpot/penpot/issues/646)
+- Have language change notification written in the new language [Taiga #1205](https://tree.taiga.io/project/penpot/issue/1205)
+- Hide register screen when registration is disabled [#598](https://github.com/penpot/penpot/issues/598)
+- Properly handle errors on github, gitlab and ldap auth backends.
+- Properly mark profile auth backend (on first register/ auth with 3rd party auth provider).
+- Refactor LDAP auth backend.
+
+
+### :heart: Community contributions by (Thank you!)
+
+- girafic [#538](https://github.com/penpot/penpot/pull/654)
+- arkhi [#591](https://github.com/penpot/penpot/pull/591)
 
 
 ## 1.2.0-alpha
 
-### New features
+### :sparkles: New features
 
 - Add horizontal/vertical flip
 - Add images lock proportions by default [#541](https://github.com/penpot/penpot/discussions/541), [#609](https://github.com/penpot/penpot/issues/609)
@@ -22,27 +143,27 @@
 - Fix behavior of select all command when there are objects outside frames [Taiga #1209](https://tree.taiga.io/project/penpot/issue/1209)
 
 
-### Bugs fixed
+### :bug: Bugs fixed
 
 - Fix 404 when access shared link [#615](https://github.com/penpot/penpot/issues/615)
 - Fix 500 when requestion password reset
-- Fix Problems when transforming path shapes [Taiga #1170](https://tree.taiga.io/project/penpot/issue/1170)
+- Fix issue when transforming path shapes [Taiga #1170](https://tree.taiga.io/project/penpot/issue/1170)
 - Fix apply a color to a text selection from color palette was not working [Taiga #1189](https://tree.taiga.io/project/penpot/issue/1189)
 - Fix issues when moving shapes outside groups [Taiga #1138](https://tree.taiga.io/project/penpot/issue/1138)
 - Fix ldap function called on login click
 - Fix logo icon in viewer should go to dashboard [Taiga #1149](https://tree.taiga.io/project/penpot/issue/1149)
 - Fix ordering when restoring deleted shapes in sync [Taiga #1163](https://tree.taiga.io/project/penpot/issue/1163)
-- Fix problem when editing text immediately after creating [Taiga #1207](https://tree.taiga.io/project/penpot/issue/1207)
-- Fix problem when pasting URL's copied from the browser url bar [Taiga #1187](https://tree.taiga.io/project/penpot/issue/1187)
-- Fix problem with multiple selection and groups [Taiga #1128](https://tree.taiga.io/project/penpot/issue/1128)
-- Fix problem with red handler indicator on resize [Taiga #1188](https://tree.taiga.io/project/penpot/issue/1188)
+- Fix issue when editing text immediately after creating [Taiga #1207](https://tree.taiga.io/project/penpot/issue/1207)
+- Fix issue when pasting URL's copied from the browser url bar [Taiga #1187](https://tree.taiga.io/project/penpot/issue/1187)
+- Fix issue with multiple selection and groups [Taiga #1128](https://tree.taiga.io/project/penpot/issue/1128)
+- Fix issue with red handler indicator on resize [Taiga #1188](https://tree.taiga.io/project/penpot/issue/1188)
 - Fix show correct error when google auth is disabled [Taiga #1119](https://tree.taiga.io/project/penpot/issue/1119)
 - Fix text alignment in preview [#594](https://github.com/penpot/penpot/issues/594)
 - Fix unexpected exception when uploading image [Taiga #1120](https://tree.taiga.io/project/penpot/issue/1120)
 - Fix updates on collaborative editing not updating selection rectangles [Taiga #1127](https://tree.taiga.io/project/penpot/issue/1127)
 - Make the team deletion deferred (in the same way other objects)
 
-### Community contributions by (Thank you! :heart:)
+### :heart: Community contributions by (Thank you!)
 
 - abtinmo [#538](https://github.com/penpot/penpot/pull/538)
 - kdrag0n [#585](https://github.com/penpot/penpot/pull/585)

README.md

@@ -9,27 +9,14 @@
 
 # PENPOT #
 
-We’re excited to share that Uxbox is now Penpot! We’re changing the name, but keeping the same project essence. Stay in the loop for more news coming early 2021. Alpha release is close!
+Penpot is the first Open Source design and prototyping platform meant
+for cross-domain teams. Non dependent on operating systems, Penpot is
+web based and works with open web standards (SVG). For all and
+empowered by the community.
 
-![PENPOT](https://raw.githubusercontent.com/penpot/penpot/develop/docs/screenshot.png)
+![PENPOT](https://penpot.app/images/workspace-ui.jpg)
 
 
-## Introduction ##
-
-The open-source solution for design and prototyping. PENPOT is
-currently at an early development stage but we are working hard to
-bring you the beta version as soon as possible. Follow the project
-progress in Twitter or Github and stay tuned!
-
-
-## SVG based ##
-
-Penpot works with SVG, a standard format, for all your designs and
-prototypes . This means that all your stuff in Penpot is portable and
-editable in many other vector tools and easy to use on the web.
-
-[See SVG specification](https://www.w3.org/Graphics/SVG/)
-
 ## Contributing ##
 
 **Open to you!**
@@ -43,7 +30,7 @@ Please refer to the [Contributing Guide](./CONTRIBUTING.md)
 
 ## Documentation ##
 
-Please refer to [docs/ directory](./docs/).
+Please refer to the [help center](https://help.penpot.app).
 
 
 ## License ##

backend/deps.edn

@@ -3,24 +3,28 @@
   "clojars" {:url "https://clojars.org/repo"}
   "jcenter" {:url "https://jcenter.bintray.com/"}}
  :deps
- {org.clojure/clojure {:mvn/version "1.10.2"}
+ {org.clojure/clojure {:mvn/version "1.10.3"}
   org.clojure/clojurescript {:mvn/version "1.10.773"}
-  org.clojure/data.json {:mvn/version "1.0.0"}
+  org.clojure/data.json {:mvn/version "1.1.0"}
   org.clojure/core.async {:mvn/version "1.3.610"}
+  org.clojure/tools.cli {:mvn/version "1.0.206"}
 
   ;; Logging
   org.clojure/tools.logging {:mvn/version "1.1.0"}
-  org.apache.logging.log4j/log4j-api {:mvn/version "2.14.0"}
-  org.apache.logging.log4j/log4j-core {:mvn/version "2.14.0"}
-  org.apache.logging.log4j/log4j-web {:mvn/version "2.14.0"}
-  org.apache.logging.log4j/log4j-jul {:mvn/version "2.14.0"}
-  org.apache.logging.log4j/log4j-slf4j-impl {:mvn/version "2.14.0"}
+  org.apache.logging.log4j/log4j-api {:mvn/version "2.14.1"}
+  org.apache.logging.log4j/log4j-core {:mvn/version "2.14.1"}
+  org.apache.logging.log4j/log4j-web {:mvn/version "2.14.1"}
+  org.apache.logging.log4j/log4j-jul {:mvn/version "2.14.1"}
+  org.apache.logging.log4j/log4j-slf4j-impl {:mvn/version "2.14.1"}
   org.slf4j/slf4j-api {:mvn/version "1.7.30"}
+  org.zeromq/jeromq {:mvn/version "0.5.2"}
 
-  org.graalvm.js/js {:mvn/version "20.3.0"}
   com.taoensso/nippy {:mvn/version "3.1.1"}
-  com.github.luben/zstd-jni {:mvn/version "1.4.8-3"}
+  com.github.luben/zstd-jni {:mvn/version "1.4.9-1"}
 
+  ;; NOTE: don't upgrade to latest version, breaking change is
+  ;; introduced on 0.10.0 that suffixes counters with _total if they
+  ;; are not already has this suffix.
   io.prometheus/simpleclient {:mvn/version "0.9.0"}
   io.prometheus/simpleclient_hotspot {:mvn/version "0.9.0"}
   io.prometheus/simpleclient_jetty {:mvn/version "0.9.0"
@@ -29,21 +33,20 @@
   io.prometheus/simpleclient_httpserver {:mvn/version "0.9.0"}
 
   selmer/selmer {:mvn/version "1.12.33"}
-  expound/expound {:mvn/version "0.8.7"}
+  expound/expound {:mvn/version "0.8.9"}
   com.cognitect/transit-clj {:mvn/version "1.0.324"}
 
-  io.lettuce/lettuce-core {:mvn/version "5.2.2.RELEASE"}
-  java-http-clj/java-http-clj {:mvn/version "0.4.1"}
+  io.lettuce/lettuce-core {:mvn/version "6.0.2.RELEASE"}
+  java-http-clj/java-http-clj {:mvn/version "0.4.2"}
 
-  info.sunng/ring-jetty9-adapter {:mvn/version "0.14.2"}
-  seancorfield/next.jdbc {:mvn/version "1.1.613"}
-  metosin/reitit-ring {:mvn/version "0.5.11"}
+  info.sunng/ring-jetty9-adapter {:mvn/version "0.15.0"}
+  com.github.seancorfield/next.jdbc {:mvn/version "1.1.646"}
+  metosin/reitit-ring {:mvn/version "0.5.12"}
   metosin/jsonista {:mvn/version "0.3.1"}
 
-  org.postgresql/postgresql {:mvn/version "42.2.18"}
-  com.zaxxer/HikariCP {:mvn/version "3.4.5"}
+  org.postgresql/postgresql {:mvn/version "42.2.19"}
+  com.zaxxer/HikariCP {:mvn/version "4.0.3"}
 
-  funcool/log4j2-clojure {:mvn/version "2020.11.23-1"}
   funcool/datoteka {:mvn/version "1.2.0"}
   funcool/promesa {:mvn/version "6.0.0"}
   funcool/cuerdas {:mvn/version "2020.03.26-3"}
@@ -61,13 +64,12 @@
   org.im4java/im4java {:mvn/version "1.4.0"}
   org.lz4/lz4-java {:mvn/version "1.7.1"}
   commons-io/commons-io {:mvn/version "2.8.0"}
-  org.apache.commons/commons-pool2 {:mvn/version "2.9.0"}
   com.sun.mail/jakarta.mail {:mvn/version "2.0.0"}
 
-  puppetlabs/clj-ldap {:mvn/version"0.3.0"}
+  org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
   integrant/integrant {:mvn/version "0.8.0"}
 
-  software.amazon.awssdk/s3 {:mvn/version "2.15.73"}
+  software.amazon.awssdk/s3 {:mvn/version "2.16.19"}
 
   ;; exception printing
   io.aviso/pretty {:mvn/version "0.1.37"}
@@ -90,11 +92,11 @@
    :args {}}
 
   :tests
-  {:extra-deps {lambdaisland/kaocha {:mvn/version "1.0.732"}}
+  {:extra-deps {lambdaisland/kaocha {:mvn/version "1.0.829"}}
    :main-opts ["-m" "kaocha.runner"]}
 
   :outdated
-  {:extra-deps {antq/antq {:mvn/version "RELEASE"}}
+  {:extra-deps {com.github.liquidz/antq {:mvn/version "0.12.0"}}
    :main-opts ["-m" "antq.core"]}
 
   :jmx-remote

backend/dev/user.clj

@@ -9,20 +9,20 @@
 
 (ns user
   (:require
+   [app.common.exceptions :as ex]
    [app.config :as cfg]
    [app.main :as main]
+   [app.util.blob :as blob]
+   [app.util.json :as json]
    [app.util.time :as dt]
    [app.util.transit :as t]
-   [app.common.exceptions :as ex]
-   [taoensso.nippy :as nippy]
-   [clojure.data.json :as json]
    [clojure.java.io :as io]
-   [clojure.test :as test]
-   [clojure.pprint :refer [pprint]]
+   [clojure.pprint :refer [pprint print-table]]
    [clojure.repl :refer :all]
    [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]]
    [criterium.core :refer [quick-bench bench with-progress-reporting]]
@@ -91,3 +91,10 @@
   []
   (stop)
   (repl/refresh-all :after 'user/start))
+
+(defn compression-bench
+  [data]
+  (print-table
+   [{:v1 (alength (blob/encode data {:version 1}))
+     :v2 (alength (blob/encode data {:version 2}))
+     :v3 (alength (blob/encode data {:version 3}))}]))

backend/resources/builtin.edn

@@ -1,11 +0,0 @@
-{:icons
- [{:name "Material Design (Action)"
-   :path "./material/action/svg/production"
-   :regex #"^.*_48px\.svg$"}]
-
- :images
- [{:name "Generic Collection 1"
-   :path "./my-images/collection1/"
-   :regex #"^.*\.(png|jpg|webp)$"}]}
-
-

backend/resources/config/default.edn

@@ -1,44 +0,0 @@
-{;; A secret key used for create tokens
- ;; WARNING: this is a default secret key and
- ;; it should be overwritten in production env.
- :secret "5qjiAn-QUpawUNqGP10UZKklSqbLKcdGY3sJpq0UUACpVXGg2HOFJCBejDWVHskhRyp7iHb4rjOLXX2ZjF-5cw"
- 
- :registration
- {
-  :enabled true}
- 
- :smtp
- {:host "localhost" ;; Hostname of the desired SMTP server.
-  :port 25          ;; Port of SMTP server.
-  :user nil         ;; Username to authenticate with (if authenticating).
-  :pass nil         ;; Password to authenticate with (if authenticating).
-  :ssl false        ;; Enables SSL encryption if value is truthy.
-  :tls false        ;; Enables TLS encryption if value is truthy.
-  :enabled false    ;; Enables SMTP if value is truthy.
-  :noop true}
-
- :auth-options {:alg :a256kw :enc :a128cbc-hs256}
-
- :email {:reply-to "no-reply@uxbox.io"
-         :from "no-reply@uxbox.io"
-         :support "support@uxbox.io"}
-
- :http {:port 6060
-        :max-body-size 52428800
-        :debug true}
-
- :media
- {:directory "resources/public/media"
-  :uri "http://localhost:6060/media/"}
-
- :static
- {:directory "resources/public/static"
-  :uri "http://localhost:6060/static/"}
-
- :database
- {:adapter "postgresql"
-  :username nil
-  :password nil
-  :database-name "uxbox"
-  :server-name "localhost"
-  :port-number 5432}}

backend/resources/config/test.edn

@@ -1,18 +0,0 @@
-{:migrations
- {:verbose false}
-
- :media
- {:directory "/tmp/uxbox/media"
-  :uri "http://localhost:6060/media/"}
-
- :static
- {:directory "/tmp/uxbox/static"
-  :uri "http://localhost:6060/static/"}
-
- :database
- {:adapter "postgresql"
-  :username nil
-  :password nil
-  :database-name "test"
-  :server-name "localhost"
-  :port-number 5432}}

backend/resources/emails/feedback/en.subj

@@ -1 +1 @@
-[FEEDBACK]: From {{ profile.email }}
+[PENPOT FEEDBACK]: {{subject|abbreviate:19}} (from {{email}})

backend/resources/emails/feedback/en.txt

@@ -1,6 +1,8 @@
-Feedback from: {{profile.fullname}} <{{profile.email}}>
-
-Profile ID: {{profile.id}}
+{% if profile %}
+Feedback profile: {{profile.fullname}} <{{profile.email}}> / {{profile.id}}
+{% else %}
+Feedback from: {{email}}
+{% endif %}
 
 Subject: {{subject}}
 

backend/resources/error-report.tmpl

@@ -31,7 +31,7 @@
 
       .table-key {
         font-weight: 600;
-        width: 70px;
+        width: 60px;
         padding: 4px;
       }
 
@@ -70,27 +70,43 @@
 
       {% if user-agent %}
       <div class="table-row">
-        <div class="table-key">UAGENT: </div>
+        <div class="table-key">UAGT: </div>
         <div class="table-val">{{user-agent}}</div>
       </div>
       {% endif %}
 
       {% if frontend-version %}
       <div class="table-row">
-        <div class="table-key">FVERS: </div>
+        <div class="table-key">FVER: </div>
         <div class="table-val">{{frontend-version}}</div>
       </div>
       {% endif %}
 
       <div class="table-row">
-        <div class="table-key">BVERS: </div>
+        <div class="table-key">BVER: </div>
         <div class="table-val">{{version}}</div>
       </div>
 
+      {% if host %}
       <div class="table-row">
         <div class="table-key">HOST: </div>
         <div class="table-val">{{host}}</div>
       </div>
+      {% endif %}
+
+      {% if tenant %}
+      <div class="table-row">
+        <div class="table-key">ENV: </div>
+        <div class="table-val">{{tenant}}</div>
+      </div>
+      {% endif %}
+
+      {% if public-uri %}
+      <div class="table-row">
+        <div class="table-key">PURI: </div>
+        <div class="table-val">{{public-uri}}</div>
+      </div>
+      {% endif %}
 
       {% if type %}
       <div class="table-row">
@@ -106,15 +122,19 @@
       </div>
       {% endif %}
 
+      {% if error %}
       <div class="table-row">
-        <div class="table-key">CLASS: </div>
-        <div class="table-val">{{class}}</div>
+        <div class="table-key">CLSS: </div>
+        <div class="table-val">{{error.class}}</div>
       </div>
+      {% endif %}
 
+      {% if error %}
       <div class="table-row">
         <div class="table-key">HINT: </div>
-        <div class="table-val">{{hint}}</div>
+        <div class="table-val">{{error.message}}</div>
       </div>
+      {% endif %}
 
       {% if method %}
       <div class="table-row">
@@ -123,8 +143,18 @@
       </div>
       {% endif %}
 
+      {% if explain %}
+        <div>(<a href="#explain">go to explain</a>)</div>
+      {% endif %}
+      {% if data %}
+        <div>(<a href="#edata">go to edata</a>)</div>
+      {% endif %}
+      {% if error %}
+        <div>(<a href="#trace">go to trace</a>)</div>
+      {% endif %}
+
       {% if params %}
-      <div class="table-row multiline">
+      <div id="params" class="table-row multiline">
         <div class="table-key">PARAMS: </div>
         <div class="table-val">
           <pre>{{params}}</pre>
@@ -133,7 +163,7 @@
       {% endif %}
 
       {% if explain %}
-      <div class="table-row multiline">
+      <div id="explain" class="table-row multiline">
         <div class="table-key">EXPLAIN: </div>
         <div class="table-val">
           <pre>{{explain}}</pre>
@@ -142,7 +172,7 @@
       {% endif %}
 
       {% if data %}
-      <div class="table-row multiline">
+      <div id="edata" class="table-row multiline">
         <div class="table-key">EDATA: </div>
         <div class="table-val">
           <pre>{{data}}</pre>
@@ -150,12 +180,14 @@
       </div>
       {% endif %}
 
-      <div class="table-row multiline">
+      {% if error %}
+      <div id="trace" class="table-row multiline">
         <div class="table-key">TRACE:</div>
         <div class="table-val">
-          <pre>{{message}}</pre>
+          <pre>{{error.trace}}</pre>
         </div>
       </div>
+      {% endif %}
     </div>
   </body>
 </html>

backend/resources/log4j2-bundle.xml

@@ -1,26 +0,0 @@
-<?xml version="1.0" encoding="UTF-8"?>
-<Configuration status="info" monitorInterval="60">
-  <Appenders>
-    <Console name="console" target="SYSTEM_OUT">
-      <PatternLayout pattern="[%t] %level{length=1} %logger{36} - %msg%n"/>
-    </Console>
-  </Appenders>
-
-  <Loggers>
-    <Logger name="com.zaxxer.hikari" level="error" additivity="false">
-      <AppenderRef ref="console"/>
-    </Logger>
-
-    <Logger name="org.eclipse.jetty" level="info" additivity="false">
-      <AppenderRef ref="console"/>
-    </Logger>
-
-    <Logger name="app" level="debug" additivity="false">
-      <AppenderRef ref="console"/>
-    </Logger>
-
-    <Root level="info">
-      <AppenderRef ref="console"/>
-    </Root>
-  </Loggers>
-</Configuration>

backend/resources/log4j2-devenv.xml

@@ -0,0 +1,43 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<Configuration status="info" monitorInterval="30">
+  <Appenders>
+    <Console name="console" target="SYSTEM_OUT">
+      <PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] [%t] %level{length=1} %logger{36} - %msg%n"/>
+    </Console>
+
+    <RollingFile name="main" fileName="logs/main.log" filePattern="logs/main-%i.log">
+      <PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] [%t] %level{length=1} %logger{36} - %msg%n"/>
+      <Policies>
+        <SizeBasedTriggeringPolicy size="50M"/>
+      </Policies>
+      <DefaultRolloverStrategy max="9"/>
+    </RollingFile>
+  </Appenders>
+
+  <Loggers>
+    <Logger name="com.zaxxer.hikari" level="error"/>
+    <Logger name="io.lettuce" level="error" />
+    <Logger name="org.eclipse.jetty" level="error" />
+    <Logger name="org.postgresql" level="error" />
+
+    <Logger name="app.cli" level="debug" additivity="false">
+      <AppenderRef ref="console"/>
+    </Logger>
+
+    <Logger name="app.loggers" level="debug" additivity="false">
+      <AppenderRef ref="main" level="debug" />
+    </Logger>
+
+    <Logger name="app" level="all" additivity="false">
+      <AppenderRef ref="main" level="trace" />
+    </Logger>
+
+    <Logger name="user" level="trace" additivity="false">
+      <AppenderRef ref="main" level="trace" />
+    </Logger>
+
+    <Root level="info">
+      <AppenderRef ref="main" />
+    </Root>
+  </Loggers>
+</Configuration>

backend/resources/log4j2.xml

@@ -1,43 +1,21 @@
 <?xml version="1.0" encoding="UTF-8"?>
-<Configuration status="info" monitorInterval="30">
+<Configuration status="info" monitorInterval="60">
   <Appenders>
     <Console name="console" target="SYSTEM_OUT">
       <PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] [%t] %level{length=1} %logger{36} - %msg%n"/>
     </Console>
-
-    <RollingFile name="main" fileName="logs/main.log" filePattern="logs/main-%i.log">
-      <PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] [%t] %level{length=1} %logger{36} - %msg%n"/>
-      <Policies>
-        <SizeBasedTriggeringPolicy size="50M"/>
-      </Policies>
-      <DefaultRolloverStrategy max="9"/>
-    </RollingFile>
-
-    <CljFn name="error-reporter" ns="app.error-reporter" fn="queue-fn">
-      <PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] [%t] %level{length=1} %logger{36} - %msg%n"/>
-    </CljFn>
   </Appenders>
 
   <Loggers>
-    <Logger name="com.zaxxer.hikari" level="error" additivity="false" />
-    <Logger name="org.eclipse.jetty" level="error" additivity="false" />
-    <Logger name="io.lettuce" level="error" additivity="false" />
-
-    <Logger name="app.cli" level="debug" additivity="false">
-      <AppenderRef ref="console"/>
-    </Logger>
-
-    <Logger name="app.error-reporter" level="debug" additivity="false">
-      <AppenderRef ref="main" level="debug" />
-    </Logger>
+    <Logger name="com.zaxxer.hikari" level="error" />
+    <Logger name="org.eclipse.jetty" level="error" />
 
     <Logger name="app" level="debug" additivity="false">
-      <AppenderRef ref="main" level="debug" />
-      <AppenderRef ref="error-reporter" level="error" />
+      <AppenderRef ref="console" />
     </Logger>
 
     <Root level="info">
-      <AppenderRef ref="main" />
+      <AppenderRef ref="console" />
     </Root>
   </Loggers>
 </Configuration>

backend/scripts/build

@@ -0,0 +1,81 @@
+#!/usr/bin/env bb
+
+;; 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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns build
+  (:require
+   [clojure.string :as str]
+   [clojure.java.io :as io]
+   [clojure.pprint :refer [pprint]]
+   [babashka.fs :as fs]
+   [babashka.process :refer [$ check]]))
+
+(defn split-cp
+  [data]
+  (str/split data #":"))
+
+(def classpath
+  (->> ($ clojure -Spath)
+       (check)
+       (:out)
+       (slurp)
+       (split-cp)
+       (map str/trim)))
+
+(def classpath-jars
+  (let [xfm (filter #(str/ends-with? % ".jar"))]
+    (into #{} xfm classpath)))
+
+(def classpath-paths
+  (let [xfm (comp (remove #(str/ends-with? % ".jar"))
+                  (filter #(.isDirectory (io/file %))))]
+    (into #{} xfm classpath)))
+
+(def version
+  (or (first *command-line-args*) "%version%"))
+
+;; Clean previous dist
+(-> ($ rm -rf "./target/dist") check)
+
+;; Create a new dist
+(-> ($ mkdir -p "./target/dist/deps") check)
+
+;; Copy all jar deps into dist
+(run! (fn [item] (-> ($ cp ~item "./target/dist/deps/") check)) classpath-jars)
+
+;; Create the application jar
+(spit "./target/dist/version.txt" version)
+(-> ($ jar cvf "./target/dist/deps/app.jar" -C ~(first classpath-paths) ".") check)
+(-> ($ jar uvf "./target/dist/deps/app.jar" -C "./target/dist" "version.txt") check)
+(run! (fn [item]
+        (-> ($ jar uvf "./target/dist/deps/app.jar" -C ~item ".")  check))
+      (rest classpath-paths))
+
+;; Copy logging configuration
+(-> ($ cp "./resources/log4j2.xml" "./target/dist/") check)
+
+;; Create classpath file
+(let [jars (->> (into ["app.jar"] classpath-jars)
+                (map fs/file-name)
+                (map #(fs/path "deps" %))
+                (map str))]
+  (spit "./target/dist/classpath" (str/join ":" jars)))
+
+;; Copy run script template
+(-> ($ cp "./scripts/run.template.sh" "./target/dist/run.sh") check)
+
+;; Copy run script template
+(-> ($ cp "./scripts/manage.template.sh" "./target/dist/manage.sh") check)
+
+;; Add exec permisions to scripts.
+(-> ($ chmod +x "./target/dist/run.sh") check)
+(-> ($ chmod +x "./target/dist/manage.sh") check)
+
+nil

backend/scripts/build.sh

@@ -1,55 +0,0 @@
-#!/usr/bin/env bash
-
-CLASSPATH=`(clojure -Spath)`
-NEWCP="./main:./common"
-
-rm -rf ./target/dist
-mkdir -p ./target/dist/deps
-
-for item in $(echo $CLASSPATH | tr ":" "\n"); do
-    if [ "${item: -4}" == ".jar" ]; then
-        cp $item ./target/dist/deps/;
-        BN="$(basename -- $item)"
-        NEWCP+=":./deps/$BN"
-    fi
-done
-
-cp ./resources/log4j2-bundle.xml ./target/dist/log4j2.xml
-cp -r ./src ./target/dist/main
-cp -r ./resources/emails ./target/dist/main/
-cp -r ./resources/svgclean.js ./target/dist/main/
-cp -r ./resources/error-report.tmpl ./target/dist/main/
-cp -r ../common ./target/dist/common
-
-echo $NEWCP > ./target/dist/classpath;
-
-tee -a ./target/dist/run.sh  >> /dev/null <<EOF
-#!/usr/bin/env bash
-
-CP="$NEWCP"
-
-# Exports
-
-# Find java executable
-set +e
-JAVA_CMD=\$(type -p java)
-
-set -e
-if [[ ! -n "\$JAVA_CMD" ]]; then
-  if [[ -n "\$JAVA_HOME" ]] && [[ -x "\$JAVA_HOME/bin/java" ]]; then
-    JAVA_CMD="\$JAVA_HOME/bin/java"
-  else
-    >&2 echo "Couldn't find 'java'. Please set JAVA_HOME."
-    exit 1
-  fi
-fi
-
-if [ -f ./environ ]; then
-   source ./environ
-fi
-
-set -x
-exec \$JAVA_CMD \$JVM_OPTS -classpath \$CP -Dlog4j.configurationFile=./log4j2.xml "\$@" clojure.main -m app.main
-EOF
-
-chmod +x ./target/dist/run.sh

backend/scripts/import-generic-collections.sh

@@ -1,4 +0,0 @@
-#!/usr/bin/env bash
-
-clojure -Adev -m app.cli.collimp $@
-

backend/scripts/manage.template.sh

@@ -0,0 +1,19 @@
+#!/usr/bin/env bash
+set +e
+JAVA_CMD=$(type -p java)
+
+set -e
+if [[ ! -n "$JAVA_CMD" ]]; then
+  if [[ -n "$JAVA_HOME" ]] && [[ -x "$JAVA_HOME/bin/java" ]]; then
+    JAVA_CMD="$JAVA_HOME/bin/java"
+  else
+    >&2 echo "Couldn't find 'java'. Please set JAVA_HOME."
+    exit 1
+  fi
+fi
+
+if [ -f ./environ ]; then
+   source ./environ
+fi
+
+exec $JAVA_CMD $JVM_OPTS -classpath $(cat classpath) -Dlog4j2.configurationFile=./log4j2.xml clojure.main -m app.cli.manage "\$@"

backend/scripts/prepare-release.sh

@@ -1,16 +0,0 @@
-#!/usr/bin/env bash
-
-if [ "$#" -e 0 ]; then
-    echo "Expecting parameters: 1=path to backend; 2=destination directory"
-    exit 1
-fi
-
-rm -rf $2 || exit 1;
-
-rsync -avr \
-      --exclude="/test" \
-      --exclude="/resources/public/media" \
-      --exclude="/target" \
-      --exclude="/scripts" \
-      --exclude="/.*" \
-      $1 $2;

backend/scripts/psql.sh

@@ -1,2 +0,0 @@
-#!/usr/bin/env bash
-PGPASSWORD=$PENPOT_DATABASE_PASSWORD psql $PENPOT_DATABASE_URI -U $PENPOT_DATABASE_USERNAME

backend/scripts/repl

@@ -2,6 +2,10 @@
 
 export PENPOT_ASSERTS_ENABLED=true
 
+export OPTIONS="-A:jmx-remote:dev -J-Dclojure.tools.logging.factory=clojure.tools.logging.impl/log4j2-factory -J-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager -J-Xms512m -J-Xmx512m -J-Dlog4j2.configurationFile=log4j2-devenv.xml"
+
+export OPTIONS_EVAL="nil"
+# export OPTIONS_EVAL="(set! *warn-on-reflection* true)"
+
 set -ex
-# clojure -Ojmx-remote -A:dev -e "(set! *warn-on-reflection* true)" -m rebel-readline.main
-clojure -A:jmx-remote:dev -J-Xms512m -J-Xmx512m -M -m rebel-readline.main
+exec clojure $OPTIONS -M -e "$OPTIONS_EVAL" -m rebel-readline.main

backend/scripts/run-tests-in-docker.sh

@@ -1,4 +0,0 @@
-#!/usr/bin/env bash
-
-set -xe
-clojure -Adev -m app.tests.main;

backend/scripts/run.template.sh

@@ -0,0 +1,20 @@
+#!/usr/bin/env bash
+set +e
+JAVA_CMD=$(type -p java)
+
+set -e
+if [[ ! -n "$JAVA_CMD" ]]; then
+  if [[ -n "$JAVA_HOME" ]] && [[ -x "$JAVA_HOME/bin/java" ]]; then
+    JAVA_CMD="$JAVA_HOME/bin/java"
+  else
+    >&2 echo "Couldn't find 'java'. Please set JAVA_HOME."
+    exit 1
+  fi
+fi
+
+if [ -f ./environ ]; then
+   source ./environ
+fi
+
+set -x
+exec $JAVA_CMD $JVM_OPTS -classpath "$(cat classpath)" -Dlog4j2.configurationFile=./log4j2.xml "$@" clojure.main -m app.main

backend/scripts/smtpd.sh

@@ -1,2 +0,0 @@
-#!/usr/bin/env bash
-python -m smtpd -n -c DebuggingServer localhost:25

backend/scripts/tests.sh

@@ -1,2 +0,0 @@
-#!/usr/bin/env sh
-exec clojure -M:dev:tests "$@"

backend/src/app/cli/fixtures.clj

@@ -81,7 +81,7 @@
                                            {:id id
                                             :fullname (str "Profile " index)
                                             :password "123123"
-                                            :demo? true
+                                            :is-demo true
                                             :email (str "profile" index "@example.com")})
                     team-id  (:default-team-id prof)
                     owner-id id]
@@ -132,12 +132,18 @@
                     (range (:num-files-per-project opts))))
 
             (create-project [conn team-id owner-id index]
-              (let [id (mk-uuid "project" team-id index)
-                    name (str "project " index)]
+              (let [id        (if index
+                                (mk-uuid "project" team-id index)
+                                (mk-uuid "project" team-id))
+                    name      (if index
+                                (str "project " index)
+                                "Drafts")
+                    is-default (nil? index)]
                 (log/info "create project" index id)
                 (db/insert! conn :project
                             {:id id
                              :team-id team-id
+                             :is-default is-default
                              :name name})
                 (db/insert! conn :project-profile-rel
                             {:project-id id
@@ -150,8 +156,10 @@
             (create-projects [conn team-id profile-ids]
               (log/info "create projects")
               (let [owner-id (rng-nth rng profile-ids)
-                    project-ids (collect (partial create-project conn team-id owner-id)
-                                         (range (:num-projects-per-team opts)))]
+                    project-ids (conj
+                                  (collect (partial create-project conn team-id owner-id)
+                                         (range (:num-projects-per-team opts)))
+                                  (create-project conn team-id owner-id nil))]
                 (run! (partial create-files conn owner-id) project-ids)))
 
             (assign-profile-to-team [conn team-id owner? profile-id]
@@ -237,6 +245,6 @@
     (try
       (run-in-system system preset)
       (catch Exception e
-        (log/errorf e "Unhandled exception."))
+        (log/errorf e "unhandled exception"))
       (finally
         (ig/halt! system)))))

backend/src/app/cli/manage.clj

@@ -0,0 +1,173 @@
+;; 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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2021 UXBOX Labs SL
+
+(ns app.cli.manage
+  "A manage cli api."
+  (:require
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.main :as main]
+   [app.rpc.mutations.profile :as profile]
+   [app.rpc.queries.profile :refer [retrieve-profile-data-by-email]]
+   [clojure.string :as str]
+   [clojure.tools.cli :refer [parse-opts]]
+   [clojure.tools.logging :as log]
+   [integrant.core :as ig])
+  (:import
+   java.io.Console))
+
+;; --- IMPL
+
+(defn init-system
+  []
+  (let [data (-> (main/build-system-config cfg/config)
+                 (select-keys [:app.db/pool :app.metrics/metrics])
+                 (assoc :app.migrations/all {}))]
+    (-> data ig/prep ig/init)))
+
+(defn- read-from-console
+  [{:keys [label type] :or {type :text}}]
+  (let [^Console console (System/console)]
+    (when-not console
+      (log/error "no console found, can proceed")
+      (System/exit 1))
+
+    (binding [*out* (.writer console)]
+      (print label " ")
+      (.flush *out*))
+
+    (case type
+      :text (.readLine console)
+      :password (String. (.readPassword console)))))
+
+(defn create-profile
+  [options]
+  (let [system   (init-system)
+        email    (or (:email options)
+                     (read-from-console {:label "Email:"}))
+        fullname (or (:fullname options)
+                     (read-from-console {:label "Full Name:"}))
+        password (or (:password options)
+                     (read-from-console {:label "Password:"
+                                         :type :password}))]
+    (try
+      (db/with-atomic [conn (:app.db/pool system)]
+        (->> (profile/create-profile conn
+                                     {:fullname fullname
+                                      :email email
+                                      :password password
+                                      :is-active true
+                                      :is-demo false})
+             (profile/create-profile-relations conn)))
+
+      (when (pos? (:verbosity options))
+        (println "User created successfully."))
+      (System/exit 0)
+
+      (catch Exception _e
+        (when (pos? (:verbosity options))
+          (println "Unable to create user, already exists."))
+        (System/exit 1)))))
+
+(defn reset-password
+  [options]
+  (let [system (init-system)]
+    (try
+      (db/with-atomic [conn (:app.db/pool system)]
+        (let [email    (or (:email options)
+                           (read-from-console {:label "Email:"}))
+              profile  (retrieve-profile-data-by-email conn email)]
+          (when-not profile
+            (when (pos? (:verbosity options))
+              (println "Profile does not exists."))
+            (System/exit 1))
+
+          (let [password (or (:password options)
+                             (read-from-console {:label "Password:"
+                                                 :type :password}))]
+            (profile/update-profile-password! conn (assoc profile :password password))
+            (when (pos? (:verbosity options))
+              (println "Password changed successfully.")))))
+      (System/exit 0)
+      (catch Exception e
+        (when (pos? (:verbosity options))
+          (println "Unable to change password."))
+        (when (= 2 (:verbosity options))
+          (.printStackTrace e))
+        (System/exit 1)))))
+
+;; --- CLI PARSE
+
+(def cli-options
+  ;; An option with a required argument
+  [["-u" "--email EMAIL" "Email Address"]
+   ["-p" "--password PASSWORD" "Password"]
+   ["-n" "--name FULLNAME" "Full Name"
+    :id :fullname]
+   ["-v" nil "Verbosity level"
+    :id :verbosity
+    :default 1
+    :update-fn inc]
+   ["-q" nil "Dont' print to console"
+    :id :verbosity
+    :update-fn (constantly 0)]
+   ["-h" "--help"]])
+
+(defn usage
+  [options-summary]
+  (->> ["Penpot CLI management."
+        ""
+        "Usage: manage [options] action"
+        ""
+        "Options:"
+        options-summary
+        ""
+        "Actions:"
+        "  create-profile    Create new profile."
+        "  reset-password    Reset profile password."
+        ""]
+       (str/join \newline)))
+
+(defn error-msg [errors]
+  (str "The following errors occurred while parsing your command:\n\n"
+       (str/join \newline errors)))
+
+(defn validate-args
+  "Validate command line arguments. Either return a map indicating the program
+  should exit (with a error message, and optional ok status), or a map
+  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}
+
+      errors ; errors => exit with description of errors
+      {:exit-message (error-msg errors)}
+
+      ;; custom validation on arguments
+      :else
+      (let [action (first arguments)]
+        (if (#{"create-profile" "reset-password"} action)
+          {:action (first arguments) :options options}
+          {:exit-message (usage summary)})))))
+
+(defn exit [status msg]
+  (println msg)
+  (System/exit status))
+
+(defn -main
+  [& args]
+  (let [{:keys [action options exit-message ok?]} (validate-args args)]
+    (if exit-message
+      (exit (if ok? 0 1) exit-message)
+      (case action
+        "create-profile" (create-profile options)
+        "reset-password" (reset-password options)))))

backend/src/app/config.clj

@@ -5,38 +5,44 @@
 ;; This Source Code Form is "Incompatible With Secondary Licenses", as
 ;; defined by the Mozilla Public License, v. 2.0.
 ;;
-;; Copyright (c) 2020 UXBOX Labs SL
+;; Copyright (c) UXBOX Labs SL
 
 (ns app.config
   "A configuration management."
+  (:refer-clojure :exclude [get])
   (:require
    [app.common.spec :as us]
    [app.common.version :as v]
    [app.util.time :as dt]
+   [clojure.core :as c]
+   [clojure.java.io :as io]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [environ.core :refer [env]]))
 
 (def defaults
   {:http-server-port 6060
-
-   :database-uri "postgresql://127.0.0.1/penpot"
+   :host "devenv"
+   :tenant "dev"
+   :database-uri "postgresql://postgres/penpot"
    :database-username "penpot"
    :database-password "penpot"
 
    :default-blob-version 1
 
+   :loggers-zmq-uri "tcp://localhost:45556"
+
    :asserts-enabled false
 
    :public-uri "http://localhost:3449"
-   :redis-uri "redis://localhost/0"
+   :redis-uri "redis://redis/0"
 
    :srepl-host "127.0.0.1"
    :srepl-port 6062
 
    :storage-backend :fs
 
-   :storage-fs-directory "resources/public/assets"
+   :storage-fs-directory "assets"
    :storage-s3-region :eu-central-1
    :storage-s3-bucket "penpot-devenv-assets-pre"
 
@@ -52,6 +58,12 @@
    :smtp-default-reply-to "Penpot <no-reply@example.com>"
    :smtp-default-from "Penpot <no-reply@example.com>"
 
+   :profile-complaint-max-age (dt/duration {:days 7})
+   :profile-complaint-threshold 2
+
+   :profile-bounce-max-age (dt/duration {:days 7})
+   :profile-bounce-threshold 10
+
    :allow-demo-users true
    :registration-enabled true
    :registration-domain-whitelist ""
@@ -59,100 +71,88 @@
    :telemetry-enabled false
    :telemetry-uri "https://telemetry.penpot.app/"
 
-   ;; LDAP auth disabled by default. Set ldap-auth-host to enable
-   ;:ldap-auth-host "ldap.mysupercompany.com"
-   ;:ldap-auth-port 389
-   ;:ldap-bind-dn "cn=admin,dc=ldap,dc=mysupercompany,dc=com"
-   ;:ldap-bind-password "verysecure"
-   ;:ldap-auth-ssl false
-   ;:ldap-auth-starttls false
-   ;:ldap-auth-base-dn "ou=People,dc=ldap,dc=mysupercompany,dc=com"
+   :ldap-user-query "(|(uid=:username)(mail=:username))"
+   :ldap-attrs-username "uid"
+   :ldap-attrs-email "mail"
+   :ldap-attrs-fullname "cn"
+   :ldap-attrs-photo "jpegPhoto"
 
-   :ldap-auth-user-query "(|(uid=$username)(mail=$username))"
-   :ldap-auth-username-attribute "uid"
-   :ldap-auth-email-attribute "mail"
-   :ldap-auth-fullname-attribute "displayName"
-   :ldap-auth-avatar-attribute "jpegPhoto"
-
-   ;; :initial-data-file "resources/initial-data.json"
-   ;; :initial-data-project-name "Penpot Oboarding"
+   ;; a server prop key where initial project is stored.
+   :initial-project-skey "initial-project"
    })
 
-(s/def ::http-server-port ::us/integer)
-(s/def ::database-username (s/nilable ::us/string))
+(s/def ::allow-demo-users ::us/boolean)
+(s/def ::asserts-enabled ::us/boolean)
+(s/def ::assets-path ::us/string)
 (s/def ::database-password (s/nilable ::us/string))
 (s/def ::database-uri ::us/string)
-(s/def ::redis-uri ::us/string)
-
-
-(s/def ::storage-backend ::us/keyword)
-(s/def ::storage-fs-directory ::us/string)
-(s/def ::assets-path ::us/string)
-(s/def ::storage-s3-region ::us/keyword)
-(s/def ::storage-s3-bucket ::us/string)
-
-(s/def ::media-uri ::us/string)
-(s/def ::media-directory ::us/string)
-(s/def ::asserts-enabled ::us/boolean)
-
-(s/def ::feedback-enabled ::us/boolean)
-(s/def ::feedback-destination ::us/string)
-
+(s/def ::database-username (s/nilable ::us/string))
+(s/def ::default-blob-version ::us/integer)
 (s/def ::error-report-webhook ::us/string)
-
-(s/def ::smtp-enabled ::us/boolean)
-(s/def ::smtp-default-reply-to ::us/string)
-(s/def ::smtp-default-from ::us/string)
-(s/def ::smtp-host ::us/string)
-(s/def ::smtp-port ::us/integer)
-(s/def ::smtp-username (s/nilable ::us/string))
-(s/def ::smtp-password (s/nilable ::us/string))
-(s/def ::smtp-tls ::us/boolean)
-(s/def ::smtp-ssl ::us/boolean)
-(s/def ::allow-demo-users ::us/boolean)
-(s/def ::registration-enabled ::us/boolean)
-(s/def ::registration-domain-whitelist ::us/string)
-(s/def ::public-uri ::us/string)
-
-(s/def ::srepl-host ::us/string)
-(s/def ::srepl-port ::us/integer)
-
-(s/def ::rlimits-password ::us/integer)
-(s/def ::rlimits-image ::us/integer)
-
-(s/def ::google-client-id ::us/string)
-(s/def ::google-client-secret ::us/string)
-
-(s/def ::gitlab-client-id ::us/string)
-(s/def ::gitlab-client-secret ::us/string)
-(s/def ::gitlab-base-uri ::us/string)
-
+(s/def ::feedback-destination ::us/string)
+(s/def ::feedback-enabled ::us/boolean)
+(s/def ::feedback-token ::us/string)
 (s/def ::github-client-id ::us/string)
 (s/def ::github-client-secret ::us/string)
-
-(s/def ::ldap-auth-host ::us/string)
-(s/def ::ldap-auth-port ::us/integer)
+(s/def ::gitlab-base-uri ::us/string)
+(s/def ::gitlab-client-id ::us/string)
+(s/def ::gitlab-client-secret ::us/string)
+(s/def ::google-client-id ::us/string)
+(s/def ::google-client-secret ::us/string)
+(s/def ::host ::us/string)
+(s/def ::http-server-port ::us/integer)
+(s/def ::http-session-cookie-name ::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 ::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)
 (s/def ::ldap-bind-password ::us/string)
-(s/def ::ldap-auth-ssl ::us/boolean)
-(s/def ::ldap-auth-starttls ::us/boolean)
-(s/def ::ldap-auth-base-dn ::us/string)
-(s/def ::ldap-auth-user-query ::us/string)
-(s/def ::ldap-auth-username-attribute ::us/string)
-(s/def ::ldap-auth-email-attribute ::us/string)
-(s/def ::ldap-auth-fullname-attribute ::us/string)
-(s/def ::ldap-auth-avatar-attribute ::us/string)
-
+(s/def ::ldap-host ::us/string)
+(s/def ::ldap-port ::us/integer)
+(s/def ::ldap-ssl ::us/boolean)
+(s/def ::ldap-starttls ::us/boolean)
+(s/def ::ldap-user-query ::us/string)
+(s/def ::loggers-loki-uri ::us/string)
+(s/def ::loggers-zmq-uri ::us/string)
+(s/def ::media-directory ::us/string)
+(s/def ::media-uri ::us/string)
+(s/def ::profile-bounce-max-age ::dt/duration)
+(s/def ::profile-bounce-threshold ::us/integer)
+(s/def ::profile-complaint-max-age ::dt/duration)
+(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/string)
+(s/def ::registration-enabled ::us/boolean)
+(s/def ::rlimits-image ::us/integer)
+(s/def ::rlimits-password ::us/integer)
+(s/def ::smtp-default-from ::us/string)
+(s/def ::smtp-default-reply-to ::us/string)
+(s/def ::smtp-enabled ::us/boolean)
+(s/def ::smtp-host ::us/string)
+(s/def ::smtp-password (s/nilable ::us/string))
+(s/def ::smtp-port ::us/integer)
+(s/def ::smtp-ssl ::us/boolean)
+(s/def ::smtp-tls ::us/boolean)
+(s/def ::smtp-username (s/nilable ::us/string))
+(s/def ::srepl-host ::us/string)
+(s/def ::srepl-port ::us/integer)
+(s/def ::storage-backend ::us/keyword)
+(s/def ::storage-fs-directory ::us/string)
+(s/def ::storage-s3-bucket ::us/string)
+(s/def ::storage-s3-region ::us/keyword)
 (s/def ::telemetry-enabled ::us/boolean)
-(s/def ::telemetry-with-taiga ::us/boolean)
-(s/def ::telemetry-uri ::us/string)
 (s/def ::telemetry-server-enabled ::us/boolean)
 (s/def ::telemetry-server-port ::us/integer)
-
-(s/def ::initial-data-file ::us/string)
-(s/def ::initial-data-project-name ::us/string)
-
-(s/def ::default-blob-version ::us/integer)
+(s/def ::telemetry-uri ::us/string)
+(s/def ::telemetry-with-taiga ::us/boolean)
+(s/def ::tenant ::us/string)
 
 (s/def ::config
   (s/keys :opt-un [::allow-demo-users
@@ -162,8 +162,9 @@
                    ::database-username
                    ::default-blob-version
                    ::error-report-webhook
-                   ::feedback-enabled
                    ::feedback-destination
+                   ::feedback-enabled
+                   ::feedback-token
                    ::github-client-id
                    ::github-client-secret
                    ::gitlab-base-uri
@@ -171,25 +172,37 @@
                    ::gitlab-client-secret
                    ::google-client-id
                    ::google-client-secret
+                   ::host
                    ::http-server-port
-                   ::ldap-auth-avatar-attribute
-                   ::ldap-auth-base-dn
-                   ::ldap-auth-email-attribute
-                   ::ldap-auth-fullname-attribute
-                   ::ldap-auth-host
-                   ::ldap-auth-port
-                   ::ldap-auth-ssl
-                   ::ldap-auth-starttls
-                   ::ldap-auth-user-query
-                   ::ldap-auth-username-attribute
+                   ::http-session-idle-max-age
+                   ::http-session-updater-batch-max-age
+                   ::http-session-updater-batch-max-size
+                   ::initial-project-skey
+                   ::ldap-attrs-email
+                   ::ldap-attrs-fullname
+                   ::ldap-attrs-photo
+                   ::ldap-attrs-username
+                   ::ldap-base-dn
                    ::ldap-bind-dn
                    ::ldap-bind-password
+                   ::ldap-host
+                   ::ldap-port
+                   ::ldap-ssl
+                   ::ldap-starttls
+                   ::ldap-user-query
+                   ::local-assets-uri
+                   ::loggers-loki-uri
+                   ::loggers-zmq-uri
+                   ::profile-bounce-max-age
+                   ::profile-bounce-threshold
+                   ::profile-complaint-max-age
+                   ::profile-complaint-threshold
                    ::public-uri
                    ::redis-uri
                    ::registration-domain-whitelist
                    ::registration-enabled
-                   ::rlimits-password
                    ::rlimits-image
+                   ::rlimits-password
                    ::smtp-default-from
                    ::smtp-default-reply-to
                    ::smtp-enabled
@@ -199,20 +212,18 @@
                    ::smtp-ssl
                    ::smtp-tls
                    ::smtp-username
-                   ::storage-backend
-                   ::storage-fs-directory
                    ::srepl-host
                    ::srepl-port
-                   ::local-assets-uri
+                   ::storage-backend
+                   ::storage-fs-directory
                    ::storage-s3-bucket
                    ::storage-s3-region
                    ::telemetry-enabled
-                   ::telemetry-with-taiga
                    ::telemetry-server-enabled
                    ::telemetry-server-port
                    ::telemetry-uri
-                   ::initial-data-file
-                   ::initial-data-project-name]))
+                   ::telemetry-with-taiga
+                   ::tenant]))
 
 (defn- env->config
   [env]
@@ -241,9 +252,19 @@
           :migrations-verbose false}
          (read-config env)))
 
-(def version (v/parse "%version%"))
+(def version (v/parse (or (some-> (io/resource "version.txt")
+                                  (slurp)
+                                  (str/trim))
+                          "%version%")))
 (def config (read-config env))
 (def test-config (read-test-config env))
 
 (def deletion-delay
   (dt/duration {:days 7}))
+
+(defn get
+  "A configuration getter. Helps code be more testable."
+  ([key]
+   (c/get config key))
+  ([key default]
+   (c/get config key default)))

backend/src/app/db.clj

@@ -13,12 +13,14 @@
    [app.common.geom.point :as gpt]
    [app.common.spec :as us]
    [app.db.sql :as sql]
+   [app.metrics :as mtx]
    [app.util.json :as json]
    [app.util.migrations :as mg]
    [app.util.time :as dt]
    [app.util.transit :as t]
    [clojure.java.io :as io]
    [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
    [integrant.core :as ig]
    [next.jdbc :as jdbc]
    [next.jdbc.date-time :as jdbc-dt])
@@ -26,6 +28,7 @@
    com.zaxxer.hikari.HikariConfig
    com.zaxxer.hikari.HikariDataSource
    com.zaxxer.hikari.metrics.prometheus.PrometheusMetricsTrackerFactory
+   java.lang.AutoCloseable
    java.sql.Connection
    java.sql.Savepoint
    org.postgresql.PGConnection
@@ -43,21 +46,24 @@
 ;; Initialization
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(declare instrument-jdbc!)
+
 (s/def ::uri ::us/not-empty-string)
 (s/def ::name ::us/not-empty-string)
 (s/def ::min-pool-size ::us/integer)
 (s/def ::max-pool-size ::us/integer)
 (s/def ::migrations map?)
-(s/def ::metrics map?)
 
 (defmethod ig/pre-init-spec ::pool [_]
-  (s/keys :req-un [::uri ::name ::min-pool-size ::max-pool-size ::migrations]))
+  (s/keys :req-un [::uri ::name ::min-pool-size ::max-pool-size ::migrations ::mtx/metrics]))
 
 (defmethod ig/init-key ::pool
-  [_ {:keys [migrations] :as cfg}]
+  [_ {:keys [migrations metrics] :as cfg}]
+  (log/infof "initialize connection pool '%s' with uri '%s'" (:name cfg) (:uri cfg))
+  (instrument-jdbc! (:registry metrics))
   (let [pool (create-pool cfg)]
     (when (seq migrations)
-      (with-open [conn (open pool)]
+      (with-open [conn ^AutoCloseable (open pool)]
         (mg/setup! conn)
         (doseq [[mname steps] migrations]
           (mg/migrate! conn {:name (name mname) :steps steps}))))
@@ -67,12 +73,22 @@
   [_ 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."}))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; API & Impl
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (def initsql
-  (str "SET statement_timeout = 60000;\n"
+  (str "SET statement_timeout = 120000;\n"
        "SET idle_in_transaction_session_timeout = 120000;"))
 
 (defn- create-datasource-config
@@ -162,7 +178,7 @@
   [& args]
   `(jdbc/with-transaction ~@args))
 
-(defn open
+(defn ^Connection open
   [pool]
   (jdbc/get-connection pool))
 
@@ -184,11 +200,6 @@
               (sql/insert table params opts)
               (assoc opts :return-keys true))))
 
-(defn insert-multi!
-  [ds table param-list]
-  (doseq [params param-list]
-    (insert! ds table params)))
-
 (defn update!
   ([ds table params where] (update! ds table params where nil))
   ([ds table params where opts]
@@ -206,9 +217,10 @@
 (defn get-by-params
   ([ds table params]
    (get-by-params ds table params nil))
-  ([ds table params opts]
+  ([ds table params {:keys [uncheked] :or {uncheked false} :as opts}]
    (let [res (exec-one! ds (sql/select table params opts))]
-     (when (or (:deleted-at res) (not res))
+     (when (and (not uncheked)
+                (or (:deleted-at res) (not res)))
        (ex/raise :type :not-found
                  :hint "database object not found"))
      res)))
@@ -250,9 +262,12 @@
   (PGpoint. (:x p) (:y p)))
 
 (defn create-array
-  [conn type aobjects]
+  [conn type objects]
   (let [^PGConnection conn (unwrap conn org.postgresql.PGConnection)]
-    (.createArrayOf conn ^String type aobjects)))
+    (if (coll? objects)
+      (.createArrayOf conn ^String type (into-array Object objects))
+      (.createArrayOf conn ^String type objects))))
+
 
 (defn decode-pgpoint
   [^PGpoint v]
@@ -286,7 +301,7 @@
     (pginterval data)
 
     (dt/duration? data)
-    (->> (/ (.toMillis data) 1000.0)
+    (->> (/ (.toMillis ^java.time.Duration data) 1000.0)
          (format "%s seconds")
          (pginterval))
 

backend/src/app/db/profile_initial_data.clj

@@ -1,117 +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/.
-;;
-;; This Source Code Form is "Incompatible With Secondary Licenses", as
-;; defined by the Mozilla Public License, v. 2.0.
-;;
-;; Copyright (c) 2020-2021 UXBOX Labs SL
-
-(ns app.db.profile-initial-data
-  (:require
-   [app.common.uuid :as uuid]
-   [app.config :as cfg]
-   [app.db :as db]
-   [app.rpc.mutations.projects :as projects]
-   [app.util.transit :as tr]
-   [clojure.java.io :as io]
-   [datoteka.core :as fs]))
-
-(def sql:file
-  "select * from file where project_id = ?")
-
-(def sql:file-library-rel
-  "with file_ids as (select id from file where project_id = ?)
-   select *
-     from file_library_rel
-     where file_id in (select id from file_ids)")
-
-(def sql:file-media-object
-  "with file_ids as (select id from file where project_id = ?)
-   select *
-     from file_media_object
-     where file_id in (select id from file_ids)")
-
-(defn change-ids
-  "Given a collection and a map from ID to ID. Changes all the `keys` properties
-  so they point to the new ID existing in `map-ids`"
-  [map-ids coll keys]
-  (let [generate-id
-        (fn [map-ids {:keys [id]}]
-          (assoc map-ids id (uuid/next)))
-
-        remap-key
-        (fn [obj map-ids key]
-          (cond-> obj
-            (contains? obj key)
-            (assoc key (get map-ids (get obj key) (get obj key)))))
-
-        change-id
-        (fn [map-ids obj]
-          (reduce #(remap-key %1 map-ids %2) obj keys))
-
-        new-map-ids (reduce generate-id map-ids coll)]
-
-    [new-map-ids (map (partial change-id new-map-ids) coll)]))
-
-(defn create-initial-data-dump
-  [conn project-id output-path]
-  (let [ ;; Retrieve data from templates
-        opath                (fs/path output-path)
-        file                 (db/exec! conn [sql:file, project-id])
-        file-library-rel     (db/exec! conn [sql:file-library-rel, project-id])
-        file-media-object    (db/exec! conn [sql:file-media-object, project-id])
-
-        data {:file file
-              :file-library-rel file-library-rel
-              :file-media-object file-media-object}]
-    (with-open [output (io/output-stream opath)]
-      (tr/encode-stream data output)
-      nil)))
-
-(defn read-initial-data
-  [path]
-  (when (fs/exists? path)
-    (with-open [input (io/input-stream (fs/path path))]
-      (tr/decode-stream input))))
-
-(defn create-profile-initial-data
-  ([conn profile]
-   (when-let [initial-data-path (:initial-data-file cfg/config)]
-     (create-profile-initial-data conn initial-data-path profile)))
-
-  ([conn file profile]
-   (when-let [{:keys [file file-library-rel file-media-object]} (read-initial-data file)]
-     (let [sample-project-name (:initial-data-project-name cfg/config "Penpot Onboarding")
-
-           proj (projects/create-project conn {:profile-id (:id profile)
-                                               :team-id (:default-team-id profile)
-                                               :name sample-project-name})
-
-           map-ids {}
-
-           ;; Create new ID's and change the references
-           [map-ids file]                 (change-ids map-ids file #{:id})
-           [map-ids file-library-rel]     (change-ids map-ids file-library-rel #{:file-id :library-file-id})
-           [_       file-media-object]    (change-ids map-ids file-media-object #{:id :file-id :media-id :thumbnail-id})
-
-           file             (map #(assoc % :project-id (:id proj)) file)
-           file-profile-rel (map #(array-map :file-id (:id %)
-                                             :profile-id (:id profile)
-                                             :is-owner true
-                                             :is-admin true
-                                             :can-edit true)
-                                 file)]
-
-       (projects/create-project-profile conn {:project-id (:id proj)
-                                              :profile-id (:id profile)})
-
-       (projects/create-team-project-profile conn {:team-id (:default-team-id profile)
-                                                   :project-id (:id proj)
-                                                   :profile-id (:id profile)})
-
-       ;; Re-insert into the database
-       (db/insert-multi! conn :file file)
-       (db/insert-multi! conn :file-profile-rel file-profile-rel)
-       (db/insert-multi! conn :file-library-rel file-library-rel)
-       (db/insert-multi! conn :file-media-object file-media-object)))))

backend/src/app/db/sql.clj

@@ -58,4 +58,3 @@
   ([table where-params opts]
    (let [opts (merge default-opts opts)]
      (sql/for-delete table where-params opts))))
-

backend/src/app/emails.clj

@@ -5,13 +5,15 @@
 ;; This Source Code Form is "Incompatible With Secondary Licenses", as
 ;; defined by the Mozilla Public License, v. 2.0.
 ;;
-;; Copyright (c) 2020 UXBOX Labs SL
+;; Copyright (c) 2020-2021 UXBOX Labs SL
 
 (ns app.emails
   "Main api for send emails."
   (:require
    [app.common.spec :as us]
    [app.config :as cfg]
+   [app.db :as db]
+   [app.db.sql :as sql]
    [app.tasks :as tasks]
    [app.util.emails :as emails]
    [clojure.spec.alpha :as s]))
@@ -41,6 +43,54 @@
                          :priority 200
                          :props email})))
 
+
+(def sql:profile-complaint-report
+  "select (select count(*)
+             from profile_complaint_report
+            where type = 'complaint'
+              and profile_id = ?
+              and created_at > now() - ?::interval) as complaints,
+          (select count(*)
+             from profile_complaint_report
+            where type = 'bounce'
+              and profile_id = ?
+              and created_at > now() - ?::interval) as bounces;")
+
+(defn allow-send-emails?
+  [conn profile]
+  (when-not (:is-muted profile false)
+    (let [complaint-threshold (cfg/get :profile-complaint-threshold)
+          complaint-max-age   (cfg/get :profile-complaint-max-age)
+          bounce-threshold    (cfg/get :profile-bounce-threshold)
+          bounce-max-age      (cfg/get :profile-bounce-max-age)
+
+          {:keys [complaints bounces] :as result}
+          (db/exec-one! conn [sql:profile-complaint-report
+                              (:id profile)
+                              (db/interval complaint-max-age)
+                              (:id profile)
+                              (db/interval bounce-max-age)])]
+
+      (and (< complaints complaint-threshold)
+           (< bounces bounce-threshold)))))
+
+(defn has-complaint-reports?
+  ([conn email] (has-complaint-reports? conn email nil))
+  ([conn email {:keys [threshold] :or {threshold 1}}]
+   (let [reports (db/exec! conn (sql/select :global-complaint-report
+                                            {:email email :type "complaint"}
+                                            {:limit 10}))]
+     (>= (count reports) threshold))))
+
+(defn has-bounce-reports?
+  ([conn email] (has-bounce-reports? conn email nil))
+  ([conn email {:keys [threshold] :or {threshold 1}}]
+   (let [reports (db/exec! conn (sql/select :global-complaint-report
+                                            {:email email :type "bounce"}
+                                            {:limit 10}))]
+     (>= (count reports) threshold))))
+
+
 ;; --- Emails
 
 (s/def ::subject ::us/string)

backend/src/app/http.clj

@@ -12,7 +12,6 @@
    [app.common.data :as d]
    [app.common.spec :as us]
    [app.config :as cfg]
-   [app.http.auth :as auth]
    [app.http.errors :as errors]
    [app.http.middleware :as middleware]
    [app.metrics :as mtx]
@@ -43,7 +42,7 @@
 
 (defmethod ig/init-key ::server
   [_ {:keys [handler ws port name metrics] :as opts}]
-  (log/infof "Starting %s server on port %s." name port)
+  (log/infof "starting '%s' server on port %s." name port)
   (let [pre-start (fn [^Server server]
                     (let [handler (doto (ErrorHandler.)
                                     (.setShowStacks true)
@@ -69,7 +68,7 @@
 
 (defmethod ig/halt-key! ::server
   [_ {:keys [server name port] :as opts}]
-  (log/infof "Stoping %s server on port %s." name port)
+  (log/infof "stoping '%s' server on port %s." name port)
   (jetty/stop-server server))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -81,14 +80,13 @@
 (s/def ::rpc map?)
 (s/def ::session map?)
 (s/def ::metrics map?)
-(s/def ::google-auth map?)
-(s/def ::gitlab-auth map?)
-(s/def ::ldap-auth fn?)
+(s/def ::oauth map?)
 (s/def ::storage map?)
 (s/def ::assets map?)
+(s/def ::feedback fn?)
 
 (defmethod ig/pre-init-spec ::router [_]
-  (s/keys :req-un [::rpc ::session ::metrics ::google-auth ::gitlab-auth ::storage ::assets]))
+  (s/keys :req-un [::rpc ::session ::metrics ::oauth ::storage ::assets ::feedback]))
 
 (defmethod ig/init-key ::router
   [_ cfg]
@@ -105,16 +103,16 @@
           (try
             (let [cdata (errors/get-error-context request e)]
               (update-thread-context! cdata)
-              (log/errorf e "Unhandled exception: %s (id: %s)" (ex-message e) (str (:id cdata)))
+              (log/errorf e "unhandled exception: %s (id: %s)" (ex-message e) (str (:id cdata)))
               {:status 500
                :body "internal server error"})
             (catch Throwable e
-              (log/errorf e "Unhandled exception: %s" (ex-message e))
+              (log/errorf e "unhandled exception: %s" (ex-message e))
               {:status 500
                :body "internal server error"})))))))
 
 (defn- create-router
-  [{:keys [session rpc google-auth gitlab-auth github-auth metrics ldap-auth svgparse assets] :as cfg}]
+  [{:keys [session rpc oauth metrics svgparse assets feedback] :as cfg}]
   (rr/router
    [["/metrics" {:get (:handler metrics)}]
 
@@ -127,7 +125,11 @@
     ["/dbg"
      ["/error-by-id/:id" {:get (:error-report-handler cfg)}]]
 
-    ["/api" {:middleware [[middleware/format-response-body]
+    ["/webhooks"
+     ["/sns" {:post (:sns-webhook cfg)}]]
+
+    ["/api" {:middleware [[middleware/etag]
+                          [middleware/format-response-body]
                           [middleware/params]
                           [middleware/multipart-params]
                           [middleware/keyword-params]
@@ -135,22 +137,19 @@
                           [middleware/errors errors/handle]
                           [middleware/cookies]]}
 
-     ["/svg" {:post svgparse}]
+     ["/svg/parse" {:post svgparse}]
+     ["/feedback" {:middleware [(:middleware session)]
+                   :post feedback}]
 
      ["/oauth"
-      ["/google" {:post (:auth-handler google-auth)}]
-      ["/google/callback" {:get (:callback-handler google-auth)}]
+      ["/google" {:post (get-in oauth [:google :handler])}]
+      ["/google/callback" {:get (get-in oauth [:google :callback-handler])}]
 
-      ["/gitlab" {:post (:auth-handler gitlab-auth)}]
-      ["/gitlab/callback" {:get (:callback-handler gitlab-auth)}]
+      ["/gitlab" {:post (get-in oauth [:gitlab :handler])}]
+      ["/gitlab/callback" {:get (get-in oauth [:gitlab :callback-handler])}]
 
-      ["/github" {:post (:auth-handler github-auth)}]
-      ["/github/callback" {:get (:callback-handler github-auth)}]]
-
-     ["/login" {:post #(auth/login-handler cfg %)}]
-     ["/logout" {:post #(auth/logout-handler cfg %)}]
-
-     ["/login-ldap" {:post ldap-auth}]
+      ["/github" {:post (get-in oauth [:github :handler])}]
+      ["/github/callback" {:get (get-in oauth [:github :callback-handler])}]]
 
      ["/rpc" {:middleware [(:middleware session)]}
       ["/query/:type" {:get (:query-handler rpc)}]

backend/src/app/http/auth.clj

@@ -1,31 +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/.
-;;
-;; This Source Code Form is "Incompatible With Secondary Licenses", as
-;; defined by the Mozilla Public License, v. 2.0.
-;;
-;; Copyright (c) 2020 UXBOX Labs SL
-
-(ns app.http.auth
-  (:require
-   [app.http.session :as session]))
-
-(defn login-handler
-  [{:keys [session rpc] :as cfg} request]
-  (let [data    (:params request)
-        uagent  (get-in request [:headers "user-agent"])
-        method  (get-in rpc [:methods :mutation :login])
-        profile (method data)
-        id      (session/create! session {:profile-id (:id profile)
-                                          :user-agent uagent})]
-    {:status 200
-     :cookies (session/cookies session {:value id})
-     :body profile}))
-
-(defn logout-handler
-  [{:keys [session] :as cfg} request]
-  (session/delete! cfg request)
-  {:status 204
-   :cookies (session/cookies session {:value "" :max-age -1})
-   :body ""})

backend/src/app/http/auth/github.clj

@@ -1,171 +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/.
-;;
-;; This Source Code Form is "Incompatible With Secondary Licenses", as
-;; defined by the Mozilla Public License, v. 2.0.
-;;
-;; Copyright (c) 2020-2021 UXBOX Labs SL
-
-(ns app.http.auth.github
-  (:require
-   [app.common.exceptions :as ex]
-   [app.common.spec :as us]
-   [app.config :as cfg]
-   [app.http.session :as session]
-   [app.util.http :as http]
-   [app.util.time :as dt]
-   [clojure.data.json :as json]
-   [clojure.spec.alpha :as s]
-   [clojure.tools.logging :as log]
-   [integrant.core :as ig]
-   [lambdaisland.uri :as u]))
-
-(def base-github-uri
-  (u/uri "https://github.com"))
-
-(def base-api-github-uri
-  (u/uri "https://api.github.com"))
-
-(def authorize-uri
-  (assoc base-github-uri :path "/login/oauth/authorize"))
-
-(def token-url
-  (assoc base-github-uri :path "/login/oauth/access_token"))
-
-(def user-info-url
-  (assoc base-api-github-uri :path "/user"))
-
-(def scope "user:email")
-
-
-(defn- build-redirect-url
-  [cfg]
-  (let [public (u/uri (:public-uri cfg))]
-    (str (assoc public :path "/api/oauth/github/callback"))))
-
-(defn- get-access-token
-  [cfg state code]
-  (let [params {:client_id (:client-id cfg)
-                :client_secret (:client-secret cfg)
-                :code code
-                :state state
-                :redirect_uri (build-redirect-url cfg)}
-        req    {:method :post
-                :headers {"content-type" "application/x-www-form-urlencoded"
-                          "accept" "application/json"}
-                :uri  (str token-url)
-                :body (u/map->query-string params)}
-        res    (http/send! req)]
-
-    (when (not= 200 (:status res))
-      (ex/raise :type :internal
-                :code :invalid-response-from-github
-                :context {:status (:status res)
-                          :body (:body res)}))
-    (try
-      (let [data (json/read-str (:body res))]
-        (get data "access_token"))
-      (catch Throwable e
-        (log/error "unexpected error on parsing response body from github access token request" e)
-        nil))))
-
-(defn- get-user-info
-  [token]
-  (let [req {:uri (str user-info-url)
-             :headers {"authorization" (str "token " token)}
-             :method :get}
-        res (http/send! req)]
-
-    (when (not= 200 (:status res))
-      (ex/raise :type :internal
-                :code :invalid-response-from-github
-                :context {:status (:status res)
-                          :body (:body res)}))
-
-    (try
-      (let [data (json/read-str (:body res))]
-        {:email (get data "email")
-         :fullname (get data "name")})
-      (catch Throwable e
-        (log/error "unexpected error on parsing response body from github access token request" e)
-        nil))))
-
-(defn auth
-  [{:keys [tokens] :as cfg} _request]
-  (let [state  (tokens :generate
-                       {:iss :github-oauth
-                        :exp (dt/in-future "15m")})
-
-        params {:client_id (:client-id cfg/config)
-                :redirect_uri (build-redirect-url cfg)
-                :state state
-                :scope scope}
-        query (u/map->query-string params)
-        uri   (-> authorize-uri
-                  (assoc :query query))]
-    {:status 200
-     :body {:redirect-uri (str uri)}}))
-
-(defn callback
-  [{:keys [tokens rpc session] :as cfg} request]
-  (let [state (get-in request [:params :state])
-        _     (tokens :verify {:token state :iss :github-oauth})
-        info  (some->> (get-in request [:params :code])
-                       (get-access-token cfg state)
-                       (get-user-info))]
-
-    (when-not info
-      (ex/raise :type :authentication
-                :code :unable-to-authenticate-with-github))
-
-    (let [method-fn (get-in rpc [:methods :mutation :login-or-register])
-          profile   (method-fn {:email (:email info)
-                                :fullname (:fullname info)})
-          uagent    (get-in request [:headers "user-agent"])
-
-          token     (tokens :generate
-                            {:iss :auth
-                             :exp (dt/in-future "15m")
-                             :profile-id (:id profile)})
-
-          uri       (-> (u/uri (:public-uri cfg/config))
-                        (assoc :path "/#/auth/verify-token")
-                        (assoc :query (u/map->query-string {:token token})))
-
-          sid     (session/create! session {:profile-id (:id profile)
-                                            :user-agent uagent})]
-
-      {:status 302
-       :headers {"location" (str uri)}
-       :cookies (session/cookies session/cookies {:value sid})
-       :body ""})))
-
-;; --- ENTRY POINT
-
-(s/def ::client-id ::us/not-empty-string)
-(s/def ::client-secret ::us/not-empty-string)
-(s/def ::public-uri ::us/not-empty-string)
-(s/def ::session map?)
-(s/def ::tokens fn?)
-
-(defmethod ig/pre-init-spec :app.http.auth/github [_]
-  (s/keys :req-un [::public-uri
-                   ::session
-                   ::tokens]
-          :opt-un [::client-id
-                   ::client-secret]))
-
-(defn- default-handler
-  [_]
-  (ex/raise :type :not-found))
-
-(defmethod ig/init-key :app.http.auth/github
-  [_ cfg]
-  (if (and (:client-id cfg)
-           (:client-secret cfg))
-    {:auth-handler #(auth cfg %)
-     :callback-handler #(callback cfg %)}
-    {:auth-handler default-handler
-     :callback-handler default-handler}))
-

backend/src/app/http/auth/gitlab.clj

@@ -1,179 +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/.
-;;
-;; This Source Code Form is "Incompatible With Secondary Licenses", as
-;; defined by the Mozilla Public License, v. 2.0.
-;;
-;; Copyright (c) 2020 UXBOX Labs SL
-
-(ns app.http.auth.gitlab
-  (:require
-   [app.common.data :as d]
-   [app.common.exceptions :as ex]
-   [app.common.spec :as us]
-   [app.http.session :as session]
-   [app.util.http :as http]
-   [app.util.time :as dt]
-   [clojure.data.json :as json]
-   [clojure.spec.alpha :as s]
-   [clojure.tools.logging :as log]
-   [integrant.core :as ig]
-   [lambdaisland.uri :as uri]))
-
-(def scope "read_user")
-
-(defn- build-redirect-url
-  [cfg]
-  (let [public (uri/uri (:public-uri cfg))]
-    (str (assoc public :path "/api/oauth/gitlab/callback"))))
-
-
-(defn- build-oauth-uri
-  [cfg]
-  (let [base-uri (uri/uri (:base-uri cfg))]
-    (assoc base-uri :path "/oauth/authorize")))
-
-
-(defn- build-token-url
-  [cfg]
-  (let [base-uri (uri/uri (:base-uri cfg))]
-    (str (assoc base-uri :path "/oauth/token"))))
-
-
-(defn- build-user-info-url
-  [cfg]
-  (let [base-uri (uri/uri (:base-uri cfg))]
-    (str (assoc base-uri :path "/api/v4/user"))))
-
-(defn- get-access-token
-  [cfg code]
-  (let [params {:client_id (:client-id cfg)
-                :client_secret (:client-secret cfg)
-                :code code
-                :grant_type "authorization_code"
-                :redirect_uri (build-redirect-url cfg)}
-        req    {:method :post
-                :headers {"content-type" "application/x-www-form-urlencoded"}
-                :uri (build-token-url cfg)
-                :body (uri/map->query-string params)}
-        res    (http/send! req)]
-
-    (when (not= 200 (:status res))
-      (ex/raise :type :internal
-                :code :invalid-response-from-gitlab
-                :context {:status (:status res)
-                          :body (:body res)}))
-
-    (try
-      (let [data (json/read-str (:body res))]
-        (get data "access_token"))
-      (catch Throwable e
-        (log/error "unexpected error on parsing response body from gitlab access token request" e)
-        nil))))
-
-
-(defn- get-user-info
-  [cfg token]
-  (let [req {:uri (build-user-info-url cfg)
-             :headers {"Authorization" (str "Bearer " token)}
-             :method :get}
-        res (http/send! req)]
-
-    (when (not= 200 (:status res))
-      (ex/raise :type :internal
-                :code :invalid-response-from-gitlab
-                :context {:status (:status res)
-                          :body (:body res)}))
-
-    (try
-      (let [data (json/read-str (:body res))]
-        ;; (clojure.pprint/pprint data)
-        {:email (get data "email")
-         :fullname (get data "name")})
-      (catch Throwable e
-        (log/error "unexpected error on parsing response body from gitlab access token request" e)
-        nil))))
-
-(defn auth
-  [{:keys [tokens] :as cfg} _request]
-  (let [token  (tokens :generate {:iss :gitlab-oauth
-                                  :exp (dt/in-future "15m")})
-
-        params {:client_id (:client-id cfg)
-                :redirect_uri (build-redirect-url cfg)
-                :response_type "code"
-                :state token
-                :scope scope}
-        query  (uri/map->query-string params)
-        uri    (-> (build-oauth-uri cfg)
-                   (assoc :query query))]
-    {:status 200
-     :body {:redirect-uri (str uri)}}))
-
-(defn callback
-  [{:keys [tokens rpc session] :as cfg} request]
-  (let [token (get-in request [:params :state])
-        _     (tokens :verify {:token token :iss :gitlab-oauth})
-        info  (some->> (get-in request [:params :code])
-                       (get-access-token cfg)
-                       (get-user-info cfg))]
-
-    (when-not info
-      (ex/raise :type :authentication
-                :code :unable-to-authenticate-with-gitlab))
-
-    (let [method-fn (get-in rpc [:methods :mutation :login-or-register])
-          profile   (method-fn {:email (:email info)
-                                :fullname (:fullname info)})
-          uagent    (get-in request [:headers "user-agent"])
-
-          token     (tokens :generate {:iss :auth
-                                       :exp (dt/in-future "15m")
-                                       :profile-id (:id profile)})
-
-          uri       (-> (uri/uri (:public-uri cfg))
-                        (assoc :path "/#/auth/verify-token")
-                        (assoc :query (uri/map->query-string {:token token})))
-
-          sid       (session/create! session {:profile-id (:id profile)
-                                              :user-agent uagent})]
-      {:status 302
-       :headers {"location" (str uri)}
-       :cookies (session/cookies session {:value sid})
-       :body ""})))
-
-
-(s/def ::client-id ::us/not-empty-string)
-(s/def ::client-secret ::us/not-empty-string)
-(s/def ::base-uri ::us/not-empty-string)
-(s/def ::public-uri ::us/not-empty-string)
-(s/def ::session map?)
-(s/def ::tokens fn?)
-
-(defmethod ig/pre-init-spec :app.http.auth/gitlab [_]
-  (s/keys :req-un [::public-uri
-                   ::session
-                   ::tokens]
-          :opt-un [::base-uri
-                   ::client-id
-                   ::client-secret]))
-
-
-(defmethod ig/prep-key :app.http.auth/gitlab
-  [_ cfg]
-  (d/merge {:base-uri "https://gitlab.com"}
-           (d/without-nils cfg)))
-
-(defn- default-handler
-  [_]
-  (ex/raise :type :not-found))
-
-(defmethod ig/init-key :app.http.auth/gitlab
-  [_ cfg]
-  (if (and (:client-id cfg)
-           (:client-secret cfg))
-    {:auth-handler #(auth cfg %)
-     :callback-handler #(callback cfg %)}
-    {:auth-handler default-handler
-     :callback-handler default-handler}))

backend/src/app/http/auth/google.clj

@@ -1,149 +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/.
-;;
-;; This Source Code Form is "Incompatible With Secondary Licenses", as
-;; defined by the Mozilla Public License, v. 2.0.
-;;
-;; Copyright (c) 2020 UXBOX Labs SL
-
-(ns app.http.auth.google
-  (:require
-   [app.common.exceptions :as ex]
-   [app.common.spec :as us]
-   [app.http.session :as session]
-   [app.util.http :as http]
-   [app.util.time :as dt]
-   [clojure.data.json :as json]
-   [clojure.spec.alpha :as s]
-   [clojure.tools.logging :as log]
-   [integrant.core :as ig]
-   [lambdaisland.uri :as uri]))
-
-(def base-goauth-uri "https://accounts.google.com/o/oauth2/v2/auth")
-
-(def scope
-  (str "email profile "
-       "https://www.googleapis.com/auth/userinfo.email "
-       "https://www.googleapis.com/auth/userinfo.profile "
-       "openid"))
-
-(defn- build-redirect-url
-  [cfg]
-  (let [public (uri/uri (:public-uri cfg))]
-    (str (assoc public :path "/api/oauth/google/callback"))))
-
-(defn- get-access-token
-  [cfg code]
-  (try
-    (let [params {:code code
-                  :client_id (:client-id cfg)
-                  :client_secret (:client-secret cfg)
-                  :redirect_uri (build-redirect-url cfg)
-                  :grant_type "authorization_code"}
-          req    {:method :post
-                  :headers {"content-type" "application/x-www-form-urlencoded"}
-                  :uri "https://oauth2.googleapis.com/token"
-                  :body (uri/map->query-string params)}
-          res    (http/send! req)]
-
-      (when (= 200 (:status res))
-        (-> (json/read-str (:body res))
-            (get "access_token"))))
-
-    (catch Exception e
-      (log/error e "unexpected error on get-access-token")
-      nil)))
-
-(defn- get-user-info
-  [token]
-  (try
-    (let [req {:uri "https://openidconnect.googleapis.com/v1/userinfo"
-               :headers {"Authorization" (str "Bearer " token)}
-               :method :get}
-          res (http/send! req)]
-      (when (= 200 (:status res))
-        (let [data (json/read-str (:body res))]
-          {:email (get data "email")
-           :fullname (get data "name")})))
-    (catch Exception e
-      (log/error e "unexpected exception on get-user-info")
-      nil)))
-
-(defn- auth
-  [{:keys [tokens] :as cfg} _req]
-  (let [token  (tokens :generate {:iss :google-oauth :exp (dt/in-future "15m")})
-        params {:scope scope
-                :access_type "offline"
-                :include_granted_scopes true
-                :state token
-                :response_type "code"
-                :redirect_uri (build-redirect-url cfg)
-                :client_id (:client-id cfg)}
-        query  (uri/map->query-string params)
-        uri    (-> (uri/uri base-goauth-uri)
-                   (assoc :query query))]
-    {:status 200
-     :body {:redirect-uri (str uri)}}))
-
-(defn- callback
-  [{:keys [tokens rpc session] :as cfg} request]
-  (try
-    (let [token (get-in request [:params :state])
-          _     (tokens :verify {:token token :iss :google-oauth})
-          info  (some->> (get-in request [:params :code])
-                         (get-access-token cfg)
-                         (get-user-info))
-          _     (when-not info
-                  (ex/raise :type :internal
-                            :code :unable-to-auth))
-          method-fn (get-in rpc [:methods :mutation :login-or-register])
-          profile   (method-fn {:email (:email info)
-                                :fullname (:fullname info)})
-          uagent    (get-in request [:headers "user-agent"])
-          token     (tokens :generate {:iss :auth
-                                       :exp (dt/in-future "15m")
-                                       :profile-id (:id profile)})
-          uri       (-> (uri/uri (:public-uri cfg))
-                        (assoc :path "/#/auth/verify-token")
-                        (assoc :query (uri/map->query-string {:token token})))
-
-          sid       (session/create! session {:profile-id (:id profile)
-                                              :user-agent uagent})]
-      {:status 302
-       :headers {"location" (str uri)}
-       :cookies (session/cookies session {:value sid})
-       :body ""})
-    (catch Exception _e
-      (let [uri (-> (uri/uri (:public-uri cfg))
-                    (assoc :path "/#/auth/login")
-                    (assoc :query (uri/map->query-string {:error "unable-to-auth"})))]
-        {:status 302
-         :headers {"location" (str uri)}
-         :body ""}))))
-
-(s/def ::client-id ::us/not-empty-string)
-(s/def ::client-secret ::us/not-empty-string)
-(s/def ::public-uri ::us/not-empty-string)
-(s/def ::session map?)
-(s/def ::tokens fn?)
-
-(defmethod ig/pre-init-spec :app.http.auth/google [_]
-  (s/keys :req-un [::public-uri
-                   ::session
-                   ::tokens]
-          :opt-un [::client-id
-                   ::client-secret]))
-
-(defn- default-handler
-  [_]
-  (ex/raise :type :not-found))
-
-(defmethod ig/init-key :app.http.auth/google
-  [_ cfg]
-  (if (and (:client-id cfg)
-           (:client-secret cfg))
-    {:auth-handler #(auth cfg %)
-     :callback-handler #(callback cfg %)}
-    {:auth-handler default-handler
-     :callback-handler default-handler}))

backend/src/app/http/auth/ldap.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/.
-;;
-;; This Source Code Form is "Incompatible With Secondary Licenses", as
-;; defined by the Mozilla Public License, v. 2.0.
-;;
-;; Copyright (c) 2020 UXBOX Labs SL
-
-(ns app.http.auth.ldap
-  (:require
-   [app.common.exceptions :as ex]
-   [app.config :as cfg]
-   [app.http.session :as session]
-   [clj-ldap.client :as client]
-   [clojure.set :as set]
-   [clojure.spec.alpha :as s]
-   [clojure.string ]
-   [clojure.tools.logging :as log]
-   [integrant.core :as ig]))
-
-(declare authenticate)
-(declare create-connection)
-(declare replace-several)
-
-
-(s/def ::host ::cfg/ldap-auth-host)
-(s/def ::port ::cfg/ldap-auth-port)
-(s/def ::ssl ::cfg/ldap-auth-ssl)
-(s/def ::starttls ::cfg/ldap-auth-starttls)
-(s/def ::user-query ::cfg/ldap-auth-user-query)
-(s/def ::base-dn ::cfg/ldap-auth-base-dn)
-(s/def ::username-attribute ::cfg/ldap-auth-username-attribute)
-(s/def ::email-attribute ::cfg/ldap-auth-email-attribute)
-(s/def ::fullname-attribute ::cfg/ldap-auth-fullname-attribute)
-(s/def ::avatar-attribute ::cfg/ldap-auth-avatar-attribute)
-
-(s/def ::rpc map?)
-(s/def ::session map?)
-
-(defmethod ig/pre-init-spec :app.http.auth/ldap
-  [_]
-  (s/keys
-   :req-un [::rpc ::session]
-   :opt-un [::host
-            ::port
-            ::ssl
-            ::starttls
-            ::username-attribute
-            ::base-dn
-            ::username-attribute
-            ::email-attribute
-            ::fullname-attribute
-            ::avatar-attribute]))
-
-(defmethod ig/init-key :app.http.auth/ldap
-  [_ {:keys [session rpc] :as cfg}]
-  (let [conn (create-connection cfg)]
-    (with-meta
-      (fn [request]
-        (let [data   (:body-params request)]
-          (when-some [info (authenticate (assoc cfg
-                                                :conn conn
-                                                :username (:email data)
-                                                :password (:password data)))]
-            (let [method-fn (get-in rpc [:methods :mutation :login-or-register])
-                  profile   (method-fn {:email (:email info)
-                                        :fullname (:fullname info)})
-                  uagent    (get-in request [:headers "user-agent"])
-                  sid       (session/create! session {:profile-id (:id profile)
-                                                      :user-agent uagent})]
-              {:status 200
-               :cookies (session/cookies session {:value sid})
-               :body profile}))))
-      {::conn conn})))
-
-(defmethod ig/halt-key! ::client
-  [_ handler]
-  (let [{:keys [::conn]} (meta handler)]
-    (when (realized? conn)
-      (.close @conn))))
-
-(defn- replace-several [s & {:as replacements}]
-  (reduce-kv clojure.string/replace s replacements))
-
-(defn- create-connection
-  [cfg]
-  (let [params (merge {:host {:address (:host cfg)
-                              :port (:port cfg)}}
-                      (-> cfg
-                          (select-keys [:ssl
-                                        :starttls
-                                        :ldap-bind-dn
-                                        :ldap-bind-password])
-                          (set/rename-keys {:ssl :ssl?
-                                            :starttls :startTLS?
-                                            :ldap-bind-dn  :bind-dn
-                                            :ldap-bind-password :password})))]
-    (delay
-      (try
-        (client/connect params)
-        (catch Exception e
-          (log/errorf e "Cannot connect to LDAP %s:%s"
-                      (:host cfg) (:port cfg)))))))
-
-
-(defn- authenticate
-  [{:keys [conn username password] :as cfg}]
-  (when-some [conn (some-> conn deref)]
-    (let [user-search-query (replace-several (:user-query cfg) "$username" username)
-          user-attributes   (-> cfg
-                                (select-keys [:username-attribute
-                                              :email-attribute
-                                              :fullname-attribute
-                                              :avatar-attribute])
-                                vals)]
-      (when-some [user-entry (-> conn
-                                 (client/search (:base-dn cfg)
-                                                {:filter user-search-query
-                                                 :sizelimit 1
-                                                 :attributes user-attributes})
-                                 (first))]
-        (when-not (client/bind? conn (:dn user-entry) password)
-          (ex/raise :type :authentication
-                    :code :wrong-credentials))
-        (set/rename-keys user-entry {(keyword (:avatar-attribute cfg)) :photo
-                                     (keyword (:fullname-attribute cfg)) :fullname
-                                     (keyword (:email-attribute cfg)) :email})))))
-

backend/src/app/http/awsns.clj

@@ -0,0 +1,207 @@
+;; 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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.http.awsns
+  "AWS SNS webhook handler for bounces."
+  (:require
+   [app.common.exceptions :as ex]
+   [app.db :as db]
+   [app.db.sql :as sql]
+   [app.util.http :as http]
+   [clojure.pprint :refer [pprint]]
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [cuerdas.core :as str]
+   [integrant.core :as ig]
+   [jsonista.core :as j]))
+
+(declare parse-json)
+(declare parse-notification)
+(declare process-report)
+
+(defn- pprint-report
+  [message]
+  (binding [clojure.pprint/*print-right-margin* 120]
+    (with-out-str (pprint message))))
+
+(defmethod ig/pre-init-spec ::handler [_]
+  (s/keys :req-un [::db/pool]))
+
+(defmethod ig/init-key ::handler
+  [_ cfg]
+  (fn [request]
+    (let [body  (parse-json (slurp (:body request)))
+          mtype (get body "Type")]
+      (cond
+        (= mtype "SubscriptionConfirmation")
+        (let [surl   (get body "SubscribeURL")
+              stopic (get body "TopicArn")]
+          (log/infof "subscription received (topic=%s, url=%s)" stopic surl)
+          (http/send! {:uri surl :method :post :timeout 10000}))
+
+        (= mtype "Notification")
+        (when-let [message (parse-json (get body "Message"))]
+          ;; (log/infof "Received: %s" (pr-str message))
+          (let [notification (parse-notification cfg message)]
+            (process-report cfg notification)))
+
+        :else
+        (log/warn (str "unexpected data received\n"
+                       (pprint-report body))))
+
+      {:status 200 :body ""})))
+
+(defn- parse-bounce
+  [data]
+  {:type        "bounce"
+   :kind        (str/lower (get data "bounceType"))
+   :category    (str/lower (get data "bounceSubType"))
+   :feedback-id (get data "feedbackId")
+   :timestamp   (get data "timestamp")
+   :recipients  (->> (get data "bouncedRecipients")
+                     (mapv (fn [item]
+                             {:email  (str/lower (get item "emailAddress"))
+                              :status (get item "status")
+                              :action (get item "action")
+                              :dcode  (get item "diagnosticCode")})))})
+
+(defn- parse-complaint
+  [data]
+  {:type          "complaint"
+   :user-agent    (get data "userAgent")
+   :kind          (get data "complaintFeedbackType")
+   :category      (get data "complaintSubType")
+   :timestamp     (get data "arrivalDate")
+   :feedback-id   (get data "feedbackId")
+   :recipients    (->> (get data "complainedRecipients")
+                       (mapv #(get % "emailAddress"))
+                       (mapv str/lower))})
+
+(defn- extract-headers
+  [mail]
+  (reduce (fn [acc item]
+            (let [key (get item "name")
+                  val (get item "value")]
+              (assoc acc (str/lower key) val)))
+          {}
+          (get mail "headers")))
+
+(defn- extract-identity
+  [{:keys [tokens] :as cfg} headers]
+  (let [tdata (get headers "x-penpot-data")]
+    (when-not (str/empty? tdata)
+      (let [result (tokens :verify {:token tdata :iss :profile-identity})]
+        (:profile-id result)))))
+
+(defn- parse-notification
+  [cfg message]
+  (let [type (get message "notificationType")
+        data (case type
+               "Bounce" (parse-bounce (get message "bounce"))
+               "Complaint" (parse-complaint (get message "complaint"))
+               {:type (keyword (str/lower type))
+                :message message})]
+    (when data
+      (let [mail (get message "mail")]
+        (when-not mail
+          (ex/raise :type :internal
+                    :code :incomplete-notification
+                    :hint "no email data received, please enable full headers report"))
+        (let [headers (extract-headers mail)
+              mail    {:destination (get mail "destination")
+                       :source      (get mail "source")
+                       :timestamp   (get mail "timestamp")
+                       :subject     (get-in mail ["commonHeaders" "subject"])
+                       :headers     headers}]
+          (assoc data
+                 :mail mail
+                 :profile-id (extract-identity cfg headers)))))))
+
+(defn- parse-json
+  [v]
+  (ex/ignoring
+   (j/read-value v)))
+
+(defn- register-bounce-for-profile
+  [{:keys [pool]} {:keys [type kind profile-id] :as report}]
+  (when (= kind "permanent")
+    (db/with-atomic [conn pool]
+      (db/insert! conn :profile-complaint-report
+                  {:profile-id profile-id
+                   :type (name type)
+                   :content (db/tjson report)})
+
+      ;; TODO: maybe also try to find profiles by mail and if exists
+      ;; register profile reports for them?
+      (doseq [recipient (:recipients report)]
+        (db/insert! conn :global-complaint-report
+                    {:email (:email recipient)
+                     :type (name type)
+                     :content (db/tjson report)}))
+
+      (let [profile (db/exec-one! conn (sql/select :profile {:id profile-id}))]
+        (when (some #(= (:email profile) (:email %)) (:recipients report))
+          ;; If the report matches the profile email, this means that
+          ;; the report is for itself, can be caused when a user
+          ;; registers with an invalid email or the user email is
+          ;; permanently rejecting receiving the email. In this case we
+          ;; have no option to mark the user as muted (and in this case
+          ;; the profile will be also inactive.
+          (db/update! conn :profile
+                      {:is-muted true}
+                      {:id profile-id}))))))
+
+(defn- register-complaint-for-profile
+  [{:keys [pool]} {:keys [type profile-id] :as report}]
+  (db/with-atomic [conn pool]
+    (db/insert! conn :profile-complaint-report
+                {:profile-id profile-id
+                 :type (name type)
+                 :content (db/tjson report)})
+
+    ;; TODO: maybe also try to find profiles by email and if exists
+    ;; register profile reports for them?
+    (doseq [email (:recipients report)]
+      (db/insert! conn :global-complaint-report
+                  {:email email
+                   :type (name type)
+                   :content (db/tjson report)}))
+
+    (let [profile (db/exec-one! conn (sql/select :profile {:id profile-id}))]
+      (when (some #(= % (:email profile)) (:recipients report))
+        ;; If the report matches the profile email, this means that
+        ;; the report is for itself, rare case but can happen; In this
+        ;; case just mark profile as muted (very rare case).
+        (db/update! conn :profile
+                    {:is-muted true}
+                    {:id profile-id})))))
+
+(defn- process-report
+  [cfg {:keys [type profile-id] :as report}]
+  (log/trace (str "procesing report:\n" (pprint-report report)))
+  (cond
+    ;; In this case we receive a bounce/complaint notification without
+    ;; confirmed identity, we just emit a warning but do nothing about
+    ;; it because this is not a normal case. All notifications should
+    ;; come with profile identity.
+    (nil? profile-id)
+    (log/warn (str "a notification without identity recevied from AWS\n"
+                   (pprint-report report)))
+
+    (= "bounce" type)
+    (register-bounce-for-profile cfg report)
+
+    (= "complaint" type)
+    (register-complaint-for-profile cfg report)
+
+    :else
+    (log/warn (str "unrecognized report received from AWS\n"
+                   (pprint-report report)))))
+
+

backend/src/app/http/errors.clj

@@ -10,8 +10,8 @@
 (ns app.http.errors
   "A errors handling for the http server."
   (:require
+   [app.common.exceptions :as ex]
    [app.common.uuid :as uuid]
-   [app.config :as cfg]
    [app.util.log4j :refer [update-thread-context!]]
    [clojure.tools.logging :as log]
    [cuerdas.core :as str]
@@ -30,16 +30,10 @@
       :path    (:uri request)
       :method  (:request-method request)
       :params  (:params request)
-      :version (:full cfg/version)
-      :host    (:public-uri cfg/config)
-      :class   (.getCanonicalName ^java.lang.Class (class error))
-      :hint    (ex-message error)
       :data    edata}
-
      (let [headers (:headers request)]
        {:user-agent (get headers "user-agent")
         :frontend-version (get headers "x-frontend-version" "unknown")})
-
      (when (and (map? edata) (:data edata))
        {:explain (explain-error edata)}))))
 
@@ -53,6 +47,11 @@
   [err _]
   {:status 401 :body (ex-data err)})
 
+
+(defmethod handle-exception :restriction
+  [err _]
+  {:status 400 :body (ex-data err)})
+
 (defmethod handle-exception :validation
   [err req]
   (let [header (get-in req [:headers "accept"])
@@ -75,7 +74,7 @@
   (let [edata (ex-data error)
         cdata (get-error-context request error)]
     (update-thread-context! cdata)
-    (log/errorf error "Internal error: assertion (id: %s)" (str (:id cdata)))
+    (log/errorf error "internal error: assertion (id: %s)" (str (:id cdata)))
     {:status 500
      :body {:type :server-error
             :data (-> edata
@@ -88,15 +87,54 @@
 
 (defmethod handle-exception :default
   [error request]
-  (let [cdata (get-error-context request error)]
+  (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)
+      (let [cdata (get-error-context request error)]
+        (update-thread-context! cdata)
+        (log/errorf error "internal error: %s (id: %s)"
+                    (ex-message error)
+                    (str (:id cdata)))
+        {:status 500
+         :body {:type :server-error
+                :hint (ex-message error)
+                :data edata}}))))
+
+(defmethod handle-exception org.postgresql.util.PSQLException
+  [error request]
+  (let [cdata (get-error-context request error)
+        state (.getSQLState ^java.sql.SQLException error)]
+
     (update-thread-context! cdata)
-    (log/errorf error "Internal error: %s (id: %s)"
+    (log/errorf error "PSQL Exception: %s (id: %s, state: %s)"
                 (ex-message error)
-                (str (:id cdata)))
-    {:status 500
-     :body {:type :server-error
-            :hint (ex-message error)
-            :data (ex-data error)}}))
+                (str (:id cdata))
+                state)
+
+    (cond
+      (= state "57014")
+      {:status 504
+       :body {:type :server-timeout
+              :code :statement-timeout
+              :hint (ex-message error)}}
+
+      (= state "25P03")
+      {:status 504
+       :body {:type :server-timeout
+              :code :idle-in-transaction-timeout
+              :hint (ex-message error)}}
+
+      :else
+      {:status 500
+       :body {:type :server-timeout
+              :hint (ex-message error)
+              :state state}})))
 
 (defn handle
   [error req]

backend/src/app/http/feedback.clj

@@ -0,0 +1,72 @@
+;; 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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2021 UXBOX Labs SL
+
+(ns app.http.feedback
+  "A general purpose feedback module."
+  (:require
+   [app.common.data :as d]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.emails :as emails]
+   [app.rpc.queries.profile :as profile]
+   [clojure.spec.alpha :as s]
+   [integrant.core :as ig]))
+
+(declare send-feedback)
+
+(defmethod ig/pre-init-spec ::handler [_]
+  (s/keys :req-un [::db/pool]))
+
+(defmethod ig/init-key ::handler
+  [_ {:keys [pool] :as scfg}]
+  (let [ftoken   (cfg/get :feedback-token ::no-token)
+        enabled  (cfg/get :feedback-enabled)]
+    (fn [{:keys [profile-id] :as request}]
+      (let [token  (get-in request [:headers "x-feedback-token"])
+            params (d/merge (:params request)
+                            (:body-params request))]
+
+        (when-not enabled
+          (ex/raise :type :validation
+                    :code :feedback-disabled
+                    :hint "feedback module is disabled"))
+
+        (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 scfg nil params))
+
+        {:status 204 :body ""}))))
+
+(s/def ::content ::us/string)
+(s/def ::from    ::us/email)
+(s/def ::subject ::us/string)
+
+(s/def ::feedback
+  (s/keys :req-un [::from ::subject ::content]))
+
+(defn send-feedback
+  [pool profile params]
+  (let [params      (us/conform ::feedback params)
+        destination (cfg/get :feedback-destination)]
+    (emails/send! pool emails/feedback
+                  {:to       destination
+                   :profile  profile
+                   :reply-to (:from params)
+                   :email    (:from params)
+                   :subject  (:subject params)
+                   :content  (:content params)})
+    nil))

backend/src/app/http/middleware.clj

@@ -12,6 +12,8 @@
    [app.metrics :as mtx]
    [app.util.json :as json]
    [app.util.transit :as t]
+   [buddy.core.codecs :as bc]
+   [buddy.core.hash :as bh]
    [clojure.java.io :as io]
    [ring.middleware.cookies :refer [wrap-cookies]]
    [ring.middleware.keyword-params :refer [wrap-keyword-params]]
@@ -119,8 +121,6 @@
    :wrap (fn [handler]
            (mtx/wrap-counter handler {:id "http__requests_counter"
                                       :help "Absolute http requests counter."}))})
-
-
 (def cookies
   {:name ::cookies
    :compile (constantly wrap-cookies)})
@@ -140,3 +140,28 @@
 (def server-timing
   {:name ::server-timing
    :compile (constantly wrap-server-timing)})
+
+(defn wrap-etag
+  [handler]
+  (letfn [(generate-etag [{:keys [body] :as response}]
+            (str "W/\"" (-> body bh/blake2b-128 bc/bytes->hex) "\""))
+          (get-match [{:keys [headers] :as request}]
+            (get headers "if-none-match"))]
+    (fn [request]
+      (let [response (handler request)]
+        (if (= :get (:request-method request))
+          (let [etag     (generate-etag response)
+                match    (get-match request)
+                response (update response :headers #(assoc % "ETag" etag))]
+            (cond-> response
+              (and (string? match)
+                   (= :get (:request-method request))
+                   (= etag match))
+              (-> response
+                  (assoc :body "")
+                  (assoc :status 304))))
+          response)))))
+
+(def etag
+  {:name ::etag
+   :compile (constantly wrap-etag)})

backend/src/app/http/oauth/github.clj

@@ -0,0 +1,159 @@
+;; 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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2020-2021 UXBOX Labs SL
+
+(ns app.http.oauth.github
+  (:require
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.config :as cfg]
+   [app.http.oauth.google :as gg]
+   [app.util.http :as http]
+   [app.util.time :as dt]
+   [clojure.data.json :as json]
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [integrant.core :as ig]
+   [lambdaisland.uri :as u]))
+
+(def base-github-uri
+  (u/uri "https://github.com"))
+
+(def base-api-github-uri
+  (u/uri "https://api.github.com"))
+
+(def authorize-uri
+  (assoc base-github-uri :path "/login/oauth/authorize"))
+
+(def token-url
+  (assoc base-github-uri :path "/login/oauth/access_token"))
+
+(def user-info-url
+  (assoc base-api-github-uri :path "/user"))
+
+(def scope "user:email")
+
+(defn- build-redirect-url
+  [cfg]
+  (let [public (u/uri (:public-uri cfg))]
+    (str (assoc public :path "/api/oauth/github/callback"))))
+
+(defn- get-access-token
+  [cfg state code]
+  (try
+    (let [params {:client_id (:client-id cfg)
+                  :client_secret (:client-secret cfg)
+                  :code code
+                  :state state
+                  :redirect_uri (build-redirect-url cfg)}
+          req    {:method :post
+                  :headers {"content-type" "application/x-www-form-urlencoded"
+                            "accept" "application/json"}
+                  :uri  (str token-url)
+                  :timeout 6000
+                  :body (u/map->query-string params)}
+          res    (http/send! req)]
+
+      (when (= 200 (:status res))
+        (-> (json/read-str (:body res))
+            (get "access_token"))))
+
+    (catch Exception e
+      (log/error e "unexpected error on get-access-token")
+      nil)))
+
+(defn- get-user-info
+  [_ token]
+  (try
+    (let [req {:uri (str user-info-url)
+               :headers {"authorization" (str "token " token)}
+               :timeout 6000
+               :method :get}
+          res (http/send! req)]
+      (when (= 200 (:status res))
+        (let [data (json/read-str (:body res))]
+          {:email (get data "email")
+           :backend "github"
+           :fullname (get data "name")})))
+    (catch Exception e
+      (log/error e "unexpected exception on get-user-info")
+      nil)))
+
+(defn- retrieve-info
+  [{:keys [tokens] :as cfg} request]
+  (let [token (get-in request [:params :state])
+        state (tokens :verify {:token token :iss :github-oauth})
+        info  (some->> (get-in request [:params :code])
+                       (get-access-token cfg state)
+                       (get-user-info cfg))]
+    (when-not info
+      (ex/raise :type :internal
+                :code :unable-to-auth))
+
+    (cond-> info
+      (some? (:invitation-token state))
+      (assoc :invitation-token (:invitation-token state)))))
+
+(defn auth-handler
+  [{:keys [tokens] :as cfg} request]
+  (let [invitation (get-in request [:params :invitation-token])
+        state      (tokens :generate {:iss :github-oauth
+                                      :invitation-token invitation
+                                      :exp (dt/in-future "15m")})
+        params     {:client_id (:client-id cfg/config)
+                    :redirect_uri (build-redirect-url cfg)
+                    :state state
+                    :scope scope}
+        query      (u/map->query-string params)
+        uri        (-> authorize-uri
+                       (assoc :query query))]
+    {:status 200
+     :body {:redirect-uri (str uri)}}))
+
+(defn- callback-handler
+  [{:keys [session] :as cfg} request]
+  (try
+    (let [info    (retrieve-info cfg request)
+          profile (gg/register-profile cfg info)
+          uri     (gg/generate-redirect-uri cfg profile)
+          sxf     ((:create session) (:id profile))]
+      (->> (gg/redirect-response uri)
+           (sxf request)))
+    (catch Exception _e
+      (-> (gg/generate-error-redirect-uri cfg)
+          (gg/redirect-response)))))
+
+
+;; --- ENTRY POINT
+
+(s/def ::client-id ::us/not-empty-string)
+(s/def ::client-secret ::us/not-empty-string)
+(s/def ::public-uri ::us/not-empty-string)
+(s/def ::session map?)
+(s/def ::tokens fn?)
+
+(defmethod ig/pre-init-spec :app.http.oauth/github [_]
+  (s/keys :req-un [::public-uri
+                   ::session
+                   ::tokens]
+          :opt-un [::client-id
+                   ::client-secret]))
+
+(defn- default-handler
+  [_]
+  (ex/raise :type :not-found))
+
+(defmethod ig/init-key :app.http.oauth/github
+  [_ cfg]
+  (if (and (:client-id cfg)
+           (:client-secret cfg))
+    {:handler #(auth-handler cfg %)
+     :callback-handler #(callback-handler cfg %)}
+    {:handler default-handler
+     :callback-handler default-handler}))
+

backend/src/app/http/oauth/gitlab.clj

@@ -0,0 +1,167 @@
+;; 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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2020 UXBOX Labs SL
+
+(ns app.http.oauth.gitlab
+  (:require
+   [app.common.data :as d]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.http.oauth.google :as gg]
+   [app.util.http :as http]
+   [app.util.time :as dt]
+   [clojure.data.json :as json]
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [integrant.core :as ig]
+   [lambdaisland.uri :as u]))
+
+(def scope "read_user")
+
+(defn- build-redirect-url
+  [cfg]
+  (let [public (u/uri (:public-uri cfg))]
+    (str (assoc public :path "/api/oauth/gitlab/callback"))))
+
+(defn- build-oauth-uri
+  [cfg]
+  (let [base-uri (u/uri (:base-uri cfg))]
+    (assoc base-uri :path "/oauth/authorize")))
+
+(defn- build-token-url
+  [cfg]
+  (let [base-uri (u/uri (:base-uri cfg))]
+    (str (assoc base-uri :path "/oauth/token"))))
+
+(defn- build-user-info-url
+  [cfg]
+  (let [base-uri (u/uri (:base-uri cfg))]
+    (str (assoc base-uri :path "/api/v4/user"))))
+
+(defn- get-access-token
+  [cfg code]
+  (try
+    (let [params {:client_id (:client-id cfg)
+                  :client_secret (:client-secret cfg)
+                  :code code
+                  :grant_type "authorization_code"
+                  :redirect_uri (build-redirect-url cfg)}
+          req    {:method :post
+                  :headers {"content-type" "application/x-www-form-urlencoded"}
+                  :uri (build-token-url cfg)
+                  :body (u/map->query-string params)}
+        res    (http/send! req)]
+
+      (when (= 200 (:status res))
+        (-> (json/read-str (:body res))
+            (get "access_token"))))
+
+    (catch Exception e
+      (log/error e "unexpected error on get-access-token")
+      nil)))
+
+(defn- get-user-info
+  [cfg token]
+  (try
+    (let [req {:uri (build-user-info-url cfg)
+               :headers {"Authorization" (str "Bearer " token)}
+               :timeout 6000
+               :method :get}
+          res (http/send! req)]
+
+      (when (= 200 (:status res))
+        (let [data (json/read-str (:body res))]
+          {:email (get data "email")
+           :backend "gitlab"
+           :fullname (get data "name")})))
+
+    (catch Exception e
+      (log/error e "unexpected exception on get-user-info")
+      nil)))
+
+
+(defn- retrieve-info
+  [{:keys [tokens] :as cfg} request]
+  (let [token (get-in request [:params :state])
+        state (tokens :verify {:token token :iss :gitlab-oauth})
+        info  (some->> (get-in request [:params :code])
+                       (get-access-token cfg)
+                       (get-user-info cfg))]
+    (when-not info
+      (ex/raise :type :internal
+                :code :unable-to-auth))
+
+    (cond-> info
+      (some? (:invitation-token state))
+      (assoc :invitation-token (:invitation-token state)))))
+
+
+(defn- auth-handler
+  [{:keys [tokens] :as cfg} request]
+  (let [invitation (get-in request [:params :invitation-token])
+        state      (tokens :generate
+                           {:iss :gitlab-oauth
+                            :invitation-token invitation
+                            :exp (dt/in-future "15m")})
+
+        params     {:client_id (:client-id cfg)
+                    :redirect_uri (build-redirect-url cfg)
+                    :response_type "code"
+                    :state state
+                    :scope scope}
+        query      (u/map->query-string params)
+        uri        (-> (build-oauth-uri cfg)
+                       (assoc :query query))]
+    {:status 200
+     :body {:redirect-uri (str uri)}}))
+
+(defn- callback-handler
+  [{:keys [session] :as cfg} request]
+  (try
+    (let [info    (retrieve-info cfg request)
+          profile (gg/register-profile cfg info)
+          uri     (gg/generate-redirect-uri cfg profile)
+          sxf     ((:create session) (:id profile))]
+      (->> (gg/redirect-response uri)
+           (sxf request)))
+    (catch Exception _e
+      (-> (gg/generate-error-redirect-uri cfg)
+          (gg/redirect-response)))))
+
+(s/def ::client-id ::us/not-empty-string)
+(s/def ::client-secret ::us/not-empty-string)
+(s/def ::base-uri ::us/not-empty-string)
+(s/def ::public-uri ::us/not-empty-string)
+(s/def ::session map?)
+(s/def ::tokens fn?)
+
+(defmethod ig/pre-init-spec :app.http.oauth/gitlab [_]
+  (s/keys :req-un [::public-uri
+                   ::session
+                   ::tokens]
+          :opt-un [::base-uri
+                   ::client-id
+                   ::client-secret]))
+
+(defmethod ig/prep-key :app.http.oauth/gitlab
+  [_ cfg]
+  (d/merge {:base-uri "https://gitlab.com"}
+           (d/without-nils cfg)))
+
+(defn- default-handler
+  [_]
+  (ex/raise :type :not-found))
+
+(defmethod ig/init-key :app.http.oauth/gitlab
+  [_ cfg]
+  (if (and (:client-id cfg)
+           (:client-secret cfg))
+    {:handler #(auth-handler cfg %)
+     :callback-handler #(callback-handler cfg %)}
+    {:handler default-handler
+     :callback-handler default-handler}))

backend/src/app/http/oauth/google.clj

@@ -0,0 +1,182 @@
+;; 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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2020-2021 UXBOX Labs SL
+
+(ns app.http.oauth.google
+  (:require
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.util.http :as http]
+   [app.util.time :as dt]
+   [clojure.data.json :as json]
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [integrant.core :as ig]
+   [lambdaisland.uri :as u]))
+
+(def base-goauth-uri "https://accounts.google.com/o/oauth2/v2/auth")
+
+(def scope
+  (str "email profile "
+       "https://www.googleapis.com/auth/userinfo.email "
+       "https://www.googleapis.com/auth/userinfo.profile "
+       "openid"))
+
+(defn- build-redirect-url
+  [cfg]
+  (let [public (u/uri (:public-uri cfg))]
+    (str (assoc public :path "/api/oauth/google/callback"))))
+
+(defn- get-access-token
+  [cfg code]
+  (try
+    (let [params {:code code
+                  :client_id (:client-id cfg)
+                  :client_secret (:client-secret cfg)
+                  :redirect_uri (build-redirect-url cfg)
+                  :grant_type "authorization_code"}
+          req    {:method :post
+                  :headers {"content-type" "application/x-www-form-urlencoded"}
+                  :uri "https://oauth2.googleapis.com/token"
+                  :timeout 6000
+                  :body (u/map->query-string params)}
+          res    (http/send! req)]
+
+      (when (= 200 (:status res))
+        (-> (json/read-str (:body res))
+            (get "access_token"))))
+    (catch Exception e
+      (log/error e "unexpected error on get-access-token")
+      nil)))
+
+(defn- get-user-info
+  [_ token]
+  (try
+    (let [req {:uri "https://openidconnect.googleapis.com/v1/userinfo"
+               :headers {"Authorization" (str "Bearer " token)}
+               :timeout 6000
+               :method :get}
+          res (http/send! req)]
+
+      (when (= 200 (:status res))
+        (let [data (json/read-str (:body res))]
+          {:email (get data "email")
+           :backend "google"
+           :fullname (get data "name")})))
+    (catch Exception e
+      (log/error e "unexpected exception on get-user-info")
+      nil)))
+
+(defn- retrieve-info
+  [{:keys [tokens] :as cfg} request]
+  (let [token (get-in request [:params :state])
+        state (tokens :verify {:token token :iss :google-oauth})
+        info  (some->> (get-in request [:params :code])
+                       (get-access-token cfg)
+                       (get-user-info cfg))]
+
+
+    (when-not info
+      (ex/raise :type :internal
+                :code :unable-to-auth))
+
+    (cond-> info
+      (some? (:invitation-token state))
+      (assoc :invitation-token (:invitation-token state)))))
+
+(defn register-profile
+  [{:keys [rpc] :as cfg} info]
+  (let [method-fn (get-in rpc [:methods :mutation :login-or-register])
+        profile   (method-fn {:email (:email info)
+                              :backend (:backend info)
+                              :fullname (:fullname info)})]
+    (cond-> profile
+      (some? (:invitation-token info))
+      (assoc :invitation-token (:invitation-token info)))))
+
+(defn generate-redirect-uri
+  [{:keys [tokens] :as cfg} profile]
+  (let [token (or (:invitation-token profile)
+                  (tokens :generate {:iss :auth
+                                     :exp (dt/in-future "15m")
+                                     :profile-id (:id profile)}))]
+    (-> (u/uri (:public-uri cfg))
+        (assoc :path "/#/auth/verify-token")
+        (assoc :query (u/map->query-string {:token token})))))
+
+(defn generate-error-redirect-uri
+  [cfg]
+  (-> (u/uri (:public-uri cfg))
+      (assoc :path "/#/auth/login")
+      (assoc :query (u/map->query-string {:error "unable-to-auth"}))))
+
+(defn redirect-response
+  [uri]
+  {:status 302
+   :headers {"location" (str uri)}
+   :body ""})
+
+(defn- auth-handler
+  [{:keys [tokens] :as cfg} request]
+  (let [invitation (get-in request [:params :invitation-token])
+        state      (tokens :generate
+                           {:iss :google-oauth
+                            :invitation-token invitation
+                            :exp (dt/in-future "15m")})
+        params     {:scope scope
+                    :access_type "offline"
+                    :include_granted_scopes true
+                    :state state
+                    :response_type "code"
+                    :redirect_uri (build-redirect-url cfg)
+                    :client_id (:client-id cfg)}
+        query      (u/map->query-string params)
+        uri        (-> (u/uri base-goauth-uri)
+                       (assoc :query query))]
+
+    {:status 200
+     :body {:redirect-uri (str uri)}}))
+
+(defn- callback-handler
+  [{:keys [session] :as cfg} request]
+  (try
+    (let [info    (retrieve-info cfg request)
+          profile (register-profile cfg info)
+          uri     (generate-redirect-uri cfg profile)
+          sxf     ((:create session) (:id profile))]
+      (->> (redirect-response uri)
+           (sxf request)))
+    (catch Exception _e
+      (-> (generate-error-redirect-uri cfg)
+          (redirect-response)))))
+
+(s/def ::client-id ::us/not-empty-string)
+(s/def ::client-secret ::us/not-empty-string)
+(s/def ::public-uri ::us/not-empty-string)
+(s/def ::session map?)
+(s/def ::tokens fn?)
+
+(defmethod ig/pre-init-spec :app.http.oauth/google [_]
+  (s/keys :req-un [::public-uri
+                   ::session
+                   ::tokens]
+          :opt-un [::client-id
+                   ::client-secret]))
+
+(defn- default-handler
+  [_]
+  (ex/raise :type :not-found))
+
+(defmethod ig/init-key :app.http.oauth/google
+  [_ cfg]
+  (if (and (:client-id cfg)
+           (:client-secret cfg))
+    {:handler #(auth-handler cfg %)
+     :callback-handler #(callback-handler cfg %)}
+    {:handler default-handler
+     :callback-handler default-handler}))

backend/src/app/http/session.clj

@@ -9,21 +9,32 @@
 
 (ns app.http.session
   (:require
+   [app.common.data :as d]
+   [app.common.exceptions :as ex]
+   [app.config :as cfg]
    [app.db :as db]
+   [app.metrics :as mtx]
+   [app.util.async :as aa]
    [app.util.log4j :refer [update-thread-context!]]
+   [app.util.time :as dt]
+   [app.worker :as wrk]
    [buddy.core.codecs :as bc]
    [buddy.core.nonce :as bn]
+   [clojure.core.async :as a]
    [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
    [integrant.core :as ig]))
 
-(defn next-session-id
+;; --- IMPL
+
+(defn- next-session-id
   ([] (next-session-id 96))
   ([n]
    (-> (bn/random-nonce n)
        (bc/bytes->b64u)
        (bc/bytes->str))))
 
-(defn create!
+(defn- create
   [{:keys [conn] :as cfg} {:keys [profile-id user-agent]}]
   (let [id (next-session-id)]
     (db/insert! conn :http-session {:id id
@@ -31,44 +42,177 @@
                                     :user-agent user-agent})
     id))
 
-(defn delete!
-  [{:keys [conn cookie-name] :as cfg} request]
-  (when-let [token (get-in request [:cookies cookie-name :value])]
+(defn- delete
+  [{:keys [conn cookie-name] :as cfg} {:keys [cookies] :as request}]
+  (when-let [token (get-in cookies [cookie-name :value])]
     (db/delete! conn :http-session {:id token}))
   nil)
 
-(defn retrieve
+(defn- retrieve
   [{:keys [conn] :as cfg} token]
   (when token
-    (-> (db/exec-one! conn ["select profile_id from http_session where id = ?" token])
-        (:profile-id))))
+    (db/exec-one! conn ["select id, profile_id from http_session where id = ?" token])))
 
-(defn retrieve-from-request
-  [{:keys [cookie-name] :as cfg} request]
-  (->> (get-in request [:cookies cookie-name :value])
+(defn- retrieve-from-request
+  [{:keys [cookie-name] :as cfg} {:keys [cookies] :as request}]
+  (->> (get-in cookies [cookie-name :value])
        (retrieve cfg)))
 
-(defn cookies
+(defn- cookies
   [{:keys [cookie-name] :as cfg} vals]
   {cookie-name (merge vals {:path "/" :http-only true})})
 
-(defn middleware
+(defn- middleware
   [cfg handler]
   (fn [request]
-    (if-let [profile-id (retrieve-from-request cfg request)]
-      (do
+    (if-let [{:keys [id profile-id] :as session} (retrieve-from-request cfg request)]
+      (let [ech (::events-ch cfg)]
+        (a/>!! ech id)
         (update-thread-context! {:profile-id profile-id})
         (handler (assoc request :profile-id profile-id)))
       (handler request))))
 
+;; --- STATE INIT: SESSION
+
+(s/def ::cookie-name ::cfg/http-session-cookie-name)
+
 (defmethod ig/pre-init-spec ::session [_]
-  (s/keys :req-un [::db/pool]))
+  (s/keys :req-un [::db/pool]
+          :opt-un [::cookie-name]))
 
 (defmethod ig/prep-key ::session
   [_ cfg]
-  (merge {:cookie-name "auth-token"} cfg))
+  (merge {:cookie-name "auth-token"
+          :buffer-size 64}
+         (d/without-nils cfg)))
 
 (defmethod ig/init-key ::session
   [_ {:keys [pool] :as cfg}]
-  (let [cfg (assoc cfg :conn pool)]
-    (merge cfg {:middleware #(middleware cfg %)})))
+  (let [events (a/chan (a/dropping-buffer (:buffer-size cfg)))
+        cfg    (assoc cfg
+                      :conn pool
+                      ::events-ch events)]
+    (-> cfg
+        (assoc :middleware #(middleware cfg %))
+        (assoc :create (fn [profile-id]
+                         (fn [request response]
+                           (let [uagent (get-in request [:headers "user-agent"])
+                                 value  (create cfg {:profile-id profile-id :user-agent uagent})]
+                             (assoc response :cookies (cookies cfg {:value value}))))))
+        (assoc :delete (fn [request response]
+                         (delete cfg request)
+                         (assoc response
+                                :status 204
+                                :body ""
+                                :cookies (cookies cfg {:value "" :max-age -1})))))))
+
+(defmethod ig/halt-key! ::session
+  [_ data]
+  (a/close! (::events-ch data)))
+
+;; --- STATE INIT: SESSION UPDATER
+
+(declare batch-events)
+(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}]
+  (log/infof "initialize session updater (max-batch-age=%s, max-batch-size=%s)"
+             (str (:max-batch-age cfg))
+             (str (:max-batch-size cfg)))
+  (let [input (batch-events cfg (::events-ch session))
+        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)
+          (if (ex/exception? result)
+            (log/error result "updater: unexpected error on update sessions")
+            (log/debugf "updater: updated %s sessions (reason: %s)." result (name reason)))
+          (recur))))))
+
+(defn- timeout-chan
+  [cfg]
+  (a/timeout (inst-ms (:max-batch-age cfg))))
+
+(defn- batch-events
+  [cfg in]
+  (let [out (a/chan)]
+    (a/go-loop [tch (timeout-chan cfg)
+                buf #{}]
+      (let [[val port] (a/alts! [tch in])]
+        (cond
+          (identical? port tch)
+          (if (empty? buf)
+            (recur (timeout-chan cfg) buf)
+            (do
+              (a/>! out [:timeout buf])
+              (recur (timeout-chan cfg) #{})))
+
+          (nil? val)
+          (a/close! out)
+
+          (identical? port in)
+          (let [buf (conj buf val)]
+            (if (>= (count buf) (:max-batch-size cfg))
+              (do
+                (a/>! out [:size buf])
+                (recur (timeout-chan cfg) #{}))
+              (recur tch buf))))))
+    out))
+
+(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)))
+
+;; --- STATE INIT: SESSION GC
+
+(declare sql:delete-expired)
+
+(s/def ::max-age ::dt/duration)
+
+(defmethod ig/pre-init-spec ::gc-task [_]
+  (s/keys :req-un [::db/pool]
+          :opt-un [::max-age]))
+
+(defmethod ig/prep-key ::gc-task
+  [_ cfg]
+  (merge {:max-age (dt/duration {:days 2})}
+         (d/without-nils cfg)))
+
+(defmethod ig/init-key ::gc-task
+  [_ {:keys [pool max-age] :as cfg}]
+  (fn [_]
+    (db/with-atomic [conn pool]
+      (let [interval (db/interval max-age)
+            result   (db/exec-one! conn [sql:delete-expired interval])
+            result   (:next.jdbc/update-count result)]
+        (log/debugf "gc-task: removed %s rows from http-session table" result)
+        result))))
+
+(def ^:private
+  sql:delete-expired
+  "delete from http_session
+    where updated_at < now() - ?::interval")

backend/src/app/loggers/loki.clj

@@ -0,0 +1,92 @@
+;; 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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2020-2021 UXBOX Labs SL
+
+(ns app.loggers.loki
+  "A Loki integration."
+  (:require
+   [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]
+   [clojure.tools.logging :as log]
+   [integrant.core :as ig]))
+
+(declare handle-event)
+
+(s/def ::uri ::us/string)
+(s/def ::receiver fn?)
+
+(defmethod ig/pre-init-spec ::reporter [_]
+  (s/keys :req-un [::wrk/executor ::receiver]
+          :opt-un [::uri]))
+
+(defmethod ig/init-key ::reporter
+  [_ {:keys [receiver uri] :as cfg}]
+  (when uri
+    (log/info "intializing loki reporter")
+    (let [output (a/chan (a/sliding-buffer 1024))]
+      (receiver :sub output)
+      (a/go-loop []
+        (let [msg (a/<! output)]
+          (if (nil? msg)
+            (log/info "stoping error reporting loop")
+            (do
+              (a/<! (handle-event cfg msg))
+              (recur)))))
+      output)))
+
+(defmethod ig/halt-key! ::reporter
+  [_ output]
+  (when output
+    (a/close! output)))
+
+(defn- prepare-payload
+  [event]
+  (let [labels {:host    (cfg/get :host)
+                :tenant  (cfg/get :tenant)
+                :version (:full cfg/version)
+                :logger  (:logger event)
+                :level   (: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))))]]}]}))
+
+(defn- send-log
+  [uri payload i]
+  (try
+    (let [response (http/send! {:uri uri
+                                :timeout 6000
+                                :method :post
+                                :headers {"content-type" "application/json"}
+                                :body (json/encode payload)})]
+      (if (= (:status response) 204)
+        true
+        (do
+          (log/errorf "error on sending log to loki (try %s)\n%s" i (pr-str response))
+          false)))
+    (catch Exception e
+      (log/errorf e "error on sending message to loki (try %s)" i)
+      false)))
+
+(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)))))))
+

backend/src/app/loggers/mattermost.clj

@@ -5,9 +5,9 @@
 ;; This Source Code Form is "Incompatible With Secondary Licenses", as
 ;; defined by the Mozilla Public License, v. 2.0.
 ;;
-;; Copyright (c) 2020 Andrey Antukh <niwi@niwi.nz>
+;; Copyright (c) 2020-2021 UXBOX Labs SL
 
-(ns app.error-reporter
+(ns app.loggers.mattermost
   "A mattermost integration for error reporting."
   (:require
    [app.common.exceptions :as ex]
@@ -15,6 +15,7 @@
    [app.common.uuid :as uuid]
    [app.config :as cfg]
    [app.db :as db]
+   [app.util.async :as aa]
    [app.util.http :as http]
    [app.util.json :as json]
    [app.util.template :as tmpl]
@@ -24,11 +25,7 @@
    [clojure.spec.alpha :as s]
    [clojure.tools.logging :as log]
    [cuerdas.core :as str]
-   [integrant.core :as ig]
-   [promesa.exec :as px])
-  (:import
-   org.apache.logging.log4j.core.LogEvent
-   org.apache.logging.log4j.util.ReadOnlyStringMap))
+   [integrant.core :as ig]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Error Listener
@@ -37,76 +34,51 @@
 (declare handle-event)
 
 (defonce enabled-mattermost (atom true))
-(defonce queue (a/chan (a/sliding-buffer 64)))
-(defonce queue-fn (fn [event] (a/>!! queue event)))
 
 (s/def ::uri ::us/string)
 
 (defmethod ig/pre-init-spec ::reporter [_]
-  (s/keys :req-un [::wrk/executor ::db/pool]
+  (s/keys :req-un [::wrk/executor ::db/pool ::receiver]
           :opt-un [::uri]))
 
 (defmethod ig/init-key ::reporter
-  [_ {:keys [executor] :as cfg}]
-  (log/info "Intializing error reporter.")
-  (let [close-ch (a/chan 1)]
+  [_ {:keys [receiver] :as cfg}]
+  (log/info "intializing mattermost error reporter")
+  (let [output (a/chan (a/sliding-buffer 128)
+                       (filter #(= (:level %) "error")))]
+    (receiver :sub output)
     (a/go-loop []
-      (let [[val port] (a/alts! [close-ch queue])]
-        (cond
-          (= port close-ch)
-          (log/info "Stoping error reporting loop.")
-
-          (nil? val)
-          (log/info "Stoping error reporting loop.")
-
-          :else
+      (let [msg (a/<! output)]
+        (if (nil? msg)
+          (log/info "stoping error reporting loop")
           (do
-            (px/run! executor #(handle-event cfg val))
+            (a/<! (handle-event cfg msg))
             (recur)))))
-    close-ch))
+    output))
 
 (defmethod ig/halt-key! ::reporter
-  [_ close-ch]
-  (a/close! close-ch))
-
-(defn- get-context-data
-  [event]
-  (let [^LogEvent levent (deref event)
-        ^ReadOnlyStringMap rosm (.getContextData levent)]
-    (into {:message (str event)
-           :id      (uuid/next)} ; set default uuid for cases when it not comes.
-          (comp
-           (map (fn [[key val]]
-                  (cond
-                    (= "id" key)         [:id (uuid/uuid val)]
-                    (= "profile-id" key) [:profile-id (uuid/uuid val)]
-                    (str/blank? val)     nil
-                    (string? key)        [(keyword key) val]
-                    :else                [key val])))
-           (filter some?))
-
-          (.toMap rosm))))
+  [_ output]
+  (a/close! output))
 
 (defn- send-mattermost-notification!
-  [cfg {:keys [message host version id] :as cdata}]
+  [cfg {:keys [host version id error] :as cdata}]
   (try
-    (let [uri    (:uri cfg)
-          prefix (str "Unhandled exception (@channel):\n"
-                      "- detail: " (:public-uri cfg/config) "/dbg/error-by-id/" id "\n"
-                      "- host: `" host "`\n"
-                      "- version: `" version "`\n")
-          text   (str prefix "```\n" message "\n```")
+    (let [uri  (:uri cfg)
+          text (str "Unhandled exception (@channel):\n"
+                    "- detail: " (:public-uri cfg/config) "/dbg/error-by-id/" id "\n"
+                    "- host: `" host "`\n"
+                    "- version: `" version "`\n"
+                    (when error
+                      (str "```\n" (:trace error)  "\n```")))
           rsp    (http/send! {:uri uri
                               :method :post
                               :headers {"content-type" "application/json"}
                               :body (json/encode-str {:text text})})]
       (when (not= (:status rsp) 200)
-        (log/warnf "Error reporting webhook replying with unexpected status: %s\n%s"
-                   (:status rsp)
-                   (pr-str rsp))))
+        (log/errorf "error on sending data to mattermost\n%s" (pr-str rsp))))
 
     (catch Exception e
-      (log/warnf e "Unexpected exception on error reporter."))))
+      (log/error e "unexpected exception on error reporter"))))
 
 (defn- persist-on-database!
   [{:keys [pool] :as cfg} {:keys [id] :as cdata}]
@@ -114,15 +86,37 @@
     (db/insert! conn :server-error-report
                 {:id id :content (db/tjson cdata)})))
 
+(defn- parse-context
+  [event]
+  (reduce-kv
+   (fn [acc k v]
+     (cond
+       (= k :id)         (assoc acc k (uuid/uuid v))
+       (= k :profile-id) (assoc acc k (uuid/uuid v))
+       (str/blank? v)    acc
+       :else             (assoc acc k v)))
+   {:id (uuid/next)}
+   (:context event)))
+
+(defn- parse-event
+  [event]
+  (-> (parse-context event)
+      (merge (dissoc event :context))
+      (assoc :tenant (cfg/get :tenant))
+      (assoc :host (cfg/get :host))
+      (assoc :public-uri (cfg/get :public-uri))
+      (assoc :version (:full cfg/version))))
+
 (defn handle-event
-  [cfg event]
-  (try
-    (let [cdata (get-context-data event)]
-      (when (and (:uri cfg) @enabled-mattermost)
-        (send-mattermost-notification! cfg cdata))
-      (persist-on-database! cfg cdata))
-    (catch Exception e
-      (log/warnf e "Unexpected exception on error reporter."))))
+  [{:keys [executor] :as cfg} event]
+  (aa/with-thread executor
+    (try
+      (let [cdata (parse-event event)]
+        (when (and (:uri cfg) @enabled-mattermost)
+          (send-mattermost-notification! cfg cdata))
+        (persist-on-database! cfg cdata))
+      (catch Exception e
+        (log/error e "unexpected exception on error reporter")))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Http Handler

backend/src/app/loggers/zmq.clj

@@ -0,0 +1,92 @@
+;; 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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2020-2021 UXBOX Labs SL
+
+(ns app.loggers.zmq
+  "A generic ZMQ listener."
+  (:require
+   [app.common.data :as d]
+   [app.common.spec :as us]
+   [app.util.json :as json]
+   [app.util.time :as dt]
+   [clojure.core.async :as a]
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [cuerdas.core :as str]
+   [integrant.core :as ig])
+  (:import
+   org.zeromq.SocketType
+   org.zeromq.ZMQ$Socket
+   org.zeromq.ZContext))
+
+(declare prepare)
+(declare start-rcv-loop)
+
+(s/def ::endpoint ::us/string)
+
+(defmethod ig/pre-init-spec ::receiver [_]
+  (s/keys :opt-un [::endpoint]))
+
+(defmethod ig/init-key ::receiver
+  [_ {:keys [endpoint] :as cfg}]
+  (log/infof "intializing ZMQ receiver on '%s'" endpoint)
+  (let [buffer (a/chan 1)
+        output (a/chan 1 (comp (filter map?)
+                               (map prepare)))
+        mult   (a/mult output)]
+    (when endpoint
+      (a/thread (start-rcv-loop {:out buffer :endpoint endpoint})))
+    (a/pipe buffer output)
+    (with-meta
+      (fn [cmd ch]
+        (case cmd
+          :sub (a/tap mult ch)
+          :unsub (a/untap mult ch))
+        ch)
+      {::output output
+       ::buffer buffer
+       ::mult mult})))
+
+(defmethod ig/halt-key! ::receiver
+  [_ f]
+  (a/close! (::buffer (meta f))))
+
+(defn- start-rcv-loop
+  ([] (start-rcv-loop nil))
+  ([{:keys [out endpoint] :or {endpoint "tcp://localhost:5556"}}]
+   (let [out    (or out (a/chan 1))
+         zctx   (ZContext.)
+         socket (.. zctx (createSocket SocketType/SUB))]
+     (.. socket (connect ^String endpoint))
+     (.. socket (subscribe ""))
+     (.. socket (setReceiveTimeOut 5000))
+     (loop []
+       (let [msg (.recv ^ZMQ$Socket socket)
+             msg (json/decode msg)
+             msg (if (nil? msg) :empty msg)]
+         (if (a/>!! out msg)
+           (recur)
+           (do
+             (.close ^java.lang.AutoCloseable socket)
+             (.close ^java.lang.AutoCloseable zctx))))))))
+
+(defn- prepare
+  [event]
+  (d/merge
+   {:logger     (:loggerName event)
+    :level      (str/lower (:level event))
+    :thread     (:thread event)
+    :created-at (dt/instant (:timeMillis event))
+    :message    (:message event)}
+   (when-let [ctx (:contextMap event)]
+     {:context ctx})
+   (when-let [thrown (:thrown event)]
+     {:error
+      {:class (:name thrown)
+       :message (:message thrown)
+       :trace (:extendedStackTrace thrown)}})))

backend/src/app/main.clj

@@ -37,11 +37,19 @@
      :max-pool-size 20}
 
     :app.metrics/metrics
-    {}
+    {:definitions
+     {: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}}}
 
     :app.migrations/all
-    {:main (ig/ref :app.migrations/migrations)
-     :telemetry  (ig/ref :app.telemetry/migrations)}
+    {:main      (ig/ref :app.migrations/migrations)
+     :telemetry (ig/ref :app.telemetry/migrations)}
 
     :app.migrations/migrations
     {}
@@ -49,11 +57,12 @@
     :app.telemetry/migrations
     {}
 
-    :app.redis/redis
-    {:uri (:redis-uri config)}
+    :app.msgbus/msgbus
+    {:backend   (:msgbus-backend config :redis)
+     :redis-uri (:redis-uri config)}
 
     :app.tokens/tokens
-    {:sprops (ig/ref :app.sprops/props)}
+    {:sprops (ig/ref :app.setup/props)}
 
     :app.storage/gc-deleted-task
     {:pool     (ig/ref :app.db/pool)
@@ -69,7 +78,23 @@
 
     :app.http.session/session
     {:pool        (ig/ref :app.db/pool)
-     :cookie-name "auth-token"}
+     :cookie-name (:http-session-cookie-name config)}
+
+    :app.http.session/gc-task
+    {:pool        (ig/ref :app.db/pool)
+     :max-age     (:http-session-idle-max-age config)}
+
+    :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  (:http-session-updater-batch-max-age config)
+     :max-batch-size (:http-session-updater-batch-max-size config)}
+
+    :app.http.awsns/handler
+    {:tokens  (ig/ref :app.tokens/tokens)
+     :pool    (ig/ref :app.db/pool)}
 
     :app.http/server
     {:port    (:http-server-port config)
@@ -83,14 +108,13 @@
      :tokens      (ig/ref :app.tokens/tokens)
      :public-uri  (:public-uri config)
      :metrics     (ig/ref :app.metrics/metrics)
-     :google-auth (ig/ref :app.http.auth/google)
-     :gitlab-auth (ig/ref :app.http.auth/gitlab)
-     :github-auth (ig/ref :app.http.auth/github)
-     :ldap-auth   (ig/ref :app.http.auth/ldap)
+     :oauth       (ig/ref :app.http.oauth/all)
      :assets      (ig/ref :app.http.assets/handlers)
      :svgparse    (ig/ref :app.svgparse/handler)
      :storage     (ig/ref :app.storage/storage)
-     :error-report-handler (ig/ref :app.error-reporter/handler)}
+     :sns-webhook (ig/ref :app.http.awsns/handler)
+     :feedback    (ig/ref :app.http.feedback/handler)
+     :error-report-handler (ig/ref :app.loggers.mattermost/handler)}
 
     :app.http.assets/handlers
     {:metrics           (ig/ref :app.metrics/metrics)
@@ -99,7 +123,15 @@
      :cache-max-age     (dt/duration {:hours 24})
      :signature-max-age (dt/duration {:hours 24 :minutes 5})}
 
-    :app.http.auth/google
+    :app.http.feedback/handler
+    {:pool (ig/ref :app.db/pool)}
+
+    :app.http.oauth/all
+    {:google (ig/ref :app.http.oauth/google)
+     :gitlab (ig/ref :app.http.oauth/gitlab)
+     :github (ig/ref :app.http.oauth/github)}
+
+    :app.http.oauth/google
     {:rpc           (ig/ref :app.rpc/rpc)
      :session       (ig/ref :app.http.session/session)
      :tokens        (ig/ref :app.tokens/tokens)
@@ -107,7 +139,7 @@
      :client-id     (:google-client-id config)
      :client-secret (:google-client-secret config)}
 
-    :app.http.auth/github
+    :app.http.oauth/github
     {:rpc           (ig/ref :app.rpc/rpc)
      :session       (ig/ref :app.http.session/session)
      :tokens        (ig/ref :app.tokens/tokens)
@@ -115,7 +147,7 @@
      :client-id     (:github-client-id config)
      :client-secret (:github-client-secret config)}
 
-    :app.http.auth/gitlab
+    :app.http.oauth/gitlab
     {:rpc           (ig/ref :app.rpc/rpc)
      :session       (ig/ref :app.http.session/session)
      :tokens        (ig/ref :app.tokens/tokens)
@@ -124,27 +156,9 @@
      :client-id     (:gitlab-client-id config)
      :client-secret (:gitlab-client-secret config)}
 
-    :app.http.auth/ldap
-    {:host               (:ldap-auth-host config)
-     :port               (:ldap-auth-port config)
-     :ssl                (:ldap-auth-ssl config)
-     :starttls           (:ldap-auth-starttls config)
-     :user-query         (:ldap-auth-user-query config)
-     :username-attribute (:ldap-auth-username-attribute config)
-     :email-attribute    (:ldap-auth-email-attribute config)
-     :fullname-attribute (:ldap-auth-fullname-attribute config)
-     :avatar-attribute   (:ldap-auth-avatar-attribute config)
-     :base-dn            (:ldap-auth-base-dn config)
-     :session            (ig/ref :app.http.session/session)
-     :rpc                (ig/ref :app.rpc/rpc)}
-
-    :app.svgparse/svgc
-    {:metrics (ig/ref :app.metrics/metrics)}
-
     ;; HTTP Handler for SVG parsing
     :app.svgparse/handler
-    {:metrics (ig/ref :app.metrics/metrics)
-     :svgc    (ig/ref :app.svgparse/svgc)}
+    {:metrics (ig/ref :app.metrics/metrics)}
 
     ;; RLimit definition for password hashing
     :app.rlimits/password
@@ -165,15 +179,15 @@
      :tokens  (ig/ref :app.tokens/tokens)
      :metrics (ig/ref :app.metrics/metrics)
      :storage (ig/ref :app.storage/storage)
-     :redis   (ig/ref :app.redis/redis)
-     :rlimits (ig/ref :app.rlimits/all)
-     :svgc    (ig/ref :app.svgparse/svgc)}
+     :msgbus  (ig/ref :app.msgbus/msgbus)
+     :rlimits (ig/ref :app.rlimits/all)}
 
     :app.notifications/handler
-    {:redis   (ig/ref :app.redis/redis)
-     :pool    (ig/ref :app.db/pool)
-     :session (ig/ref :app.http.session/session)
-     :metrics (ig/ref :app.metrics/metrics)}
+    {:msgbus   (ig/ref :app.msgbus/msgbus)
+     :pool     (ig/ref :app.db/pool)
+     :session  (ig/ref :app.http.session/session)
+     :metrics  (ig/ref :app.metrics/metrics)
+     :executor (ig/ref :app.worker/executor)}
 
     :app.worker/executor
     {:name "worker"}
@@ -181,46 +195,61 @@
     :app.worker/worker
     {:executor   (ig/ref :app.worker/executor)
      :pool       (ig/ref :app.db/pool)
-     :tasks      (ig/ref :app.tasks/all)}
+     :tasks      (ig/ref :app.tasks/registry)}
 
     :app.worker/scheduler
     {:executor   (ig/ref :app.worker/executor)
      :pool       (ig/ref :app.db/pool)
+     :tasks      (ig/ref :app.tasks/registry)
      :schedule
      [{:id "file-media-gc"
        :cron #app/cron "0 0 0 */1 * ? *" ;; daily
-       :fn (ig/ref :app.tasks.file-media-gc/handler)}
+       :task :file-media-gc}
 
       {:id "file-xlog-gc"
        :cron #app/cron "0 0 */1 * * ?"  ;; hourly
-       :fn (ig/ref :app.tasks.file-xlog-gc/handler)}
+       :task :file-xlog-gc}
 
       {:id "storage-deleted-gc"
        :cron #app/cron "0 0 1 */1 * ?"  ;; daily (1 hour shift)
-       :fn (ig/ref :app.storage/gc-deleted-task)}
+       :task :storage-deleted-gc}
 
       {:id "storage-touched-gc"
        :cron #app/cron "0 0 2 */1 * ?"  ;; daily (2 hour shift)
-       :fn (ig/ref :app.storage/gc-touched-task)}
+       :task :storage-touched-gc}
+
+      {:id "session-gc"
+       :cron #app/cron "0 0 3 */1 * ?"  ;; daily (3 hour shift)
+       :task :session-gc}
 
       {:id "storage-recheck"
        :cron #app/cron "0 0 */1 * * ?"  ;; hourly
-       :fn (ig/ref :app.storage/recheck-task)}
+       :task :storage-recheck}
 
       {:id "tasks-gc"
        :cron #app/cron "0 0 0 */1 * ?"  ;; daily
-       :fn (ig/ref :app.tasks.tasks-gc/handler)}
+       :task :tasks-gc}
 
       (when (:telemetry-enabled config)
         {:id   "telemetry"
          :cron #app/cron "0 0 */6 * * ?" ;; every 6h
          :uri  (:telemetry-uri config)
-         :fn   (ig/ref :app.tasks.telemetry/handler)})]}
+         :task :telemetry})]}
 
-    :app.tasks/all
-    {"sendmail"       (ig/ref :app.tasks.sendmail/handler)
-     "delete-object"  (ig/ref :app.tasks.delete-object/handler)
-     "delete-profile" (ig/ref :app.tasks.delete-profile/handler)}
+    :app.tasks/registry
+    {:metrics (ig/ref :app.metrics/metrics)
+     :tasks
+     {:sendmail           (ig/ref :app.tasks.sendmail/handler)
+      :delete-object      (ig/ref :app.tasks.delete-object/handler)
+      :delete-profile     (ig/ref :app.tasks.delete-profile/handler)
+      :file-media-gc      (ig/ref :app.tasks.file-media-gc/handler)
+      :file-xlog-gc       (ig/ref :app.tasks.file-xlog-gc/handler)
+      :storage-deleted-gc (ig/ref :app.storage/gc-deleted-task)
+      :storage-touched-gc (ig/ref :app.storage/gc-touched-task)
+      :storage-recheck    (ig/ref :app.storage/recheck-task)
+      :tasks-gc           (ig/ref :app.tasks.tasks-gc/handler)
+      :telemetry          (ig/ref :app.tasks.telemetry/handler)
+      :session-gc         (ig/ref :app.http.session/gc-task)}}
 
     :app.tasks.sendmail/handler
     {:host             (:smtp-host config)
@@ -266,21 +295,30 @@
     {:pool        (ig/ref :app.db/pool)
      :version     (:full cfg/version)
      :uri         (:telemetry-uri config)
-     :sprops      (ig/ref :app.sprops/props)}
+     :sprops      (ig/ref :app.setup/props)}
 
     :app.srepl/server
     {:port (:srepl-port config)
      :host (:srepl-host config)}
 
-    :app.sprops/props
+    :app.setup/props
     {:pool (ig/ref :app.db/pool)}
 
-    :app.error-reporter/reporter
+    :app.loggers.zmq/receiver
+    {:endpoint (:loggers-zmq-uri config)}
+
+    :app.loggers.loki/reporter
+    {:uri      (:loggers-loki-uri config)
+     :receiver (ig/ref :app.loggers.zmq/receiver)
+     :executor (ig/ref :app.worker/executor)}
+
+    :app.loggers.mattermost/reporter
     {:uri      (:error-report-webhook config)
+     :receiver (ig/ref :app.loggers.zmq/receiver)
      :pool     (ig/ref :app.db/pool)
      :executor (ig/ref :app.worker/executor)}
 
-    :app.error-reporter/handler
+    :app.loggers.mattermost/handler
     {:pool (ig/ref :app.db/pool)}
 
     :app.storage/storage
@@ -333,7 +371,7 @@
                                (-> system-config
                                    (ig/prep)
                                    (ig/init))))
-    (log/infof "Welcome to penpot! Version: '%s'."
+    (log/infof "welcome to penpot (version: '%s')"
                (:full cfg/version))))
 
 (defn stop

backend/src/app/media.clj

@@ -77,7 +77,7 @@
       (assoc params
              :format format
              :mtype  (cm/format->mtype format)
-             :size   (alength thumbnail-data)
+             :size   (alength ^bytes thumbnail-data)
              :data   (ByteArrayInputStream. thumbnail-data)))))
 
 (defmulti process :cmd)
@@ -89,7 +89,7 @@
              (.addImage)
              (.autoOrient)
              (.strip)
-             (.thumbnail (int width) (int height) ">")
+             (.thumbnail ^Integer (int width) ^Integer (int height) ">")
              (.quality (double quality))
              (.addImage))]
     (generic-process (assoc params :operation op))))
@@ -101,7 +101,7 @@
              (.addImage)
              (.autoOrient)
              (.strip)
-             (.thumbnail (int width) (int height) "^")
+             (.thumbnail ^Integer (int width) ^Integer (int height) "^")
              (.gravity "center")
              (.extent (int width) (int height))
              (.quality (double quality))
@@ -157,8 +157,11 @@
                     :code :media-type-mismatch
                     :hint (str "Seems like you are uploading a file whose content does not match the extension."
                                "Expected: " mtype ". Got: " mtype')))
-        {:width  (.getImageWidth instance)
-         :height (.getImageHeight instance)
+        ;; 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}))))
 
 (defmethod process :default
@@ -185,8 +188,9 @@
 ;; --- Utility functions
 
 (defn validate-media-type
-  [media-type]
-  (when-not (cm/valid-media-types media-type)
-    (ex/raise :type :validation
-              :code :media-type-not-allowed
-              :hint "Seems like you are uploading an invalid media object")))
+  ([mtype] (validate-media-type mtype cm/valid-media-types))
+  ([mtype allowed]
+   (when-not (contains? allowed mtype)
+     (ex/raise :type :validation
+               :code :media-type-not-allowed
+               :hint "Seems like you are uploading an invalid media object"))))

backend/src/app/metrics.clj

@@ -10,17 +10,15 @@
 (ns app.metrics
   (:require
    [app.common.exceptions :as ex]
-   [app.util.time :as dt]
-   [app.worker]
    [clojure.spec.alpha :as s]
    [clojure.tools.logging :as log]
-   [integrant.core :as ig]
-   [next.jdbc :as jdbc])
+   [integrant.core :as ig])
   (:import
    io.prometheus.client.CollectorRegistry
    io.prometheus.client.Counter
    io.prometheus.client.Gauge
    io.prometheus.client.Summary
+   io.prometheus.client.Histogram
    io.prometheus.client.exporter.common.TextFormat
    io.prometheus.client.hotspot.DefaultExports
    io.prometheus.client.jetty.JettyStatisticsCollector
@@ -30,41 +28,12 @@
 (declare instrument-vars!)
 (declare instrument)
 (declare create-registry)
-
+(declare create)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Entry Point
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defn- instrument-jdbc!
-  [registry]
-  (instrument-vars!
-   [#'next.jdbc/execute-one!
-    #'next.jdbc/execute!]
-   {:registry registry
-    :type :counter
-    :name "database_query_counter"
-    :help "An absolute counter of database queries."}))
-
-(defn- instrument-workers!
-  [registry]
-  (instrument-vars!
-   [#'app.worker/run-task]
-   {:registry registry
-    :type :summary
-    :name "worker_task_checkout_millis"
-    :help "Latency measured between scheduld_at and execution time."
-    :wrap (fn [rootf mobj]
-            (let [mdata (meta rootf)
-                  origf (::original mdata rootf)]
-              (with-meta
-                (fn [tasks item]
-                  (let [now (inst-ms (dt/now))
-                        sat (inst-ms (:scheduled-at item))]
-                    (mobj :observe (- now sat))
-                    (origf tasks item)))
-                {::original origf})))}))
-
 (defn- handler
   [registry _request]
   (let [samples  (.metricFamilySamples ^CollectorRegistry registry)
@@ -73,13 +42,24 @@
     {:headers {"content-type" TextFormat/CONTENT_TYPE_004}
      :body (.toString writer)}))
 
+(s/def ::definitions
+  (s/map-of keyword? map?))
+
+(defmethod ig/pre-init-spec ::metrics [_]
+  (s/keys :opt-un [::definitions]))
+
 (defmethod ig/init-key ::metrics
-  [_ _cfg]
+  [_ {:keys [definitions] :as cfg}]
   (log/infof "Initializing prometheus registry and instrumentation.")
-  (let [registry (create-registry)]
-    (instrument-workers! registry)
-    (instrument-jdbc! registry)
+  (let [registry    (create-registry)
+        definitions (reduce-kv (fn [res k v]
+                                 (->> (assoc v :registry registry)
+                                      (create)
+                                      (assoc res k)))
+                               {}
+                               definitions)]
     {:handler (partial handler registry)
+     :definitions definitions
      :registry registry}))
 
 (s/def ::handler fn?)
@@ -87,7 +67,6 @@
 (s/def ::metrics
   (s/keys :req-un [::registry ::handler]))
 
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Implementation
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -126,7 +105,7 @@
 
       (invoke [_ cmd labels]
         (.. ^Counter instance
-            (labels labels)
+            (labels (into-array String labels))
             (inc))))))
 
 (defn make-gauge
@@ -150,19 +129,27 @@
           :dec (.dec ^Gauge instance)))
 
       (invoke [_ cmd labels]
-        (case cmd
-          :inc (.. ^Gauge instance (labels labels) (inc))
-          :dec (.. ^Gauge instance (labels labels) (dec)))))))
+        (let [labels (into-array String [labels])]
+          (case cmd
+            :inc (.. ^Gauge instance (labels labels) (inc))
+            :dec (.. ^Gauge instance (labels labels) (dec))))))))
+
+(def default-quantiles
+  [[0.75 0.02]
+   [0.99 0.001]])
 
 (defn make-summary
-  [{:keys [name help registry reg labels max-age] :or {max-age 3600} :as props}]
+  [{:keys [name help registry reg labels max-age quantiles buckets]
+    :or {max-age 3600 buckets 6 quantiles default-quantiles} :as props}]
   (let [registry (or registry reg)
         instance (doto (Summary/build)
                    (.name name)
-                   (.help help)
-                   (.maxAgeSeconds max-age)
-                   (.quantile 0.75 0.02)
-                   (.quantile 0.99 0.001))
+                   (.help help))
+        _        (when (seq quantiles)
+                   (.maxAgeSeconds ^Summary instance max-age)
+                   (.ageBuckets ^Summary instance buckets))
+        _        (doseq [[q e] quantiles]
+                   (.quantile ^Summary instance q e))
         _        (when (seq labels)
                    (.labelNames instance (into-array String labels)))
         instance (.register instance registry)]
@@ -176,7 +163,34 @@
 
       (invoke [_ cmd val labels]
         (.. ^Summary instance
-            (labels labels)
+            (labels (into-array String labels))
+            (observe val))))))
+
+(def default-histogram-buckets
+  [1 5 10 25 50 75 100 250 500 750 1000 2500 5000 7500])
+
+(defn make-histogram
+  [{:keys [name help registry reg labels buckets]
+    :or {buckets default-histogram-buckets}}]
+  (let [registry (or registry reg)
+        instance (doto (Histogram/build)
+                   (.name name)
+                   (.help help)
+                   (.buckets (into-array Double/TYPE buckets)))
+        _        (when (seq labels)
+                   (.labelNames instance (into-array String labels)))
+        instance (.register instance registry)]
+    (reify
+      clojure.lang.IDeref
+      (deref [_] instance)
+
+      clojure.lang.IFn
+      (invoke [_ cmd val]
+        (.observe ^Histogram instance val))
+
+      (invoke [_ cmd val labels]
+        (.. ^Histogram instance
+            (labels (into-array String labels))
             (observe val))))))
 
 (defn create
@@ -184,7 +198,8 @@
   (case type
     :counter (make-counter props)
     :gauge   (make-gauge props)
-    :summary (make-summary props)))
+    :summary (make-summary props)
+    :histogram (make-histogram props)))
 
 (defn wrap-counter
   ([rootf mobj]
@@ -204,7 +219,6 @@
        (assoc mdata ::original origf))))
   ([rootf mobj labels]
    (let [mdata  (meta rootf)
-         labels (into-array String labels)
          origf  (::original mdata rootf)]
      (with-meta
        (fn
@@ -241,7 +255,6 @@
 
   ([rootf mobj labels]
    (let [mdata  (meta rootf)
-         labels (into-array String labels)
          origf  (::original mdata rootf)]
      (with-meta
        (fn
@@ -284,6 +297,9 @@
       (instance? Summary @obj)
       ((or wrap wrap-summary) f obj)
 
+      (instance? Histogram @obj)
+      ((or wrap wrap-summary) f obj)
+
       :else
       (ex/raise :type :not-implemented))))
 

backend/src/app/migrations.clj

@@ -148,6 +148,24 @@
 
    {:name "0045-add-index-to-file-change-table"
     :fn (mg/resource "app/migrations/sql/0045-add-index-to-file-change-table.sql")}
+
+   {:name "0046-add-profile-complaint-table"
+    :fn (mg/resource "app/migrations/sql/0046-add-profile-complaint-table.sql")}
+
+   {:name "0047-mod-file-change-table"
+    :fn (mg/resource "app/migrations/sql/0047-mod-file-change-table.sql")}
+
+   {:name "0048-mod-storage-tables"
+    :fn (mg/resource "app/migrations/sql/0048-mod-storage-tables.sql")}
+
+   {:name "0049-mod-http-session-table"
+    :fn (mg/resource "app/migrations/sql/0049-mod-http-session-table.sql")}
+
+   {:name "0050-mod-server-prop-table"
+    :fn (mg/resource "app/migrations/sql/0050-mod-server-prop-table.sql")}
+
+   {:name "0051-mod-file-library-rel-table"
+    :fn (mg/resource "app/migrations/sql/0051-mod-file-library-rel-table.sql")}
    ])
 
 

backend/src/app/migrations/sql/0035-add-storage-tables.sql

@@ -10,11 +10,17 @@ CREATE TABLE storage_object (
   metadata jsonb NULL DEFAULT NULL
 );
 
+CREATE INDEX storage_object__id__deleted_at__idx
+    ON storage_object(id, deleted_at)
+ WHERE deleted_at IS NOT null;
+
 CREATE TABLE storage_data (
   id uuid PRIMARY KEY REFERENCES storage_object (id) ON DELETE CASCADE,
   data bytea NOT NULL
 );
 
+CREATE INDEX storage_data__id__idx ON storage_data(id);
+
 -- Table used for store inflight upload ids, for later recheck and
 -- delete possible staled files that exists on the phisical storage
 -- but does not exists in the 'storage_object' table.
@@ -28,8 +34,3 @@ CREATE TABLE storage_pending (
   PRIMARY KEY (created_at, id)
 );
 
-CREATE INDEX storage_data__id__idx ON storage_data(id);
-CREATE INDEX storage_object__id__deleted_at__idx
-    ON storage_object(id, deleted_at)
- WHERE deleted_at IS NOT null;
-

backend/src/app/migrations/sql/0044-add-storage-refcount.sql

@@ -5,9 +5,6 @@ CREATE INDEX storage_object__id_touched_at__idx
     ON storage_object (touched_at, id)
  WHERE touched_at IS NOT NULL;
 
--- DROP TRIGGER file_media_object__on_delete__tgr ON file_media_object CASCADE;
--- DROP FUNCTION on_delete_file_media_object () ;
-
 CREATE OR REPLACE FUNCTION on_delete_file_media_object()
   RETURNS TRIGGER AS $func$
   BEGIN

backend/src/app/migrations/sql/0046-add-profile-complaint-table.sql

@@ -0,0 +1,45 @@
+CREATE TABLE profile_complaint_report (
+  profile_id uuid NOT NULL REFERENCES profile(id) ON DELETE CASCADE,
+  created_at timestamptz NOT NULL DEFAULT now(),
+
+  type text NOT NULL,
+  content jsonb,
+
+  PRIMARY KEY (profile_id, created_at)
+);
+
+ALTER TABLE profile_complaint_report
+  ALTER COLUMN type SET STORAGE external,
+  ALTER COLUMN content SET STORAGE external;
+
+ALTER TABLE profile
+  ADD COLUMN is_muted boolean DEFAULT false,
+  ADD COLUMN auth_backend text NULL;
+
+ALTER TABLE profile
+  ALTER COLUMN auth_backend SET STORAGE external;
+
+UPDATE profile
+   SET auth_backend = 'google'
+ WHERE password = '!';
+
+UPDATE profile
+   SET auth_backend = 'penpot'
+ WHERE password != '!';
+
+-- Table storing a permanent complaint table for register all
+-- permanent bounces and spam reports (complaints) and avoid sending
+-- more emails there.
+CREATE TABLE global_complaint_report (
+  email text NOT NULL,
+  created_at timestamptz NOT NULL DEFAULT now(),
+
+  type text NOT NULL,
+  content jsonb,
+
+  PRIMARY KEY (email, created_at)
+);
+
+ALTER TABLE global_complaint_report
+  ALTER COLUMN type SET STORAGE external,
+  ALTER COLUMN content SET STORAGE external;

backend/src/app/migrations/sql/0047-mod-file-change-table.sql

@@ -0,0 +1,16 @@
+--- Helps on the lagged changes query on update-file rpc
+CREATE INDEX file_change__file_id__revn__idx ON file_change (file_id, revn);
+
+--- Drop redundant index
+DROP INDEX page_change_file_id_idx;
+
+--- Add profile_id field.
+ALTER TABLE file_change
+  ADD COLUMN profile_id uuid NULL REFERENCES profile (id) ON DELETE SET NULL;
+
+CREATE INDEX file_change__profile_id__idx
+    ON file_change (profile_id)
+ WHERE profile_id IS NOT NULL;
+
+--- Fix naming
+ALTER INDEX file_change__created_at_idx RENAME TO file_change__created_at__idx;

backend/src/app/migrations/sql/0048-mod-storage-tables.sql

@@ -0,0 +1,9 @@
+--- Drop redundant index already covered by primary key
+DROP INDEX storage_data__id__idx;
+
+--- Replace not efficient index with more efficient one
+DROP INDEX storage_object__id__deleted_at__idx;
+
+CREATE INDEX storage_object__id__deleted_at__idx
+    ON storage_object(deleted_at, id)
+ WHERE deleted_at IS NOT NULL;

backend/src/app/migrations/sql/0049-mod-http-session-table.sql

@@ -0,0 +1,6 @@
+ALTER TABLE http_session
+  ADD COLUMN updated_at timestamptz NULL;
+
+CREATE INDEX http_session__updated_at__idx
+    ON http_session (updated_at)
+ WHERE updated_at IS NOT NULL;

backend/src/app/migrations/sql/0050-mod-server-prop-table.sql

@@ -0,0 +1,4 @@
+ALTER TABLE server_prop
+  ADD COLUMN preload boolean DEFAULT false;
+
+UPDATE server_prop SET preload = true;

backend/src/app/migrations/sql/0051-mod-file-library-rel-table.sql

@@ -0,0 +1,4 @@
+ALTER TABLE file_library_rel
+ DROP CONSTRAINT file_library_rel_library_file_id_fkey,
+  ADD CONSTRAINT file_library_rel_library_file_id_fkey
+         FOREIGN KEY (library_file_id) REFERENCES file(id) ON DELETE CASCADE DEFERRABLE;

backend/src/app/msgbus.clj

@@ -0,0 +1,290 @@
+;; 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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2021 UXBOX Labs SL
+
+(ns app.msgbus
+  "The msgbus abstraction implemented using redis as underlying backend."
+  (:require
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.config :as cfg]
+   [app.util.blob :as blob]
+   [app.util.time :as dt]
+   [clojure.core.async :as a]
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [integrant.core :as ig]
+   [promesa.core :as p])
+  (:import
+   java.time.Duration
+   io.lettuce.core.RedisClient
+   io.lettuce.core.RedisURI
+   io.lettuce.core.api.StatefulRedisConnection
+   io.lettuce.core.api.async.RedisAsyncCommands
+   io.lettuce.core.codec.ByteArrayCodec
+   io.lettuce.core.codec.RedisCodec
+   io.lettuce.core.codec.StringCodec
+   io.lettuce.core.pubsub.RedisPubSubListener
+   io.lettuce.core.pubsub.StatefulRedisPubSubConnection
+   io.lettuce.core.pubsub.api.async.RedisPubSubAsyncCommands))
+
+(def ^:private prefix (cfg/get :tenant))
+
+(defn- prefix-topic
+  [topic]
+  (str prefix "." topic))
+
+(def xform-prefix (map prefix-topic))
+(def xform-topics (map (fn [m] (update m :topics #(into #{} xform-prefix %)))))
+(def xform-topic  (map (fn [m] (update m :topic prefix-topic))))
+
+(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]))
+
+(defmethod ig/prep-key ::msgbus
+  [_ cfg]
+  (merge {:buffer-size 128} cfg))
+
+(defmethod ig/init-key ::msgbus
+  [_ {:keys [backend buffer-size] :as cfg}]
+  (log/debugf "initializing msgbus (backend=%s)" (name backend))
+  (let [cfg     (init-backend cfg)
+
+        ;; 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)
+
+    (with-meta
+      (fn run
+        ([command] (run command nil))
+        ([command params]
+         (a/go
+           (case command
+             :pub (a/>! pub-ch params)
+             :sub (a/>! sub-ch 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))))
+
+;; --- IN-MEMORY BACKEND IMPL
+
+(defmethod init-backend :memory [cfg] cfg)
+(defmethod stop-backend :memory [_])
+(defmethod init-pub-loop :memory [_])
+
+(defmethod init-sub-loop :memory
+  [{:keys [::sub-ch ::pub-ch]}]
+  (a/go-loop [state {}]
+    (let [[val port] (a/alts! [pub-ch sub-ch])]
+      (cond
+        (and (= port sub-ch) (some? val))
+        (let [{:keys [topics chan]} val]
+          (recur (reduce #(update %1 %2 (fnil conj #{}) chan) state topics)))
+
+        (and (= port pub-ch) (some? val))
+        (let [topic   (:topic val)
+              message (:message val)
+              state   (loop [state state
+                             chans (get state topic)]
+                        (if-let [c (first chans)]
+                          (if (a/>! c message)
+                            (recur state (rest chans))
+                            (recur (update state topic disj c)
+                                   (rest chans)))
+                          state))]
+          (recur state))
+
+        :else
+        (->> (vals state)
+             (mapcat identity)
+             (run! a/close!))))))
+
+
+;; Add a unique listener to connection
+
+;; --- REDIS BACKEND IMPL
+
+(declare impl-redis-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}))
+
+    (-> cfg
+        (assoc ::pub-conn pub-conn)
+        (assoc ::sub-conn sub-conn))))
+
+(defmethod stop-backend :redis
+  [{:keys [::pub-conn ::sub-conn] :as cfg}]
+  (.close ^StatefulRedisConnection pub-conn)
+  (.close ^StatefulRedisPubSubConnection sub-conn))
+
+(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 (ex/exception? result)
+            (log/error result "unexpected error on publish message to redis")))
+        (recur)))))
+
+(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 #(log/error % "unexpected error on agent"))
+        rac     (.async ^StatefulRedisPubSubConnection sub-conn)]
+
+    ;; Add a unique listener to connection
+    (.addListener sub-conn
+                  (reify RedisPubSubListener
+                    (message [it pattern topic message])
+                    (message [it 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)
+                          (log/warn "dropping message on subscription loop"))))
+                    (psubscribed [it pattern count])
+                    (punsubscribed [it pattern count])
+                    (subscribed [it topic count])
+                    (unsubscribed [it topic count])))
+
+    (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))]
+                    (log/tracef "opening subscription to %s" topic)
+                    (when (ex/exception? result)
+                      (log/errorf result "unexpected exception on subscribing to '%s'" topic))))
+                nsubs))
+
+            (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))]
+                    (log/tracef "closing subscription to %s" topic)
+                    (when (ex/exception? result)
+                      (log/errorf result "unexpected exception on unsubscribing from '%s'" 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)))
+
+      ;; Asyncrhonous 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))]
+            ;; (log/tracef "received message => pending: %s" (pr-str 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- 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))
+                     (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 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))

backend/src/app/notifications.clj

@@ -13,9 +13,10 @@
    [app.common.spec :as us]
    [app.db :as db]
    [app.metrics :as mtx]
-   [app.redis :as rd]
    [app.util.async :as aa]
+   [app.util.time :as dt]
    [app.util.transit :as t]
+   [app.worker :as wrk]
    [clojure.core.async :as a]
    [clojure.spec.alpha :as s]
    [clojure.tools.logging :as log]
@@ -34,9 +35,10 @@
 (declare handler)
 
 (s/def ::session map?)
+(s/def ::msgbus fn?)
 
 (defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::rd/redis ::db/pool ::session ::mtx/metrics]))
+  (s/keys :req-un [::msgbus ::db/pool ::session ::mtx/metrics ::wrk/executor]))
 
 (defmethod ig/init-key ::handler
   [_ {:keys [session metrics] :as cfg}]
@@ -44,29 +46,32 @@
 
         mtx-active-connections
         (mtx/create
-         {:name "websocket_notifications_active_connections"
+         {:name "websocket_active_connections"
           :registry (:registry metrics)
           :type :gauge
-          :help "Active websocket connections on notifications service."})
+          :help "Active websocket connections."})
 
-        mtx-message-recv
+        mtx-messages
         (mtx/create
-         {:name "websocket_notifications_message_recv_timing"
+         {:name "websocket_message_total"
           :registry (:registry metrics)
-          :type :summary
-          :help "Message receive summary timing (ms)."})
+          :labels ["op"]
+          :type :counter
+          :help "Counter of processed messages."})
 
-        mtx-message-send
+        mtx-sessions
         (mtx/create
-         {:name "websocket_notifications_message_send_timing"
+         {:name "websocket_session_timing"
           :registry (:registry metrics)
-          :type :summary
-          :help "Message receive summary timing (ms)."})
+          :quantiles []
+          :help "Websocket session timing (seconds)."
+          :type :summary})
 
         cfg (assoc cfg
                    :mtx-active-connections mtx-active-connections
-                   :mtx-message-recv mtx-message-recv
-                   :mtx-message-send mtx-message-send)]
+                   :mtx-messages mtx-messages
+                   :mtx-sessions mtx-sessions
+                   )]
     (-> #(handler cfg %)
         (wrap-session)
         (wrap-keyword-params)
@@ -109,14 +114,10 @@
   (db/exec-one! conn [sql:retrieve-file id]))
 
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; WebSocket Http Handler
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; --- WEBSOCKET INIT
 
 (declare handle-connect)
 
-(defrecord WebSocket [conn in out sub])
-
 (defn- ws-send
   [conn data]
   (try
@@ -127,174 +128,149 @@
       false)))
 
 (defn websocket
-  [{:keys [file-id team-id redis] :as cfg}]
-  (let [in  (a/chan 32)
-        out (a/chan 32)
-        mtx-active-connections (:mtx-active-connections cfg)
-        mtx-message-send       (:mtx-message-send cfg)
-        mtx-message-recv       (:mtx-message-recv cfg)
-
-        ws-send (mtx/wrap-summary ws-send mtx-message-send)]
+  [{:keys [file-id team-id msgbus executor] :as cfg}]
+  (let [rcv-ch       (a/chan 32)
+        out-ch       (a/chan 32)
+        mtx-aconn    (:mtx-active-connections cfg)
+        mtx-messages (:mtx-messages cfg)
+        mtx-sessions (:mtx-sessions cfg)
+        created-at   (dt/now)
+        ws-send      (mtx/wrap-counter ws-send mtx-messages ["send"])]
 
     (letfn [(on-connect [conn]
-              (mtx-active-connections :inc)
-              (let [sub (rd/subscribe redis {:xform (map t/decode-str)
-                                             :topics [file-id team-id]})
-                    ws  (WebSocket. conn in out sub nil cfg)]
+              (mtx-aconn :inc)
+              ;; A subscription channel should use a lossy buffer
+              ;; because we can't penalize normal clients when one
+              ;; slow client is connected to the room.
+              (let [sub-ch (a/chan (a/dropping-buffer 128))
+                    cfg    (assoc cfg
+                                  :conn conn
+                                  :rcv-ch rcv-ch
+                                  :out-ch out-ch
+                                  :sub-ch sub-ch)]
 
-                ;; message forwarding loop
+                (log/tracef "on-connect %s" (:session-id cfg))
+
+                ;; Forward all messages from out-ch to the websocket
+                ;; connection
                 (a/go-loop []
-                  (let [val (a/<! out)]
-                    (when-not (nil? val)
-                      (when (ws-send conn (t/encode-str val))
+                  (let [val (a/<! out-ch)]
+                    (when (some? val)
+                      (when (a/<! (aa/thread-call executor #(ws-send conn (t/encode-str val))))
                         (recur)))))
 
                 (a/go
-                  (a/<! (handle-connect ws))
-                  (a/close! sub))))
+                  ;; Subscribe to corresponding topics
+                  (a/<! (msgbus :sub {:topics [file-id team-id] :chan sub-ch}))
+                  (a/<! (handle-connect cfg))
+                  (a/close! sub-ch))))
 
-            (on-error [_conn _e]
-              (a/close! out)
-              (a/close! in))
+            (on-error [_conn e]
+              (mtx-aconn :dec)
+              (mtx-sessions :observe (/ (inst-ms (dt/duration-between created-at (dt/now))) 1000.0))
+              (log/tracef "on-error %s (%s)" (:session-id cfg) (ex-message e))
+              (a/close! out-ch)
+              (a/close! rcv-ch))
 
             (on-close [_conn _status _reason]
-              (mtx-active-connections :dec)
-              (a/close! out)
-              (a/close! in))
+              (mtx-aconn :dec)
+              (mtx-sessions :observe (/ (inst-ms (dt/duration-between created-at (dt/now))) 1000.0))
+              (log/tracef "on-close %s" (:session-id cfg))
+              (a/close! out-ch)
+              (a/close! rcv-ch))
 
             (on-message [_ws message]
               (let [message (t/decode-str message)]
-                (a/>!! in message)))]
+                (when-not (a/offer! rcv-ch message)
+                  (log/warn "droping ws input message, channe full"))))]
 
       {:on-connect on-connect
        :on-error on-error
        :on-close on-close
-       :on-text (mtx/wrap-summary on-message mtx-message-recv)
+       :on-text (mtx/wrap-counter on-message mtx-messages ["recv"])
        :on-bytes (constantly nil)})))
 
+;; --- CONNECTION INIT
+
+(declare send-presence)
 (declare handle-message)
 (declare start-loop!)
 
 (defn- handle-connect
-  [{:keys [conn] :as ws}]
+  [cfg]
   (a/go
-    (try
-      (aa/<? (handle-message ws {:type :connect}))
-      (aa/<? (start-loop! ws))
-      (aa/<? (handle-message ws {:type :disconnect}))
-      (catch Throwable err
-        (log/errorf err "Unexpected exception on websocket handler.")
-        (let [session (.getSession conn)]
-          (when session
-            (.disconnect session)))))))
+    (a/<! (handle-message cfg {:type :connect}))
+    (a/<! (start-loop! cfg))
+    (a/<! (handle-message cfg {:type :disconnect}))))
 
 (defn- start-loop!
-  [{:keys [in out sub session-id] :as ws}]
-  (aa/go-try
-   (loop []
-     (let [timeout (a/timeout 30000)
-           [val port] (a/alts! [in sub timeout])]
+  [{:keys [rcv-ch out-ch sub-ch session-id] :as cfg}]
+  (a/go-loop []
+    (let [timeout    (a/timeout 30000)
+          [val port] (a/alts! [rcv-ch sub-ch timeout])]
+      (cond
+        ;; Process message coming from connected client
+        (and (= port rcv-ch) (some? val))
+        (do
+          (a/<! (handle-message cfg val))
+          (recur))
 
-       ;; (prn "alts" val "from" (cond (= port in)  "input"
-       ;;                              (= port sub) "redis"
-       ;;                              :else "timeout"))
+        ;; Process message coming from pubsub.
+        (and (= port sub-ch) (some? val))
+        (do
+          (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 cfg :presence)))
 
-       (cond
-         ;; Process message coming from connected client
-         (and (= port in) (not (nil? val)))
-         (do
-           (aa/<? (handle-message ws val))
-           (recur))
+            ;; Then, just forward the message
+            (a/>! out-ch val))
+          (recur))
 
-         ;; Forward message to the websocket
-         (and (= port sub) (not (nil? val)))
-         (do
-           (when-not (= (:session-id val) session-id)
-             (a/>! out val))
-           (recur))
+        ;; When timeout channel is signaled, we need to send a ping
+        ;; message to the output channel. TODO: we need to make this
+        ;; more smart.
+        (= port timeout)
+        (do
+          (a/>! out-ch {:type :ping})
+          (recur))))))
 
-         ;; Timeout channel signaling
-         (= port timeout)
-         (do
-           (a/>! out {:type :ping})
-           (recur))
+(defn send-presence
+  ([cfg] (send-presence cfg :presence))
+  ([{:keys [msgbus session-id profile-id file-id]} type]
+   (a/go
+     (a/<! (msgbus :pub {:topic file-id
+                         :message {:type type
+                                   :session-id session-id
+                                   :profile-id profile-id}})))))
 
-         :else
-         nil)))))
-
-;; Incoming Messages Handling
-
-(defn- publish
-  [redis channel message]
-  (aa/go-try
-   (let [message (t/encode-str message)]
-     (aa/<? (rd/run redis :publish {:channel (str channel)
-                                         :message message})))))
-
-(def ^:private
-  sql:retrieve-presence
-  "select * from presence
-    where file_id=?
-      and (clock_timestamp() - updated_at) < '5 min'::interval")
-
-(defn- retrieve-presence
-  [pool file-id]
-  (aa/thread-try
-   (let [rows (db/exec! pool [sql:retrieve-presence file-id])]
-     (mapv (juxt :session-id :profile-id) rows))))
-
-(def ^:private
-  sql:update-presence
-  "insert into presence (file_id, session_id, profile_id, updated_at)
-   values (?, ?, ?, clock_timestamp())
-       on conflict (file_id, session_id, profile_id)
-       do update set updated_at=clock_timestamp()")
-
-(defn- update-presence
-  [conn file-id session-id profile-id]
-  (aa/thread-try
-   (let [sql [sql:update-presence file-id session-id profile-id]]
-     (db/exec-one! conn sql))))
-
-(defn- delete-presence
-  [pool file-id session-id profile-id]
-  (aa/thread-try
-   (db/delete! pool :presence {:file-id file-id
-                               :profile-id profile-id
-                               :session-id session-id})))
+;; --- INCOMING MSG PROCESSING
 
 (defmulti handle-message
   (fn [_ message] (:type message)))
 
-;; TODO: check permissions for join a file-id channel (probably using
-;; single use token for avoid explicit database query).
-
 (defmethod handle-message :connect
-  [{:keys [file-id profile-id session-id pool redis] :as ws} _message]
+  [cfg _]
   ;; (log/debugf "profile '%s' is connected to file '%s'" profile-id file-id)
-  (aa/go-try
-   (aa/<? (update-presence pool file-id session-id profile-id))
-   (let [members (aa/<? (retrieve-presence pool file-id))]
-     (aa/<? (publish redis file-id {:type :presence :sessions members})))))
+  (send-presence cfg :connect))
 
 (defmethod handle-message :disconnect
-  [{:keys [profile-id file-id session-id redis pool] :as ws} _message]
+  [cfg _]
   ;; (log/debugf "profile '%s' is disconnected from '%s'" profile-id file-id)
-  (aa/go-try
-   (aa/<? (delete-presence pool file-id session-id profile-id))
-   (let [members (aa/<? (retrieve-presence pool file-id))]
-     (aa/<? (publish redis file-id {:type :presence :sessions members})))))
+  (send-presence cfg :disconnect))
 
 (defmethod handle-message :keepalive
-  [{:keys [profile-id file-id session-id pool] :as ws} _message]
-  (update-presence pool file-id session-id profile-id))
+  [_ _]
+  (a/go :nothing))
 
 (defmethod handle-message :pointer-update
-  [{:keys [profile-id file-id session-id redis] :as ws} message]
+  [{:keys [profile-id file-id session-id msgbus] :as cfg} message]
   (let [message (assoc message
                        :profile-id profile-id
                        :session-id session-id)]
-    (publish redis file-id message)))
+    (msgbus :pub {:topic file-id
+                  :message message})))
 
 (defmethod handle-message :default
   [_ws message]

backend/src/app/redis.clj

@@ -1,58 +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) 2019 Andrey Antukh <niwi@niwi.nz>
-
-(ns app.redis
-  (:refer-clojure :exclude [run!])
-  (:require
-   [app.common.spec :as us]
-   [app.util.redis :as redis]
-   [clojure.spec.alpha :as s]
-   [integrant.core :as ig])
-  (:import
-   java.lang.AutoCloseable))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; State
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defmethod ig/pre-init-spec ::redis [_]
-  (s/keys :req-un [::uri]))
-
-(defmethod ig/init-key ::redis
-  [_ cfg]
-  (let [client (redis/client (:uri cfg "redis://redis/0"))
-        conn   (redis/connect client)]
-    {::client client
-     ::conn conn}))
-
-(defmethod ig/halt-key! ::redis
-  [_ {:keys [::client ::conn]}]
-  (.close ^AutoCloseable conn)
-  (.close ^AutoCloseable client))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; API
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(s/def ::client some?)
-(s/def ::conn some?)
-(s/def ::redis (s/keys :req [::client ::conn]))
-
-(defn subscribe
-  [client opts]
-  (us/assert ::redis client)
-  (redis/subscribe (::client client) opts))
-
-(defn run!
-  [client cmd params]
-  (us/assert ::redis client)
-  (redis/run! (::conn client) cmd params))
-
-(defn run
-  [client cmd params]
-  (us/assert ::redis client)
-  (redis/run (::conn client) cmd params))
-

backend/src/app/rpc.clj

@@ -25,6 +25,11 @@
   [_]
   (ex/raise :type :not-found))
 
+(defn- run-hook
+  [hook-fn response]
+  (ex/ignoring (hook-fn))
+  response)
+
 (defn- rpc-query-handler
   [methods {:keys [profile-id] :as request}]
   (let [type   (keyword (get-in request [:path-params :type]))
@@ -36,7 +41,8 @@
         mdata  (meta result)]
 
     (cond->> {:status 200 :body result}
-      (fn? (:transform-response mdata)) ((:transform-response mdata) request))))
+      (fn? (:transform-response mdata))
+      ((:transform-response mdata) request))))
 
 (defn- rpc-mutation-handler
   [methods {:keys [profile-id] :as request}]
@@ -50,7 +56,11 @@
         result ((get methods type default-handler) data)
         mdata  (meta result)]
     (cond->> {:status 200 :body result}
-      (fn? (:transform-response mdata)) ((:transform-response mdata) request))))
+      (fn? (:transform-response mdata))
+      ((:transform-response mdata) request)
+
+      (fn? (:before-complete mdata))
+      (run-hook (:before-complete mdata)))))
 
 (defn- wrap-with-metrics
   [cfg f mdata]
@@ -66,7 +76,7 @@
         (ex/raise :type :internal
                   :code :rlimit-not-configured
                   :hint (str/fmt "%s rlimit not configured" key)))
-      (log/tracef "Adding rlimit to '%s' rpc handler." (::sv/name mdata))
+      (log/tracef "adding rlimit to '%s' rpc handler" (::sv/name mdata))
       (fn [cfg params]
         (rlm/execute rlinst (f cfg params))))
     f))
@@ -76,7 +86,7 @@
   (let [f     (wrap-with-rlimits cfg f mdata)
         f     (wrap-with-metrics cfg f mdata)
         spec  (or (::sv/spec mdata) (s/spec any?))]
-    (log/tracef "Registering '%s' command to rpc service." (::sv/name mdata))
+    (log/tracef "registering '%s' command to rpc service" (::sv/name mdata))
     (fn [params]
       (when (and (:auth mdata true) (not (uuid? (:profile-id params))))
         (ex/raise :type :authentication
@@ -96,7 +106,7 @@
               {:name "rpc_query_timing"
                :labels ["name"]
                :registry (get-in cfg [:metrics :registry])
-               :type :summary
+               :type :histogram
                :help "Timing of query services."})
         cfg  (assoc cfg ::mobj mobj)]
     (->> (sv/scan-ns 'app.rpc.queries.projects
@@ -115,7 +125,7 @@
               {:name "rpc_mutation_timing"
                :labels ["name"]
                :registry (get-in cfg [:metrics :registry])
-               :type :summary
+               :type :histogram
                :help "Timing of mutation services."})
         cfg  (assoc cfg ::mobj mobj)]
     (->> (sv/scan-ns 'app.rpc.mutations.demo
@@ -126,7 +136,8 @@
                      'app.rpc.mutations.projects
                      'app.rpc.mutations.viewer
                      'app.rpc.mutations.teams
-                     'app.rpc.mutations.feedback
+                     'app.rpc.mutations.management
+                     'app.rpc.mutations.ldap
                      'app.rpc.mutations.verify-token)
          (map (partial process-method cfg))
          (into {}))))

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

@@ -146,14 +146,14 @@
   (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)
+        (ex/raise :type :not-found))
 
       (files/check-read-permissions! conn profile-id (:file-id thread))
 
       (db/update! conn :comment-thread
                   {:is-resolved is-resolved}
                   {:id id})
-      nil))))
+      nil)))
 
 
 ;; --- Mutation: Add Comment

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

@@ -5,7 +5,7 @@
 ;; This Source Code Form is "Incompatible With Secondary Licenses", as
 ;; defined by the Mozilla Public License, v. 2.0.
 ;;
-;; Copyright (c) 2020 UXBOX Labs SL
+;; Copyright (c) 2020-2021 UXBOX Labs SL
 
 (ns app.rpc.mutations.demo
   "A demo specific mutations."
@@ -14,8 +14,8 @@
    [app.common.uuid :as uuid]
    [app.config :as cfg]
    [app.db :as db]
-   [app.db.profile-initial-data :refer [create-profile-initial-data]]
    [app.rpc.mutations.profile :as profile]
+   [app.setup.initial-data :as sid]
    [app.tasks :as tasks]
    [app.util.services :as sv]
    [buddy.core.codecs :as bc]
@@ -36,7 +36,7 @@
         params   {:id id
                   :email email
                   :fullname fullname
-                  :demo? true
+                  :is-demo true
                   :password password
                   :props {:onboarding-viewed true}}]
 
@@ -48,7 +48,7 @@
     (db/with-atomic [conn pool]
       (->> (#'profile/create-profile conn params)
            (#'profile/create-profile-relations conn)
-           (create-profile-initial-data conn))
+           (sid/load-initial-project! conn))
 
       ;; Schedule deletion of the demo profile
       (tasks/submit! conn {:name "delete-profile"

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

@@ -1,41 +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/.
-;;
-;; This Source Code Form is "Incompatible With Secondary Licenses", as
-;; defined by the Mozilla Public License, v. 2.0.
-;;
-;; Copyright (c) 2021 UXBOX Labs SL
-
-(ns app.rpc.mutations.feedback
-  (:require
-   [app.common.exceptions :as ex]
-   [app.common.spec :as us]
-   [app.config :as cfg]
-   [app.db :as db]
-   [app.emails :as emails]
-   [app.rpc.queries.profile :as profile]
-   [app.util.services :as sv]
-   [clojure.spec.alpha :as s]))
-
-(s/def ::subject ::us/string)
-(s/def ::content ::us/string)
-
-(s/def ::send-profile-feedback
-  (s/keys :req-un [::profile-id ::subject ::content]))
-
-(sv/defmethod ::send-profile-feedback
-  [{:keys [pool] :as cfg} {:keys [profile-id subject content] :as params}]
-  (when-not (:feedback-enabled cfg/config)
-    (ex/raise :type :validation
-              :code :feedback-disabled
-              :hint "feedback module is disabled"))
-
-  (db/with-atomic [conn pool]
-    (let [profile (profile/retrieve-profile-data conn profile-id)]
-      (emails/send! conn emails/feedback
-                    {:to (:feedback-destination cfg/config)
-                     :profile profile
-                     :subject subject
-                     :content content})
-      nil)))

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

@@ -16,14 +16,13 @@
    [app.common.uuid :as uuid]
    [app.config :as cfg]
    [app.db :as db]
-   [app.redis :as rd]
+   [app.rpc.permissions :as perms]
    [app.rpc.queries.files :as files]
    [app.rpc.queries.projects :as proj]
    [app.tasks :as tasks]
    [app.util.blob :as blob]
    [app.util.services :as sv]
    [app.util.time :as dt]
-   [app.util.transit :as t]
    [clojure.spec.alpha :as s]))
 
 ;; --- Helpers & Specs
@@ -49,14 +48,13 @@
     (proj/check-edition-permissions! conn profile-id project-id)
     (create-file conn params)))
 
-(defn- create-file-profile
-  [conn {:keys [profile-id file-id] :as params}]
-  (db/insert! conn :file-profile-rel
-              {:profile-id profile-id
-               :file-id file-id
-               :is-owner true
-               :is-admin true
-               :can-edit true}))
+
+(defn create-file-role
+  [conn {:keys [file-id profile-id role]}]
+  (let [params {:file-id file-id
+                :profile-id profile-id}]
+    (->> (perms/assign-role-flags params role)
+         (db/insert! conn :file-profile-rel))))
 
 (defn create-file
   [conn {:keys [id name project-id is-shared]
@@ -70,8 +68,8 @@
                           :name name
                           :is-shared is-shared
                           :data (blob/encode data)})]
-    (->> (assoc params :file-id id)
-         (create-file-profile conn))
+    (->> (assoc params :file-id id :role :owner)
+         (create-file-role conn))
     (assoc file :data data)))
 
 
@@ -157,6 +155,7 @@
               :hint "A file cannot be linked to itself"))
   (db/with-atomic [conn pool]
     (files/check-edition-permissions! conn profile-id file-id)
+    (files/check-edition-permissions! conn profile-id library-id)
     (link-file-to-library conn params)))
 
 (def sql:link-file-to-library
@@ -252,19 +251,22 @@
               :reg-objects :mov-objects} (:type change))
            (some? (:component-id change)))))
 
-(declare update-file)
-(declare retrieve-lagged-changes)
 (declare insert-change)
+(declare retrieve-lagged-changes)
+(declare retrieve-team-id)
+(declare send-notifications)
+(declare update-file)
 
 (sv/defmethod ::update-file
   [{:keys [pool] :as cfg} {:keys [id profile-id] :as params}]
   (db/with-atomic [conn pool]
     (let [{:keys [id] :as file} (db/get-by-id conn :file id {:for-update true})]
       (files/check-edition-permissions! conn profile-id id)
-      (update-file (assoc cfg :conn  conn) file params))))
+      (update-file (assoc cfg :conn  conn)
+                   (assoc params :file file)))))
 
 (defn- update-file
-  [{:keys [conn redis]} file params]
+  [{:keys [conn] :as cfg} {:keys [file changes session-id profile-id] :as params}]
   (when (> (:revn params)
            (:revn file))
     (ex/raise :type :validation
@@ -272,64 +274,70 @@
               :hint "The incoming revision number is greater that stored version."
               :context {:incoming-revn (:revn params)
                         :stored-revn (:revn file)}))
-  (let [sid      (:session-id params)
-        changes  (:changes params)
-        file     (-> file
-                     (update :data blob/decode)
-                     (update :data assoc :id (:id file))
-                     (update :data pmg/migrate-data)
-                     (update :data cp/process-changes changes)
-                     (update :data blob/encode)
-                     (update :revn inc)
-                     (assoc :changes (blob/encode changes)
-                            :session-id sid))
 
-        _        (insert-change conn file)
-        msg      {:type :file-change
-                  :profile-id (:profile-id params)
-                  :file-id (:id file)
-                  :session-id sid
-                  :revn (:revn file)
-                  :changes changes}
-
-        library-changes (filter library-change? changes)]
-
-    @(rd/run! redis :publish {:channel (str (:id file))
-                              :message (t/encode-str msg)})
-
-    (when (and (:is-shared file) (seq library-changes))
-      (let [{:keys [team-id] :as project}
-            (db/get-by-id conn :project (:project-id file))
-
-            msg {:type :library-change
-                 :profile-id (:profile-id params)
+  (let [file (-> file
+                 (update :revn inc)
+                 (update :data (fn [data]
+                                 (-> data
+                                     (blob/decode)
+                                     (assoc :id (:id file))
+                                     (pmg/migrate-data)
+                                     (cp/process-changes changes)
+                                     (blob/encode)))))]
+    ;; Insert change to the xlog
+    (db/insert! conn :file-change
+                {:id (uuid/next)
+                 :session-id session-id
+                 :profile-id profile-id
                  :file-id (:id file)
-                 :session-id sid
                  :revn (:revn file)
-                 :modified-at (dt/now)
-                 :changes library-changes}]
-
-        @(rd/run! redis :publish {:channel (str team-id)
-                                  :message (t/encode-str msg)})))
+                 :data (:data file)
+                 :changes (blob/encode changes)})
 
+    ;; Update file
     (db/update! conn :file
                 {:revn (:revn file)
-                 :data (:data file)}
+                 :data (:data file)
+                 :has-media-trimmed false}
                 {:id (:id file)})
 
-    (retrieve-lagged-changes conn params)))
+    (let [params (assoc params :file file)]
+      ;; Send asynchronous notifications
+      (send-notifications cfg params)
 
-(defn- insert-change
-  [conn {:keys [revn data changes session-id] :as file}]
-  (let [id      (uuid/next)
-        file-id (:id file)]
-    (db/insert! conn :file-change
-                {:id id
-                 :session-id session-id
-                 :file-id file-id
-                 :revn revn
-                 :data data
-                 :changes changes})))
+      ;; Retrieve and return lagged data
+      (retrieve-lagged-changes conn params))))
+
+(defn- send-notifications
+  [{:keys [msgbus conn] :as cfg} {:keys [file changes session-id] :as params}]
+  (let [lchanges (filter library-change? changes)]
+
+    ;; 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}})
+
+    (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}})))))
+
+(defn- retrieve-team-id
+  [conn project-id]
+  (:team-id (db/get-by-id conn :project project-id {:columns [:team-id]})))
 
 (def ^:private
   sql:lagged-changes

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

@@ -0,0 +1,101 @@
+;; 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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2020-2021 UXBOX Labs SL
+
+(ns app.rpc.mutations.ldap
+  (:require
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.config :as cfg]
+   [app.rpc.mutations.profile :refer [login-or-register]]
+   [app.util.services :as sv]
+   [clj-ldap.client :as ldap]
+   [clojure.spec.alpha :as s]
+   [clojure.string]))
+
+(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)
+
+(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} {:keys [email password invitation-token] :as params}]
+  (let [info (authenticate params)
+        cfg  (assoc cfg :conn pool)]
+    (when-not info
+      (ex/raise :type :validation
+                :code :wrong-credentials))
+    (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))}))
+
+        (with-meta profile
+          {:transform-response ((:create session) (: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] :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    (get luser (keyword (cfg/get :ldap-attrs-email)))
+         :backend  "ldap"}))))

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

@@ -0,0 +1,325 @@
+;; 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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2021 UXBOX Labs SL
+
+(ns app.rpc.mutations.management
+  "Move & Duplicate RPC methods for files and projects."
+  (:require
+   [app.common.data :as d]
+   [app.common.exceptions :as ex]
+   [app.common.pages.migrations :as pmg]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.db :as db]
+   [app.rpc.mutations.projects :refer [create-project-role create-project]]
+   [app.rpc.queries.projects :as proj]
+   [app.rpc.queries.teams :as teams]
+   [app.util.blob :as blob]
+   [app.util.services :as sv]
+   [app.util.time :as dt]
+   [clojure.spec.alpha :as s]
+   [clojure.walk :as walk]))
+
+(s/def ::id ::us/uuid)
+(s/def ::profile-id ::us/uuid)
+(s/def ::project-id ::us/uuid)
+(s/def ::file-id ::us/uuid)
+(s/def ::team-id ::us/uuid)
+(s/def ::name ::us/string)
+
+(defn- remap-id
+  [item index key]
+  (cond-> item
+    (contains? item key)
+    (assoc key (get index (get item key) (get item key)))))
+
+(defn- process-file
+  [file index]
+  (letfn [(process-form [form]
+            (cond-> form
+              ;; Relink Components
+              (and (map? form)
+                   (uuid? (:component-file form)))
+              (update :component-file #(get index % %))
+
+              ;; Relink Image Shapes
+              (and (map? form)
+                   (map? (:metadata form))
+                   (= :image (:type form)))
+              (update-in [:metadata :id] #(get index % %))))
+
+          ;; A function responsible to analize all file data and
+          ;; replace the old :component-file reference with the new
+          ;; ones, using the provided file-index
+          (relink-shapes [data]
+            (walk/postwalk process-form data))
+
+          ;; A function responsible of process the :media attr of file
+          ;; data and remap the old ids with the new ones.
+          (relink-media [media]
+            (reduce-kv (fn [res k v]
+                         (let [id (get index k)]
+                           (if (uuid? id)
+                             (-> res
+                                 (assoc id (assoc v :id id))
+                                 (dissoc k))
+                             res)))
+                       media
+                       media))]
+
+    (update file :data
+            (fn [data]
+              (-> data
+                  (blob/decode)
+                  (assoc :id (:id file))
+                  (pmg/migrate-data)
+                  (update :pages-index relink-shapes)
+                  (update :components relink-shapes)
+                  (update :media relink-media)
+                  (d/without-nils)
+                  (blob/encode))))))
+
+(def sql:retrieve-used-libraries
+  "select flr.*
+     from file_library_rel as flr
+    inner join file as l on (flr.library_file_id = l.id)
+    where flr.file_id = ?
+      and l.deleted_at is null")
+
+(def sql:retrieve-used-media-objects
+  "select fmo.*
+     from file_media_object as fmo
+    inner join storage_object as o on (fmo.media_id = o.id)
+    where fmo.file_id = ?
+      and o.deleted_at is null")
+
+(defn duplicate-file
+  [conn {:keys [profile-id file index project-id name]} {:keys [reset-shared-flag] :as opts}]
+  (let [flibs    (db/exec! conn [sql:retrieve-used-libraries (:id file)])
+        fmeds    (db/exec! conn [sql:retrieve-used-media-objects (:id file)])
+
+        ;; memo uniform creation/modification date
+        now      (dt/now)
+        ignore   (dt/plus now (dt/duration {:seconds 5}))
+
+        ;; add to the index all file media objects.
+        index  (reduce #(assoc %1 (:id %2) (uuid/next)) index fmeds)
+
+        flibs-xf (comp
+                  (map #(remap-id % index :file-id))
+                  (map #(remap-id % index :library-file-id))
+                  (map #(assoc % :synced-at now))
+                  (map #(assoc % :created-at now)))
+
+        ;; remap all file-library-rel row
+        flibs    (sequence flibs-xf flibs)
+
+        fmeds-xf (comp
+                  (map #(assoc % :id (get index (:id %))))
+                  (map #(assoc % :created-at now))
+                  (map #(remap-id % index :file-id)))
+
+        ;; remap all file-media-object rows
+        fmeds   (sequence fmeds-xf fmeds)
+
+        file    (cond-> file
+                  (some? project-id)
+                  (assoc :project-id project-id)
+
+                  (some? name)
+                  (assoc :name name)
+
+                  (true? reset-shared-flag)
+                  (assoc :is-shared false))
+
+        file    (-> file
+                    (assoc :created-at now)
+                    (assoc :modified-at now)
+                    (assoc :ignore-sync-until ignore)
+                    (update :id #(get index %))
+                    (process-file index))]
+
+    (db/insert! conn :file file)
+    (db/insert! conn :file-profile-rel
+                {:file-id (:id file)
+                 :profile-id profile-id
+                 :is-owner true
+                 :is-admin true
+                 :can-edit true})
+
+    (doseq [params flibs]
+      (db/insert! conn :file-library-rel params))
+
+    (doseq [params fmeds]
+      (db/insert! conn :file-media-object params))
+
+    file))
+
+
+;; --- MUTATION: Duplicate File
+
+(declare duplicate-file)
+
+(s/def ::duplicate-file
+  (s/keys :req-un [::profile-id ::file-id]
+          :opt-un [::name]))
+
+(sv/defmethod ::duplicate-file
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id name] :as params}]
+  (db/with-atomic [conn pool]
+    (let [file   (db/get-by-id conn :file file-id)
+          index  {file-id (uuid/next)}
+          params (assoc params :index index :file file)]
+      (proj/check-edition-permissions! conn profile-id (:project-id file))
+
+      (-> (duplicate-file conn params {:reset-shared-flag true})
+          (update :data blob/decode)))))
+
+
+;; --- MUTATION: Duplicate Project
+
+(declare duplicate-project)
+
+(s/def ::duplicate-project
+  (s/keys :req-un [::profile-id ::project-id]
+          :opt-un [::name]))
+
+(sv/defmethod ::duplicate-project
+  [{:keys [pool] :as cfg} {:keys [profile-id project-id name] :as params}]
+  (db/with-atomic [conn pool]
+    (let [project (db/get-by-id conn :project project-id)]
+      (teams/check-edition-permissions! conn profile-id (:team-id project))
+      (duplicate-project conn (assoc params :project project)))))
+
+(defn duplicate-project
+  [conn {:keys [profile-id project name] :as params}]
+  (let [files   (db/query conn :file
+                          {:project-id (:id project)
+                           :deleted-at nil}
+                          {:columns [:id]})
+
+        project (cond-> project
+                  (string? name)
+                  (assoc :name name)
+
+                  :always
+                  (assoc :id (uuid/next)))]
+
+    ;; create the duplicated project and assign the current profile as
+    ;; a project owner
+    (create-project conn project)
+    (create-project-role conn {:project-id (:id project)
+                               :profile-id profile-id
+                               :role :owner})
+
+    ;; duplicate all files
+    (let [index  (reduce #(assoc %1 (:id %2) (uuid/next)) {} files)
+          params (-> params
+                     (dissoc :name)
+                     (assoc :project-id (:id project))
+                     (assoc :index index))]
+      (doseq [{:keys [id]} files]
+        (let [file   (db/get-by-id conn :file id)
+              params (assoc params :file file)
+              opts   {:reset-shared-flag false}]
+          (duplicate-file conn params opts))))
+
+    ;; return the created project
+    project))
+
+
+;; --- MUTATION: Move file
+
+(def sql:retrieve-files
+  "select id, project_id from file where id = ANY(?)")
+
+(def sql:move-files
+  "update file set project_id = ? where id = ANY(?)")
+
+(def sql:delete-broken-relations
+  "with broken as (
+     (select * from file_library_rel as flr
+       inner join file as f on (flr.file_id = f.id)
+       inner join project as p on (f.project_id = p.id)
+       inner join file as lf on (flr.library_file_id = lf.id)
+       inner join project as lp on (lf.project_id = lp.id)
+       where p.id = ANY(?)
+         and lp.team_id != p.team_id)
+   )
+   delete from file_library_rel as rel
+    using broken as br
+    where rel.file_id = br.file_id
+      and rel.library_file_id = br.library_file_id")
+
+(s/def ::ids (s/every ::us/uuid :kind set?))
+(s/def ::move-files
+  (s/keys :req-un [::profile-id ::ids ::project-id]))
+
+(sv/defmethod ::move-files
+  [{:keys [pool] :as cfg} {:keys [profile-id ids project-id] :as params}]
+  (db/with-atomic [conn pool]
+    (let [fids    (db/create-array conn "uuid" ids)
+          files   (db/exec! conn [sql:retrieve-files fids])
+          source  (into #{} (map :project-id) files)
+          pids    (->> (conj source project-id)
+                       (db/create-array conn "uuid"))]
+
+      ;; Check if we have permissions on the destination project
+      (proj/check-edition-permissions! conn profile-id project-id)
+
+      ;; Check if we have permissions on all source projects
+      (doseq [project-id source]
+        (proj/check-edition-permissions! conn profile-id project-id))
+
+      (when (contains? source project-id)
+        (ex/raise :type :validation
+                  :code :cant-move-to-same-project
+                  :hint "Unable to move a file to the same project"))
+
+      ;; move all files to the project
+      (db/exec-one! conn [sql:move-files project-id fids])
+
+      ;; delete posible broken relations on moved files
+      (db/exec-one! conn [sql:delete-broken-relations pids])
+
+      nil)))
+
+
+;; --- MUTATION: Move project
+
+(declare move-project)
+
+(s/def ::move-project
+  (s/keys :req-un [::profile-id ::team-id ::project-id]))
+
+(sv/defmethod ::move-project
+  [{:keys [pool] :as cfg} {:keys [profile-id team-id project-id] :as params}]
+  (db/with-atomic [conn pool]
+    (let [project (db/get-by-id conn :project project-id {:columns [:id :team-id]})
+
+          pids    (->> (db/query conn :project {:team-id (:team-id project)} {:columns [:id]})
+                       (map :id)
+                       (db/create-array conn "uuid"))]
+
+      (teams/check-edition-permissions! conn profile-id (:team-id project))
+      (teams/check-edition-permissions! conn profile-id team-id)
+
+      (when (= team-id (:team-id project))
+        (ex/raise :type :validation
+                  :code :cant-move-to-same-team
+                  :hint "Unable to move a project to same team"))
+
+      ;; move project to the destination team
+      (db/update! conn :project
+                  {:team-id team-id}
+                  {:id project-id})
+
+      ;; delete posible broken relations on moved files
+      (db/exec-one! conn [sql:delete-broken-relations pids])
+
+      nil)))

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

@@ -92,7 +92,7 @@
 
 
 (defn create-file-media-object
-  [{:keys [conn storage svgc] :as cfg} {:keys [file-id is-local name content] :as params}]
+  [{:keys [conn storage] :as cfg} {:keys [file-id is-local name content] :as params}]
   (media/validate-media-type (:content-type content))
   (let [storage      (assoc storage :conn conn)
         source-path  (fs/path (:tempfile content))
@@ -108,7 +108,7 @@
                                                      :path source-path})))
 
         image        (if (= (:mtype source-info) "image/svg+xml")
-                       (let [data (svgc (slurp source-path))]
+                       (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)

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

@@ -14,28 +14,25 @@
    [app.common.uuid :as uuid]
    [app.config :as cfg]
    [app.db :as db]
-   [app.db.profile-initial-data :refer [create-profile-initial-data]]
    [app.emails :as emails]
-   [app.http.session :as session]
    [app.media :as media]
    [app.rpc.mutations.projects :as projects]
    [app.rpc.mutations.teams :as teams]
-   [app.rpc.mutations.verify-token :refer [process-token]]
    [app.rpc.queries.profile :as profile]
+   [app.setup.initial-data :as sid]
    [app.storage :as sto]
    [app.tasks :as tasks]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [buddy.hashers :as hashers]
    [clojure.spec.alpha :as s]
-   [clojure.tools.logging :as log]
    [cuerdas.core :as str]))
 
 ;; --- Helpers & Specs
 
 (s/def ::email ::us/email)
 (s/def ::fullname ::us/not-empty-string)
-(s/def ::lang ::us/not-empty-string)
+(s/def ::lang (s/nilable ::us/not-empty-string))
 (s/def ::path ::us/string)
 (s/def ::profile-id ::us/uuid)
 (s/def ::password ::us/not-empty-string)
@@ -44,79 +41,94 @@
 
 ;; --- Mutation: Register Profile
 
+(declare annotate-profile-register)
 (declare check-profile-existence!)
 (declare create-profile)
 (declare create-profile-relations)
 (declare email-domain-in-whitelist?)
+(declare register-profile)
+
+(s/def ::invitation-token ::us/not-empty-string)
+(s/def ::terms-privacy ::us/boolean)
 
-(s/def ::token ::us/not-empty-string)
 (s/def ::register-profile
-  (s/keys :req-un [::email ::password ::fullname]
-          :opt-un [::token]))
+  (s/keys :req-un [::email ::password ::fullname ::terms-privacy]
+          :opt-un [::invitation-token]))
 
 (sv/defmethod ::register-profile {:auth false :rlimit :password}
-  [{:keys [pool tokens session] :as cfg} {:keys [token] :as params}]
-  (when-not (:registration-enabled cfg/config)
+  [{:keys [pool tokens session] :as cfg} params]
+  (when-not (cfg/get :registration-enabled)
     (ex/raise :type :restriction
               :code :registration-disabled))
 
-  (when-not (email-domain-in-whitelist? (:registration-domain-whitelist cfg/config)
-                                        (:email params))
+  (when-not (email-domain-in-whitelist? (cfg/get :registration-domain-whitelist) (:email params))
     (ex/raise :type :validation
               :code :email-domain-is-not-allowed))
 
+  (when-not (:terms-privacy params)
+    (ex/raise :type :validation
+              :code :invalid-terms-and-privacy))
+
   (db/with-atomic [conn pool]
-    (check-profile-existence! conn params)
-    (let [profile (->> (create-profile conn params)
-                       (create-profile-relations conn))]
-      (create-profile-initial-data conn profile)
+    (let [cfg     (assoc cfg :conn conn)]
+      (register-profile cfg params))))
 
-      (if token
-        ;; If token comes in params, this is because the user comes
-        ;; from team-invitation process; in this case we revalidate
-        ;; the token and process the token claims again with the new
-        ;; profile data.
-        (let [claims (tokens :verify {:token token :iss :team-invitation})
-              claims (assoc claims :member-id  (:id profile))
-              params (assoc params :profile-id (:id profile))
-              cfg    (assoc cfg :conn conn)]
+(defn- annotate-profile-register
+  "A helper for properly increase the profile-register metric once the
+  transaction is completed."
+  [metrics profile]
+  (fn []
+    (when (::created profile)
+      ((get-in metrics [:definitions :profile-register]) :inc))))
 
-          (process-token cfg params claims)
+(defn- register-profile
+  [{:keys [conn tokens session metrics] :as cfg} params]
+  (check-profile-existence! conn params)
+  (let [profile (->> (create-profile conn params)
+                     (create-profile-relations conn))
+        profile (assoc profile ::created true)]
 
-          ;; Automatically mark the created profile as active because
-          ;; we already have the verification of email with the
-          ;; team-invitation token.
-          (db/update! conn :profile
-                      {:is-active true}
-                      {:id (:id profile)})
+    (sid/load-initial-project! conn profile)
 
-          ;; Return profile data and create http session for
-          ;; automatically login the profile.
-          (with-meta (assoc profile
-                            :is-active true
-                            :claims claims)
-            {:transform-response
-             (fn [request response]
-               (let [uagent (get-in request [:headers "user-agent"])
-                     id     (session/create! session {:profile-id (:id profile)
-                                                      :user-agent uagent})]
-                 (assoc response
-                        :cookies (session/cookies session {:value id}))))}))
+    (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)
+            resp   {:invitation-token token}]
+        (with-meta resp
+          {:transform-response ((:create session) (:id profile))
+           :before-complete (annotate-profile-register metrics profile)}))
 
-        ;; If no token is provided, send a verification email
-        (let [token (tokens :generate
-                            {:iss :verify-email
-                             :exp (dt/in-future "48h")
-                             :profile-id (:id profile)
-                             :email (:email profile)})]
+      ;; If no token is provided, send a verification email
+      (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)})]
 
-          (emails/send! conn emails/register
-                        {:to (:email profile)
-                         :name (:fullname profile)
-                         :token token})
-
-          profile)))))
+        ;; Don't allow proceed in register page if the email is
+        ;; already reported as permanent bounced
+        (when (emails/has-bounce-reports? conn (:email profile))
+          (ex/raise :type :validation
+                    :code :email-has-permanent-bounces
+                    :hint "looks like the email has one or many bounces reported"))
 
+        (emails/send! conn emails/register
+                      {:to (:email profile)
+                       :name (:fullname profile)
+                       :token vtoken
+                       :extra-data ptoken})
+        (with-meta profile
+          {:before-complete (annotate-profile-register metrics profile)})))))
 
 (defn email-domain-in-whitelist?
   "Returns true if email's domain is in the given whitelist or if given
@@ -154,31 +166,30 @@
   [attempt password]
   (try
     (hashers/verify attempt password)
-    (catch Exception e
-      (log/warnf e "Error on verify password (only informative, nothing affected to user).")
+    (catch Exception _e
       {:update false
        :valid false})))
 
-(defn- create-profile
+(defn create-profile
   "Create the profile entry on the database with limited input
   filling all the other fields with defaults."
-  [conn {:keys [id fullname email password demo? props is-active]
-         :or {is-active false}
-         :as params}]
-  (let [id       (or id (uuid/next))
-        demo?    (if (boolean? demo?) demo? false)
-        active?  (if demo? true is-active)
-        props    (db/tjson (or props {}))
-        password (derive-password password)]
+  [conn {:keys [id fullname email password props is-active is-muted is-demo opts]
+         :or {is-active false is-muted false is-demo false}}]
+  (let [id        (or id (uuid/next))
+        is-active (if is-demo true is-active)
+        props     (db/tjson (or props {}))
+        password  (derive-password password)
+        params    {:id id
+                   :fullname fullname
+                   :email (str/lower email)
+                   :auth-backend "penpot"
+                   :password password
+                   :props props
+                   :is-active is-active
+                   :is-muted is-muted
+                   :is-demo is-demo}]
     (try
-      (-> (db/insert! conn :profile
-                      {:id id
-                       :fullname fullname
-                       :email (str/lower email)
-                       :password password
-                       :props props
-                       :is-active active?
-                       :is-demo demo?})
+      (-> (db/insert! conn :profile params opts)
           (update :props db/decode-transit-pgobject))
       (catch org.postgresql.util.PSQLException e
         (let [state (.getSQLState e)]
@@ -189,23 +200,27 @@
                       :cause e)))))))
 
 
-(defn- create-profile-relations
+(defn create-profile-relations
   [conn profile]
-  (let [team (teams/create-team conn {:profile-id (:id profile)
-                                      :name "Default"
-                                      :default? true})
-        proj (projects/create-project conn {:profile-id (:id profile)
-                                            :team-id (:id team)
-                                            :name "Drafts"
-                                            :default? true})]
-    (teams/create-team-profile conn {:team-id (:id team)
-                                     :profile-id (:id profile)})
-    (projects/create-project-profile conn {:project-id (:id proj)
-                                           :profile-id (:id profile)})
+  (let [team    (teams/create-team conn {:profile-id (:id profile)
+                                         :name "Default"
+                                         :is-default true})
+        project (projects/create-project conn {:profile-id (:id profile)
+                                               :team-id (:id team)
+                                               :name "Drafts"
+                                               :is-default true})
+        params  {:team-id (:id team)
+                 :profile-id (:id profile)
+                 :project-id (:id project)
+                 :role :owner}]
 
-    (merge (profile/strip-private-attrs profile)
-           {:default-team-id (:id team)
-            :default-project-id (:id proj)})))
+    (teams/create-team-role conn params)
+    (projects/create-project-role conn params)
+
+    (-> profile
+        (profile/strip-private-attrs)
+        (assoc :default-team-id (:id team))
+        (assoc :default-project-id (:id project)))))
 
 ;; --- Mutation: Login
 
@@ -214,10 +229,10 @@
 
 (s/def ::login
   (s/keys :req-un [::email ::password]
-          :opt-un [::scope]))
+          :opt-un [::scope ::invitation-token]))
 
 (sv/defmethod ::login {:auth false :rlimit :password}
-  [{:keys [pool] :as cfg} {:keys [email password scope] :as params}]
+  [{:keys [pool session tokens] :as cfg} {:keys [email password scope] :as params}]
   (letfn [(check-password [profile password]
             (when (= (:password profile) "!")
               (ex/raise :type :validation
@@ -237,29 +252,63 @@
             profile)]
 
     (db/with-atomic [conn pool]
-      (let [prof (-> (profile/retrieve-profile-data-by-email conn email)
-                     (validate-profile)
-                     (profile/strip-private-attrs))
-            addt (profile/retrieve-additional-data conn (:id prof))]
-        (merge prof addt)))))
+      (let [profile (->> (profile/retrieve-profile-data-by-email conn email)
+                         (validate-profile)
+                         (profile/strip-private-attrs)
+                         (profile/populate-additional-data conn))]
+        (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))}))
+
+          (with-meta profile
+            {:transform-response ((:create session) (:id profile))}))))))
+
+;; --- Mutation: Logout
+
+(s/def ::logout
+  (s/keys :req-un [::profile-id]))
+
+(sv/defmethod ::logout
+  [{:keys [pool session] :as cfg} {:keys [profile-id] :as params}]
+  (with-meta {}
+    {:transform-response (:delete session)}))
 
 
 ;; --- Mutation: Register if not exists
 
+(declare login-or-register)
+
+(s/def ::backend ::us/string)
 (s/def ::login-or-register
-  (s/keys :req-un [::email ::fullname]))
+  (s/keys :req-un [::email ::fullname ::backend]))
 
 (sv/defmethod ::login-or-register {:auth false}
-  [{:keys [pool] :as cfg} {:keys [email fullname] :as params}]
-  (letfn [(populate-additional-data [conn profile]
-            (let [data (profile/retrieve-additional-data conn (:id profile))]
-              (merge profile data)))
+  [{:keys [pool metrics] :as cfg} params]
+  (db/with-atomic [conn pool]
+    (let [profile (-> (assoc cfg :conn conn)
+                      (login-or-register params))]
+      (with-meta profile
+        {:before-complete (annotate-profile-register metrics profile)}))))
 
-          (create-profile [conn {:keys [fullname email]}]
+(defn login-or-register
+  [{:keys [conn] :as cfg} {:keys [email backend] :as params}]
+  (letfn [(create-profile [conn {:keys [fullname email]}]
             (db/insert! conn :profile
                         {:id (uuid/next)
                          :fullname fullname
                          :email (str/lower email)
+                         :auth-backend backend
                          :is-active true
                          :password "!"
                          :is-demo false}))
@@ -267,15 +316,14 @@
           (register-profile [conn params]
             (let [profile (->> (create-profile conn params)
                                (create-profile-relations conn))]
-              (create-profile-initial-data conn profile)
-              profile))]
+              (sid/load-initial-project! conn profile)
+              (assoc profile ::created true)))]
 
-    (db/with-atomic [conn pool]
-      (let [profile (profile/retrieve-profile-data-by-email conn email)
-            profile (if profile
-                      (populate-additional-data conn profile)
-                      (register-profile conn params))]
-        (profile/strip-private-attrs profile)))))
+    (let [profile (profile/retrieve-profile-data-by-email conn email)
+          profile (if profile
+                    (profile/populate-additional-data conn profile)
+                    (register-profile conn params))]
+      (profile/strip-private-attrs profile))))
 
 
 ;; --- Mutation: Update Profile (own)
@@ -289,7 +337,8 @@
               {:id id}))
 
 (s/def ::update-profile
-  (s/keys :req-un [::id ::fullname ::lang ::theme]))
+  (s/keys :req-un [::id ::fullname]
+          :opt-un [::lang ::theme]))
 
 (sv/defmethod ::update-profile
   [{:keys [pool] :as cfg} params]
@@ -300,12 +349,8 @@
 
 ;; --- Mutation: Update Password
 
-(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)))
-      (ex/raise :type :validation
-                :code :old-password-not-match))))
+(declare validate-password!)
+(declare update-profile-password!)
 
 (s/def ::update-profile-password
   (s/keys :req-un [::profile-id ::password ::old-password]))
@@ -313,12 +358,23 @@
 (sv/defmethod ::update-profile-password {:rlimit :password}
   [{:keys [pool] :as cfg} {:keys [password profile-id] :as params}]
   (db/with-atomic [conn pool]
-    (validate-password! conn params)
-    (db/update! conn :profile
-                {:password (derive-password password)}
-                {:id profile-id})
-    nil))
+    (let [profile (validate-password! conn params)]
+      (update-profile-password! conn (assoc profile :password password))
+      nil)))
 
+(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)))
+      (ex/raise :type :validation
+                :code :old-password-not-match))
+    profile))
+
+(defn update-profile-password!
+  [conn {:keys [id password] :as profile}]
+  (db/update! conn :profile
+              {:password (derive-password password)}
+              {:id id}))
 
 ;; --- Mutation: Update Photo
 
@@ -330,8 +386,8 @@
 
 (sv/defmethod ::update-profile-photo
   [{:keys [pool storage] :as cfg} {:keys [profile-id file] :as params}]
-  (media/validate-media-type (:content-type file))
   (db/with-atomic [conn pool]
+    (media/validate-media-type (:content-type file) #{"image/jpeg" "image/png" "image/webp"})
     (let [profile (db/get-by-id conn :profile profile-id)
           _       (media/run cfg {:cmd :info :input {:path (:tempfile file)
                                                      :mtype (:content-type file)}})
@@ -352,31 +408,68 @@
               {:id profile-id})
   nil)
 
+
 ;; --- Mutation: Request Email Change
 
+(declare request-email-change)
+(declare change-email-inmediatelly)
+
 (s/def ::request-email-change
   (s/keys :req-un [::email]))
 
 (sv/defmethod ::request-email-change
-  [{:keys [pool tokens] :as cfg} {:keys [profile-id email] :as params}]
+  [{:keys [pool] :as cfg} {:keys [profile-id email] :as params}]
   (db/with-atomic [conn pool]
-    (let [email   (str/lower email)
-          profile (db/get-by-id conn :profile profile-id)
-          token   (tokens :generate
-                          {:iss :change-email
-                           :exp (dt/in-future "15m")
-                           :profile-id profile-id
-                           :email email})]
+    (let [profile (db/get-by-id conn :profile profile-id)
+          cfg     (assoc cfg :conn conn)
+          params  (assoc params
+                         :profile profile
+                         :email (str/lower email))]
+      (if (cfg/get :smtp-enabled)
+        (request-email-change cfg params)
+        (change-email-inmediatelly cfg params)))))
 
-      (when (not= email (:email profile))
-        (check-profile-existence! conn params))
+(defn- change-email-inmediatelly
+  [{:keys [conn]} {:keys [profile email] :as params}]
+  (when (not= email (:email profile))
+    (check-profile-existence! conn params))
+  (db/update! conn :profile
+              {:email email}
+              {:id (:id profile)})
+  {:changed true})
+
+(defn- request-email-change
+  [{:keys [conn tokens]} {:keys [profile email] :as params}]
+  (let [token   (tokens :generate
+                        {:iss :change-email
+                         :exp (dt/in-future "15m")
+                         :profile-id (:id profile)
+                         :email email})
+        ptoken  (tokens :generate-predefined
+                        {:iss :profile-identity
+                         :profile-id (:id profile)})]
+
+    (when (not= email (:email profile))
+      (check-profile-existence! conn params))
+
+    (when-not (emails/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 (emails/has-bounce-reports? conn email)
+      (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"))
+
+    (emails/send! conn emails/change-email
+                  {:to (:email profile)
+                   :name (:fullname profile)
+                   :pending-email email
+                   :token token
+                   :extra-data ptoken})
+    nil))
 
-      (emails/send! conn emails/change-email
-                    {:to (:email profile)
-                     :name (:fullname profile)
-                     :pending-email email
-                     :token token})
-      nil)))
 
 (defn select-profile-for-update
   [conn id]
@@ -397,18 +490,33 @@
               (assoc profile :token token)))
 
           (send-email-notification [conn profile]
-            (emails/send! conn emails/password-recovery
-                          {:to (:email profile)
-                           :token (:token profile)
-                           :name (:fullname profile)})
-            nil)]
+            (let [ptoken (tokens :generate-predefined
+                                 {:iss :profile-identity
+                                  :profile-id (:id profile)})]
+              (emails/send! conn emails/password-recovery
+                            {: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 (emails/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 (emails/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))))))
@@ -480,11 +588,7 @@
                 {:id profile-id})
 
     (with-meta {}
-      {:transform-response
-       (fn [request response]
-         (session/delete! session request)
-         (assoc response
-                :cookies (session/cookies session {:value "" :max-age -1})))})))
+      {:transform-response (:delete session)})))
 
 (def sql:owned-teams
   "with owner_teams as (

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

@@ -13,7 +13,9 @@
    [app.common.uuid :as uuid]
    [app.config :as cfg]
    [app.db :as db]
+   [app.rpc.permissions :as perms]
    [app.rpc.queries.projects :as proj]
+   [app.rpc.queries.teams :as teams]
    [app.tasks :as tasks]
    [app.util.services :as sv]
    [app.util.time :as dt]
@@ -29,7 +31,7 @@
 ;; --- Mutation: Create Project
 
 (declare create-project)
-(declare create-project-profile)
+(declare create-project-role)
 (declare create-team-project-profile)
 
 (s/def ::team-id ::us/uuid)
@@ -38,33 +40,35 @@
           :opt-un [::id]))
 
 (sv/defmethod ::create-project
-  [{:keys [pool] :as cfg} params]
+  [{:keys [pool] :as cfg} {:keys [profile-id team-id] :as params}]
   (db/with-atomic [conn pool]
-    (let [proj   (create-project conn params)
-          params (assoc params :project-id (:id proj))]
-      (create-project-profile conn params)
+    (teams/check-edition-permissions! conn profile-id team-id)
+    (let [project (create-project conn params)
+          params  (assoc params
+                         :project-id (:id project)
+                         :role :owner)]
+      (create-project-role conn params)
       (create-team-project-profile conn params)
-      (assoc proj :is-pinned true))))
+      (assoc project :is-pinned true))))
 
 (defn create-project
-  [conn {:keys [id team-id name default?] :as params}]
-  (let [id (or id (uuid/next))
-        default? (if (boolean? default?) default? false)]
+  [conn {:keys [id team-id name is-default] :as params}]
+  (let [id         (or id (uuid/next))
+        is-default (if (boolean? is-default) is-default false)]
     (db/insert! conn :project
                 {:id id
-                 :team-id team-id
                  :name name
-                 :is-default default?})))
+                 :team-id team-id
+                 :is-default is-default})))
 
-(defn create-project-profile
-  [conn {:keys [project-id profile-id] :as params}]
-  (db/insert! conn :project-profile-rel
-              {:project-id project-id
-               :profile-id profile-id
-               :is-owner true
-               :is-admin true
-               :can-edit true}))
+(defn create-project-role
+  [conn {:keys [project-id profile-id role]}]
+  (let [params {:project-id project-id
+                :profile-id profile-id}]
+    (->> (perms/assign-role-flags params role)
+         (db/insert! conn :project-profile-rel))))
 
+;; TODO: pending to be refactored
 (defn create-team-project-profile
   [conn {:keys [team-id project-id profile-id] :as params}]
   (db/insert! conn :team-project-profile-rel
@@ -92,6 +96,7 @@
 (sv/defmethod ::update-project-pin
   [{:keys [pool] :as cfg} {:keys [id profile-id team-id is-pinned] :as params}]
   (db/with-atomic [conn pool]
+    (proj/check-edition-permissions! conn profile-id id)
     (db/exec-one! conn [sql:update-project-pin team-id id profile-id is-pinned is-pinned])
     nil))
 

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

@@ -18,6 +18,7 @@
    [app.emails :as emails]
    [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.storage :as sto]
@@ -36,7 +37,7 @@
 ;; --- Mutation: Create Team
 
 (declare create-team)
-(declare create-team-profile)
+(declare create-team-role)
 (declare create-team-default-project)
 
 (s/def ::create-team
@@ -47,37 +48,39 @@
   [{:keys [pool] :as cfg} params]
   (db/with-atomic [conn pool]
     (let [team   (create-team conn params)
-          params (assoc params :team-id (:id team))]
-      (create-team-profile conn params)
+          params (assoc params
+                        :team-id (:id team)
+                        :role :owner)]
+      (create-team-role conn params)
       (create-team-default-project conn params)
       team)))
 
 (defn create-team
-  [conn {:keys [id name default?] :as params}]
-  (let [id (or id (uuid/next))
-        default? (if (boolean? default?) default? false)]
+  [conn {:keys [id name is-default] :as params}]
+  (let [id         (or id (uuid/next))
+        is-default (if (boolean? is-default) is-default false)]
     (db/insert! conn :team
                 {:id id
                  :name name
-                 :is-default default?})))
+                 :is-default is-default})))
 
-(defn create-team-profile
-  [conn {:keys [team-id profile-id] :as params}]
-  (db/insert! conn :team-profile-rel
-              {:team-id team-id
-               :profile-id profile-id
-               :is-owner true
-               :is-admin true
-               :can-edit true}))
+(defn create-team-role
+  [conn {:keys [team-id profile-id role] :as params}]
+  (let [params {:team-id team-id
+                :profile-id profile-id}]
+    (->> (perms/assign-role-flags params role)
+         (db/insert! conn :team-profile-rel))))
 
 (defn create-team-default-project
   [conn {:keys [team-id profile-id] :as params}]
-  (let [proj (projects/create-project conn {:team-id team-id
-                                            :name "Drafts"
-                                            :default? true})]
-    (projects/create-project-profile conn {:project-id (:id proj)
-                                           :profile-id profile-id})))
-
+  (let [project {:id (uuid/next)
+                 :team-id team-id
+                 :name "Drafts"
+                 :is-default true}]
+    (projects/create-project conn project)
+    (projects/create-project-role conn {:project-id (:id project)
+                                        :profile-id profile-id
+                                        :role :owner})))
 
 ;; --- Mutation: Update Team
 
@@ -146,7 +149,7 @@
       nil)))
 
 
-;; --- Mutation: Tean Update Role
+;; --- Mutation: Team Update Role
 
 (declare retrieve-team-member)
 (declare role->params)
@@ -171,7 +174,10 @@
           ;; convenience, if this bocomes a bottleneck or problematic,
           ;; we will change it to more efficient fetch mechanims.
           members (teams/retrieve-team-members conn team-id)
-          member  (d/seek #(= member-id (:id %)) members)]
+          member  (d/seek #(= member-id (:id %)) members)
+
+          is-owner? (some :is-owner perms)
+          is-admin? (some :is-admin perms)]
 
       ;; If no member is found, just 404
       (when-not member
@@ -179,8 +185,7 @@
                   :code :member-does-not-exist))
 
       ;; First check if we have permissions to change roles
-      (when-not (or (some :is-owner perms)
-                    (some :is-admin perms))
+      (when-not (or is-owner? is-admin?)
         (ex/raise :type :validation
                   :code :insufficient-permissions))
 
@@ -190,21 +195,20 @@
                   :code :cant-change-role-to-owner))
 
       ;; Don't allow promote to owner to admin users.
-      (when (and (= role :owner)
-                 (not (:is-owner perms)))
+      (when (and (not is-owner?) (= role :owner))
         (ex/raise :type :validation
                   :code :cant-promote-to-owner))
 
       (let [params (role->params role)]
         ;; Only allow single owner on team
-        (when (and (= role :owner)
-                   (:is-owner perms))
+        (when (= role :owner)
           (db/update! conn :team-profile-rel
                       {:is-owner false}
                       {:team-id team-id
                        :profile-id profile-id}))
 
-        (db/update! conn :team-profile-rel params
+        (db/update! conn :team-profile-rel
+                    params
                     {:team-id team-id
                      :profile-id member-id})
         nil))))
@@ -218,7 +222,7 @@
     :viewer {:is-owner false :is-admin false :can-edit false}))
 
 
-;; --- Mutation: Team Update Role
+;; --- Mutation: Delete Team Member
 
 (s/def ::delete-team-member
   (s/keys :req-un [::profile-id ::team-id ::member-id]))
@@ -227,8 +231,8 @@
   [{:keys [pool] :as cfg} {:keys [team-id profile-id member-id] :as params}]
   (db/with-atomic [conn pool]
     (let [perms (teams/check-read-permissions! conn profile-id team-id)]
-      (when-not (or (:is-owner perms)
-                    (:is-admin perms))
+      (when-not (or (some :is-owner perms)
+                    (some :is-admin perms))
         (ex/raise :type :validation
                   :code :insufficient-permissions))
 
@@ -252,9 +256,10 @@
 
 (sv/defmethod ::update-team-photo
   [{:keys [pool storage] :as cfg} {:keys [profile-id file team-id] :as params}]
-  (media/validate-media-type (:content-type file))
   (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"})
+
     (let [team    (teams/retrieve-team conn profile-id team-id)
           _       (media/run cfg {:cmd :info :input {:path (:tempfile file)
                                                      :mtype (:content-type file)}})
@@ -297,26 +302,48 @@
 (sv/defmethod ::invite-team-member
   [{:keys [pool tokens] :as cfg} {:keys [profile-id team-id email role] :as params}]
   (db/with-atomic [conn pool]
-    (let [perms   (teams/check-edition-permissions! conn profile-id team-id)
-          profile (db/get-by-id conn :profile profile-id)
-          member  (profile/retrieve-profile-data-by-email conn email)
-          team    (db/get-by-id conn :team team-id)
-          token   (tokens :generate
-                          {:iss :team-invitation
-                           :exp (dt/in-future "24h")
-                           :profile-id (:id profile)
-                           :role role
-                           :team-id team-id
-                           :member-email (:email member email)
-                           :member-id (:id member)})]
+    (let [perms    (teams/check-edition-permissions! conn profile-id team-id)
+          profile  (db/get-by-id conn :profile profile-id)
+          member   (profile/retrieve-profile-data-by-email conn email)
+          team     (db/get-by-id conn :team team-id)
+          itoken   (tokens :generate
+                           {:iss :team-invitation
+                            :exp (dt/in-future "6h")
+                            :profile-id (:id profile)
+                            :role role
+                            :team-id team-id
+                            :member-email (:email member email)
+                            :member-id (:id member)})
+          ptoken   (tokens :generate-predefined
+                           {:iss :profile-identity
+                            :profile-id (:id profile)})]
 
       (when-not (some :is-admin perms)
         (ex/raise :type :validation
                   :code :insufficient-permissions))
 
+      ;; First check if the current profile is allowed to send emails.
+      (when-not (emails/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 (and member (not (emails/allow-send-emails? conn member)))
+        (ex/raise :type :validation
+                  :code :member-is-muted
+                  :hint "looks like the profile has reported repeatedly as spam or has permanent bounces"))
+
+      ;; Secondly check if the invited member email is part of the
+      ;; global spam/bounce report.
+      (when (emails/has-bounce-reports? conn email)
+        (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"))
+
       (emails/send! conn emails/invite-to-team
                     {:to email
                      :invited-by (:fullname profile)
                      :team (:name team)
-                     :token token})
+                     :token itoken
+                     :extra-data ptoken})
       nil)))

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

@@ -5,14 +5,13 @@
 ;; This Source Code Form is "Incompatible With Secondary Licenses", as
 ;; defined by the Mozilla Public License, v. 2.0.
 ;;
-;; Copyright (c) 2020 UXBOX Labs SL
+;; Copyright (c) 2020-2021 UXBOX Labs SL
 
 (ns app.rpc.mutations.verify-token
   (:require
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.db :as db]
-   [app.http.session :as session]
    [app.rpc.mutations.teams :as teams]
    [app.rpc.queries.profile :as profile]
    [app.util.services :as sv]
@@ -41,8 +40,15 @@
               {:id profile-id})
   claims)
 
+(defn- annotate-profile-activation
+  "A helper for properly increase the profile-activation metric once the
+  transaction is completed."
+  [metrics]
+  (fn []
+    ((get-in metrics [:definitions :profile-activation]) :inc)))
+
 (defmethod process-token :verify-email
-  [{:keys [conn session] :as cfg} _params {:keys [profile-id] :as claims}]
+  [{:keys [conn session metrics] :as cfg} _ {:keys [profile-id] :as claims}]
   (let [profile (profile/retrieve-profile conn profile-id)
         claims  (assoc claims :profile profile)]
 
@@ -57,14 +63,8 @@
                   {:id (:id profile)}))
 
     (with-meta claims
-      {:transform-response
-       (fn [request response]
-         (let [uagent (get-in request [:headers "user-agent"])
-               id     (session/create! session {:profile-id profile-id
-                                                :user-agent uagent})]
-           (assoc response
-                  :cookies (session/cookies session {:value id}))))})))
-
+      {:transform-response ((:create session) profile-id)
+       :before-complete (annotate-profile-activation metrics)})))
 
 (defmethod process-token :auth
   [{:keys [conn] :as cfg} _params {:keys [profile-id] :as claims}]
@@ -91,47 +91,78 @@
                    :internal.tokens.team-invitation/member-email]
           :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
+                       :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})
+
+    ;; If profile is not yet verified, mark it as verified because
+    ;; accepting an invitation link serves as verification.
+    (when-not (:is-active member)
+      (db/update! conn :profile
+                  {:is-active true}
+                  {:id member-id}))
+    (assoc member :is-active true)))
+
 (defmethod process-token :team-invitation
-  [{:keys [conn session] :as cfg} {:keys [profile-id token]} {:keys [member-id team-id role] :as claims}]
+  [{:keys [session] :as cfg} {:keys [profile-id token]} {:keys [member-id] :as claims}]
   (us/assert ::team-invitation-claims claims)
-  (if (uuid? member-id)
-    (let [params (merge {:team-id team-id
-                         :profile-id member-id}
-                        (teams/role->params role))
-          claims (assoc claims :state :created)]
-
-      (db/insert! conn :team-profile-rel params
-                  {:on-conflict-do-nothing true})
-
-      (if (and (uuid? profile-id)
-               (= member-id profile-id))
+  (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))
+    (do
+      (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.
-        claims
+        (assoc claims :state :created)
 
-        ;; If the session does not matches the invited member id,
-        ;; replace the session with a new one matching the invited
-        ;; member. This techinique should be considered secure because
-        ;; the user clicking the link he already has access to the
-        ;; email account.
-        (with-meta claims
-          {:transform-response
-           (fn [request response]
-             (let [uagent (get-in request [:headers "user-agent"])
-                   id     (session/create! session {:profile-id member-id
-                                                    :user-agent uagent})]
-               (assoc response
-                      :cookies (session/cookies session {:value id}))))})))
+        ;; If the session does not matches the invited member, replace
+        ;; the session with a new one matching the invited member.
+        ;; This techinique 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)})))
+
+    ;; 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))
+    (do
+      (accept-invitation cfg (assoc claims :member-id profile-id))
+      (assoc claims :state :created))
+
+    ;; 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))
+    (do
+      (accept-invitation cfg claims)
+      (with-meta
+        (assoc claims :state :created)
+        {:transform-response ((:create session) member-id)}))
 
     ;; In this case, we wait until frontend app redirect user to
     ;; registeration 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.
-    (assoc claims
-           :token token
-           :state :pending)))
+    :else
+    {:invitation-token token
+     :iss :team-invitation
+     :state :pending}))
 
 
 ;; --- Default

backend/src/app/rpc/permissions.clj

@@ -11,7 +11,34 @@
   "A permission checking helper factories."
   (:require
    [app.common.exceptions :as ex]
-   [app.common.spec :as us]))
+   [app.common.spec :as us]
+   [clojure.spec.alpha :as s]))
+
+(s/def ::role #{:admin :owner :editor :viewer})
+
+(defn assign-role-flags
+  [params role]
+  (us/verify ::role role)
+  (cond-> params
+    (= role :owner)
+    (assoc :is-owner true
+           :is-admin true
+           :can-edit true)
+
+    (= role :admin)
+    (assoc :is-owner false
+           :is-admin true
+           :can-edit true)
+
+    (= role :editor)
+    (assoc :is-owner false
+           :is-admin false
+           :can-edit true)
+
+    (= role :viewer)
+    (assoc :is-owner false
+           :is-admin false
+           :can-edit false)))
 
 (defn make-edition-check-fn
   "A simple factory for edition permission check functions."

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

@@ -166,7 +166,6 @@
     (let [file (retrieve-file conn file-id)]
       (get-in file [:data :pages-index id]))))
 
-
 ;; --- Query: Shared Library Files
 
 (def ^:private sql:shared-files
@@ -256,12 +255,11 @@
 ;; --- Helpers
 
 (defn decode-row
-  [{:keys [pages data changes] :as row}]
+  [{:keys [data changes] :as row}]
   (when row
     (cond-> row
       changes (assoc :changes (blob/decode changes))
-      data (assoc :data (blob/decode data))
-      pages (assoc :pages (vec (.getArray pages))))))
+      data    (assoc :data (blob/decode data)))))
 
 (def decode-row-xf
   (comp (map decode-row)

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

@@ -14,8 +14,7 @@
    [app.common.uuid :as uuid]
    [app.db :as db]
    [app.util.services :as sv]
-   [clojure.spec.alpha :as s]
-   [cuerdas.core :as str]))
+   [clojure.spec.alpha :as s]))
 
 ;; --- Helpers & Specs
 
@@ -71,6 +70,10 @@
     {:default-team-id (:id team)
      :default-project-id (:id project)}))
 
+(defn populate-additional-data
+  [conn profile]
+  (merge profile (retrieve-additional-data conn (:id profile))))
+
 (defn decode-profile-row
   [{:keys [props] :as row}]
   (cond-> row
@@ -83,27 +86,25 @@
 
 (defn retrieve-profile
   [conn id]
-  (let [profile (some-> (retrieve-profile-data conn id)
-                        (strip-private-attrs)
-                        (merge (retrieve-additional-data conn id)))]
+  (let [profile (some->> (retrieve-profile-data conn id)
+                         (strip-private-attrs)
+                         (populate-additional-data conn))]
     (when (nil? profile)
       (ex/raise :type :not-found
                 :hint "Object doest not exists."))
 
     profile))
 
-
-(def sql:profile-by-email
-  "select * from profile
-    where email=?
-      and deleted_at is null")
+(def sql:retrieve-profile-by-email
+  "select p.* from profile as p
+    where p.email = lower(?)
+      and p.deleted_at is null")
 
 (defn retrieve-profile-data-by-email
   [conn email]
-  (let [email (str/lower email)]
-    (-> (db/exec-one! conn [sql:profile-by-email email])
-        (decode-profile-row))))
-
+  (let [sql  [sql:retrieve-profile-by-email email]]
+    (some-> (db/exec-one! conn sql)
+            (decode-profile-row))))
 
 ;; --- Attrs Helpers
 

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

@@ -82,6 +82,50 @@
   (db/exec! conn [sql:projects profile-id team-id]))
 
 
+;; --- Query: All projects
+
+(declare retrieve-all-projects)
+
+(s/def ::profile-id ::us/uuid)
+(s/def ::all-projects
+  (s/keys :req-un [::profile-id]))
+
+(sv/defmethod ::all-projects
+  [{:keys [pool]} {:keys [profile-id]}]
+  (with-open [conn (db/open pool)]
+    (retrieve-all-projects conn profile-id)))
+
+(def sql:all-projects
+  "select p1.*, t.name as team_name, t.is_default as is_default_team
+     from project as p1
+    inner join team as t
+            on t.id = p1.team_id
+    where t.id in (select team_id
+                     from team_profile_rel as tpr
+                    where tpr.profile_id = ?
+                      and (tpr.can_edit = true or
+                           tpr.is_owner = true or
+                           tpr.is_admin = true))
+      and p1.deleted_at is null
+   union
+   select p2.*, t.name as team_name, t.is_default as is_default_team
+     from project as p2
+    inner join team as t
+              on t.id = p2.team_id
+    where p2.id in (select project_id
+                     from project_profile_rel as ppr
+                    where ppr.profile_id = ?
+                      and (ppr.can_edit = true or
+                           ppr.is_owner = true or
+                           ppr.is_admin = true))
+      and p2.deleted_at is null
+    order by team_name, name;")
+
+(defn retrieve-all-projects
+  [conn profile-id]
+  (db/exec! conn [sql:all-projects profile-id profile-id]))
+
+
 ;; --- Query: Project
 
 (s/def ::id ::us/uuid)
@@ -94,3 +138,4 @@
     (let [project (db/get-by-id conn :project id)]
       (check-read-permissions! conn profile-id id)
       project)))
+

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

@@ -27,7 +27,7 @@
      window w as (partition by f.project_id order by f.modified_at desc)
       order by f.modified_at desc
    )
-   select * from recent_files where row_num <= 6;")
+   select * from recent_files where row_num <= 10;")
 
 (s/def ::team-id ::us/uuid)
 (s/def ::profile-id ::us/uuid)
@@ -41,5 +41,3 @@
     (teams/check-read-permissions! conn profile-id team-id)
     (let [files (db/exec! conn [sql:recent-files team-id])]
       (into [] decode-row-xf files))))
-
-

backend/src/app/setup.clj

@@ -7,8 +7,8 @@
 ;;
 ;; Copyright (c) 2020-2021 UXBOX Labs SL
 
-(ns app.sprops
-  "Server props module."
+(ns app.setup
+  "Initial data setup of instance."
   (:require
    [app.common.uuid :as uuid]
    [app.db :as db]
@@ -17,42 +17,45 @@
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]))
 
-(declare initialize)
+(declare initialize-instance-id!)
+(declare initialize-secret-key!)
+(declare retrieve-all)
 
 (defmethod ig/pre-init-spec ::props [_]
   (s/keys :req-un [::db/pool]))
 
 (defmethod ig/init-key ::props
-  [_ cfg]
-  (initialize cfg))
+  [_ {:keys [pool] :as cfg}]
+  (db/with-atomic [conn pool]
+    (let [cfg (assoc cfg :conn conn)]
+      (initialize-secret-key! cfg)
+      (initialize-instance-id! cfg)
+      (retrieve-all cfg))))
 
-(defn- initialize-secret-key
+(defn- initialize-secret-key!
   [{:keys [conn] :as cfg}]
   (let [key (-> (bn/random-bytes 64)
                 (bc/bytes->b64u)
                 (bc/bytes->str))]
-    (db/exec-one! conn ["insert into server_prop (id, content)
-                         values ('secret-key', ?) on conflict do nothing"
-                        (db/tjson key)])))
+    (db/insert! conn :server-prop
+                {:id "secret-key"
+                 :preload true
+                 :content (db/tjson key)}
+                {:on-conflict-do-nothing true})))
 
-(defn- initialize-instance-id
+(defn- initialize-instance-id!
   [{:keys [conn] :as cfg}]
   (let [iid (uuid/random)]
-    (db/exec-one! conn ["insert into server_prop (id, content)
-                         values ('instance-id', ?::jsonb) on conflict do nothing"
-                        (db/tjson iid)])))
+
+    (db/insert! conn :server-prop
+                {:id "instance-id"
+                 :preload true
+                 :content (db/tjson iid)}
+                {:on-conflict-do-nothing true})))
 
 (defn- retrieve-all
   [{:keys [conn] :as cfg}]
   (reduce (fn [acc row]
             (assoc acc (keyword (:id row)) (db/decode-transit-pgobject (:content row))))
           {}
-          (db/exec! conn ["select * from server_prop;"])))
-
-(defn- initialize
-  [{:keys [pool] :as cfg}]
-  (db/with-atomic [conn pool]
-    (let [cfg (assoc cfg :conn conn)]
-      (initialize-secret-key cfg)
-      (initialize-instance-id cfg)
-      (retrieve-all cfg))))
+          (db/query conn :server-prop {:preload true})))

backend/src/app/setup/initial_data.clj

@@ -0,0 +1,103 @@
+;; 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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2021 UXBOX Labs SL
+
+(ns app.setup.initial-data
+  (:refer-clojure :exclude [load])
+  (:require
+   [app.common.uuid :as uuid]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.rpc.mutations.management :refer [duplicate-file]]
+   [app.rpc.mutations.projects :refer [create-project create-project-role]]
+   [app.rpc.queries.profile :as profile]))
+
+;; --- DUMP GENERATION
+
+(def sql:file
+  "select * from file where project_id = ?")
+
+(def sql:file-library-rel
+  "with file_ids as (select id from file where project_id = ?)
+   select *
+     from file_library_rel
+     where file_id in (select id from file_ids)")
+
+(def sql:file-media-object
+  "with file_ids as (select id from file where project_id = ?)
+   select *
+     from file_media_object
+     where file_id in (select id from file_ids)")
+
+(defn dump
+  ([system project-id] (dump system project-id nil))
+  ([system project-id {:keys [skey project-name]
+                       :or {project-name "Penpot Onboarding"}}]
+   (db/with-atomic [conn (:app.db/pool system)]
+     (let [skey  (or skey (cfg/get :initial-project-skey))
+           files (db/exec! conn [sql:file project-id])
+           flibs (db/exec! conn [sql:file-library-rel project-id])
+           fmeds (db/exec! conn [sql:file-media-object project-id])
+           data  {:project-name project-name
+                  :files files
+                  :flibs flibs
+                  :fmeds fmeds}]
+
+       (db/delete! conn :server-prop {:id skey})
+       (db/insert! conn :server-prop
+                   {:id skey
+                    :preload false
+                    :content (db/tjson data)})
+       skey))))
+
+
+;; --- DUMP LOADING
+
+(defn- retrieve-data
+  [conn skey]
+  (when-let [row (db/exec-one! conn ["select content from server_prop where id = ?" skey])]
+    (when-let [content (:content row)]
+      (when (db/pgobject? content)
+        (db/decode-transit-pgobject content)))))
+
+(defn load-initial-project!
+  ([conn profile] (load-initial-project! conn profile nil))
+  ([conn profile opts]
+   (let [skey (or (:skey opts) (cfg/get :initial-project-skey))
+         data (retrieve-data conn skey)]
+     (when data
+       (let [index   (reduce #(assoc %1 (:id %2) (uuid/next)) {} (:files data))
+             project {:id (uuid/next)
+                      :profile-id (:id profile)
+                      :team-id (:default-team-id profile)
+                      :name (:project-name data)}]
+
+         (db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED"])
+
+         (create-project conn project)
+         (create-project-role conn {:project-id (:id project)
+                                    :profile-id (:id profile)
+                                    :role :owner})
+
+         (doseq [file (:files data)]
+           (let [params {:profile-id (:id profile)
+                         :project-id (:id project)
+                         :file file
+                         :index index}
+                 opts   {:reset-shared-flag false}]
+             (duplicate-file conn params opts))))))))
+
+(defn load
+  [system {:keys [email] :as opts}]
+  (db/with-atomic [conn (:app.db/pool system)]
+    (when-let [profile (some->> email
+                                (profile/retrieve-profile-data-by-email conn)
+                                (profile/populate-additional-data conn))]
+      (load-initial-project! conn profile opts)
+      true)))
+

backend/src/app/srepl/main.clj

@@ -3,14 +3,16 @@
   #_:clj-kondo/ignore
   (:require
    [app.common.pages :as cp]
+   [app.common.uuid :as uuid]
    [app.common.pages.migrations :as pmg]
    [app.config :as cfg]
    [app.db :as db]
-   [app.db.profile-initial-data :as pid]
+   [app.db.sql :as sql]
    [app.main :refer [system]]
    [app.rpc.queries.profile :as prof]
    [app.srepl.dev :as dev]
    [app.util.blob :as blob]
+   [cuerdas.core :as str]
    [clojure.pprint :refer [pprint]]))
 
 (defn update-file
@@ -53,27 +55,6 @@
 ;;         (fn [{:keys [data] :as file}]
 ;;           (update-in data [:pages-index #uuid "878278c0-3ef0-11eb-9d67-8551e7624f43" :objects] dissoc nil))))
 
-(def default-project-id #uuid "5761a890-3b81-11eb-9e7d-556a2f641513")
-
-(defn initial-data-dump
-  ([system file] (initial-data-dump system default-project-id file))
-  ([system project-id path]
-   (db/with-atomic [conn (:app.db/pool system)]
-     (pid/create-initial-data-dump conn project-id path))))
-
-(defn load-data-into-user
-  ([system user-email]
-   (if-let [file (:initial-data-file cfg/config)]
-     (load-data-into-user system file user-email)
-     (prn "Data file not found in configuration")))
-
-  ([system file user-email]
-   (db/with-atomic [conn (:app.db/pool system)]
-     (let [profile (prof/retrieve-profile-data-by-email conn user-email)
-           profile (merge profile (prof/retrieve-additional-data conn (:id profile)))]
-       (pid/create-profile-initial-data conn file profile)))))
-
-
 ;; Migrate
 
 (defn update-file-data-blob-format
@@ -86,3 +67,17 @@
                     {:data (-> (blob/decode data)
                                (blob/encode {:version 2}))}
                     {:id id})))))
+
+
+(defn duplicate-file
+  "This is a raw version of duplication of file just only for forensic analisys"
+  [system file-id email]
+  (db/with-atomic [conn (:app.db/pool system)]
+    (when-let [profile (some->> (prof/retrieve-profile-data-by-email conn (str/lower email))
+                                (prof/populate-additional-data conn))]
+      (when-let [file (db/exec-one! conn (sql/select :file {:id file-id}))]
+        (let [params (assoc file
+                            :id (uuid/next)
+                            :project-id (:default-project-id profile))]
+          (db/insert! conn :file params)
+          (:id file))))))

backend/src/app/storage.clj

@@ -308,7 +308,7 @@
           (if-let [[groups total] (retrieve-deleted-objects conn)]
             (do
               (run! (partial delete-in-bulk conn) groups)
-              (recur (+ n total)))
+              (recur (+ n ^long total)))
             (do
               (log/infof "gc-deleted: processed %s items" n)
               {:deleted n})))))))

backend/src/app/storage/impl.clj

@@ -165,7 +165,7 @@
      (string->content data)
 
      (bytes? data)
-     (input-stream->content (ByteArrayInputStream. ^bytes data) (alength data))
+     (input-stream->content (ByteArrayInputStream. ^bytes data) (alength ^bytes data))
 
      (instance? InputStream data)
      (do

backend/src/app/svgparse.clj

@@ -5,90 +5,19 @@
 ;; This Source Code Form is "Incompatible With Secondary Licenses", as
 ;; defined by the Mozilla Public License, v. 2.0.
 ;;
-;; Copyright (c) 2020 UXBOX Labs SL
+;; Copyright (c) UXBOX Labs SL
 
 (ns app.svgparse
   (:require
    [app.common.exceptions :as ex]
    [app.metrics :as mtx]
-   [app.util.graal :as graal]
-   [app.util.pool :as pool]
-   [clojure.java.io :as io]
    [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
    [clojure.xml :as xml]
    [integrant.core :as ig])
   (:import
-   java.util.function.Consumer
    org.apache.commons.io.IOUtils))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; SVG Clean
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(declare clean-svg)
-(declare prepare-context-pool)
-
-(defmethod ig/pre-init-spec ::svgc [_]
-  (s/keys :req-un [::mtx/metrics]))
-
-(defmethod ig/init-key ::svgc
-  [_ {:keys [metrics] :as cfg}]
-  (let [pool    (prepare-context-pool cfg)
-        cfg     (assoc cfg :pool pool)
-        handler #(clean-svg cfg %)
-        handler (->> {:registry (:registry metrics)
-                      :type :summary
-                      :name "svgc_timing"
-                      :help "svg optimization function timing"}
-                     (mtx/instrument handler))]
-    (with-meta handler {::pool pool})))
-
-(defmethod ig/halt-key! ::svgc
-  [_ f]
-  (let [{:keys [::pool]} (meta f)]
-    (pool/clear! pool)
-    (pool/close! pool)))
-
-(defn- prepare-context-pool
-  [cfg]
-  (pool/create
-   {:min-idle  (:min-idle cfg 0)
-    :max-idle  (:max-idle cfg 3)
-    :max-total (:max-total cfg 3)
-    :create
-    (fn []
-      (let [ctx (graal/context "js")]
-        (->> (graal/source "js" (io/resource "svgclean.js"))
-             (graal/eval! ctx))
-        ctx))
-    :destroy
-    (fn [ctx]
-      (graal/close! ctx))}))
-
-(defn- clean-svg
-  [{:keys [pool]} data]
-  (with-open [ctx (pool/acquire pool)]
-    (let [res      (promise)
-          optimize (-> (graal/get-bindings @ctx "js")
-                       (graal/get-member "svgc")
-                       (graal/get-member "optimize"))
-          resultp (graal/invoke optimize data)]
-
-      (graal/invoke-member resultp "then"
-                           (reify Consumer
-                             (accept [_ val]
-                               (deliver res val))))
-
-      (graal/invoke-member resultp "catch"
-                           (reify Consumer
-                             (accept [_ err]
-                               (deliver res err))))
-
-      (let [result (deref res)]
-        (if (instance? Throwable result)
-          (throw result)
-          result)))))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Handler
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -96,10 +25,8 @@
 (declare handler)
 (declare process-request)
 
-(s/def ::svgc fn?)
-
 (defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::mtx/metrics ::svgc]))
+  (s/keys :req-un [::mtx/metrics]))
 
 (defmethod ig/init-key ::handler
   [_ {:keys [metrics] :as cfg}]
@@ -111,26 +38,35 @@
          (mtx/instrument handler))))
 
 (defn- handler
-  [cfg {:keys [headers body] :as request}]
+  [_ {:keys [headers body] :as request}]
   (when (not= "image/svg+xml" (get headers "content-type"))
     (ex/raise :type :validation
               :code :unsupported-mime-type
               :mime (get headers "content-type")))
   {:status 200
-   :body (process-request cfg body)})
+   :body (process-request body)})
+
+(defn secure-factory
+  [s ch]
+  (.. (doto (javax.xml.parsers.SAXParserFactory/newInstance)
+        (.setFeature javax.xml.XMLConstants/FEATURE_SECURE_PROCESSING true)
+        (.setFeature "http://apache.org/xml/features/disallow-doctype-decl" true))
+      (newSAXParser)
+      (parse s ch)))
 
 (defn parse
   [data]
   (try
     (with-open [istream (IOUtils/toInputStream data "UTF-8")]
-      (xml/parse istream))
-    (catch org.xml.sax.SAXParseException _e
+      (xml/parse istream secure-factory))
+    (catch Exception e
+      (log/warnf "error on processing svg: %s" (ex-message e))
       (ex/raise :type :validation
-                :code :invalid-svg-file))))
+                :code :invalid-svg-file
+                :cause e))))
 
 (defn process-request
-  [{:keys [svgc] :as cfg} body]
-  (let [data (slurp body)
-        data (svgc data)]
+  [body]
+  (let [data (slurp body)]
     (parse data)))
 

backend/src/app/tasks.clj

@@ -5,17 +5,19 @@
 ;; This Source Code Form is "Incompatible With Secondary Licenses", as
 ;; defined by the Mozilla Public License, v. 2.0.
 ;;
-;; Copyright (c) 2020 UXBOX Labs SL
+;; Copyright (c) 2020-2021 UXBOX Labs SL
 
 (ns app.tasks
   (:require
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
    [app.db :as db]
-   ;; [app.metrics :as mtx]
+   [app.metrics :as mtx]
    [app.util.time :as dt]
+   [app.worker]
    [clojure.spec.alpha :as s]
-   [clojure.tools.logging :as log]))
+   [clojure.tools.logging :as log]
+   [integrant.core :as ig]))
 
 (s/def ::name ::us/string)
 (s/def ::delay
@@ -41,11 +43,68 @@
         interval  (db/interval duration)
         props     (db/tjson props)
         id        (uuid/next)]
-    (log/infof "Submit task '%s' to be executed in '%s'." name (str duration))
+    (log/debugf "submit task '%s' to be executed in '%s'" name (str duration))
     (db/exec-one! conn [sql:insert-new-task id name props queue priority max-retries interval])
     id))
 
-;; (mtx/instrument-with-counter!
-;;  {:var #'submit!
-;;   :id "tasks__submit_counter"
-;;   :help "Absolute task submit counter."})
+(defn- instrument!
+  [registry]
+  (mtx/instrument-vars!
+   [#'submit!]
+   {:registry registry
+    :type :counter
+    :labels ["name"]
+    :name "tasks_submit_total"
+    :help "A counter of task submissions."
+    :wrap (fn [rootf mobj]
+            (let [mdata (meta rootf)
+                  origf (::original mdata rootf)]
+              (with-meta
+                (fn [conn params]
+                  (let [tname (:name params)]
+                    (mobj :inc [tname])
+                    (origf conn params)))
+                {::original origf})))})
+
+  (mtx/instrument-vars!
+   [#'app.worker/run-task]
+   {:registry registry
+    :type :summary
+    :quantiles []
+    :name "tasks_checkout_timing"
+    :help "Latency measured between scheduld_at and execution time."
+    :wrap (fn [rootf mobj]
+            (let [mdata (meta rootf)
+                  origf (::original mdata rootf)]
+              (with-meta
+                (fn [tasks item]
+                  (let [now (inst-ms (dt/now))
+                        sat (inst-ms (:scheduled-at item))]
+                    (mobj :observe (- now sat))
+                    (origf tasks item)))
+                {::original origf})))}))
+
+;; --- STATE INIT: REGISTRY
+
+(s/def ::tasks
+  (s/map-of keyword? fn?))
+
+(defmethod ig/pre-init-spec ::registry [_]
+  (s/keys :req-un [::mtx/metrics ::tasks]))
+
+(defmethod ig/init-key ::registry
+  [_ {:keys [metrics tasks]}]
+  (instrument! (:registry metrics))
+  (let [mobj (mtx/create
+              {:registry (:registry metrics)
+               :type :summary
+               :labels ["name"]
+               :quantiles []
+               :name "tasks_timing"
+               :help "Background task execution timing."})]
+    (reduce-kv (fn [res k v]
+                 (let [tname (name k)]
+                   (log/debugf "registring task '%s'" tname)
+                   (assoc res tname (mtx/wrap-summary v mobj [tname]))))
+               {}
+               tasks)))

backend/src/app/tasks/delete_object.clj

@@ -12,42 +12,32 @@
   (:require
    [app.common.spec :as us]
    [app.db :as db]
-   [app.metrics :as mtx]
    [clojure.spec.alpha :as s]
    [clojure.tools.logging :as log]
    [integrant.core :as ig]))
 
-(declare handler)
 (declare handle-deletion)
 
 (defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::db/pool ::mtx/metrics]))
+  (s/keys :req-un [::db/pool]))
 
 (defmethod ig/init-key ::handler
-  [_ {:keys [metrics] :as cfg}]
-  (let [handler #(handler cfg %)]
-    (->> {:registry (:registry metrics)
-          :type :summary
-          :name "task_delete_object_timing"
-          :help "delete object task timing"}
-         (mtx/instrument handler))))
+  [_ {:keys [pool] :as cfg}]
+  (fn [{:keys [props] :as task}]
+    (us/verify ::props props)
+    (db/with-atomic [conn pool]
+      (handle-deletion conn props))))
 
 (s/def ::type ::us/keyword)
 (s/def ::id ::us/uuid)
 (s/def ::props (s/keys :req-un [::id ::type]))
 
-(defn- handler
-  [{:keys [pool]} {:keys [props] :as task}]
-  (us/verify ::props props)
-  (db/with-atomic [conn pool]
-    (handle-deletion conn props)))
-
 (defmulti handle-deletion
   (fn [_ props] (:type props)))
 
 (defmethod handle-deletion :default
   [_conn {:keys [type]}]
-  (log/warnf "no handler found for %s" type))
+  (log/warnf "no handler found for '%s'" type))
 
 (defmethod handle-deletion :file
   [conn {:keys [id] :as props}]

backend/src/app/tasks/delete_profile.clj

@@ -13,27 +13,16 @@
    [app.common.spec :as us]
    [app.db :as db]
    [app.db.sql :as sql]
-   [app.metrics :as mtx]
    [clojure.spec.alpha :as s]
    [clojure.tools.logging :as log]
    [integrant.core :as ig]))
 
 (declare delete-profile-data)
-(declare handler)
 
 ;; --- INIT
 
 (defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::db/pool ::mtx/metrics]))
-
-(defmethod ig/init-key ::handler
-  [_ {:keys [metrics] :as cfg}]
-  (let [handler #(handler cfg %)]
-    (->> {:registry (:registry metrics)
-          :type :summary
-          :name "task_delete_profile_timing"
-          :help "delete profile task timing"}
-         (mtx/instrument handler))))
+  (s/keys :req-un [::db/pool]))
 
 ;; This task is responsible to permanently delete a profile with all
 ;; the dependent data. As step (1) we delete all owned teams of the
@@ -48,16 +37,17 @@
 (s/def ::profile-id ::us/uuid)
 (s/def ::props (s/keys :req-un [::profile-id]))
 
-(defn handler
-  [{:keys [pool]} {:keys [props] :as task}]
-  (us/verify ::props props)
-  (db/with-atomic [conn pool]
-    (let [id      (:profile-id props)
-          profile (db/exec-one! conn (sql/select :profile {:id id} {:for-update true}))]
-      (if (or (:is-demo profile)
-              (:deleted-at profile))
-        (delete-profile-data conn id)
-        (log/warnf "Profile %s does not match constraints for deletion" id)))))
+(defmethod ig/init-key ::handler
+  [_ {:keys [pool] :as cfg}]
+  (fn [{:keys [props] :as task}]
+    (us/verify ::props props)
+    (db/with-atomic [conn pool]
+      (let [id      (:profile-id props)
+            profile (db/exec-one! conn (sql/select :profile {:id id} {:for-update true}))]
+        (if (or (:is-demo profile)
+                (:deleted-at profile))
+          (delete-profile-data conn id)
+          (log/warnf "profile '%s' does not match constraints for deletion" id))))))
 
 ;; --- IMPL
 
@@ -80,7 +70,7 @@
 
 (defn- delete-profile-data
   [conn profile-id]
-  (log/infof "Proceding to delete all data related to profile id = %s" profile-id)
+  (log/debugf "proceding to delete all data related to profile '%s'" profile-id)
   (delete-teams conn profile-id)
   (delete-profile conn profile-id)
   true)

backend/src/app/tasks/file_media_gc.clj

@@ -5,7 +5,7 @@
 ;; This Source Code Form is "Incompatible With Secondary Licenses", as
 ;; defined by the Mozilla Public License, v. 2.0.
 ;;
-;; Copyright (c) 2020 UXBOX Labs SL
+;; Copyright (c) 2020-2021 UXBOX Labs SL
 
 (ns app.tasks.file-media-gc
   "A maintenance task that is responsible to purge the unused media
@@ -14,44 +14,34 @@
   (:require
    [app.common.pages.migrations :as pmg]
    [app.db :as db]
-   [app.metrics :as mtx]
    [app.util.blob :as blob]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
    [clojure.tools.logging :as log]
    [integrant.core :as ig]))
 
-(declare handler)
 (declare process-file)
 (declare retrieve-candidates)
 
 (s/def ::max-age ::dt/duration)
 
 (defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::db/pool ::mtx/metrics ::max-age]))
+  (s/keys :req-un [::db/pool ::max-age]))
 
 (defmethod ig/init-key ::handler
-  [_ {:keys [metrics] :as cfg}]
-  (let [handler #(handler cfg %)]
-    (->> {:registry (:registry metrics)
-          :type :summary
-          :name "task_file_media_gc_timing"
-          :help "file media garbage collection task timing"}
-         (mtx/instrument handler))))
-
-(defn- handler
-  [{:keys [pool] :as cfg} _]
-  (db/with-atomic [conn pool]
-    (let [cfg (assoc cfg :conn conn)]
-      (loop [n 0]
-        (let [files (retrieve-candidates cfg)]
-          (if (seq files)
-            (do
-              (run! (partial process-file cfg) files)
-              (recur (+ n (count files))))
-            (do
-              (log/infof "finalized with total of %s processed files" n)
-              {:processed n})))))))
+  [_ {:keys [pool] :as cfg}]
+  (fn [_]
+    (db/with-atomic [conn pool]
+      (let [cfg (assoc cfg :conn conn)]
+        (loop [n 0]
+          (let [files (retrieve-candidates cfg)]
+            (if (seq files)
+              (do
+                (run! (partial process-file cfg) files)
+                (recur (+ n (count files))))
+              (do
+                (log/debugf "finalized with total of %s processed files" n)
+                {:processed n}))))))))
 
 (def ^:private
   sql:retrieve-candidates-chunk
@@ -98,7 +88,7 @@
         unused (->> (db/query conn :file-media-object {:file-id id})
                     (remove #(contains? used (:id %))))]
 
-    (log/infof "processing file: id='%s' age='%s' to-delete=%s" id age (count unused))
+    (log/debugf "processing file: id='%s' age='%s' to-delete=%s" id age (count unused))
 
     ;; Mark file as trimmed
     (db/update! conn :file

backend/src/app/tasks/file_xlog_gc.clj

@@ -5,45 +5,36 @@
 ;; This Source Code Form is "Incompatible With Secondary Licenses", as
 ;; defined by the Mozilla Public License, v. 2.0.
 ;;
-;; Copyright (c) 2020 UXBOX Labs SL
+;; Copyright (c) 2020-2021 UXBOX Labs SL
 
 (ns app.tasks.file-xlog-gc
   "A maintenance task that performs a garbage collection of the file
   change (transaction) log."
   (:require
    [app.db :as db]
-   [app.metrics :as mtx]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
    [clojure.tools.logging :as log]
    [integrant.core :as ig]))
 
-(declare handler)
+(declare sql:delete-files-xlog)
 
 (s/def ::max-age ::dt/duration)
 
 (defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::db/pool ::mtx/metrics ::max-age]))
+  (s/keys :req-un [::db/pool ::max-age]))
 
 (defmethod ig/init-key ::handler
-  [_ {:keys [metrics] :as cfg}]
-  (let [handler #(handler cfg %)]
-    (->> {:registry (:registry metrics)
-          :type :summary
-          :name "task_file_xlog_gc_timing"
-          :help "file changes garbage collection task timing"}
-         (mtx/instrument handler))))
+  [_ {:keys [pool max-age] :as cfg}]
+  (fn [_]
+    (db/with-atomic [conn pool]
+      (let [interval (db/interval max-age)
+            result   (db/exec-one! conn [sql:delete-files-xlog interval])
+            result   (:next.jdbc/update-count result)]
+        (log/debugf "removed %s rows from file-change table" result)
+        result))))
 
 (def ^:private
   sql:delete-files-xlog
   "delete from file_change
     where created_at < now() - ?::interval")
-
-(defn- handler
-  [{:keys [pool max-age]} _]
-  (db/with-atomic [conn pool]
-    (let [interval (db/interval max-age)
-          result   (db/exec-one! conn [sql:delete-files-xlog interval])
-          result   (:next.jdbc/update-count result)]
-      (log/infof "removed %s rows from file_change table" result)
-      nil)))

backend/src/app/tasks/sendmail.clj

@@ -10,13 +10,12 @@
 (ns app.tasks.sendmail
   (:require
    [app.config :as cfg]
-   [app.metrics :as mtx]
    [app.util.emails :as emails]
    [clojure.spec.alpha :as s]
    [clojure.tools.logging :as log]
    [integrant.core :as ig]))
 
-(declare handler)
+(declare send-console!)
 
 (s/def ::username ::cfg/smtp-username)
 (s/def ::password ::cfg/smtp-password)
@@ -29,7 +28,7 @@
 (s/def ::enabled ::cfg/smtp-enabled)
 
 (defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::enabled ::mtx/metrics]
+  (s/keys :req-un [::enabled]
           :opt-un [::username
                    ::password
                    ::tls
@@ -40,13 +39,11 @@
                    ::default-reply-to]))
 
 (defmethod ig/init-key ::handler
-  [_ {:keys [metrics] :as cfg}]
-  (let [handler #(handler cfg %)]
-    (->> {:registry (:registry metrics)
-          :type :summary
-          :name "task_sendmail_timing"
-          :help "sendmail task timing"}
-         (mtx/instrument handler))))
+  [_ cfg]
+  (fn [{:keys [props] :as task}]
+    (if (:enabled cfg)
+      (emails/send! cfg props)
+      (send-console! cfg props))))
 
 (defn- send-console!
   [cfg email]
@@ -59,9 +56,3 @@
                 (println (.toString baos))
                 (println "******** end email "(:id email) "**********"))]
       (log/info out))))
-
-(defn handler
-  [cfg {:keys [props] :as task}]
-  (if (:enabled cfg)
-    (emails/send! cfg props)
-    (send-console! cfg props)))

backend/src/app/tasks/tasks_gc.clj

@@ -5,46 +5,36 @@
 ;; This Source Code Form is "Incompatible With Secondary Licenses", as
 ;; defined by the Mozilla Public License, v. 2.0.
 ;;
-;; Copyright (c) 2020 UXBOX Labs SL
+;; Copyright (c) 2020-2021 UXBOX Labs SL
 
 (ns app.tasks.tasks-gc
   "A maintenance task that performs a cleanup of already executed tasks
   from the database table."
   (:require
    [app.db :as db]
-   [app.metrics :as mtx]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
    [clojure.tools.logging :as log]
    [integrant.core :as ig]))
 
-(declare handler)
+(declare sql:delete-completed-tasks)
 
 (s/def ::max-age ::dt/duration)
 
 (defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::db/pool ::mtx/metrics ::max-age]))
+  (s/keys :req-un [::db/pool ::max-age]))
 
 (defmethod ig/init-key ::handler
-  [_ {:keys [metrics] :as cfg}]
-  (let [handler #(handler cfg %)]
-    (->> {:registry (:registry metrics)
-          :type :summary
-          :name "task_tasks_gc_timing"
-          :help "tasks garbage collection task timing"}
-         (mtx/instrument handler))))
+  [_ {:keys [pool max-age] :as cfg}]
+  (fn [_]
+    (db/with-atomic [conn pool]
+      (let [interval (db/interval max-age)
+            result   (db/exec-one! conn [sql:delete-completed-tasks interval])
+            result   (:next.jdbc/update-count result)]
+        (log/debugf "removed %s rows from tasks-completed table" result)
+        result))))
 
 (def ^:private
   sql:delete-completed-tasks
   "delete from task_completed
     where scheduled_at < now() - ?::interval")
-
-(defn- handler
-  [{:keys [pool max-age]} _]
-  (db/with-atomic [conn pool]
-    (let [interval (db/interval max-age)
-          result   (db/exec-one! conn [sql:delete-completed-tasks interval])
-          result   (:next.jdbc/update-count result)]
-      (log/infof "removed %s rows from tasks_completed table" result)
-      nil)))
-

backend/src/app/telemetry.clj

@@ -88,7 +88,7 @@
     (catch Exception e
       ;; We don't want notify user of a error, just log it for posible
       ;; future investigation.
-      (log/warn e (str "Unexpected error on telemetry:\n"
+      (log/warn e (str "unexpected error on telemetry:\n"
                        (when-let [edata (ex-data e)]
                          (str "ex-data: \n"
                               (with-out-str (pprint edata))))
@@ -118,4 +118,4 @@
                         data
                         data])))
     (catch Exception e
-      (log/errorf e "Error on procesing request."))))
+      (log/errorf e "error on procesing request"))))

backend/src/app/tokens.clj

@@ -60,11 +60,25 @@
 (defmethod ig/pre-init-spec ::tokens [_]
   (s/keys :req-un [::sprops]))
 
+(defn- generate-predefined
+  [cfg {:keys [iss profile-id] :as params}]
+  (case iss
+    :profile-identity
+    (do
+      (us/verify uuid? profile-id)
+      (generate cfg (assoc params
+                           :exp (dt/in-future {:days 30}))))
+
+    (ex/raise :type :internal
+              :code :not-implemented
+              :hint "no predefined token")))
+
 (defmethod ig/init-key ::tokens
   [_ {:keys [sprops] :as cfg}]
   (let [secret (derive-tokens-secret (:secret-key sprops))
         cfg    (assoc cfg ::secret secret)]
     (fn [action params]
       (case action
+        :generate-predefined (generate-predefined cfg params)
         :verify (verify cfg params)
         :generate (generate cfg params)))))

backend/src/app/util/async.clj

@@ -46,8 +46,7 @@
                 (fn []
                   (try
                     (let [ret (try (f) (catch Exception e e))]
-                      (when-not (nil? ret)
-                        (a/>!! c ret)))
+                      (when (some? ret) (a/>!! c ret)))
                     (finally
                       (a/close! c)))))
       c

backend/src/app/util/blob.clj

@@ -28,8 +28,10 @@
 
 (declare decode-v1)
 (declare decode-v2)
+(declare decode-v3)
 (declare encode-v1)
 (declare encode-v2)
+(declare encode-v3)
 
 (def default-version
   (:default-blob-version cfg/config 1))
@@ -37,9 +39,10 @@
 (defn encode
   ([data] (encode data nil))
   ([data {:keys [version] :or {version default-version}}]
-   (case version
+   (case  (long version)
      1 (encode-v1 data)
      2 (encode-v2 data)
+     3 (encode-v3 data)
      (throw (ex-info "unsupported version" {:version version})))))
 
 (defn decode
@@ -52,6 +55,7 @@
       (case version
         1 (decode-v1 data ulen)
         2 (decode-v2 data ulen)
+        3 (decode-v3 data ulen)
         (throw (ex-info "unsupported version" {:version version}))))))
 
 ;; --- IMPL
@@ -81,7 +85,7 @@
 (defn- encode-v2
   [data]
   (let [data  (n/fast-freeze data)
-        dlen  (alength data)
+        dlen  (alength ^bytes data)
         mlen  (Zstd/compressBound dlen)
         cdata (byte-array mlen)
         clen  (Zstd/compressByteArray ^bytes cdata 0 mlen
@@ -100,3 +104,26 @@
     (Zstd/decompressByteArray ^bytes udata 0 ulen
                               ^bytes cdata 6 (- (alength cdata) 6))
     (n/fast-thaw udata)))
+
+(defn- encode-v3
+  [data]
+  (let [data  (t/encode data {:type :json})
+        dlen  (alength ^bytes data)
+        mlen  (Zstd/compressBound dlen)
+        cdata (byte-array mlen)
+        clen  (Zstd/compressByteArray ^bytes cdata 0 mlen
+                                      ^bytes data 0 dlen
+                                      4)]
+    (with-open [^ByteArrayOutputStream baos (ByteArrayOutputStream. (+ (alength cdata) 2 4))
+                ^DataOutputStream dos (DataOutputStream. baos)]
+      (.writeShort dos (short 3)) ;; version number
+      (.writeInt dos (int dlen))
+      (.write dos ^bytes cdata (int 0) clen)
+      (.toByteArray baos))))
+
+(defn- decode-v3
+  [^bytes cdata ^long ulen]
+  (let [udata (byte-array ulen)]
+    (Zstd/decompressByteArray ^bytes udata 0 ulen
+                              ^bytes cdata 6 (- (alength cdata) 6))
+    (t/decode udata {:type :json})))