🎉 Add server repl helper for duplicate file.

Add more Chinese translations

.clj-kondo/config.edn

@@ -1,5 +1,6 @@
 {:lint-as {potok.core/reify clojure.core/reify
            promesa.core/let clojure.core/let
+           rumext.alpha/defc clojure.core/defn
            app.db/with-atomic clojure.core/with-open}
  :output
  {:exclude-files ["data_readers.clj"]}

.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)

CHANGES.md

@@ -0,0 +1,108 @@
+# CHANGELOG #
+
+## :rocket: Next
+
+### :sparkles: New features
+
+### :bug: Bugs fixed
+
+### :heart: Community contributions by (Thank you!)
+
+
+## 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 (problem 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 problem width handoff code generation [Taiga #1204](https://tree.taiga.io/project/penpot/issue/1204)
+- Fix problem 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
+
+### :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)
+- Add new blob storage format (Zstd+nippy)
+- Add user feedback form
+- Improve French translations
+- Improve component testing
+- Increase default deletion delay to 7 days
+- Show a pixel grid when zoom greater than 800% [#519](https://github.com/penpot/penpot/discussions/519)
+- Fix behavior of select all command when there are objects outside frames [Taiga #1209](https://tree.taiga.io/project/penpot/issue/1209)
+
+
+### :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 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 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)
+
+### :heart: Community contributions by (Thank you!)
+
+- abtinmo [#538](https://github.com/penpot/penpot/pull/538)
+- kdrag0n [#585](https://github.com/penpot/penpot/pull/585)
+- nisrulz [#586](https://github.com/penpot/penpot/pull/586)
+- tomer [#575](https://github.com/penpot/penpot/pull/575)
+- violoncelloCH [#554](https://github.com/penpot/penpot/pull/554)
+
+## 1.1.0-alpha
+
+- Bugfixing and stabilization post-launch
+- Some changes to the register flow
+- Improved MacOS shortcuts and helpers
+- Small changes to shape creation
+
+
+## 1.0.0-alpha
+
+Initial release

CONTRIBUTING.md

@@ -1,8 +1,8 @@
 # Contributing Guide #
 
 Thank you for your interest in contributing to Penpot. This is a
-generic guide that details how to contribute to Penpot in a way that is
-efficient for everyone. If you want a specific documentation for
+generic guide that details how to contribute to Penpot in a way that
+is efficient for everyone. If you want a specific documentation for
 different parts of the platform, please refer to `docs/` directory.
 
 
@@ -19,12 +19,20 @@ If you found a bug, please report it, as far as possible with:
 - a browser and the browser version used
 - a dev tools console exception stack trace (if it is available)
 
+If you found a bug that you consider better discuse in private (for
+example: security bugs), consider first send an email to
+`info@penpot.app`.
+
+**We don't have formal bug bounty program for security reports; this
+is an open source application and your contribution will be recognized
+in the changelog.**
+
 
 ## Pull requests ##
 
 If you want propose a change or bug fix with the Pull-Request system
-firstly you should carefully read the **Contributor License Aggreement**
-section and format your commits accordingly.
+firstly you should carefully read the **DCO** section and format your
+commits accordingly.
 
 If you intend to fix a bug it's fine to submit a pull request right
 away but we still recommend to file an issue detailing what you're
@@ -127,7 +135,7 @@ This Code of Conduct is adapted from the Contributor Covenant, version
 1.1.0, available from http://contributor-covenant.org/version/1/1/0/
 
 
-## Contributor License Agreement ##
+## Developer's Certificate of Origin (DCO) ##
 
 By submitting code you are agree and can certify the below:
 
@@ -157,9 +165,9 @@ By submitting code you are agree and can certify the below:
         maintained indefinitely and may be redistributed consistent with
         this project or the open source license(s) involved.
 
-Then, all your patches should contain a sign-off at the end of the
-patch/commit description body. It can be automatically added on adding
-`-s` parameter to `git commit`.
+Then, all your code patches (**documentation are excluded**) should
+contain a sign-off at the end of the patch/commit description body. It
+can be automatically added on adding `-s` parameter to `git commit`.
 
 This is an example of the aspect of the line:
 

README.md

@@ -4,7 +4,7 @@
 
 [![License: MPL-2.0][uri_license_image]][uri_license]
 [![Gitter](https://badges.gitter.im/sereno-xyz/community.svg)](https://gitter.im/penpot/community)
-[![Managed with Taiga.io](https://img.shields.io/badge/managed%20with-TAIGA.io-709f14.svg)](https://tree.taiga.io/project/uxboxproject/ "Managed with Taiga.io")
+[![Managed with Taiga.io](https://img.shields.io/badge/managed%20with-TAIGA.io-709f14.svg)](https://tree.taiga.io/project/penpot/ "Managed with Taiga.io")
 
 
 # PENPOT #

backend/deps.edn

@@ -7,6 +7,7 @@
   org.clojure/clojurescript {:mvn/version "1.10.773"}
   org.clojure/data.json {:mvn/version "1.0.0"}
   org.clojure/core.async {:mvn/version "1.3.610"}
+  org.clojure/tools.cli {:mvn/version "1.0.194"}
 
   ;; Logging
   org.clojure/tools.logging {:mvn/version "1.1.0"}
@@ -16,8 +17,12 @@
   org.apache.logging.log4j/log4j-jul {:mvn/version "2.14.0"}
   org.apache.logging.log4j/log4j-slf4j-impl {:mvn/version "2.14.0"}
   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"}
 
   io.prometheus/simpleclient {:mvn/version "0.9.0"}
   io.prometheus/simpleclient_hotspot {:mvn/version "0.9.0"}
@@ -30,7 +35,7 @@
   expound/expound {:mvn/version "0.8.7"}
   com.cognitect/transit-clj {:mvn/version "1.0.324"}
 
-  io.lettuce/lettuce-core {:mvn/version "5.2.2.RELEASE"}
+  io.lettuce/lettuce-core {:mvn/version "6.0.2.RELEASE"}
   java-http-clj/java-http-clj {:mvn/version "0.4.1"}
 
   info.sunng/ring-jetty9-adapter {:mvn/version "0.14.2"}
@@ -41,7 +46,6 @@
   org.postgresql/postgresql {:mvn/version "42.2.18"}
   com.zaxxer/HikariCP {:mvn/version "3.4.5"}
 
-  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"}

backend/dev/user.clj

@@ -9,23 +9,24 @@
 
 (ns user
   (:require
+   [app.common.exceptions :as ex]
    [app.config :as cfg]
    [app.main :as main]
    [app.util.time :as dt]
    [app.util.transit :as t]
-   [app.common.exceptions :as ex]
-   [clojure.data.json :as json]
+   [app.util.json :as json]
    [clojure.java.io :as io]
-   [clojure.test :as test]
    [clojure.pprint :refer [pprint]]
    [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]]
-   [integrant.core :as ig]))
+   [integrant.core :as ig]
+   [taoensso.nippy :as nippy]))
 
 (repl/disable-reload! (find-ns 'integrant.core))
 

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

@@ -30,14 +30,14 @@
           for security reasons.
         </mj-text>
         <mj-text>Enjoy!</mj-text>
-        <mj-text>The UXBOX team.</mj-text>
+        <mj-text>The Penpot team.</mj-text>
       </mj-column>
     </mj-section>
 
     <mj-section padding="24px 0 0 0">
       <mj-column width="425px">
         <mj-text align="center" font-size="14px" color="#64666A">
-          UXBOX is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.
+          Penpot is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.
         </mj-text>
       </mj-column>
     </mj-section>
@@ -57,7 +57,7 @@
     <mj-section padding="0 0 24px 0">
       <mj-column>
         <mj-text align="center" font-size="14px" color="#64666A" line-height="150%">
-          UXBOX © 2020 | Made with &lt;3 and Open Source
+          Penpot © 2020 | Made with &lt;3 and Open Source
         </mj-text>
       </mj-column>
     </mj-section>

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

@@ -23,14 +23,14 @@
           Accept invite
         </mj-button>
         <mj-text>Enjoy!</mj-text>
-        <mj-text>The UXBOX team.</mj-text>
+        <mj-text>The Penpot team.</mj-text>
       </mj-column>
     </mj-section>
 
     <mj-section padding="24px 0 0 0">
       <mj-column width="425px">
         <mj-text align="center" font-size="14px" color="#64666A">
-          UXBOX is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.
+          Penpot is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.
         </mj-text>
       </mj-column>
     </mj-section>
@@ -50,7 +50,7 @@
     <mj-section padding="0 0 24px 0">
       <mj-column>
         <mj-text align="center" font-size="14px" color="#64666A" line-height="150%">
-          UXBOX © 2020 | Made with &lt;3 and Open Source
+          Penpot © 2020 | Made with &lt;3 and Open Source
         </mj-text>
       </mj-column>
     </mj-section>

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

@@ -32,14 +32,14 @@
           it. Your password won't be changed.
         </mj-text>
         <mj-text>Enjoy!</mj-text>
-        <mj-text>The UXBOX team.</mj-text>
+        <mj-text>The Penpot team.</mj-text>
       </mj-column>
     </mj-section>
 
     <mj-section padding="24px 0 0 0">
       <mj-column width="425px">
         <mj-text align="center" font-size="14px" color="#64666A">
-          UXBOX is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.
+          Penpot is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.
         </mj-text>
       </mj-column>
     </mj-section>
@@ -59,7 +59,7 @@
     <mj-section padding="0 0 24px 0">
       <mj-column>
         <mj-text align="center" font-size="14px" color="#64666A" line-height="150%">
-          UXBOX © 2020 | Made with &lt;3 and Open Source
+          Penpot © 2020 | Made with &lt;3 and Open Source
         </mj-text>
       </mj-column>
     </mj-section>

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

@@ -21,7 +21,7 @@
       <mj-column>
         <mj-text font-size="24px" font-weight="600">Hello {{name}}!</mj-text>
         <mj-text>
-          Thanks for signing up for your UXBOX account! Please verify your
+          Thanks for signing up for your Penpot account! Please verify your
           email using the link below adn get started building mockups and
           prototypes today!
         </mj-text>
@@ -29,14 +29,14 @@
           Verify email
         </mj-button>
         <mj-text>Enjoy!</mj-text>
-        <mj-text>The UXBOX team.</mj-text>
+        <mj-text>The Penpot team.</mj-text>
       </mj-column>
     </mj-section>
 
     <mj-section padding="24px 0 0 0">
       <mj-column width="425px">
         <mj-text align="center" font-size="14px" color="#64666A">
-          UXBOX is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.
+          Penpot is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.
         </mj-text>
       </mj-column>
     </mj-section>
@@ -56,7 +56,7 @@
     <mj-section padding="0 0 24px 0">
       <mj-column>
         <mj-text align="center" font-size="14px" color="#64666A" line-height="150%">
-          UXBOX © 2020 | Made with &lt;3 and Open Source
+          Penpot © 2020 | Made with &lt;3 and Open Source
         </mj-text>
       </mj-column>
     </mj-section>

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

@@ -10,4 +10,4 @@ If you received this email by mistake, please consider changing your password
 for security reasons.
 
 Enjoy!
-The UXBOX team.
+The Penpot team.

backend/resources/emails/feedback/en.subj

@@ -0,0 +1 @@
+[PENPOT FEEDBACK]: {{subject|abbreviate:19}} (from {{email}})

backend/resources/emails/feedback/en.txt

@@ -0,0 +1,9 @@
+{% if profile %}
+Feedback profile: {{profile.fullname}} <{{profile.email}}> / {{profile.id}}
+{% else %}
+Feedback from: {{email}}
+{% endif %}
+
+Subject: {{subject}}
+
+{{content}}

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

@@ -7,4 +7,4 @@ Accept invitation using this link:
 {{ public-uri }}/#/auth/verify-token?token={{token}}
 
 Enjoy!
-The UXBOX team.
+The Penpot team.

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

@@ -9,4 +9,4 @@ If you received this email by mistake, you can safely ignore it. Your password
 won't be changed.
 
 Enjoy!
-The UXBOX team.
+The Penpot team.

backend/resources/emails/register/en.txt

@@ -1,9 +1,9 @@
 Hello {{name}}!
 
-Thanks for signing up for your UXBOX account! Please verify your email using the
+Thanks for signing up for your Penpot account! Please verify your email using the
 link below adn get started building mockups and prototypes today!
 
 {{ public-uri }}/#/auth/verify-token?token={{token}}
 
 Enjoy!
-The UXBOX team.
+The Penpot team.

backend/resources/error-report.tmpl

@@ -31,7 +31,7 @@
 
       .table-key {
         font-weight: 600;
-        width: 70px;
+        width: 60px;
         padding: 4px;
       }
 
@@ -67,42 +67,94 @@
         <div class="table-val">{{profile-id}}</div>
       </div>
       {% endif %}
+
+      {% if user-agent %}
       <div class="table-row">
-        <div class="table-key">VERS: </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">FVER: </div>
+        <div class="table-val">{{frontend-version}}</div>
+      </div>
+      {% endif %}
+
+      <div class="table-row">
+        <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">
         <div class="table-key">TYPE: </div>
         <div class="table-val">{{type}}</div>
       </div>
       {% endif %}
+
       {% if code %}
       <div class="table-row">
         <div class="table-key">CODE: </div>
         <div class="table-val">{{code}}</div>
       </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">
         <div class="table-key">PATH: </div>
         <div class="table-val">{{method|upper}} {{path}}</div>
       </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>
@@ -111,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>
@@ -120,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>
@@ -128,13 +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

@@ -7,20 +7,15 @@
   </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="com.zaxxer.hikari" level="error" />
+    <Logger name="org.eclipse.jetty" level="error" />
 
     <Logger name="app" level="debug" additivity="false">
-      <AppenderRef ref="console"/>
+      <AppenderRef ref="console" />
     </Logger>
 
     <Root level="info">
-      <AppenderRef ref="console"/>
+      <AppenderRef ref="console" />
     </Root>
   </Loggers>
 </Configuration>

backend/resources/log4j2.xml

@@ -13,27 +13,33 @@
       <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>
+    <JeroMQ name="zmq">
+      <Property name="endpoint">tcp://localhost:45556</Property>
+      <JsonLayout complete="false" compact="true" includeTimeMillis="true" stacktraceAsString="true" properties="true" />
+    </JeroMQ>
   </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="com.zaxxer.hikari" level="error"/>
+    <Logger name="io.lettuce" level="error" />
+    <Logger name="org.eclipse.jetty" level="error" />
 
     <Logger name="app.cli" level="debug" additivity="false">
       <AppenderRef ref="console"/>
     </Logger>
 
-    <Logger name="app.error-reporter" level="debug" additivity="false">
+    <Logger name="app.loggers" level="debug" additivity="false">
       <AppenderRef ref="main" level="debug" />
     </Logger>
 
     <Logger name="app" level="debug" additivity="false">
-      <AppenderRef ref="main" level="debug" />
-      <AppenderRef ref="error-reporter" level="error" />
+      <AppenderRef ref="main" level="trace" />
+      <AppenderRef ref="zmq" level="debug" />
+    </Logger>
+
+    <Logger name="user" level="trace" additivity="false">
+      <AppenderRef ref="main" level="trace" />
+      <AppenderRef ref="zmq" level="debug" />
     </Logger>
 
     <Root level="info">

backend/scripts/build.sh

@@ -25,12 +25,8 @@ 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)
 
@@ -52,4 +48,30 @@ set -x
 exec \$JAVA_CMD \$JVM_OPTS -classpath \$CP -Dlog4j.configurationFile=./log4j2.xml "\$@" clojure.main -m app.main
 EOF
 
+tee -a ./target/dist/manage.sh  >> /dev/null <<EOF
+#!/usr/bin/env bash
+CP="$NEWCP"
+
+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 \$CP -Dlog4j.configurationFile=./log4j2.xml clojure.main -m app.cli.manage "\$@"
+EOF
+
 chmod +x ./target/dist/run.sh
+chmod +x ./target/dist/manage.sh
+

backend/scripts/repl

@@ -2,6 +2,9 @@
 
 export PENPOT_ASSERTS_ENABLED=true
 
+export OPTIONS="-A:jmx-remote:dev -J-Dclojure.tools.logging.factory=clojure.tools.logging.impl/log4j2-factory -J-Xms512m -J-Xmx512m"
+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/src/app/cli/fixtures.clj

@@ -75,13 +75,13 @@
   (let [rng (java.util.Random. 1)]
     (letfn [(create-profile [conn index]
               (let [id   (mk-uuid "profile" index)
-                    _    (log/info "create profile" id)
+                    _    (log/info "create profile" index id)
 
                     prof (register-profile conn
                                            {: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]
@@ -98,10 +98,9 @@
             (create-team [conn index]
               (let [id (mk-uuid "team" index)
                     name (str "Team" index)]
-                (log/info "create team" id)
+                (log/info "create team" index id)
                 (db/insert! conn :team {:id id
-                                        :name name
-                                        :photo ""})
+                                        :name name})
                 id))
 
             (create-teams [conn]
@@ -113,7 +112,7 @@
               (let [id (mk-uuid "file" project-id index)
                     name (str "file" index)
                     data (cp/make-file-data id)]
-                (log/info "create file" id)
+                (log/info "create file" index id)
                 (db/insert! conn :file
                             {:id id
                              :data (blob/encode data)
@@ -135,7 +134,7 @@
             (create-project [conn team-id owner-id index]
               (let [id (mk-uuid "project" team-id index)
                     name (str "project " index)]
-                (log/info "create project" id)
+                (log/info "create project" index id)
                 (db/insert! conn :project
                             {:id id
                              :team-id team-id
@@ -188,7 +187,7 @@
                     project-id (:default-project-id owner)
                     data       (cp/make-file-data id)]
 
-                (log/info "create draft file" id)
+                (log/info "create draft file" index id)
                 (db/insert! conn :file
                             {:id id
                              :data (blob/encode data)
@@ -238,6 +237,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,25 +5,32 @@
 ;; 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.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.spec.alpha :as s]
    [cuerdas.core :as str]
    [environ.core :refer [env]]))
 
 (def defaults
   {:http-server-port 6060
-
+   :host "devenv"
+   :tenant "dev"
    :database-uri "postgresql://127.0.0.1/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"
@@ -38,110 +45,114 @@
    :storage-s3-region :eu-central-1
    :storage-s3-bucket "penpot-devenv-assets-pre"
 
+   :feedback-destination "info@example.com"
+   :feedback-enabled false
+
    :assets-path "/internal/assets/"
 
    :rlimits-password 10
    :rlimits-image 2
 
    :smtp-enabled false
-   :smtp-default-reply-to "no-reply@example.com"
-   :smtp-default-from "no-reply@example.com"
+   :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 ""
 
    :telemetry-enabled false
-   :telemetry-with-taiga true
    :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 ::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/email)
-(s/def ::smtp-default-from ::us/email)
-(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-reply-to ::us/email)
+(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 ::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
@@ -149,7 +160,12 @@
                    ::database-password
                    ::database-uri
                    ::database-username
+                   ::default-blob-version
                    ::error-report-webhook
+                   ::feedback-destination
+                   ::feedback-enabled
+                   ::feedback-reply-to
+                   ::feedback-token
                    ::github-client-id
                    ::github-client-secret
                    ::gitlab-base-uri
@@ -157,25 +173,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
@@ -185,20 +213,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]
@@ -231,5 +257,12 @@
 (def config (read-config env))
 (def test-config (read-test-config env))
 
-(def default-deletion-delay
-  (dt/duration {:hours 48}))
+(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_count"
+    :help "An absolute counter of database queries."}))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; API & Impl
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (def initsql
-  (str "SET statement_timeout = 10000;\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]
@@ -286,7 +297,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,113 +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)]
-    (when-let [{:keys [file file-library-rel file-media-object]} (read-initial-data initial-data-path)]
-      (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/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,8 +43,66 @@
                          :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)
+(s/def ::content ::us/string)
+
+(s/def ::feedback
+  (s/keys :req-un [::subject ::content]))
+
+(def feedback
+  "A profile feedback email."
+  (emails/template-factory ::feedback default-context))
+
 (s/def ::name ::us/string)
 (s/def ::register
   (s/keys :req-un [::name]))

backend/src/app/http.clj

@@ -12,10 +12,10 @@
    [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]
+   [app.util.log4j :refer [update-thread-context!]]
    [clojure.spec.alpha :as s]
    [clojure.tools.logging :as log]
    [integrant.core :as ig]
@@ -42,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)
@@ -68,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))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -80,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]
@@ -103,17 +102,17 @@
         (catch Throwable e
           (try
             (let [cdata (errors/get-error-context request e)]
-              (errors/update-thread-context! cdata)
-              (log/errorf e "Unhandled exception: %s (id: %s)" (ex-message e) (str (:id cdata)))
+              (update-thread-context! 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)}]
 
@@ -126,6 +125,9 @@
     ["/dbg"
      ["/error-by-id/:id" {:get (:error-report-handler cfg)}]]
 
+    ["/webhooks"
+     ["/sns" {:post (:sns-webhook cfg)}]]
+
     ["/api" {:middleware [[middleware/format-response-body]
                           [middleware/params]
                           [middleware/multipart-params]
@@ -135,21 +137,18 @@
                           [middleware/cookies]]}
 
      ["/svg" {: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,154 +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]
-  (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 (not= 200 (:status res))
-      (ex/raise :type :internal
-                :code :invalid-response-from-google
-                :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 google access token request" e)
-        nil))))
-
-(defn- get-user-info
-  [token]
-  (let [req {:uri "https://openidconnect.googleapis.com/v1/userinfo"
-             :headers {"Authorization" (str "Bearer " token)}
-             :method :get}
-        res (http/send! req)]
-
-    (when (not= 200 (:status res))
-      (ex/raise :type :internal
-                :code :invalid-response-from-google
-                :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 google access token request" e)
-        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]
-  (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 :authentication
-                :code :unable-to-authenticate-with-google))
-
-    (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 ::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

@@ -11,26 +11,10 @@
   "A errors handling for the http server."
   (:require
    [app.common.uuid :as uuid]
-   [app.config :as cfg]
-   [clojure.pprint :refer [pprint]]
+   [app.util.log4j :refer [update-thread-context!]]
    [clojure.tools.logging :as log]
    [cuerdas.core :as str]
-   [expound.alpha :as expound])
-  (:import
-   org.apache.logging.log4j.ThreadContext))
-
-(defn update-thread-context!
-  [data]
-  (run! (fn [[key val]]
-          (ThreadContext/put
-           (name key)
-           (cond
-             (coll? val)
-             (binding [clojure.pprint/*print-right-margin* 120]
-               (with-out-str (pprint val)))
-             (instance? clojure.lang.Named val) (name val)
-             :else (str val))))
-        data))
+   [expound.alpha :as expound]))
 
 (defn- explain-error
   [error]
@@ -45,14 +29,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)}
-
-     (when (map? edata)
-       edata)
-
+      :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)}))))
 
@@ -66,6 +46,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"])
@@ -88,7 +73,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
@@ -103,7 +88,7 @@
   [error request]
   (let [cdata (get-error-context request error)]
     (update-thread-context! cdata)
-    (log/errorf error "Internal error: %s (id: %s)"
+    (log/errorf error "internal error: %s (id: %s)"
                 (ex-message error)
                 (str (:id cdata)))
     {:status 500

backend/src/app/http/feedback.clj

@@ -0,0 +1,73 @@
+;; 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)
+        reply-to    (cfg/get :feedback-reply-to)]
+    (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/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.http.errors :refer [update-thread-context!]]
+   [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_updater_count"
+                :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/tracef "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
@@ -36,76 +33,52 @@
 
 (declare handle-event)
 
-(defonce queue (a/chan (a/sliding-buffer 64)))
-(defonce queue-fn (fn [event] (a/>!! queue event)))
+(defonce enabled-mattermost (atom true))
 
 (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}]
@@ -113,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 (:uri cfg)
-        (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,11 @@
     :app.telemetry/migrations
     {}
 
-    :app.redis/redis
+    :app.msgbus/msgbus
     {: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 +77,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,23 +107,30 @@
      :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)
-     :assets-path       (:assets-path cfg/config)
+     :assets-path       (:assets-path config)
      :storage           (ig/ref :app.storage/storage)
      :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 +138,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 +146,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,20 +155,6 @@
      :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)}
 
@@ -148,11 +165,11 @@
 
     ;; RLimit definition for password hashing
     :app.rlimits/password
-    (:rlimits-password cfg/config)
+    (:rlimits-password config)
 
     ;; RLimit definition for image processing
     :app.rlimits/image
-    (:rlimits-image cfg/config)
+    (:rlimits-image config)
 
     ;; A collection of rlimits as hash-map.
     :app.rlimits/all
@@ -165,15 +182,16 @@
      :tokens  (ig/ref :app.tokens/tokens)
      :metrics (ig/ref :app.metrics/metrics)
      :storage (ig/ref :app.storage/storage)
-     :redis   (ig/ref :app.redis/redis)
+     :msgbus  (ig/ref :app.msgbus/msgbus)
      :rlimits (ig/ref :app.rlimits/all)
      :svgc    (ig/ref :app.svgparse/svgc)}
 
     :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 +199,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 */6 * * ?"  ;; every 2 hours
-       :fn (ig/ref :app.tasks.file-xlog-gc/handler)}
+       :cron #app/cron "0 0 */1 * * ?"  ;; hourly
+       :task :file-xlog-gc}
 
       {:id "storage-deleted-gc"
-       :cron #app/cron "0 0 */6 * * ?"  ;; every 6 hours
-       :fn (ig/ref :app.storage/gc-deleted-task)}
+       :cron #app/cron "0 0 1 */1 * ?"  ;; daily (1 hour shift)
+       :task :storage-deleted-gc}
 
       {:id "storage-touched-gc"
-       :cron #app/cron "0 30 */6 * * ?"  ;; every 6 hours
-       :fn (ig/ref :app.storage/gc-touched-task)}
+       :cron #app/cron "0 0 2 */1 * ?"  ;; daily (2 hour shift)
+       :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 */6 * * ?"  ;; every 6 hours
-       :fn (ig/ref :app.storage/recheck-task)}
+       :cron #app/cron "0 0 */1 * * ?"  ;; hourly
+       :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 cfg/config)
+      (when (:telemetry-enabled config)
         {:id   "telemetry"
          :cron #app/cron "0 0 */6 * * ?" ;; every 6h
-         :uri  (:telemetry-uri cfg/config)
-         :fn   (ig/ref :app.tasks.telemetry/handler)})]}
+         :uri  (:telemetry-uri config)
+         :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)
@@ -260,44 +293,53 @@
     :app.tasks.file-xlog-gc/handler
     {:pool    (ig/ref :app.db/pool)
      :metrics (ig/ref :app.metrics/metrics)
-     :max-age (dt/duration {:hours 24})}
+     :max-age (dt/duration {:hours 48})}
 
     :app.tasks.telemetry/handler
     {:pool        (ig/ref :app.db/pool)
      :version     (:full cfg/version)
-     :uri         (:telemetry-uri cfg/config)
-     :sprops      (ig/ref :app.sprops/props)}
+     :uri         (:telemetry-uri config)
+     :sprops      (ig/ref :app.setup/props)}
 
     :app.srepl/server
-    {:port (:srepl-port cfg/config)
-     :host (:srepl-host cfg/config)}
+    {:port (:srepl-port config)
+     :host (:srepl-host config)}
 
-    :app.sprops/props
+    :app.setup/props
     {:pool (ig/ref :app.db/pool)}
 
-    :app.error-reporter/reporter
-    {:uri      (:error-report-webhook cfg/config)
+    :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
     {:pool     (ig/ref :app.db/pool)
      :executor (ig/ref :app.worker/executor)
-     :backend  (:storage-backend cfg/config :fs)
+     :backend  (:storage-backend config :fs)
      :backends {:s3  (ig/ref [::main :app.storage.s3/backend])
                 :db  (ig/ref [::main :app.storage.db/backend])
                 :fs  (ig/ref [::main :app.storage.fs/backend])
                 :tmp (ig/ref [::tmp  :app.storage.fs/backend])}}
 
     [::main :app.storage.s3/backend]
-    {:region (:storage-s3-region cfg/config)
-     :bucket (:storage-s3-bucket cfg/config)}
+    {:region (:storage-s3-region config)
+     :bucket (:storage-s3-bucket config)}
 
     [::main :app.storage.fs/backend]
-    {:directory (:storage-fs-directory cfg/config)}
+    {:directory (:storage-fs-directory config)}
 
     [::tmp :app.storage.fs/backend]
     {:directory "/tmp/penpot"}
@@ -305,7 +347,7 @@
     [::main :app.storage.db/backend]
     {:pool (ig/ref :app.db/pool)}}
 
-   (when (:telemetry-server-enabled cfg/config)
+   (when (:telemetry-server-enabled config)
      {:app.telemetry/handler
       {:pool     (ig/ref :app.db/pool)
        :executor (ig/ref :app.worker/executor)}
@@ -333,7 +375,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))
@@ -175,7 +175,12 @@
       (ex/raise :type :internal
                 :code :rlimit-not-configured
                 :hint ":image rlimit not configured"))
-    (rlm/execute rlimit (process params))))
+    (try
+      (rlm/execute rlimit (process params))
+      (catch org.im4java.core.InfoException e
+        (ex/raise :type :validation
+                  :code :invalid-image
+                  :cause e)))))
 
 ;; --- Utility functions
 

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,18 +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] :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)
-                   (.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)]
@@ -175,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
@@ -183,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]
@@ -203,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
@@ -240,7 +255,6 @@
 
   ([rootf mobj labels]
    (let [mdata  (meta rootf)
-         labels (into-array String labels)
          origf  (::original mdata rootf)]
      (with-meta
        (fn
@@ -283,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

@@ -145,6 +145,24 @@
 
    {:name "0044-add-storage-refcount"
     :fn (mg/resource "app/migrations/sql/0044-add-storage-refcount.sql")}
+
+   {: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")}
    ])
 
 

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/0045-add-index-to-file-change-table.sql

@@ -0,0 +1,2 @@
+CREATE INDEX file_change__created_at_idx
+    ON file_change (created_at);

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

@@ -0,0 +1,249 @@
+;; 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))
+
+(declare impl-publish-loop)
+(declare impl-redis-pub)
+(declare impl-redis-sub)
+(declare impl-redis-unsub)
+(declare impl-subscribe-loop)
+
+
+;; --- STATE INIT: Publisher
+
+(s/def ::uri ::us/string)
+(s/def ::buffer-size ::us/integer)
+
+(defmethod ig/pre-init-spec ::msgbus [_]
+  (s/keys :req-un [::uri]
+          :opt-un [::buffer-size]))
+
+(defmethod ig/prep-key ::msgbus
+  [_ cfg]
+  (merge {:buffer-size 128} cfg))
+
+(defmethod ig/init-key ::msgbus
+  [_ {:keys [uri buffer-size] :as cfg}]
+  (let [codec    (RedisCodec/of StringCodec/UTF8 ByteArrayCodec/INSTANCE)
+
+        uri      (RedisURI/create uri)
+        rclient  (RedisClient/create ^RedisURI uri)
+
+        snd-conn (.connect ^RedisClient rclient ^RedisCodec codec)
+        rcv-conn (.connectPubSub ^RedisClient rclient ^RedisCodec codec)
+
+        ;; Channel used for receive publications from the application.
+        pub-chan (a/chan (a/dropping-buffer buffer-size))
+
+        ;; Channel used for receive data from redis
+        rcv-chan (a/chan (a/dropping-buffer buffer-size))
+
+        ;; Channel used for receive subscription requests.
+        sub-chan (a/chan)
+        cch      (a/chan 1)]
+
+    (.setTimeout ^StatefulRedisConnection snd-conn ^Duration (dt/duration {:seconds 10}))
+    (.setTimeout ^StatefulRedisPubSubConnection rcv-conn ^Duration (dt/duration {:seconds 10}))
+
+    (log/debugf "initializing msgbus (uri: '%s')" (str uri))
+
+    ;; Start the sending (publishing) loop
+    (impl-publish-loop snd-conn pub-chan cch)
+
+    ;; Start the receiving (subscribing) loop
+    (impl-subscribe-loop rcv-conn rcv-chan sub-chan cch)
+
+    (with-meta
+      (fn run
+        ([command] (run command nil))
+        ([command params]
+         (a/go
+           (case command
+             :pub (a/>! pub-chan params)
+             :sub (a/>! sub-chan params)))))
+
+      {::snd-conn snd-conn
+       ::rcv-conn rcv-conn
+       ::cch cch
+       ::pub-chan pub-chan
+       ::rcv-chan rcv-chan})))
+
+(defmethod ig/halt-key! ::msgbus
+  [_ f]
+  (let [mdata (meta f)]
+    (.close ^StatefulRedisConnection (::snd-conn mdata))
+    (.close ^StatefulRedisPubSubConnection (::rcv-conn mdata))
+    (a/close! (::cch mdata))
+    (a/close! (::pub-chan mdata))
+    (a/close! (::rcv-chan mdata))))
+
+(defn- impl-publish-loop
+  [conn pub-chan cch]
+  (let [rac (.async ^StatefulRedisConnection conn)]
+    (a/go-loop []
+      (let [[val _] (a/alts! [cch pub-chan] :priority true)]
+        (when (some? val)
+          (let [result (a/<! (impl-redis-pub rac val))]
+            (when (ex/exception? result)
+              (log/error result "unexpected error on publish message to redis")))
+          (recur))))))
+
+(defn- impl-subscribe-loop
+  [conn rcv-chan sub-chan cch]
+  ;; Add a unique listener to connection
+  (.addListener 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-chan val)
+                             (log/warn "dropping message on subscription loop"))))
+                       (psubscribed [it pattern count])
+                       (punsubscribed [it pattern count])
+                       (subscribed [it topic count])
+                       (unsubscribed [it topic count])))
+
+  (let [chans   (agent {} :error-handler #(log/error % "unexpected error on agent"))
+        tprefix (str (cfg/get :tenant) ".")
+
+        subscribe-to-single-topic
+        (fn [nsubs topic chan]
+          (let [nsubs (if (nil? nsubs) #{chan} (conj nsubs chan))]
+            (when (= 1 (count nsubs))
+              (let [result (a/<!! (impl-redis-sub conn 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
+        (fn [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
+        (fn [nsubs topic chan]
+          (let [nsubs (disj nsubs chan)]
+            (when (empty? nsubs)
+              (let [result (a/<!! (impl-redis-unsub conn 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
+        (fn [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; terminates when sub-chan is
+    ;; closed.
+    (a/go-loop []
+      (when-let [{:keys [topics chan]} (a/<! sub-chan)]
+        (let [topics (into #{} (map #(str tprefix %)) topics)]
+          (send-off chans subscribe-to-topics topics chan)
+          (recur))))
+
+    (a/go-loop []
+      (let [[val port] (a/alts! [cch rcv-chan])]
+        (cond
+          ;; Stop condition; close all underlying subscriptions and
+          ;; exit. The close operation is performed asynchronously.
+          (= port cch)
+          (send-off chans (fn [state]
+                            (log/tracef "close")
+                            (->> (vals state)
+                                 (mapcat identity)
+                                 (filter some?)
+                                 (run! a/close!))))
+
+          ;; This means we receive data from redis and we need to
+          ;; forward it to the underlying subscriptions.
+          (= port rcv-chan)
+          (let [topic   (:topic val)    ; topic is already string
+                pending (loop [chans   (seq (get-in @chans [:topics topic]))
+                               pending #{}]
+                          (if-let [ch (first chans)]
+                            (if (a/>! ch (:message val))
+                              (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)))))))
+
+(defn- impl-redis-pub
+  [rac {:keys [topic message]}]
+  (let [topic   (str (cfg/get :tenant) "." topic)
+        message (blob/encode message)
+        res     (a/chan 1)]
+    (-> (.publish ^RedisAsyncCommands rac ^String topic ^bytes message)
+        (p/finally (fn [_ e]
+                     (when e (a/>!! res e))
+                     (a/close! res))))
+    res))
+
+(defn impl-redis-sub
+  [conn topic]
+  (let [^RedisPubSubAsyncCommands cmd (.async ^StatefulRedisPubSubConnection conn)
+        res (a/chan 1)]
+    (-> (.subscribe cmd (into-array String [topic]))
+        (p/finally (fn [_ e]
+                     (when e (a/>!! res e))
+                     (a/close! res))))
+    res))
+
+(defn impl-redis-unsub
+  [conn topic]
+  (let [^RedisPubSubAsyncCommands cmd (.async ^StatefulRedisPubSubConnection conn)
+        res (a/chan 1)]
+    (-> (.unsubscribe cmd (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]
@@ -23,7 +24,9 @@
    [ring.adapter.jetty9 :as jetty]
    [ring.middleware.cookies :refer [wrap-cookies]]
    [ring.middleware.keyword-params :refer [wrap-keyword-params]]
-   [ring.middleware.params :refer [wrap-params]]))
+   [ring.middleware.params :refer [wrap-params]])
+  (:import
+   org.eclipse.jetty.websocket.api.WebSocketAdapter))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Http Handler
@@ -34,9 +37,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 +48,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_count"
           :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 +116,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,109 +130,120 @@
       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 handle-message)
 (declare start-loop!)
 
 (defn- handle-connect
-  [{:keys [conn] :as ws}]
+  [{:keys [conn] :as cfg}]
   (a/go
     (try
-      (aa/<? (handle-message ws {:type :connect}))
-      (aa/<? (start-loop! ws))
-      (aa/<? (handle-message ws {:type :disconnect}))
+      (aa/<? (handle-message cfg {:type :connect}))
+      (aa/<? (start-loop! cfg))
+      (aa/<? (handle-message cfg {:type :disconnect}))
       (catch Throwable err
-        (log/errorf err "Unexpected exception on websocket handler.")
-        (let [session (.getSession conn)]
+        (log/errorf err "unexpected exception on websocket handler")
+        (let [session (.getSession ^WebSocketAdapter conn)]
           (when session
             (.disconnect session)))))))
 
 (defn- start-loop!
-  [{:keys [in out sub session-id] :as ws}]
+  [{:keys [rcv-ch out-ch sub-ch session-id] :as cfg}]
   (aa/go-try
    (loop []
-     (let [timeout (a/timeout 30000)
-           [val port] (a/alts! [in sub timeout])]
-
-       ;; (prn "alts" val "from" (cond (= port in)  "input"
-       ;;                              (= port sub) "redis"
-       ;;                              :else "timeout"))
+     (let [timeout    (a/timeout 30000)
+           [val port] (a/alts! [rcv-ch sub-ch timeout])]
 
        (cond
          ;; Process message coming from connected client
-         (and (= port in) (not (nil? val)))
+         (and (= port rcv-ch) (some? val))
          (do
-           (aa/<? (handle-message ws val))
+           (aa/<? (handle-message cfg val))
            (recur))
 
-         ;; Forward message to the websocket
-         (and (= port sub) (not (nil? val)))
+         ;; If message comes from subscription channel; we just need
+         ;; to foreward it to the output channel.
+         (and (= port sub-ch) (some? val))
          (do
            (when-not (= (:session-id val) session-id)
-             (a/>! out val))
+             (a/>! out-ch val))
            (recur))
 
-         ;; Timeout channel signaling
+         ;; 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 {:type :ping})
+           (a/>! out-ch {:type :ping})
            (recur))
 
          :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})))))
+;; --- PRESENCE HANDLING API
 
 (def ^:private
   sql:retrieve-presence
@@ -237,12 +251,6 @@
     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)
@@ -250,51 +258,71 @@
        on conflict (file_id, session_id, profile_id)
        do update set updated_at=clock_timestamp()")
 
+(defn- retrieve-presence
+  [{:keys [pool file-id] :as cfg}]
+  (let [rows (db/exec! pool [sql:retrieve-presence file-id])]
+    (mapv (juxt :session-id :profile-id) rows)))
+
+(defn- retrieve-presence*
+  [{:keys [executor] :as cfg}]
+  (aa/with-thread executor
+    (retrieve-presence cfg)))
+
 (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))))
+  [{:keys [pool file-id session-id profile-id] :as cfg}]
+  (let [sql [sql:update-presence file-id session-id profile-id]]
+    (db/exec-one! pool sql)))
+
+(defn- update-presence*
+  [{:keys [executor] :as cfg}]
+  (aa/with-thread executor
+    (update-presence cfg)))
 
 (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})))
+  [{:keys [pool file-id session-id profile-id] :as cfg}]
+  (db/delete! pool :presence {:file-id file-id
+                              :profile-id profile-id
+                              :session-id session-id}))
+
+(defn- delete-presence*
+  [{:keys [executor] :as cfg}]
+  (aa/with-thread executor
+    (delete-presence cfg)))
+
+;; --- 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]
+  [{:keys [file-id msgbus] :as cfg} _message]
   ;; (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})))))
+   (aa/<? (update-presence* cfg))
+   (let [members (aa/<? (retrieve-presence* cfg))
+         val     {:topic file-id :message {:type :presence :sessions members}}]
+     (a/<! (msgbus :pub val)))))
 
 (defmethod handle-message :disconnect
-  [{:keys [profile-id file-id session-id redis pool] :as ws} _message]
+  [{:keys [file-id msgbus] :as cfg} _message]
   ;; (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})))))
+   (aa/<? (delete-presence* cfg))
+   (let [members (aa/<? (retrieve-presence* cfg))
+         val     {:topic file-id :message {:type :presence :sessions members}}]
+     (a/<! (msgbus :pub val)))))
 
 (defmethod handle-message :keepalive
-  [{:keys [profile-id file-id session-id pool] :as ws} _message]
-  (update-presence pool file-id session-id profile-id))
+  [cfg _message]
+  (update-presence* cfg))
 
 (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]))
@@ -50,7 +55,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 +75,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 +85,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 +105,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 +124,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,6 +135,7 @@
                      'app.rpc.mutations.projects
                      'app.rpc.mutations.viewer
                      'app.rpc.mutations.teams
+                     'app.rpc.mutations.ldap
                      'app.rpc.mutations.verify-token)
          (map (partial process-method cfg))
          (into {}))))

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,11 +48,11 @@
     (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"
-                           :delay cfg/default-deletion-delay
+                           :delay cfg/deletion-delay
                            :props {:profile-id id}})
 
       {:email email

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

@@ -16,14 +16,12 @@
    [app.common.uuid :as uuid]
    [app.config :as cfg]
    [app.db :as db]
-   [app.redis :as rd]
    [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
@@ -129,7 +127,7 @@
 
     ;; Schedule object deletion
     (tasks/submit! conn {:name "delete-object"
-                         :delay cfg/default-deletion-delay
+                         :delay cfg/deletion-delay
                          :props {:id id :type :file}})
 
     (mark-file-deleted conn params)))
@@ -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,105 @@
+;; 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]
+   [clojure.tools.logging :as log]))
+
+(def cpool
+  (delay
+    (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
+          (log/errorf e "cannot connect to LDAP %s:%s"
+                      (get-in params [:host :address])
+                      (get-in params [:host :port])))))))
+
+;; --- 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}]
+  (when-not @cpool
+    (ex/raise :type :restriction
+              :code :ldap-disabled
+              :hint "ldap disabled or unable to connect"))
+
+  (let [info (authenticate @cpool 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
+  [cpool {:keys [password] :as params}]
+  (when-let [{:keys [dn] :as luser} (get-ldap-user cpool params)]
+    (when (ldap/bind? cpool 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/media.clj

@@ -38,7 +38,7 @@
 ;; --- Create File Media object (upload)
 
 (declare create-file-media-object)
-(declare select-file-for-update)
+(declare select-file)
 
 (s/def ::content ::media/upload)
 (s/def ::is-local ::us/boolean)
@@ -50,7 +50,7 @@
 (sv/defmethod ::upload-file-media-object
   [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
   (db/with-atomic [conn pool]
-    (let [file (select-file-for-update conn file-id)]
+    (let [file (select-file conn file-id)]
       (teams/check-edition-permissions! conn profile-id (:team-id file))
       (-> (assoc cfg :conn conn)
           (create-file-media-object params)))))
@@ -66,9 +66,18 @@
   [info]
   (= (:mtype info) "image/svg+xml"))
 
+(defn- fetch-url
+  [url]
+  (try
+    (http/get! url {:as :byte-array})
+    (catch Exception e
+      (ex/raise :type :validation
+                :code :unable-to-access-to-url
+                :cause e))))
+
 (defn- download-media
   [{:keys [storage] :as cfg} url]
-  (let [result (http/get! url {:as :byte-array})
+  (let [result (fetch-url url)
         data   (:body result)
         mtype  (get (:headers result) "content-type")
         format (cm/mtype->format mtype)]
@@ -129,7 +138,7 @@
 (sv/defmethod ::create-file-media-object-from-url
   [{:keys [pool storage] :as cfg} {:keys [profile-id file-id url name] :as params}]
   (db/with-atomic [conn pool]
-    (let [file (select-file-for-update conn file-id)]
+    (let [file (select-file conn file-id)]
       (teams/check-edition-permissions! conn profile-id (:team-id file))
       (let [mobj    (download-media cfg url)
             content {:filename "tempfile"
@@ -152,7 +161,7 @@
 (sv/defmethod ::clone-file-media-object
   [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
   (db/with-atomic [conn pool]
-    (let [file (select-file-for-update conn file-id)]
+    (let [file (select-file conn file-id)]
       (teams/check-edition-permissions! conn profile-id (:team-id file))
 
       (-> (assoc cfg :conn conn)
@@ -175,17 +184,17 @@
 
 ;; --- HELPERS
 
-(def ^:private sql:select-file-for-update
+(def ^:private
+  sql:select-file
   "select file.*,
           project.team_id as team_id
      from file
     inner join project on (project.id = file.project_id)
-    where file.id = ?
-      for update of file")
+    where file.id = ?")
 
-(defn- select-file-for-update
+(defn- select-file
   [conn id]
-  (let [row (db/exec-one! conn [sql:select-file-for-update id])]
+  (let [row (db/exec-one! conn [sql:select-file id])]
     (when-not row
       (ex/raise :type :not-found))
     row))

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,77 +41,88 @@
 
 ;; --- 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 ::token ::us/not-empty-string)
+(s/def ::invitation-token ::us/not-empty-string)
 (s/def ::register-profile
   (s/keys :req-un [::email ::password ::fullname]
-          :opt-un [::token]))
+          :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))
 
   (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))]
-          (process-token conn params claims)
+(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))))
 
-          ;; 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)})
+(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)]
 
-          ;; 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}))))}))
+    (sid/load-initial-project! conn 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-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)}))
 
-          (emails/send! conn emails/register
-                        {:to (:email profile)
-                         :name (:fullname profile)
-                         :token token})
+      ;; 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)})]
 
-          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
@@ -152,33 +160,41 @@
   [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)]
-    (-> (db/insert! conn :profile
-                    {:id id
-                     :fullname fullname
-                     :email (str/lower email)
-                     :password password
-                     :props props
-                     :is-active active?
-                     :is-demo demo?})
-        (update :props db/decode-transit-pgobject))))
+  [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 params opts)
+          (update :props db/decode-transit-pgobject))
+      (catch org.postgresql.util.PSQLException e
+        (let [state (.getSQLState e)]
+          (if (not= state "23505")
+            (throw e)
+            (ex/raise :type :validation
+                      :code :email-already-exists
+                      :cause e)))))))
 
-(defn- create-profile-relations
+
+(defn create-profile-relations
   [conn profile]
   (let [team (teams/create-team conn {:profile-id (:id profile)
                                       :name "Default"
@@ -203,10 +219,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
@@ -226,29 +242,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}))
@@ -256,15 +306,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,12 +338,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]))
@@ -302,12 +347,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
 
@@ -341,31 +397,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]
@@ -386,17 +479,36 @@
               (assoc profile :token token)))
 
           (send-email-notification [conn profile]
-            (emails/send! conn emails/password-recovery
-                          {:to (:email profile)
-                           :token (:token profile)
-                           :name (:fullname profile)}))]
+            (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]
-      (some->> email
-               (profile/retrieve-profile-data-by-email conn)
-               (create-recovery-token)
-               (send-email-notification conn))
-      nil)))
+      (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))))))
 
 
 ;; --- Mutation: Recover Profile
@@ -457,7 +569,7 @@
 
     ;; Schedule a complete deletion of profile
     (tasks/submit! conn {:name "delete-profile"
-                         :delay (dt/duration {:hours 48})
+                         :delay cfg/deletion-delay
                          :props {:profile-id profile-id}})
 
     (db/update! conn :profile
@@ -465,11 +577,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

@@ -14,8 +14,10 @@
    [app.config :as cfg]
    [app.db :as db]
    [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]
    [clojure.spec.alpha :as s]))
 
 ;; --- Helpers & Specs
@@ -37,13 +39,14 @@
           :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))]
+    (teams/check-edition-permissions! conn profile-id team-id)
+    (let [project (create-project conn params)
+          params  (assoc params :project-id (:id project))]
       (create-project-profile 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}]
@@ -91,6 +94,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))
 
@@ -113,8 +117,6 @@
 
 ;; --- Mutation: Delete Project
 
-(declare mark-project-deleted)
-
 (s/def ::delete-project
   (s/keys :req-un [::id ::profile-id]))
 
@@ -125,18 +127,10 @@
 
     ;; Schedule object deletion
     (tasks/submit! conn {:name "delete-object"
-                         :delay cfg/default-deletion-delay
+                         :delay cfg/deletion-delay
                          :props {:id id :type :project}})
 
-    (mark-project-deleted conn params)))
-
-(def ^:private sql:mark-project-deleted
-  "update project
-      set deleted_at = clock_timestamp()
-    where id = ?
-   returning id")
-
-(defn mark-project-deleted
-  [conn {:keys [id] :as params}]
-  (db/exec! conn [sql:mark-project-deleted id])
-  nil)
+    (db/update! conn :project
+                {:deleted-at (dt/now)}
+                {:id id})
+    nil))

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

@@ -13,6 +13,7 @@
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
+   [app.config :as cfg]
    [app.db :as db]
    [app.emails :as emails]
    [app.media :as media]
@@ -20,6 +21,7 @@
    [app.rpc.queries.profile :as profile]
    [app.rpc.queries.teams :as teams]
    [app.storage :as sto]
+   [app.tasks :as tasks]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
@@ -133,11 +135,18 @@
         (ex/raise :type :validation
                   :code :only-owner-can-delete-team))
 
-      (db/delete! conn :team {:id id})
+      ;; Schedule object deletion
+      (tasks/submit! conn {:name "delete-object"
+                           :delay cfg/deletion-delay
+                           :props {:id id :type :team}})
+
+      (db/update! conn :team
+                  {:deleted-at (dt/now)}
+                  {:id id})
       nil)))
 
 
-;; --- Mutation: Tean Update Role
+;; --- Mutation: Team Update Role
 
 (declare retrieve-team-member)
 (declare role->params)
@@ -209,7 +218,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]))
@@ -218,8 +227,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))
 
@@ -288,26 +297,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,16 +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
-
-;; TODO: session
+;; 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]
@@ -43,21 +40,31 @@
               {:id profile-id})
   claims)
 
-(defmethod process-token :verify-email
-  [{:keys [conn] :as cfg} _params {:keys [profile-id] :as claims}]
-  (let [profile (db/get-by-id conn :profile profile-id {:for-update true})]
-    (when (:is-active profile)
-      (ex/raise :type :validation
-                :code :email-already-validated))
-    (when (not= (:email profile)
-                (:email claims))
-      (ex/raise :type :validation
-                :code :invalid-token))
+(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)))
 
-    (db/update! conn :profile
-                {:is-active true}
-                {:id (:id profile)})
-    claims))
+(defmethod process-token :verify-email
+  [{:keys [conn session metrics] :as cfg} _ {:keys [profile-id] :as claims}]
+  (let [profile (profile/retrieve-profile conn profile-id)
+        claims  (assoc claims :profile profile)]
+
+    (when-not (:is-active profile)
+      (when (not= (:email profile)
+                  (:email claims))
+        (ex/raise :type :validation
+                  :code :invalid-token))
+
+      (db/update! conn :profile
+                  {:is-active true}
+                  {:id (:id profile)}))
+
+    (with-meta claims
+      {: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}]
@@ -84,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/queries/files.clj

@@ -256,12 +256,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

@@ -13,6 +13,7 @@
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
    [app.db :as db]
+   [app.db.sql :as sql]
    [app.util.services :as sv]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]))
@@ -71,6 +72,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 +88,21 @@
 
 (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")
-
 (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/select :profile {:email (str/lower email)})
+        data (db/exec-one! conn sql)]
+    (when (and data (nil? (:deleted-at data)))
+      (decode-profile-row data))))
 
 ;; --- Attrs Helpers
 

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

@@ -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,193 @@
+;; 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.data :as d]
+   [app.common.pages.migrations :as pmg]
+   [app.common.uuid :as uuid]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.rpc.mutations.projects :as projects]
+   [app.rpc.queries.profile :as profile]
+   [app.util.blob :as blob]
+   [app.util.time :as dt]
+   [clojure.walk :as walk]))
+
+;; --- 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- 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))))))
+
+(defn- remap-id
+  [item index key]
+  (cond-> item
+    (contains? item key)
+    (assoc key (get index (get item key) (get item key)))))
+
+(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 [project (projects/create-project conn {:profile-id (:id profile)
+                                                    :team-id (:default-team-id profile)
+                                                    :name (:project-name data)})
+
+             now     (dt/now)
+             ignore  (dt/plus now (dt/duration {:seconds 5}))
+             index   (as-> {} index
+                       (reduce #(assoc %1 (:id %2) (uuid/next)) index (:files data))
+                       (reduce #(assoc %1 (:id %2) (uuid/next)) index (:fmeds data)))
+
+             flibs   (->> (:flibs data)
+                          (map #(remap-id % index :file-id))
+                          (map #(remap-id % index :library-file-id))
+                          (map #(assoc % :synced-at now))
+                          (map #(assoc % :created-at now)))
+
+             files   (->> (:files data)
+                          (map #(assoc % :id (get index (:id %))))
+                          (map #(assoc % :project-id (:id project)))
+                          (map #(assoc % :created-at now))
+                          (map #(assoc % :modified-at now))
+                          (map #(assoc % :ignore-sync-until ignore))
+                          (map #(process-file % index)))
+
+             fmeds   (->> (:fmeds data)
+                          (map #(assoc % :id (get index (:id %))))
+                          (map #(assoc % :created-at now))
+                          (map #(remap-id % index :file-id)))
+
+             fprofs  (map #(array-map :file-id (:id %)
+                                      :profile-id (:id profile)
+                                      :is-owner true
+                                      :is-admin true
+                                      :can-edit true) files)]
+
+       (projects/create-project-profile conn {:project-id (:id project)
+                                              :profile-id (:id profile)})
+
+       (projects/create-team-project-profile conn {:team-id (:default-team-id profile)
+                                                   :project-id (:id project)
+                                                   :profile-id (:id profile)})
+
+       ;; Re-insert into the database
+       (doseq [params files]
+         (db/insert! conn :file params))
+
+       (doseq [params fprofs]
+         (db/insert! conn :file-profile-rel params))
+
+       (doseq [params flibs]
+         (db/insert! conn :file-library-rel params))
+
+       (doseq [params fmeds]
+         (db/insert! conn :file-media-object params)))))))
+
+(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,12 +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
@@ -36,7 +40,7 @@
                 {:id id})))
 
 (defn get-file
-  [id]
+  [system id]
   (with-open [conn (db/open (:app.db/pool system))]
     (let [file (db/get-by-id conn :file id)]
       (-> file
@@ -51,10 +55,29 @@
 ;;         (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")
+;; Migrate
 
-(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 update-file-data-blob-format
+  [system]
+  (db/with-atomic [conn (:app.db/pool system)]
+    (doseq [id (->> (db/exec! conn ["select id from file;"]) (map :id))]
+      (let [{:keys [data]} (db/get-by-id conn :file id {:columns [:id :data]})]
+        (prn "Updating file:" id)
+        (db/update! conn :file
+                    {: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

@@ -121,11 +121,16 @@
 
 (defn parse
   [data]
-  (with-open [istream (IOUtils/toInputStream data "UTF-8")]
-    (xml/parse istream)))
+  (try
+    (with-open [istream (IOUtils/toInputStream data "UTF-8")]
+      (xml/parse istream))
+    (catch Exception _e
+      (ex/raise :type :validation
+                :code :invalid-svg-file))))
 
 (defn process-request
   [{:keys [svgc] :as cfg} body]
   (let [data (slurp body)
         data (svgc data)]
     (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_counter"
+    :help "An absolute 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,41 +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)))
+(defmulti handle-deletion
+  (fn [_ props] (:type props)))
 
 (defmethod handle-deletion :default
   [_conn {:keys [type]}]
-  (log/warn "no handler found for" type))
+  (log/warnf "no handler found for '%s'" type))
 
 (defmethod handle-deletion :file
   [conn {:keys [id] :as props}]
@@ -57,3 +48,8 @@
   [conn {:keys [id] :as props}]
   (let [sql "delete from project where id=? and deleted_at is not null"]
     (db/exec-one! conn [sql id])))
+
+(defmethod handle-deletion :team
+  [conn {:keys [id] :as props}]
+  (let [sql "delete from team where id=? and deleted_at is not null"]
+    (db/exec-one! conn [sql id])))

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/tasks/telemetry.clj

@@ -63,6 +63,7 @@
                                  :uri (:uri cfg)
                                  :headers {"content-type" "application/json"}
                                  :body (json/encode-str data)})]
+
     (when (not= 200 (:status response))
       (ex/raise :type :internal
                 :code :invalid-response-from-google
@@ -129,7 +130,7 @@
   [{:keys [conn version]}]
   (merge
    {:version version
-    :with-taiga  (:telemetry-with-taiga cfg/config)
+    :with-taiga  (:telemetry-with-taiga cfg/config false)
     :total-teams (retrieve-num-teams conn)
     :total-projects (retrieve-num-projects conn)
     :total-files (retrieve-num-files conn)}

backend/src/app/telemetry.clj

@@ -12,6 +12,7 @@
    [app.common.spec :as us]
    [app.db :as db]
    [app.http.middleware :refer [wrap-parse-request-body]]
+   [clojure.pprint :refer [pprint]]
    [clojure.spec.alpha :as s]
    [clojure.tools.logging :as log]
    [integrant.core :as ig]
@@ -87,7 +88,12 @@
     (catch Exception e
       ;; We don't want notify user of a error, just log it for posible
       ;; future investigation.
-      (log/warnf e "Unexpected error on telemetry.")))
+      (log/warn e (str "unexpected error on telemetry:\n"
+                       (when-let [edata (ex-data e)]
+                         (str "ex-data: \n"
+                              (with-out-str (pprint edata))))
+                       (str "params: \n"
+                            (with-out-str (pprint params)))))))
   {:status 200
    :body "OK\n"})
 
@@ -112,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

@@ -10,61 +10,93 @@
 (ns app.util.blob
   "A generic blob storage encoding. Mainly used for
   page data, page options and txlog payload storage."
-  (:require [app.util.transit :as t])
+  (:require
+   [app.config :as cfg]
+   [app.util.transit :as t]
+   [taoensso.nippy :as n])
   (:import
    java.io.ByteArrayInputStream
    java.io.ByteArrayOutputStream
    java.io.DataInputStream
    java.io.DataOutputStream
+   com.github.luben.zstd.Zstd
    net.jpountz.lz4.LZ4Factory
    net.jpountz.lz4.LZ4FastDecompressor
    net.jpountz.lz4.LZ4Compressor))
 
-(defprotocol IDataToBytes
-  (->bytes [data] "convert data to bytes"))
-
-(extend-protocol IDataToBytes
-  (Class/forName "[B")
-  (->bytes [data] data)
-
-  String
-  (->bytes [data] (.getBytes ^String data "UTF-8")))
-
 (def lz4-factory (LZ4Factory/fastestInstance))
 
-(defn encode
-  [data]
-  (let [data (t/encode data {:type :json})
-        data-len (alength ^bytes data)
-        cp (.fastCompressor ^LZ4Factory lz4-factory)
-        max-len (.maxCompressedLength cp data-len)
-        cdata (byte-array max-len)
-        clen (.compress ^LZ4Compressor cp ^bytes data 0 data-len cdata 0 max-len)]
-    (with-open [^ByteArrayOutputStream baos (ByteArrayOutputStream. (+ (alength cdata) 2 4))
-                ^DataOutputStream dos (DataOutputStream. baos)]
-      (.writeShort dos (short 1)) ;; version number
-      (.writeInt dos (int data-len))
-      (.write dos ^bytes cdata (int 0) clen)
-      (.toByteArray baos))))
-
 (declare decode-v1)
+(declare decode-v2)
+(declare encode-v1)
+(declare encode-v2)
+
+(def default-version
+  (:default-blob-version cfg/config 1))
+
+(defn encode
+  ([data] (encode data nil))
+  ([data {:keys [version] :or {version default-version}}]
+   (case  (long version)
+     1 (encode-v1 data)
+     2 (encode-v2 data)
+     (throw (ex-info "unsupported version" {:version version})))))
 
 (defn decode
   "A function used for decode persisted blobs in the database."
+  [^bytes data]
+  (with-open [bais (ByteArrayInputStream. data)
+              dis  (DataInputStream. bais)]
+    (let [version (.readShort dis)
+          ulen    (.readInt dis)]
+      (case version
+        1 (decode-v1 data ulen)
+        2 (decode-v2 data ulen)
+        (throw (ex-info "unsupported version" {:version version}))))))
+
+;; --- IMPL
+
+(defn- encode-v1
   [data]
-  (let [data (->bytes data)]
-    (with-open [bais (ByteArrayInputStream. data)
-                dis  (DataInputStream. bais)]
-      (let [version (.readShort dis)
-            udata-len (.readInt dis)]
-        (case version
-          1 (decode-v1 data udata-len)
-          (throw (ex-info "unsupported version" {:version version})))))))
+  (let [data  (t/encode data {:type :json})
+        dlen  (alength ^bytes data)
+        cp    (.fastCompressor ^LZ4Factory lz4-factory)
+        mlen  (.maxCompressedLength cp dlen)
+        cdata (byte-array mlen)
+        clen  (.compress ^LZ4Compressor cp ^bytes data 0 dlen cdata 0 mlen)]
+    (with-open [^ByteArrayOutputStream baos (ByteArrayOutputStream. (+ (alength cdata) 2 4))
+                ^DataOutputStream dos (DataOutputStream. baos)]
+      (.writeShort dos (short 1)) ;; version number
+      (.writeInt dos (int dlen))
+      (.write dos ^bytes cdata (int 0) clen)
+      (.toByteArray baos))))
 
 (defn- decode-v1
-  [^bytes cdata ^long udata-len]
-  (let [^LZ4FastDecompressor dcp (.fastDecompressor ^LZ4Factory lz4-factory)
-        ^bytes udata (byte-array udata-len)]
-    (.decompress dcp cdata 6 udata 0 udata-len)
+  [^bytes cdata ^long ulen]
+  (let [dcp   (.fastDecompressor ^LZ4Factory lz4-factory)
+        udata (byte-array ulen)]
+    (.decompress ^LZ4FastDecompressor dcp cdata 6 ^bytes udata 0 ulen)
     (t/decode udata {:type :json})))
 
+(defn- encode-v2
+  [data]
+  (let [data  (n/fast-freeze data)
+        dlen  (alength ^bytes data)
+        mlen  (Zstd/compressBound dlen)
+        cdata (byte-array mlen)
+        clen  (Zstd/compressByteArray ^bytes cdata 0 mlen
+                                      ^bytes data 0 dlen
+                                      8)]
+    (with-open [^ByteArrayOutputStream baos (ByteArrayOutputStream. (+ (alength cdata) 2 4))
+                ^DataOutputStream dos (DataOutputStream. baos)]
+      (.writeShort dos (short 2)) ;; version number
+      (.writeInt dos (int dlen))
+      (.write dos ^bytes cdata (int 0) clen)
+      (.toByteArray baos))))
+
+(defn- decode-v2
+  [^bytes cdata ^long ulen]
+  (let [udata (byte-array ulen)]
+    (Zstd/decompressByteArray ^bytes udata 0 ulen
+                              ^bytes cdata 6 (- (alength cdata) 6))
+    (n/fast-thaw udata)))

backend/src/app/util/emails.clj

@@ -9,6 +9,7 @@
 
 (ns app.util.emails
   (:require
+   [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.util.template :as tmpl]
@@ -29,24 +30,11 @@
 ;; Email Building
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defn build-address
-  [v charset]
-  (try
-    (cond
-      (string? v)
-      (InternetAddress. v nil charset)
+(defn- parse-address
+  [v]
+  (InternetAddress/parse ^String v))
 
-      (map? v)
-      (InternetAddress. (:addr v)
-                        (:name v)
-                        (:charset v charset))
-
-      :else
-      (throw (ex-info "Invalid address" {:data v})))
-    (catch Exception e
-      (throw (ex-info "Invalid address" {:data v} e)))))
-
-(defn- resolve-recipient-type
+(defn- ^Message$RecipientType resolve-recipient-type
   [type]
   (case type
     :to  Message$RecipientType/TO
@@ -54,33 +42,33 @@
     :bcc Message$RecipientType/BCC))
 
 (defn- assign-recipient
-  [^MimeMessage mmsg type address charset]
+  [^MimeMessage mmsg type address]
   (if (sequential? address)
-    (reduce #(assign-recipient %1 type %2 charset) mmsg address)
-    (let [address (build-address address charset)
+    (reduce #(assign-recipient %1 type %2) mmsg address)
+    (let [address (parse-address address)
           type    (resolve-recipient-type type)]
-      (.addRecipient mmsg type address)
+      (.addRecipients mmsg type address)
       mmsg)))
 
 (defn- assign-recipients
-  [mmsg {:keys [to cc bcc charset] :or {charset "utf-8"} :as params}]
+  [mmsg {:keys [to cc bcc] :as params}]
   (cond-> mmsg
-    (some? to)  (assign-recipient :to to charset)
-    (some? cc)  (assign-recipient :cc cc charset)
-    (some? bcc) (assign-recipient :bcc bcc charset)))
+    (some? to)  (assign-recipient :to to)
+    (some? cc)  (assign-recipient :cc cc)
+    (some? bcc) (assign-recipient :bcc bcc)))
 
 (defn- assign-from
-  [mmsg {:keys [from charset] :or {charset "utf-8"}}]
-  (when from
-    (let [from (build-address from charset)]
-      (.setFrom ^MimeMessage mmsg ^InternetAddress from))))
+  [mmsg {:keys [default-from]} {:keys [from] :as props}]
+  (let [from (or from default-from)]
+    (when from
+      (let [from (parse-address from)]
+        (.addFrom ^MimeMessage mmsg from)))))
 
 (defn- assign-reply-to
-  [mmsg {:keys [defaut-reply-to]} {:keys [reply-to charset] :or {charset "utf-8"}}]
-  (let [reply-to (or reply-to defaut-reply-to)]
+  [mmsg {:keys [default-reply-to] :as cfg} {:keys [reply-to] :as params}]
+  (let [reply-to (or reply-to default-reply-to)]
     (when reply-to
-      (let [reply-to (build-address reply-to charset)
-            reply-to (into-array InternetAddress [reply-to])]
+      (let [reply-to (parse-address reply-to)]
         (.setReplyTo ^MimeMessage mmsg reply-to)))))
 
 (defn- assign-subject
@@ -136,7 +124,7 @@
   [cfg session params]
   (let [mmsg (MimeMessage. ^Session session)]
     (assign-recipients mmsg params)
-    (assign-from mmsg params)
+    (assign-from mmsg cfg params)
     (assign-reply-to mmsg cfg params)
     (assign-subject mmsg params)
     (assign-extra-headers mmsg params)
@@ -156,12 +144,12 @@
    (Properties.)
    {"mail.user" username
     "mail.host" host
+    "mail.from" default-from
     "mail.smtp.auth" (boolean username)
     "mail.smtp.starttls.enable" tls
     "mail.smtp.starttls.required" tls
     "mail.smtp.host" host
     "mail.smtp.port" port
-    "mail.smtp.from" default-from
     "mail.smtp.user" username
     "mail.smtp.timeout" timeout
     "mail.smtp.connectiontimeout" timeout}))
@@ -173,7 +161,7 @@
     (.setDebug session debug)
     session))
 
-(defn smtp-message
+(defn ^MimeMessage smtp-message
   [cfg message]
   (let [^Session session (smtp-session cfg)]
     (build-message cfg session message)))
@@ -183,7 +171,9 @@
 (defn send!
   [cfg message]
   (let [^MimeMessage message (smtp-message cfg message)]
-    (Transport/send message (:username cfg) (:password cfg))
+    (Transport/send message
+                    (:username cfg)
+                    (:password cfg))
     nil))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -207,15 +197,17 @@
         text (render-email-template-part :txt id context)
         html (render-email-template-part :html id context)]
     (when (or (not subj)
-              (not text)
-              (not html))
+              (and (not text)
+                   (not html)))
       (ex/raise :type :internal
                 :code :missing-email-templates))
     {:subject subj
-     :body [{:type "text/plain"
-             :content text}
-            {:type "text/html"
-             :content html}]}))
+     :body (d/concat
+            [{:type "text/plain"
+              :content text}]
+            (when html
+              [{:type "text/html"
+                :content html}]))}))
 
 (s/def ::priority #{:high :low})
 (s/def ::to (s/or :sigle ::us/email

backend/src/app/util/json.clj

@@ -16,10 +16,18 @@
   [v]
   (j/write-value-as-string v j/keyword-keys-object-mapper))
 
+(defn encode
+  [v]
+  (j/write-value-as-bytes v j/keyword-keys-object-mapper))
+
 (defn decode-str
   [v]
   (j/read-value v j/keyword-keys-object-mapper))
 
+(defn decode
+  [v]
+  (j/read-value v j/keyword-keys-object-mapper))
+
 (defn read
   [v]
   (j/read-value v j/keyword-keys-object-mapper))

backend/src/app/util/log4j.clj

@@ -0,0 +1,27 @@
+;; 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.util.log4j
+  (:require
+   [clojure.pprint :refer [pprint]])
+  (:import
+   org.apache.logging.log4j.ThreadContext))
+
+(defn update-thread-context!
+  [data]
+  (run! (fn [[key val]]
+          (ThreadContext/put
+           (name key)
+           (cond
+             (coll? val)
+             (binding [clojure.pprint/*print-right-margin* 120]
+               (with-out-str (pprint val)))
+             (instance? clojure.lang.Named val) (name val)
+             :else (str val))))
+        data))

backend/src/app/util/redis.clj

@@ -1,166 +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.util.redis
-  "Asynchronous posgresql client."
-  (:refer-clojure :exclude [run!])
-  (:require
-   [clojure.core.async :as a]
-   [promesa.core :as p])
-  (:import
-   io.lettuce.core.RedisClient
-   io.lettuce.core.RedisURI
-   io.lettuce.core.codec.StringCodec
-   io.lettuce.core.api.async.RedisAsyncCommands
-   io.lettuce.core.api.StatefulRedisConnection
-   io.lettuce.core.pubsub.RedisPubSubListener
-   io.lettuce.core.pubsub.StatefulRedisPubSubConnection
-   io.lettuce.core.pubsub.api.sync.RedisPubSubCommands
-   ))
-
-(defrecord Client [^RedisClient inner
-                   ^RedisURI uri]
-  clojure.lang.IDeref
-  (deref [_] inner)
-
-  java.lang.AutoCloseable
-  (close [_]
-    (.shutdown inner)))
-
-(defrecord Connection [^StatefulRedisConnection inner
-                       ^RedisAsyncCommands cmd]
-  clojure.lang.IDeref
-  (deref [_] inner)
-
-  java.lang.AutoCloseable
-  (close [_]
-    (.close ^StatefulRedisConnection inner)))
-
-(defn client
-  [uri]
-  (->Client (RedisClient/create)
-            (RedisURI/create uri)))
-
-(defn connect
-  [{:keys [uri] :as client}]
-  (let [conn (.connect ^RedisClient @client StringCodec/UTF8 ^RedisURI uri)]
-    (->Connection conn (.async ^StatefulRedisConnection conn))))
-
-(defn- impl-subscribe
-  [topics xform ^StatefulRedisPubSubConnection conn]
-  (let [cmd    (.sync conn)
-        output (a/chan 1 (comp (filter string?) xform))
-        buffer (a/chan (a/sliding-buffer 64))
-        sub    (reify RedisPubSubListener
-                 (message [it pattern channel message])
-                 (message [it channel 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.
-                   (a/put! buffer message))
-                 (psubscribed [it pattern count])
-                 (punsubscribed [it pattern count])
-                 (subscribed [it channel count])
-                 (unsubscribed [it channel count]))]
-
-    ;; Start message event-loop (with keepalive mechanism)
-    (a/go-loop []
-      (let [[val port] (a/alts! [buffer (a/timeout 5000)])
-            message (if (= port buffer) val ::keepalive)]
-        (if (a/>! output message)
-          (recur)
-          (do
-            (a/close! buffer)
-            (.removeListener conn sub)
-            (when (.isOpen conn)
-              (.close conn))))))
-
-    ;; Synchronously subscribe to topics
-    (.addListener conn sub)
-    (.subscribe ^RedisPubSubCommands cmd topics)
-
-    ;; Return the output channel
-    output))
-
-(defn subscribe
-  [{:keys [uri] :as client} {:keys [topics xform]}]
-  (let [topics (if (vector? topics)
-                 (into-array String (map str topics))
-                 (into-array String [(str topics)]))]
-    (->> (.connectPubSub ^RedisClient @client StringCodec/UTF8 ^RedisURI uri)
-         (impl-subscribe topics xform))))
-
-(defn- resolve-to-bool
-  [v]
-  (if (= v 1)
-    true
-    false))
-
-(defmulti impl-run (fn [_ cmd _] cmd))
-
-(defn run!
-  [conn cmd params]
-  (let [^RedisAsyncCommands conn (:cmd conn)]
-    (impl-run conn cmd params)))
-
-(defn run
-  [conn cmd params]
-  (let [res (a/chan 1)]
-    (if (instance? Connection conn)
-      (-> (run! conn cmd params)
-          (p/finally (fn [v e]
-                       (if e
-                         (a/offer! res e)
-                         (a/offer! res v)))))
-      (a/close! res))
-    res))
-
-(defmethod impl-run :get
-  [conn _ {:keys [key]}]
-  (.get ^RedisAsyncCommands conn ^String key))
-
-(defmethod impl-run :set
-  [conn _ {:keys [key val]}]
-  (.set ^RedisAsyncCommands conn ^String key ^String val))
-
-(defmethod impl-run :smembers
-  [conn _ {:keys [key]}]
-  (-> (.smembers ^RedisAsyncCommands conn ^String key)
-      (p/then' #(into #{} %))))
-
-(defmethod impl-run :sadd
-  [conn _ {:keys [key val]}]
-  (let [keys (into-array String [val])]
-    (-> (.sadd ^RedisAsyncCommands conn ^String key ^"[S;" keys)
-        (p/then resolve-to-bool))))
-
-(defmethod impl-run :srem
-  [conn _ {:keys [key val]}]
-  (let [keys (into-array String [val])]
-    (-> (.srem ^RedisAsyncCommands conn ^String key ^"[S;" keys)
-        (p/then resolve-to-bool))))
-
-(defmethod impl-run :publish
-  [conn _ {:keys [channel message]}]
-  (-> (.publish ^RedisAsyncCommands conn ^String channel ^String message)
-      (p/then resolve-to-bool)))
-
-(defmethod impl-run :hset
-  [^RedisAsyncCommands conn _ {:keys [key field value]}]
-  (.hset conn key field value))
-
-(defmethod impl-run :hgetall
-  [^RedisAsyncCommands conn _ {:keys [key]}]
-  (.hgetall conn key))
-
-(defmethod impl-run :hdel
-  [^RedisAsyncCommands conn _ {:keys [key field]}]
-  (let [fields (into-array String [field])]
-    (.hdel conn key fields)))
-

backend/src/app/util/services.clj

@@ -21,7 +21,7 @@
                      ::spec sname
                      ::name (name sname))
 
-        sym   (symbol (str "service-method-" (name sname)))]
+        sym   (symbol (str "sm$" (name sname)))]
     `(do
        (def ~sym (fn ~args ~@body))
        (reset-meta! (var ~sym) ~mdata))))

backend/src/app/util/svg.clj

@@ -1,101 +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.util.svg
-  "Icons SVG parsing helpers."
-  (:require
-   [app.common.exceptions :as ex]
-   [app.common.spec :as us]
-   [clojure.spec.alpha :as s]
-   [cuerdas.core :as str])
-  (:import
-   org.jsoup.Jsoup
-   org.jsoup.nodes.Attribute
-   org.jsoup.nodes.Element
-   org.jsoup.nodes.Document))
-
-(s/def ::content string?)
-(s/def ::width ::us/number)
-(s/def ::height ::us/number)
-(s/def ::name string?)
-(s/def ::view-box (s/coll-of ::us/number :min-count 4 :max-count 4))
-
-(s/def ::svg-entity
-  (s/keys :req-un [::content ::width ::height ::view-box]
-          :opt-un [::name]))
-
-;; --- Implementation
-
-(defn- parse-double
-  [data]
-  (s/assert ::us/string data)
-  (Double/parseDouble data))
-
-(defn- parse-viewbox
-  [data]
-  (s/assert ::us/string data)
-  (mapv parse-double (str/split data #"\s+")))
-
-(defn- parse-attrs
-  [^Element element]
-  (persistent!
-   (reduce (fn [acc ^Attribute attr]
-             (let [key (.getKey attr)
-                   val (.getValue attr)]
-               (case key
-                 "width" (assoc! acc :width (parse-double val))
-                 "height" (assoc! acc :height (parse-double val))
-                 "viewbox" (assoc! acc :view-box (parse-viewbox val))
-                 "sodipodi:docname" (assoc! acc :name val)
-                 acc)))
-           (transient {})
-           (.attributes element))))
-
-(defn- impl-parse
-  [data]
-  (try
-    (let [document (Jsoup/parse ^String data)
-          element (some-> (.body ^Document document)
-                          (.getElementsByTag "svg")
-                          (first))
-          content (.html element)
-          attrs (parse-attrs element)]
-      (assoc attrs :content content))
-    (catch java.lang.IllegalArgumentException _e
-      (ex/raise :type :validation
-                :code ::invalid-input
-                :message "Input does not seems to be a valid svg."))
-    (catch java.lang.NullPointerException _e
-      (ex/raise :type :validation
-                :code ::invalid-input
-                :message "Input does not seems to be a valid svg."))
-    (catch org.jsoup.UncheckedIOException _e
-      (ex/raise :type :validation
-                :code ::invalid-input
-                :message "Input does not seems to be a valid svg."))
-    (catch Exception _e
-      (ex/raise :type :internal
-                :code ::unexpected))))
-
-;; --- Public Api
-
-(defn parse-string
-  "Parse SVG from a string."
-  [data]
-  (s/assert ::us/string data)
-  (let [result (impl-parse data)]
-    (if (s/valid? ::svg-entity result)
-      result
-      (ex/raise :type :validation
-                :code ::invalid-result
-                :message "The result does not conform valid svg entity."))))
-
-(defn parse
-  [data]
-  (parse-string (slurp data)))

backend/src/app/util/time.clj

@@ -93,6 +93,10 @@
   [t1 t2]
   (Duration/between t1 t2))
 
+(defn instant
+  [ms]
+  (Instant/ofEpochMilli ms))
+
 (defn parse-duration
   [s]
   (Duration/parse s))

backend/src/app/worker.clj

@@ -10,15 +10,17 @@
 (ns app.worker
   "Async tasks abstraction (impl)."
   (:require
+   [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
    [app.db :as db]
    [app.util.async :as aa]
+   [app.util.log4j :refer [update-thread-context!]]
    [app.util.time :as dt]
    [clojure.core.async :as a]
-   [clojure.pprint :refer [pprint]]
    [clojure.spec.alpha :as s]
    [clojure.tools.logging :as log]
+   [cuerdas.core :as str]
    [integrant.core :as ig]
    [promesa.exec :as px])
   (:import
@@ -72,7 +74,7 @@
 (s/def ::queue ::us/string)
 (s/def ::parallelism ::us/integer)
 (s/def ::batch-size ::us/integer)
-(s/def ::tasks (s/map-of string? ::us/fn))
+(s/def ::tasks (s/map-of string? fn?))
 (s/def ::poll-interval ::dt/duration)
 
 (defmethod ig/pre-init-spec ::worker [_]
@@ -94,7 +96,7 @@
 
 (defmethod ig/init-key ::worker
   [_ {:keys [pool poll-interval name queue] :as cfg}]
-  (log/infof "Starting worker '%s' on queue '%s'." name queue)
+  (log/infof "starting worker '%s' on queue '%s'" name queue)
   (let [cch     (a/chan 1)
         poll-ms (inst-ms poll-interval)]
     (a/go-loop []
@@ -103,30 +105,30 @@
           ;; Terminate the loop if close channel is closed or
           ;; event-loop-fn returns nil.
           (or (= port cch) (nil? val))
-          (log/infof "Stop condition found. Shutdown worker: '%s'" name)
+          (log/infof "stop condition found; shutdown worker: '%s'" name)
 
           (db/pool-closed? pool)
           (do
-            (log/info "Worker eventloop is aborted because pool is closed.")
+            (log/info "worker eventloop is aborted because pool is closed")
             (a/close! cch))
 
           (and (instance? java.sql.SQLException val)
                (contains? #{"08003" "08006" "08001" "08004"} (.getSQLState ^java.sql.SQLException val)))
           (do
-            (log/error "Connection error, trying resume in some instants.")
+            (log/error "connection error, trying resume in some instants")
             (a/<! (a/timeout poll-interval))
             (recur))
 
           (and (instance? java.sql.SQLException val)
                (= "40001" (.getSQLState ^java.sql.SQLException val)))
           (do
-            (log/debug "Serialization failure (retrying in some instants).")
+            (log/debug "serialization failure (retrying in some instants)")
             (a/<! (a/timeout poll-ms))
             (recur))
 
           (instance? Exception val)
           (do
-            (log/errorf val "Unexpected error ocurried on polling the database (will resume in some instants).")
+            (log/errorf val "unexpected error ocurried on polling the database (will resume in some instants)")
             (a/<! (a/timeout poll-ms))
             (recur))
 
@@ -202,9 +204,16 @@
   (let [task-fn (get tasks name)]
     (if task-fn
       (task-fn item)
-      (log/warn "no task handler found for" (pr-str name)))
+      (log/warnf "no task handler found for '%s'" (pr-str name)))
     {:status :completed :task item}))
 
+(defn get-error-context
+  [error item]
+  (let [edata (ex-data error)]
+    {:id      (uuid/next)
+     :data    edata
+     :params  item}))
+
 (defn- handle-exception
   [error item]
   (let [edata (ex-data error)]
@@ -218,14 +227,9 @@
         (= ::noop (:strategy edata))
         (assoc :inc-by 0))
 
-      (do
-        (log/errorf error
-                    (str "Unhandled exception.\n"
-                         "=> task:  " (:name item) "\n"
-                         "=> retry: " (:retry-num item) "\n"
-                         "=> props: \n"
-                         (with-out-str
-                           (pprint (:props item)))))
+      (let [cdata (get-error-context error item)]
+        (update-thread-context! cdata)
+        (log/errorf error "unhandled exception on task (id: '%s')" (:id cdata))
         (if (>= (:retry-num item) (:max-retries item))
           {:status :failed :task item :error error}
           {:status :retry :task item :error error})))))
@@ -233,12 +237,12 @@
 (defn- run-task
   [{:keys [tasks]} item]
   (try
-    (log/debugf "Started task '%s/%s/%s'." (:name item) (:id item) (:retry-num item))
+    (log/debugf "started task '%s/%s/%s'" (:name item) (:id item) (:retry-num item))
     (handle-task tasks item)
     (catch Exception e
       (handle-exception e item))
     (finally
-      (log/debugf "Finished task '%s/%s/%s'." (:name item) (:id item) (:retry-num item)))))
+      (log/debugf "finished task '%s/%s/%s'" (:name item) (:id item) (:retry-num item)))))
 
 (def sql:select-next-tasks
   "select * from task as t
@@ -287,21 +291,31 @@
 (s/def ::id ::us/string)
 (s/def ::cron dt/cron?)
 (s/def ::props (s/nilable map?))
+(s/def ::task keyword?)
 
 (s/def ::scheduled-task-spec
-  (s/keys :req-un [::id ::cron ::fn]
+  (s/keys :req-un [::id ::cron ::task]
           :opt-un [::props]))
 
-(s/def ::schedule
-  (s/coll-of (s/nilable ::scheduled-task-spec)))
+(s/def ::schedule (s/coll-of (s/nilable ::scheduled-task-spec)))
 
 (defmethod ig/pre-init-spec ::scheduler [_]
-  (s/keys :req-un [::executor ::db/pool ::schedule]))
+  (s/keys :req-un [::executor ::db/pool ::schedule ::tasks]))
 
 (defmethod ig/init-key ::scheduler
-  [_ {:keys [schedule] :as cfg}]
+  [_ {:keys [schedule tasks] :as cfg}]
   (let [scheduler (Executors/newScheduledThreadPool (int 1))
-        schedule  (filter some? schedule)
+        schedule  (->> schedule
+                       (filter some?)
+                       (map (fn [{:keys [task] :as item}]
+                              (let [f (get tasks (name task))]
+                                (when-not f
+                                  (ex/raise :type :internal
+                                            :code :task-not-found
+                                            :hint (str/fmt "task %s not configured" task)))
+                                (-> item
+                                    (dissoc :task)
+                                    (assoc :fn f))))))
         cfg       (assoc cfg
                          :scheduler scheduler
                          :schedule schedule)]
@@ -328,7 +342,7 @@
 (defn- synchronize-schedule-item
   [conn {:keys [id cron]}]
   (let [cron (str cron)]
-    (log/debugf "initialize scheduled task '%s' (cron: '%s')." id cron)
+    (log/infof "initialize scheduled task '%s' (cron: '%s')" id cron)
     (db/exec-one! conn [sql:upsert-scheduled-task id cron cron])))
 
 (defn- synchronize-schedule
@@ -349,27 +363,16 @@
   (letfn [(run-task [conn]
             (try
               (when (db/exec-one! conn [sql:lock-scheduled-task id])
-                (log/info "Executing scheduled task" id)
+                (log/debugf "executing scheduled task '%s'" id)
                 ((:fn task) task))
-              (catch Exception e
+              (catch Throwable e
                 e)))
 
-          (handle-task* [conn]
-            (let [result (run-task conn)]
-              (if (instance? Throwable result)
-                (do
-                  (log/warnf result "unhandled exception on scheduled task '%s'" id)
-                  (db/insert! conn :scheduled-task-history
-                              {:id (uuid/next)
-                               :task-id id
-                               :is-error true
-                               :reason (exception->string result)}))
-                (db/insert! conn :scheduled-task-history
-                            {:id (uuid/next)
-                             :task-id id}))))
           (handle-task []
             (db/with-atomic [conn pool]
-              (handle-task* conn)))]
+              (let [result (run-task conn)]
+                (when (ex/exception? result)
+                  (log/errorf result "unhandled exception on scheduled task '%s'" id)))))]
 
     (try
       (px/run! executor handle-task)

backend/tests/app/tests/helpers.clj

@@ -31,15 +31,23 @@
    [environ.core :refer [env]]
    [expound.alpha :as expound]
    [integrant.core :as ig]
+   [mockery.core :as mk]
    [promesa.core :as p])
   (:import org.postgresql.ds.PGSimpleDataSource))
 
 (def ^:dynamic *system* nil)
 (def ^:dynamic *pool* nil)
 
+(def config
+  (merge {:redis-uri "redis://redis/1"
+          :database-uri "postgresql://postgres/penpot_test"
+          :storage-fs-directory "/tmp/app/storage"
+          :migrations-verbose false}
+         cfg/config))
+
 (defn state-init
   [next]
-  (let [config (-> (main/build-system-config cfg/test-config)
+  (let [config (-> (main/build-system-config config)
                    (dissoc :app.srepl/server
                            :app.http/server
                            :app.http/router
@@ -99,48 +107,7 @@
   [prefix & args]
   (uuid/namespaced uuid/zero (apply str prefix args)))
 
-
-(defn create-profile
-  [conn i]
-  (let [params {:id (mk-uuid "profile" i)
-                :fullname (str "Profile " i)
-                :email (str "profile" i ".test@nodomain.com")
-                :password "123123"
-                :demo? true}]
-    (->> (#'profile/create-profile conn params)
-         (#'profile/create-profile-relations conn))))
-
-(defn create-team
-  [conn profile-id i]
-  (let [id (mk-uuid "team" i)
-        team (#'teams/create-team conn {:id id
-                                        :profile-id profile-id
-                                        :name (str "team" i)})]
-    (#'teams/create-team-profile conn
-                                 {:team-id id
-                                  :profile-id profile-id
-                                  :is-owner true
-                                  :is-admin true
-                                  :can-edit true})
-    team))
-
-(defn create-project
-  [conn profile-id team-id i]
-  (#'projects/create-project conn {:id (mk-uuid "project" i)
-                                   :profile-id profile-id
-                                   :team-id team-id
-                                   :name (str "project" i)}))
-
-(defn create-file
-  [conn profile-id project-id is-shared i]
-  (#'files/create-file conn {:id (mk-uuid "file" i)
-                             :profile-id profile-id
-                             :project-id project-id
-                             :is-shared is-shared
-                             :name (str "file" i)}))
-
-
-;; --- NEW HELPERS
+;; --- FACTORIES
 
 (defn create-profile*
   ([i] (create-profile* *pool* i {}))
@@ -150,7 +117,7 @@
                         :fullname (str "Profile " i)
                         :email (str "profile" i ".test@nodomain.com")
                         :password "123123"
-                        :demo? false}
+                        :is-demo false}
                        params)]
      (->> (#'profile/create-profile conn params)
           (#'profile/create-profile-relations conn)))))
@@ -193,6 +160,60 @@
                                    :can-edit true})
      team)))
 
+(defn link-file-to-library*
+  ([params] (link-file-to-library* *pool* params))
+  ([conn {:keys [file-id library-id] :as params}]
+   (#'files/link-file-to-library conn {:file-id file-id :library-id library-id})))
+
+(defn create-complaint-for
+  [conn {:keys [id created-at type]}]
+  (db/insert! conn :profile-complaint-report
+              {:profile-id id
+               :created-at (or created-at (dt/now))
+               :type (name type)
+               :content (db/tjson {})}))
+
+(defn create-global-complaint-for
+  [conn {:keys [email type created-at]}]
+  (db/insert! conn :global-complaint-report
+              {:email email
+               :type (name type)
+               :created-at (or created-at (dt/now))
+               :content (db/tjson {})}))
+
+
+(defn create-team-permission*
+  ([params] (create-team-permission* *pool* params))
+  ([conn {:keys [team-id profile-id is-owner is-admin can-edit]
+          :or {is-owner true is-admin true can-edit true}}]
+   (db/insert! conn :team-profile-rel {:team-id team-id
+                                       :profile-id profile-id
+                                       :is-owner is-owner
+                                       :is-admin is-admin
+                                       :can-edit can-edit})))
+
+(defn create-project-permission*
+  ([params] (create-project-permission* *pool* params))
+  ([conn {:keys [project-id profile-id is-owner is-admin can-edit]
+          :or {is-owner true is-admin true can-edit true}}]
+   (db/insert! conn :project-profile-rel {:project-id project-id
+                                          :profile-id profile-id
+                                          :is-owner is-owner
+                                          :is-admin is-admin
+                                          :can-edit can-edit})))
+
+(defn create-file-permission*
+  ([params] (create-file-permission* *pool* params))
+  ([conn {:keys [file-id profile-id is-owner is-admin can-edit]
+          :or {is-owner true is-admin true can-edit true}}]
+   (db/insert! conn :project-profile-rel {:file-id file-id
+                                          :profile-id profile-id
+                                          :is-owner is-owner
+                                          :is-admin is-admin
+                                          :can-edit can-edit})))
+
+
+;; --- RPC HELPERS
 
 (defn handle-error
   [^Throwable err]
@@ -200,14 +221,6 @@
     (handle-error (.getCause err))
     err))
 
-(defmacro try-on
-  [expr]
-  `(try
-     (let [result# (deref ~expr)]
-       [nil result#])
-     (catch Exception e#
-       [(handle-error e#) nil])))
-
 (defmacro try-on!
   [expr]
   `(try
@@ -217,16 +230,6 @@
        {:error (handle-error e#)
         :result nil})))
 
-(defmacro try!
-  [expr]
-  `(try
-     {:error nil
-      :result ~expr}
-     (catch Exception e#
-       {:error (handle-error e#)
-        :result nil})))
-
-
 (defn mutation!
   [{:keys [::type] :as data}]
   (let [method-fn (get-in *system* [:app.rpc/rpc :methods :mutation type])]
@@ -239,7 +242,7 @@
     (try-on!
      (method-fn (dissoc data ::type)))))
 
-;; --- Utils
+;; --- UTILS
 
 (defn print-error!
   [error]
@@ -300,3 +303,14 @@
 (defn sleep
   [ms]
   (Thread/sleep ms))
+
+(defn mock-config-get-with
+  "Helper for mock app.config/get"
+  [data]
+  (fn
+    ([key] (get (merge config data) key))
+    ([key default] (get (merge config data) key default))))
+
+(defn reset-mock!
+  [m]
+  (reset! m @(mk/make-mock {})))

backend/tests/app/tests/test_bounces_handling.clj

@@ -0,0 +1,316 @@
+;; 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.tests.test-bounces-handling
+  (:require
+   [clojure.pprint :refer [pprint]]
+   [app.http.awsns :as awsns]
+   [app.emails :as emails]
+   [app.tests.helpers :as th]
+   [app.db :as db]
+   [app.util.time :as dt]
+   [mockery.core :refer [with-mocks]]
+   [clojure.test :as t]))
+
+(t/use-fixtures :once th/state-init)
+(t/use-fixtures :each th/database-reset)
+
+;; (with-mocks [mock {:target 'app.tasks/submit! :return nil}]
+;; Right now we have many different scenarios what can cause a
+;; bounce/complain report.
+
+(defn- decode-row
+  [{:keys [content] :as row}]
+  (cond-> row
+    (db/pgobject? content)
+    (assoc :content (db/decode-transit-pgobject content))))
+
+(defn bounce-report
+  [{:keys [token email] :or {email "user@example.com"}}]
+  {"notificationType" "Bounce",
+   "bounce" {"feedbackId""010701776d7dd251-c08d280d-9f47-41aa-b959-0094fec779d9-000000",
+             "bounceType" "Permanent",
+             "bounceSubType" "General",
+             "bouncedRecipients" [{"emailAddress" email,
+                                   "action" "failed",
+                                   "status" "5.1.1",
+                                   "diagnosticCode" "smtp; 550 5.1.1 user unknown"}]
+             "timestamp" "2021-02-04T14:41:38.000Z",
+             "remoteMtaIp" "22.22.22.22",
+             "reportingMTA" "dsn; b224-13.smtp-out.eu-central-1.amazonses.com"}
+   "mail" {"timestamp" "2021-02-04T14:41:37.020Z",
+           "source" "no-reply@penpot.app",
+           "sourceArn" "arn:aws:ses:eu-central-1:1111111111:identity/penpot.app",
+           "sourceIp" "22.22.22.22",
+           "sendingAccountId" "1111111111",
+           "messageId" "010701776d7dccfc-3c0094e7-01d7-458d-8100-893320186028-000000",
+           "destination" [email],
+           "headersTruncated" false,
+           "headers" [{"name" "Received","value" "from app-pre"},
+                      {"name" "Date","value" "Thu, 4 Feb 2021 14:41:36 +0000 (UTC)"},
+                      {"name" "From","value" "Penpot <no-reply@penpot.app>"},
+                      {"name" "Reply-To","value" "Penpot <no-reply@penpot.app>"},
+                      {"name" "To","value" email},
+                      {"name" "Message-ID","value" "<2054501.5.1612449696846@penpot.app>"},
+                      {"name" "Subject","value" "test"},
+                      {"name" "MIME-Version","value" "1.0"},
+                      {"name" "Content-Type","value" "multipart/mixed;  boundary=\"----=_Part_3_1150363050.1612449696845\""},
+                      {"name" "X-Penpot-Data","value" token}],
+           "commonHeaders" {"from" ["Penpot <no-reply@penpot.app>"],
+                            "replyTo" ["Penpot <no-reply@penpot.app>"],
+                            "date" "Thu, 4 Feb 2021 14:41:36 +0000 (UTC)",
+                            "to" [email],
+                            "messageId" "<2054501.5.1612449696846@penpot.app>",
+                            "subject" "test"}}})
+
+
+(defn complaint-report
+  [{:keys [token email] :or {email "user@example.com"}}]
+  {"notificationType" "Complaint",
+   "complaint" {"feedbackId" "0107017771528618-dcf4d61f-c889-4c8b-a6ff-6f0b6553b837-000000",
+                "complaintSubType" nil,
+                "complainedRecipients" [{"emailAddress" email}],
+                "timestamp" "2021-02-05T08:32:49.000Z",
+                "userAgent" "Yahoo!-Mail-Feedback/2.0",
+                "complaintFeedbackType" "abuse",
+                "arrivalDate" "2021-02-05T08:31:15.000Z"},
+   "mail" {"timestamp" "2021-02-05T08:31:13.715Z",
+           "source" "no-reply@penpot.app",
+           "sourceArn" "arn:aws:ses:eu-central-1:111111111:identity/penpot.app",
+           "sourceIp" "22.22.22.22",
+           "sendingAccountId" "11111111111",
+           "messageId" "0107017771510f33-a0696d28-859c-4f08-9211-8392d1b5c226-000000",
+           "destination" ["user@yahoo.com"],
+           "headersTruncated" false,
+           "headers" [{"name" "Received","value" "from smtp"},
+                      {"name" "Date","value" "Fri, 5 Feb 2021 08:31:13 +0000 (UTC)"},
+                      {"name" "From","value" "Penpot <no-reply@penpot.app>"},
+                      {"name" "Reply-To","value" "Penpot <no-reply@penpot.app>"},
+                      {"name" "To","value" email},
+                      {"name" "Message-ID","value" "<1833063698.279.1612513873536@penpot.app>"},
+                      {"name" "Subject","value" "Verify email."},
+                      {"name" "MIME-Version","value" "1.0"},
+                      {"name" "Content-Type","value" "multipart/mixed;  boundary=\"----=_Part_276_1174403980.1612513873535\""},
+                      {"name" "X-Penpot-Data","value" token}],
+           "commonHeaders" {"from" ["Penpot <no-reply@penpot.app>"],
+                            "replyTo" ["Penpot <no-reply@penpot.app>"],
+                            "date" "Fri, 5 Feb 2021 08:31:13 +0000 (UTC)",
+                            "to" [email],
+                            "messageId" "<1833063698.279.1612513873536@penpot.app>",
+                            "subject" "Verify email."}}})
+
+(t/deftest test-parse-bounce-report
+  (let [profile (th/create-profile* 1)
+        tokens  (:app.tokens/tokens th/*system*)
+        cfg     {:tokens tokens}
+        report  (bounce-report {:token (tokens :generate-predefined
+                                               {:iss :profile-identity
+                                                :profile-id (:id profile)})})
+        result  (#'awsns/parse-notification cfg report)]
+    ;; (pprint result)
+
+    (t/is (= "bounce" (:type result)))
+    (t/is (= "permanent" (:kind result)))
+    (t/is (= "general" (:category result)))
+    (t/is (= ["user@example.com"] (mapv :email (:recipients result))))
+    (t/is (= (:id profile) (:profile-id result)))
+    ))
+
+(t/deftest test-parse-complaint-report
+  (let [profile (th/create-profile* 1)
+        tokens  (:app.tokens/tokens th/*system*)
+        cfg     {:tokens tokens}
+        report  (complaint-report {:token (tokens :generate-predefined
+                                                  {:iss :profile-identity
+                                                   :profile-id (:id profile)})})
+        result  (#'awsns/parse-notification cfg report)]
+    ;; (pprint result)
+    (t/is (= "complaint" (:type result)))
+    (t/is (= "abuse" (:kind result)))
+    (t/is (= nil (:category result)))
+    (t/is (= ["user@example.com"] (into [] (:recipients result))))
+    (t/is (= (:id profile) (:profile-id result)))
+    ))
+
+(t/deftest test-parse-complaint-report-without-token
+  (let [tokens  (:app.tokens/tokens th/*system*)
+        cfg     {:tokens tokens}
+        report  (complaint-report {:token ""})
+        result  (#'awsns/parse-notification cfg report)]
+    (t/is (= "complaint" (:type result)))
+    (t/is (= "abuse" (:kind result)))
+    (t/is (= nil (:category result)))
+    (t/is (= ["user@example.com"] (into [] (:recipients result))))
+    (t/is (= nil (:profile-id result)))
+    ))
+
+(t/deftest test-process-bounce-report
+  (let [profile (th/create-profile* 1)
+        tokens  (:app.tokens/tokens th/*system*)
+        pool    (:app.db/pool th/*system*)
+        cfg     {:tokens tokens :pool pool}
+        report  (bounce-report {:token (tokens :generate-predefined
+                                               {:iss :profile-identity
+                                                :profile-id (:id profile)})})
+        report  (#'awsns/parse-notification cfg report)]
+
+    (#'awsns/process-report cfg report)
+
+    (let [rows (->> (db/query pool :profile-complaint-report {:profile-id (:id profile)})
+                    (mapv decode-row))]
+      (t/is (= 1 (count rows)))
+      (t/is (= "bounce" (get-in rows [0 :type])))
+      (t/is (= "2021-02-04T14:41:38.000Z" (get-in rows [0 :content :timestamp]))))
+
+    (let [rows (->> (db/query pool :global-complaint-report :all)
+                    (mapv decode-row))]
+      (t/is (= 1 (count rows)))
+      (t/is (= "bounce" (get-in rows [0 :type])))
+      (t/is (= "user@example.com" (get-in rows [0 :email]))))
+
+    (let [prof (db/get-by-id pool :profile (:id profile))]
+      (t/is (false? (:is-muted prof))))
+
+    ))
+
+(t/deftest test-process-complaint-report
+  (let [profile (th/create-profile* 1)
+        tokens  (:app.tokens/tokens th/*system*)
+        pool    (:app.db/pool th/*system*)
+        cfg     {:tokens tokens :pool pool}
+        report  (complaint-report {:token (tokens :generate-predefined
+                                                  {:iss :profile-identity
+                                                   :profile-id (:id profile)})})
+        report  (#'awsns/parse-notification cfg report)]
+
+    (#'awsns/process-report cfg report)
+
+    (let [rows (->> (db/query pool :profile-complaint-report {:profile-id (:id profile)})
+                    (mapv decode-row))]
+      (t/is (= 1 (count rows)))
+      (t/is (= "complaint" (get-in rows [0 :type])))
+      (t/is (= "2021-02-05T08:31:15.000Z" (get-in rows [0 :content :timestamp]))))
+
+
+    (let [rows (->> (db/query pool :global-complaint-report :all)
+                    (mapv decode-row))]
+      (t/is (= 1 (count rows)))
+      (t/is (= "complaint" (get-in rows [0 :type])))
+      (t/is (= "user@example.com" (get-in rows [0 :email]))))
+
+
+    (let [prof (db/get-by-id pool :profile (:id profile))]
+      (t/is (false? (:is-muted prof))))
+
+    ))
+
+(t/deftest test-process-bounce-report-to-self
+  (let [profile (th/create-profile* 1)
+        tokens  (:app.tokens/tokens th/*system*)
+        pool    (:app.db/pool th/*system*)
+        cfg     {:tokens tokens :pool pool}
+        report  (bounce-report {:email (:email profile)
+                                   :token (tokens :generate-predefined
+                                                  {:iss :profile-identity
+                                                   :profile-id (:id profile)})})
+        report  (#'awsns/parse-notification cfg report)]
+
+    (#'awsns/process-report cfg report)
+
+    (let [rows (db/query pool :profile-complaint-report {:profile-id (:id profile)})]
+      (t/is (= 1 (count rows))))
+
+    (let [rows (db/query pool :global-complaint-report :all)]
+      (t/is (= 1 (count rows))))
+
+    (let [prof (db/get-by-id pool :profile (:id profile))]
+      (t/is (true? (:is-muted prof))))))
+
+(t/deftest test-process-complaint-report-to-self
+  (let [profile (th/create-profile* 1)
+        tokens  (:app.tokens/tokens th/*system*)
+        pool    (:app.db/pool th/*system*)
+        cfg     {:tokens tokens :pool pool}
+        report  (complaint-report {:email (:email profile)
+                                   :token (tokens :generate-predefined
+                                                  {:iss :profile-identity
+                                                   :profile-id (:id profile)})})
+        report  (#'awsns/parse-notification cfg report)]
+
+    (#'awsns/process-report cfg report)
+
+    (let [rows (db/query pool :profile-complaint-report {:profile-id (:id profile)})]
+      (t/is (= 1 (count rows))))
+
+    (let [rows (db/query pool :global-complaint-report :all)]
+      (t/is (= 1 (count rows))))
+
+    (let [prof (db/get-by-id pool :profile (:id profile))]
+      (t/is (true? (:is-muted prof))))))
+
+(t/deftest test-allow-send-messages-predicate-with-bounces
+  (with-mocks [mock {:target 'app.config/get
+                     :return (th/mock-config-get-with
+                              {:profile-bounce-threshold 3
+                               :profile-complaint-threshold 2})}]
+    (let [profile (th/create-profile* 1)
+          pool    (:app.db/pool th/*system*)]
+      (th/create-complaint-for pool {:type :bounce :id (:id profile) :created-at (dt/in-past {:days 8})})
+      (th/create-complaint-for pool {:type :bounce :id (:id profile)})
+      (th/create-complaint-for pool {:type :bounce :id (:id profile)})
+
+      (t/is (true? (emails/allow-send-emails? pool profile)))
+      (t/is (= 4 (:call-count (deref mock))))
+
+      (th/create-complaint-for pool {:type :bounce :id (:id profile)})
+      (t/is (false? (emails/allow-send-emails? pool profile))))))
+
+
+(t/deftest test-allow-send-messages-predicate-with-complaints
+  (with-mocks [mock {:target 'app.config/get
+                     :return (th/mock-config-get-with
+                              {:profile-bounce-threshold 3
+                               :profile-complaint-threshold 2})}]
+    (let [profile (th/create-profile* 1)
+          pool    (:app.db/pool th/*system*)]
+      (th/create-complaint-for pool {:type :bounce :id (:id profile) :created-at (dt/in-past {:days 8})})
+      (th/create-complaint-for pool {:type :bounce :id (:id profile) :created-at (dt/in-past {:days 8})})
+      (th/create-complaint-for pool {:type :bounce :id (:id profile)})
+      (th/create-complaint-for pool {:type :bounce :id (:id profile)})
+      (th/create-complaint-for pool {:type :complaint :id (:id profile)})
+
+      (t/is (true? (emails/allow-send-emails? pool profile)))
+      (t/is (= 4 (:call-count (deref mock))))
+
+      (th/create-complaint-for pool {:type :complaint :id (:id profile)})
+      (t/is (false? (emails/allow-send-emails? pool profile))))))
+
+(t/deftest test-has-complaint-reports-predicate
+  (let [profile (th/create-profile* 1)
+        pool    (:app.db/pool th/*system*)]
+
+    (t/is (false? (emails/has-complaint-reports? pool (:email profile))))
+
+    (th/create-global-complaint-for pool {:type :bounce :email (:email profile)})
+    (t/is (false? (emails/has-complaint-reports? pool (:email profile))))
+
+    (th/create-global-complaint-for pool {:type :complaint :email (:email profile)})
+    (t/is (true? (emails/has-complaint-reports? pool (:email profile))))))
+
+(t/deftest test-has-bounce-reports-predicate
+  (let [profile (th/create-profile* 1)
+        pool    (:app.db/pool th/*system*)]
+
+    (t/is (false? (emails/has-bounce-reports? pool (:email profile))))
+
+    (th/create-global-complaint-for pool {:type :complaint :email (:email profile)})
+    (t/is (false? (emails/has-bounce-reports? pool (:email profile))))
+
+    (th/create-global-complaint-for pool {:type :bounce :email (:email profile)})
+    (t/is (true? (emails/has-bounce-reports? pool (:email profile))))))

backend/tests/app/tests/test_common_geom_shapes.clj

@@ -12,6 +12,7 @@
    [app.common.geom.matrix :as gmt]
    [app.common.geom.point :as gpt]
    [app.common.geom.shapes :as gsh]
+   [app.common.math :refer [close?]]
    [app.common.pages :refer [make-minimal-shape]]
    [clojure.test :as t]))
 
@@ -32,7 +33,9 @@
            :points points)))
 
 (defn add-rect-data [shape]
-  (let [selrect (gsh/rect->selrect shape)
+  (let [shape (-> shape
+                  (assoc :width 20 :height 20))
+        selrect (gsh/rect->selrect shape)
         points (gsh/rect->points selrect)]
     (assoc shape
            :selrect selrect
@@ -64,17 +67,17 @@
                 shape-after  (gsh/transform-shape shape-before)]
             (t/is (not= shape-before shape-after))
 
-            (t/is (== (get-in shape-before [:selrect :x])
-                      (- 10 (get-in shape-after  [:selrect :x]))))
+            (t/is (close? (get-in shape-before [:selrect :x])
+                          (- 10 (get-in shape-after  [:selrect :x]))))
 
-            (t/is (== (get-in shape-before [:selrect :y])
-                      (+ 10 (get-in shape-after  [:selrect :y]))))
+            (t/is (close? (get-in shape-before [:selrect :y])
+                          (+ 10 (get-in shape-after  [:selrect :y]))))
 
-            (t/is (== (get-in shape-before [:selrect :width])
-                      (get-in shape-after  [:selrect :width])))
+            (t/is (close? (get-in shape-before [:selrect :width])
+                          (get-in shape-after  [:selrect :width])))
 
-            (t/is (== (get-in shape-before [:selrect :height])
-                      (get-in shape-after  [:selrect :height])))))
+            (t/is (close? (get-in shape-before [:selrect :height])
+                          (get-in shape-after  [:selrect :height])))))
 
       :rect :path))
 
@@ -84,8 +87,8 @@
               shape-before (create-test-shape type {:modifiers modifiers})
               shape-after  (gsh/transform-shape shape-before)]
           (t/are [prop]
-              (t/is (== (get-in shape-before [:selrect prop])
-                        (get-in shape-after [:selrect prop])))
+              (t/is (close? (get-in shape-before [:selrect prop])
+                            (get-in shape-after [:selrect prop])))
             :x :y :width :height :x1 :y1 :x2 :y2))
       :rect :path))
 
@@ -98,17 +101,17 @@
               shape-after  (gsh/transform-shape shape-before)]
           (t/is (not= shape-before shape-after))
 
-          (t/is (== (get-in shape-before [:selrect :x])
-                    (get-in shape-after  [:selrect :x])))
+          (t/is (close? (get-in shape-before [:selrect :x])
+                        (get-in shape-after  [:selrect :x])))
 
-          (t/is (== (get-in shape-before [:selrect :y])
-                    (get-in shape-after  [:selrect :y])))
+          (t/is (close? (get-in shape-before [:selrect :y])
+                        (get-in shape-after  [:selrect :y])))
 
-          (t/is (== (* 2 (get-in shape-before [:selrect :width]))
-                    (get-in shape-after  [:selrect :width])))
+          (t/is (close? (* 2 (get-in shape-before [:selrect :width]))
+                        (get-in shape-after  [:selrect :width])))
 
-          (t/is (== (* 2 (get-in shape-before [:selrect :height]))
-                    (get-in shape-after  [:selrect :height]))))
+          (t/is (close? (* 2 (get-in shape-before [:selrect :height]))
+                        (get-in shape-after  [:selrect :height]))))
       :rect :path))
 
   (t/testing "Transform with empty resize"
@@ -119,8 +122,8 @@
               shape-before (create-test-shape type {:modifiers modifiers})
               shape-after  (gsh/transform-shape shape-before)]
           (t/are [prop]
-              (t/is (== (get-in shape-before [:selrect prop])
-                        (get-in shape-after [:selrect prop])))
+              (t/is (close? (get-in shape-before [:selrect prop])
+                            (get-in shape-after [:selrect prop])))
             :x :y :width :height :x1 :y1 :x2 :y2))
       :rect :path))
 
@@ -145,13 +148,23 @@
         (let [modifiers {:rotation 30}
               shape-before (create-test-shape type {:modifiers modifiers})
               shape-after  (gsh/transform-shape shape-before)]
+
           (t/is (not= shape-before shape-after))
 
-          (t/is (not (== (get-in shape-before [:selrect :x])
-                         (get-in shape-after  [:selrect :x]))))
+          ;; Selrect won't change with a rotation, but points will
+          (t/is (close? (get-in shape-before [:selrect :x])
+                        (get-in shape-after  [:selrect :x])))
 
-          (t/is (not (== (get-in shape-before [:selrect :y])
-                         (get-in shape-after  [:selrect :y])))))
+          (t/is (close? (get-in shape-before [:selrect :y])
+                        (get-in shape-after  [:selrect :y])))
+
+          (t/is (= (count (:points shape-before)) (count (:points shape-after))))
+
+          (for [idx (range 0 (count (:point shape-before)))]
+            (do (t/is (not (close? (get-in shape-before [:points idx :x])
+                                   (get-in shape-after [:points idx :x]))))
+                (t/is (not (close? (get-in shape-before [:points idx :y])
+                                   (get-in shape-after [:points idx :y])))))))
       :rect :path))
 
   (t/testing "Transform shape with rotation = 0 should leave equal selrect"
@@ -160,8 +173,8 @@
               shape-before (create-test-shape type {:modifiers modifiers})
               shape-after  (gsh/transform-shape shape-before)]
           (t/are [prop]
-              (t/is (== (get-in shape-before [:selrect prop])
-                        (get-in shape-after [:selrect prop])))
+              (t/is (close? (get-in shape-before [:selrect prop])
+                            (get-in shape-after [:selrect prop])))
             :x :y :width :height :x1 :y1 :x2 :y2))
       :rect :path))