📎 Update CHANGES.md file

🐛 Fix draggin projects css

.circleci/config.yml

@@ -0,0 +1,106 @@
+version: 2
+jobs:
+  build:
+    docker:
+      - image: penpotapp/devenv:latest
+      - image: cimg/postgres:13.5
+        environment:
+          POSTGRES_USER: penpot_test
+          POSTGRES_PASSWORD: penpot_test
+          POSTGRES_DB: penpot_test
+      - image: cimg/redis:6.2.6
+
+    working_directory: ~/repo
+    resource_class: large
+
+    environment:
+      # Customize the JVM maximum heap limit
+      JVM_OPTS: -Xmx1g
+
+    steps:
+      - checkout
+
+      # Download and cache dependencies
+      - restore_cache:
+         keys:
+           - v1-dependencies-{{ checksum "backend/deps.edn" }}-{{ checksum "frontend/deps.edn"}}-{{ checksum "common/deps.edn"}}
+           # fallback to using the latest cache if no exact match is found
+           - v1-dependencies-
+
+      - run: cd .clj-kondo && cat config.edn
+
+      - run:
+          name: common lint
+          working_directory: "./common"
+          command: |
+            clj-kondo --version
+            clj-kondo --parallel --lint src/
+
+      - run:
+          name: frontend lint
+          working_directory: "./frontend"
+          command: |
+            clj-kondo --version
+            clj-kondo --parallel --lint src/
+
+      - run:
+          name: frontend styles prettier
+          working_directory: "./frontend"
+          command: |
+            yarn install
+            yarn run lint-scss
+
+      - run:
+          name: backend lint
+          working_directory: "./backend"
+          command: |
+            clj-kondo --version
+            clj-kondo --parallel --lint src/
+
+      # run backend test
+      - run:
+          name: backend test
+          working_directory: "./backend"
+          command: "clojure -X:dev:test"
+          environment:
+            PENPOT_TEST_DATABASE_URI: "postgresql://localhost/penpot_test"
+            PENPOT_TEST_DATABASE_USERNAME: penpot_test
+            PENPOT_TEST_DATABASE_PASSWORD: penpot_test
+            PENPOT_TEST_REDIS_URI: "redis://localhost/1"
+
+      - run:
+          name: frontend tests
+          working_directory: "./frontend"
+          command: |
+            yarn install
+            clojure -M:dev:shadow-cljs compile test
+            node target/tests.js
+
+          environment:
+            PATH: /usr/local/nodejs/bin/:/usr/local/bin:/bin:/usr/bin
+
+      - run:
+          working_directory: "./common"
+          name: common tests (cljs)
+          command: |
+            yarn install
+            yarn run compile-test
+            node target/test.js
+
+          environment:
+            PATH: /usr/local/nodejs/bin/:/usr/local/bin:/bin:/usr/bin
+
+      - run:
+          working_directory: "./common"
+          name: common tests (clj)
+          command: |
+            clojure -X:dev:test
+
+          environment:
+            PATH: /usr/local/nodejs/bin/:/usr/local/bin:/bin:/usr/bin
+
+      - save_cache:
+         paths:
+           - ~/.m2
+         key: v1-dependencies-{{ checksum "backend/deps.edn" }}-{{ checksum "frontend/deps.edn"}}-{{ checksum "common/deps.edn"}}
+

.clj-kondo/config.edn

@@ -1,13 +1,36 @@
-{:lint-as {potok.core/reify clojure.core/reify
-           promesa.core/let clojure.core/let
-           app.db/with-atomic clojure.core/with-open}
+{:lint-as
+ {promesa.core/let clojure.core/let
+  promesa.core/->> clojure.core/->>
+  promesa.core/-> clojure.core/->
+  rumext.v2/defc clojure.core/defn
+  rumext.v2/fnc clojure.core/fn
+  app.common.data/export clojure.core/def
+  app.db/with-atomic clojure.core/with-open
+  app.common.data.macros/get-in clojure.core/get-in
+  app.common.data.macros/select-keys clojure.core/select-keys
+  app.common.logging/with-context clojure.core/do}
+
+ :hooks
+ {:analyze-call
+  {app.common.data.macros/export hooks.export/export
+   potok.core/reify hooks.export/potok-reify
+   app.util.services/defmethod hooks.export/service-defmethod
+   }}
+
  :output
- {:exclude-files ["data_readers.clj"]}
+ {:exclude-files
+  ["data_readers.clj"
+   "app/util/perf.cljs"
+   "app/common/logging.cljc"
+   "app/common/exceptions.cljc"]}
 
  :linters
  {:unsorted-required-namespaces
   {:level :warning}
 
+  :potok/reify-type
+  {:level :error}
+
   :unresolved-namespace
   {:level :warning
    :exclude [data_readers]}
@@ -15,15 +38,15 @@
   :single-key-in
   {:level :warning}
 
+  :non-arg-vec-return-type-hint
+  {:level :off}
+
+  :redundant-do
+  {:level :off}
+
   :unused-binding
   {:exclude-destructured-as true
    :exclude-destructured-keys-in-fn-args false
    }
-
-  :unresolved-symbol
-  {:exclude ['(app.services.mutations/defmutation)
-             '(app.services.queries/defquery)
-             '(app.util.dispatcher/defservice)
-             '(mount.core/defstate)
-             ]}}}
+  }}
 

.clj-kondo/hooks/export.clj

@@ -0,0 +1,89 @@
+(ns hooks.export
+  (:require [clj-kondo.hooks-api :as api]))
+
+(defn export
+  [{:keys [:node]}]
+  (let [[_ sname] (:children node)
+        result  (api/list-node
+                 [(api/token-node (symbol "def"))
+                  (api/token-node (symbol (name (:value sname))))
+                  sname])]
+    {:node result}))
+
+(def registry (atom {}))
+
+(defn potok-reify
+  [{:keys [:node :filename] :as params}]
+  (let [[rnode rtype & other] (:children node)
+        rsym (symbol (str "event-type-" (name (:k rtype))))
+        reg  (get @registry filename #{})]
+    (when-not (:namespaced? rtype)
+      (let [{:keys [:row :col]} (meta rtype)]
+        (api/reg-finding! {:message "ptk/reify type should be namespaced"
+                           :type :potok/reify-type
+                           :row row
+                           :col col})))
+
+    (if (contains? reg rsym)
+      (let [{:keys [:row :col]} (meta rtype)]
+        (api/reg-finding! {:message (str "duplicate type: " (name (:k rtype)))
+                           :type :potok/reify-type
+                           :row row
+                           :col col}))
+      (swap! registry update filename (fnil conj #{}) rsym))
+
+    (let [result  (api/list-node
+                   (into [(api/token-node (symbol "deftype"))
+                          (api/token-node rsym)
+                          (api/vector-node [])]
+                         other))]
+      {:node result})))
+
+(defn clojure-specify
+  [{:keys [:node]}]
+  (let [[rnode rtype & other] (:children node)
+        result  (api/list-node
+                 (into [(api/token-node (symbol "extend-type"))
+                        (api/token-node (gensym (:string-value rtype)))]
+                       other))]
+    {:node result}))
+
+
+(defn service-defmethod
+  [{:keys [:node]}]
+  (let [[rnode rtype ?meta & other] (:children node)
+        rsym    (gensym (name (:k rtype)))
+
+        [?docs other] (if (api/string-node? ?meta)
+                        [?meta other]
+                        [nil (cons ?meta other)])
+
+        [?meta other] (let [?meta (first other)]
+                        (if (api/map-node? ?meta)
+                          [?meta (rest other)]
+                          [nil   other]))
+
+        nodes         [(api/token-node (symbol "do"))
+                       (api/list-node
+                        [(api/token-node (symbol "declare"))
+                         (api/token-node rsym)])
+
+                       (when ?docs
+                         (api/list-node
+                          [(api/token-node (symbol "comment")) ?docs]))
+
+                       (when ?meta
+                         (api/list-node
+                          [(api/token-node (symbol "reset-meta!"))
+                           (api/token-node rsym)
+                           ?meta]))
+                       (api/list-node
+                        (into [(api/token-node (symbol "defmethod"))
+                               (api/token-node rsym)
+                               rtype]
+                              other))]
+        result  (api/list-node (filterv some? nodes))]
+
+    ;; (prn "=====>" rtype)
+    ;; (prn (api/sexpr result))
+    {:node result}))

.github/ISSUE_TEMPLATE/bug_report.md

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

.gitignore

@@ -1,34 +1,55 @@
-figwheel_server.log
-*jar
 *-init.clj
+*.jar
+*.penpot
+*.orig
+.calva
+.clj-kondo
+.cpcache
 .lein-deps-sum
 .lein-failures
-.lein-repl-history
 .lein-plugins/
-.repl
+.lein-repl-history
+.lsp
 .nrepl-port
-.cpcache
+.nyc_output
 .rebel_readline_history
-/vendor/**/target
-/cd.md
-node_modules
-/backend/target/
-/backend/resources/public/media
+.repl
+/.clj-kondo/.cache
+/_dump
+/backend/-
+/backend/assets/
 /backend/dist/
 /backend/logs/
-/backend/-
-/frontend/npm-debug.log
-/frontend/target/
-/frontend/dist/
-/frontend/out/
-/frontend/.shadow-cljs
-/frontend/resources/public/*
-/exporter/target
-/exporter/.shadow-cljs
-/docker/images/bundle
-/.clj-kondo/.cache
+/backend/resources/public/assets
+/backend/resources/public/media
+/backend/target/
+/backend/builtin-templates
 /bundle*
-/media
+/cd.md
+/clj-profiler/
+/common/.shadow-cljs
+/common/coverage
+/common/target
 /deploy
+/docker/images/bundle*
+/exporter/.shadow-cljs
+/exporter/target
+/frontend/.shadow-cljs
+/frontend/package-lock.json
+/frontend/cypress/videos/*/
+/frontend/cypress/fixtures/validuser.json
+/frontend/dist/
+/frontend/npm-debug.log
+/frontend/out/
+/frontend/resources/fonts/experiments
+/frontend/resources/public/*
+/frontend/target/
+/frontend/cypress/videos/*/
+/media
+/telemetry/
+/vendor/**/target
+/vendor/svgclean/bundle*.js
 /web
-/_dump
+clj-profiler/
+figwheel_server.log
+node_modules

.gitpod.yml

@@ -0,0 +1,105 @@
+image:
+  file: docker/gitpod/Dockerfile
+
+ports:
+  # nginx
+  - port: 3449
+    onOpen: open-preview
+
+  # frontend nREPL
+  - port: 3447
+    onOpen: ignore
+    visibility: private
+
+  # frontend shadow server
+  - port: 3448
+    onOpen: ignore
+    visibility: private
+
+  # backend
+  - port: 6060
+    onOpen: ignore
+
+  # exporter shadow server
+  - port: 9630
+    onOpen: ignore
+    visibility: private
+
+  # exporter http server
+  - port: 6061
+    onOpen: ignore
+
+  # mailhog web interface
+  - port: 8025
+    onOpen: ignore
+
+  # mailhog postfix
+  - port: 1025
+    onOpen: ignore
+
+  # postgres
+  - port: 5432
+    onOpen: ignore
+
+  # redis
+  - port: 6379
+    onOpen: ignore
+
+  # openldap
+  - port: 389
+    onOpen: ignore
+
+tasks:
+  # https://github.com/gitpod-io/gitpod/issues/666#issuecomment-534347856
+  - name: gulp
+    command: >
+      cd $GITPOD_REPO_ROOT/frontend/;
+      yarn && gp sync-done 'frontend-yarn';
+      npx gulp --theme=${PENPOT_THEME} watch
+
+  - name: frontend shadow watch
+    command: >
+      cd $GITPOD_REPO_ROOT/frontend/;
+      gp sync-await 'frontend-yarn';
+      npx shadow-cljs watch main
+
+  - init: gp await-port 5432 && psql -f $GITPOD_REPO_ROOT/docker/gitpod/files/postgresql_init.sql
+    name: backend
+    command: >
+      cd $GITPOD_REPO_ROOT/backend/;
+      ./scripts/start-dev
+
+  - name: exporter shadow watch
+    command:
+      cd $GITPOD_REPO_ROOT/exporter/;
+      gp sync-await 'frontend-yarn';
+      yarn && npx shadow-cljs watch main
+
+  - name: exporter web server
+    command: >
+      cd $GITPOD_REPO_ROOT/exporter/;
+      ./scripts/wait-and-start.sh
+
+  - name: signed terminal
+    before: >
+      [[ ! -z ${GNUGPG}  ]] &&
+      cd ~ &&
+      rm -rf .gnupg &&
+      echo ${GNUGPG} | base64 -d | tar --no-same-owner -xzvf -
+    init: >
+      [[ ! -z ${GNUGPG_KEY}  ]] &&
+      git config --global commit.gpgsign true &&
+      git config --global user.signingkey ${GNUGPG_KEY}
+    command: cd $GITPOD_REPO_ROOT
+
+  - name: redis
+    command: redis-server
+
+  - before: go get github.com/mailhog/MailHog
+    name: mailhog
+    command: MailHog
+
+  - name: Nginx
+    command: >
+      nginx &&
+      multitail /var/log/nginx/access.log -I /var/log/nginx/error.log

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 discuss in private (for
+example: security bugs), consider first send an email to
+`support@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
@@ -46,7 +54,7 @@ We will use the `easy fix` mark for tag for indicate issues that are
 easy for beginners.
 
 
-## Commit Message Guidelines ##
+## Commit Guidelines ##
 
 We have very precise rules over how our git commit messages can be formatted.
 
@@ -70,7 +78,6 @@ Where type is:
 - :ambulance: `:ambulance:` a commit that fixes critical bug
 - :books: `:books:` a commit that improves or adds documentation
 - :construction: `:construction:`: a wip commit
-- :construction_worker: `:construction_worker:` a commit with CI related stuff
 - :boom: `:boom:` a commit with breaking changes
 - :wrench: `:wrench:` a commit for config updates
 - :zap: `:zap:` a commit with performance improvements
@@ -83,12 +90,25 @@ More info:
  - https://gist.github.com/parmentf/035de27d6ed1dce0b36a
  - https://gist.github.com/rxaviers/7360908
 
-The subject should be:
+Each commit should have:
 
-- Use the imperative mood.
-- Capitalize the first letter.
-- Don't put a period at the end of the subject line.
-- Put a blank line between the subject line and the body.
+- A concise subject using imperative mood.
+- The subject should have capitalized the first letter, without period
+  at the end and no larger than 65 characters.
+- A blank line between the subject line and the body.
+- An entry on the CHANGES.md file if applicable, referencing the
+  github or taiga issue/user-story using the these same rules.
+
+Examples of good commit messags:
+
+- :bug: Fix unexpected error on launching modal
+- :bug: Set proper error message on generic error
+- :sparkles: Enable new modal for profile
+- :zap: Improve performance of dashboard navigation
+- :wrench: Update default backend configuration
+- :books: Add more documentation for authentication process
+- :ambulance: Fix critical bug on user registration process
+- :tada: Add new approach for user registration
 
 
 ## Code of conduct ##
@@ -127,7 +147,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 +177,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

@@ -2,42 +2,131 @@
 [uri_license]: https://www.mozilla.org/en-US/MPL/2.0
 [uri_license_image]: https://img.shields.io/badge/MPL-2.0-blue.svg
 
-[![License: MPL-2.0][uri_license_image]][uri_license]
-[![Managed with Taiga.io](https://img.shields.io/badge/managed%20with-TAIGA.io-709f14.svg)](https://tree.taiga.io/project/uxbox/ "Managed with Taiga.io")
+<h1 align="center">
+  <br>
+  <img src="https://penpot.app/images/readme/readme-logo.jpg" alt="PENPOT">
+</h1>
+
+<p align="center"><a href="https://www.mozilla.org/en-US/MPL/2.0" rel="nofollow"><img src="https://camo.githubusercontent.com/3fcf3d6b678ea15fde3cf7d6af0e242160366282d62a7c182d83a50bfee3f45e/68747470733a2f2f696d672e736869656c64732e696f2f62616467652f4d504c2d322e302d626c75652e737667" alt="License: MPL-2.0" data-canonical-src="https://img.shields.io/badge/MPL-2.0-blue.svg" style="max-width:100%;"></a>
+<a href="https://gitter.im/penpot/community" rel="nofollow"><img src="https://camo.githubusercontent.com/5b0aecb33434f82a7b158eab7247544235ada0cf7eeb9ce8e52562dd67f614b7/68747470733a2f2f6261646765732e6769747465722e696d2f736572656e6f2d78797a2f636f6d6d756e6974792e737667" alt="Gitter" data-canonical-src="https://badges.gitter.im/sereno-xyz/community.svg" style="max-width:100%;"></a>
+<a href="https://tree.taiga.io/project/penpot/" title="Managed with Taiga.io" rel="nofollow"><img src="https://camo.githubusercontent.com/4a1d1112f0272e3393b1e8da312ff4435418e9e2eb4c0964881e3680f90a653c/68747470733a2f2f696d672e736869656c64732e696f2f62616467652f6d616e61676564253230776974682d54414947412e696f2d3730396631342e737667" alt="Managed with Taiga.io" data-canonical-src="https://img.shields.io/badge/managed%20with-TAIGA.io-709f14.svg" style="max-width:100%;"></a>
+<a href="https://gitpod.io/#https://github.com/penpot/penpot" rel="nofollow"><img src="https://camo.githubusercontent.com/daadb4894128d1e19b72d80236f5959f1f2b47f9fe081373f3246131f0189f6c/68747470733a2f2f696d672e736869656c64732e696f2f62616467652f476974706f642d72656164792d2d746f2d2d636f64652d626c75653f6c6f676f3d676974706f64" alt="Gitpod ready-to-code" data-canonical-src="https://img.shields.io/badge/Gitpod-ready--to--code-blue?logo=gitpod" style="max-width:100%;"></a></p>
+
+<p align="center">
+    <a href="https://penpot.app/"><b>Website</b></a> •
+    <a href="https://help.penpot.app/technical-guide/getting-started/"><b>Getting Started</b></a> •
+    <a href="https://help.penpot.app/user-guide/"><b>User Guide</b></a> •
+    <a href="https://help.penpot.app/user-guide/introduction/info/"><b>Tutorials & Info</b></a> •
+    <a href="https://community.penpot.app/"><b>Community</b></a> •
+    <a href="https://twitter.com/penpotapp"><b>Twitter</b></a> •
+    <a href="https://instagram.com/penpot.app"><b>Instagram</b></a> •
+    <a href="https://fosstodon.org/@penpot/"><b>Mastodon</b></a> •
+    <a href="https://www.youtube.com/channel/UCAqS8G72uv9P5HG1IfgnQ9g"><b>Youtube</b></a>
+</p>
+
+![feature-readme](https://user-images.githubusercontent.com/1045247/189871786-0b44f7cf-3a0a-4445-a87b-9919ec398bf7.gif)
+
+Penpot is the first **Open Source** design and prototyping platform meant for cross-domain teams. Non dependent on operating systems, Penpot is web based and works with open standards (SVG). Penpot invites designers all over the world to fall in love with open source while getting developers excited about the design process in return.
+
+## Table of contents ##
+
+- [Why Penpot](#why-penpot)
+- [Getting Started](#getting-started)
+- [Community](#community)
+- [Resources](#resources)
+- [License](#license)
+
+## Why Penpot ##
+
+Penpot makes design and prototyping accessible to every team in the world.
+
+### For cross-domain teams ###
+We have a clear focus on design and code teams and our capabilities reflect exactly that. The less hand-off mindset, the more fun for everyone.
+
+### Multiplatform ###
+Being web based, Penpot is not dependent on operating systems or local installations, you will only need to run a modern browser.
+
+### Open Standards ###
+Using SVG as no other design and prototyping tool does, Penpot files sport compatibility with most of the vectorial tools, are tech friendly and extremely easy to use on the web. We make sure you will always own your work.
+
+<p align="center">
+  <img src="https://penpot.app/images/open-source.png" alt="Open Source">
+</p>
 
 
-# PENPOT #
+## Getting started ##
 
-We’re excited to share that Uxbox is now Penpot! We’re changing the name, but keeping the same project essence. Stay in the loop for more news coming early 2021. Alpha release is close!
+### Install with Elestio ###
+[Elestio](https://elest.io/) offers a fully managed service for on-premise instances of a selection of open-source software! This means you can deploy a dedicated instance of Penpot in just 3 minutes with no technical knowledge needed.
 
-![PENPOT](https://raw.githubusercontent.com/penpot/penpot/develop/docs/screenshot.png)
+You don’t need to worry about DNS configuration, SMTP, backups, SSL certificates, OS & Penpot upgrades, and much more.
 
+[Get started with Elestio.](https://help.penpot.app/technical-guide/getting-started/#install-with-elestio)
 
-## Introduction ##
+### Install with Docker ###
 
-The open-source solution for design and prototyping. PENPOT is
-currently at an early development stage but we are working hard to
-bring you the beta version as soon as possible. Follow the project
-progress in Twitter or Github and stay tuned!
+You can also get started with Penpot locally or self-host it with **docker** and **docker-compose**.
 
+Here’s a step-by-step guide on [getting started with Docker.](https://help.penpot.app/technical-guide/getting-started/#install-with-docker)
 
-## SVG based ##
+### Penpot cloud app ###
 
-Penpot works with SVG, a standard format, for all your designs and
-prototypes . This means that all your stuff in Penpot is portable and
-editable in many other vector tools and easy to use on the web.
+If you prefer not to install Penpot in a local environment, [login or register on our Penpot cloud app](https://design.penpot.app). Create a team to work together on projects and share design assets or jump right away into Penpot and **start designing** on your own.
 
-[See SVG specification](https://www.w3.org/Graphics/SVG/)
+<p align="center">
+  <img src="https://help.penpot.app/img/home-techguide.png" alt="Getting started">
+</p>
+
+## Community ##
+
+We love the open source software community. Contributing is our passion and if it’s yours too, [participate](https://community.penpot.app/) and [improve](https://community.penpot.app/c/help-us-improve-penpot/7) Penpot. All your ideas and code are welcome!
+
+If you need help or have any questions; if you’d like to share your experience using Penpot or get inspired; if you’d rather meet our community of developers and designers, [join our Community](https://community.penpot.app/)!
+
+You will find the following categories:
+- [Ask the Community](https://community.penpot.app/c/ask-for-help-using-penpot/6)
+- [Troubleshooting](https://community.penpot.app/c/technical/8)
+- [Help us Improve Penpot](https://community.penpot.app/c/help-us-improve-penpot/7)
+- [#MadeWithPenpot](https://community.penpot.app/c/madewithpenpot/9)
+- [Events and Announcements](https://community.penpot.app/c/announcements/5)
+- [Inside Penpot](https://community.penpot.app/c/inside-penpot/21)
+- [Penpot in your language](https://community.penpot.app/c/penpot-in-your-language/12)
+
+<p align="center">
+  <img src="https://penpot.app/images/cross-teams.webp" alt="Community">
+</p>
 
 ## Contributing ##
 
-**Open to you!**
+Every sort of contribution will be very helpful to enhance Penpot. How you’ll participate? All your ideas, designs and code are welcome:
 
-We love the open source software community. Contributing is our
-passion and because of this, we'll be glad if you want to participate
-and improve Penpot. All your awesome ideas and code are welcome!
+- Invite your [team to join](https://design.penpot.app/#/auth/register)
+- Star this repo and follow us on Social Media:  [Twitter](https://twitter.com/penpotapp), [Instagram](https://instagram.com/penpot.app), [Youtube](https://www.youtube.com/c/Penpot) or [Mastodon](https://fosstodon.org/@penpot/).
+- Participate in the [Community](https://community.penpot.app/) asking and answering questions, reacting to others’ articles or opening your own conversations.
+- Report bugs with our easy [guide for bugs hunting](https://help.penpot.app/contributing-guide/reporting-bugs/) or [GitHub issues](https://github.com/penpot/penpot/issues)
+- Create and [share Libraries & templates](https://penpot.app/libraries-templates.html) that will be helpful for the community
+- Become a [translator](https://help.penpot.app/contributing-guide/translations)
+- Give feedback: [Mail us](mailto:support@penpot.app)
 
-Please refer to the [Contributing Guide](./CONTRIBUTING.md)
+To find (almost) everything you need to know on how to contribute to Penpot, refer to the [contributing-guide](https://help.penpot.app/contributing-guide/).
+
+<p align="center">
+  <img src="https://help.penpot.app/img/home-contributing.png" alt="Contributing">
+</p>
+
+## Resources ##
+
+You can ask and answer questions, have open-ended conversations, and follow along on decisions affecting the project.
+
+💾 [Documentation](https://help.penpot.app/technical-guide/)
+
+🚀 [Getting Started](https://help.penpot.app/technical-guide/getting-started/)
+
+✏️ [Tutorials](https://www.youtube.com/playlist?list=PLgcCPfOv5v54WpXhHmNO7T-YC7AE-SRsr)
+
+🏘️ [Architecture](https://help.penpot.app/technical-guide/architecture/)
+
+📚 [Dev Diaries](https://penpot.app/dev-diaries.html)
 
 
 ## License ##
@@ -46,4 +135,7 @@ Please refer to the [Contributing Guide](./CONTRIBUTING.md)
 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) KALEIDOS INC
 ```
+Penpot is a Kaleidos’ [open source project](https://kaleidos.net/products)

SECURITY.md

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

THANKYOU.md

@@ -0,0 +1,88 @@
+# THANK YOU
+
+We want to thank to the amazing people that help us! Thank you! You're the best!
+
+## Security
+* Husnain Iqbal (CEO OF ALPHA INFERNO PVT LTD)
+* [Shiraz Ali Khan](https://www.linkedin.com/in/shiraz-ali-khan-1ba508180/)
+
+## Internationalization
+* [00ff88](https://hosted.weblate.org/user/00ff88)
+* [AhmadHB](https://hosted.weblate.org/user/AhmadHB)
+* [Aimee](https://hosted.weblate.org/user/Aimee)
+* [alejandro.alonso](alejandro.https://hosted.weblate.org/user/alonso)
+* [alexpawlak](https://hosted.weblate.org/user/alexpawlak)
+* [allytiago](https://hosted.weblate.org/user/allytiago)
+* [alonso.torres](alonso.https://hosted.weblate.org/user/torres)
+* [andres.moya](andres.https://hosted.weblate.org/user/moya)
+* [antoniofsm](https://hosted.weblate.org/user/antoniofsm)
+* [ascarida](https://hosted.weblate.org/user/ascarida)
+* [Bechii](https://hosted.weblate.org/user/Bechii)
+* [Beeby](https://hosted.weblate.org/user/Beeby)
+* [bingling-sama](bingling-https://hosted.weblate.org/user/sama)
+* [devadarta](https://hosted.weblate.org/user/devadarta)
+* [diacritica](https://hosted.weblate.org/user/diacritica)
+* [dundzys.vincas](dundzys.https://hosted.weblate.org/user/vincas)
+* [Eranot](https://hosted.weblate.org/user/Eranot)
+* [erral](https://hosted.weblate.org/user/erral)
+* [ersen](https://hosted.weblate.org/user/ersen)
+* [filipepessanha](https://hosted.weblate.org/user/filipepessanha)
+* [fortx](https://hosted.weblate.org/user/fortx)
+* [foxbit](https://hosted.weblate.org/user/foxbit)
+* [georgelemon](https://hosted.weblate.org/user/georgelemon)
+* [girafic](https://hosted.weblate.org/user/girafic)
+* [gizemb](https://hosted.weblate.org/user/gizemb)
+* [greench](https://hosted.weblate.org/user/greench)
+* [guidimas](https://hosted.weblate.org/user/guidimas)
+* [hfigueira_1](https://hosted.weblate.org/user/hfigueira_1)
+* [hifiaz](https://hosted.weblate.org/user/hifiaz)
+* [httpsterio](https://hosted.weblate.org/user/httpsterio)
+* [humteus](https://hosted.weblate.org/user/humteus)
+* [iblueer](https://hosted.weblate.org/user/iblueer)
+* [insan](https://hosted.weblate.org/user/insan)
+* [Iphi](https://hosted.weblate.org/user/Iphi)
+* [iWangJiaxiang](https://hosted.weblate.org/user/iWangJiaxiang)
+* [jancborchardt](https://hosted.weblate.org/user/jancborchardt)
+* [jazz](https://hosted.weblate.org/user/jazz)
+* [johnterroa](https://hosted.weblate.org/user/johnterroa)
+* [jponsa](https://hosted.weblate.org/user/jponsa)
+* [kapler](https://hosted.weblate.org/user/kapler)
+* [kingu](https://hosted.weblate.org/user/kingu)
+* [KnahkAmath](https://hosted.weblate.org/user/KnahkAmath)
+* [laminne](https://hosted.weblate.org/user/laminne)
+* [lenildoleite](https://hosted.weblate.org/user/lenildoleite)
+* [liimee](https://hosted.weblate.org/user/liimee)
+* [lixeix](https://hosted.weblate.org/user/lixeix)
+* [locness3](https://hosted.weblate.org/user/locness3)
+* [maiwann](https://hosted.weblate.org/user/maiwann)
+* [MidooDj](https://hosted.weblate.org/user/MidooDj)
+* [Mohamed_amine_gdoura](https://hosted.weblate.org/user/Mohamed_amine_gdoura)
+* [myfunnyandy](https://hosted.weblate.org/user/myfunnyandy)
+* [NampoinaRal](https://hosted.weblate.org/user/NampoinaRal)
+* [nautilusx](https://hosted.weblate.org/user/nautilusx)
+* [niwinz](https://hosted.weblate.org/user/niwinz)
+* [pablo.alba](pablo.https://hosted.weblate.org/user/alba)
+* [PhilippeAccorsi](https://hosted.weblate.org/user/PhilippeAccorsi)
+* [rnarius](https://hosted.weblate.org/user/rnarius)
+* [rnd](https://hosted.weblate.org/user/rnd)
+* [RuanAragao](https://hosted.weblate.org/user/RuanAragao)
+* [ruben](https://hosted.weblate.org/user/ruben)
+* [semonxue](https://hosted.weblate.org/user/semonxue)
+* [shahab](https://hosted.weblate.org/user/shahab)
+* [shuaib85](https://hosted.weblate.org/user/shuaib85)
+* [SiderealArt](https://hosted.weblate.org/user/SiderealArt)
+* [swapnil.cx](swapnil.https://hosted.weblate.org/user/cx)
+* [syuza](https://hosted.weblate.org/user/syuza)
+* [th3ph4nt0m](https://hosted.weblate.org/user/th3ph4nt0m)
+* [tiwb](https://hosted.weblate.org/user/tiwb)
+* [tommi](https://hosted.weblate.org/user/tommi)
+* [val](https://hosted.weblate.org/user/val)
+* [vikt](https://hosted.weblate.org/user/vikt)
+* [VinLin](https://hosted.weblate.org/user/VinLin)
+* [vintprox](https://hosted.weblate.org/user/vintprox)
+* [Voxybuns](https://hosted.weblate.org/user/Voxybuns)
+* [winie](https://hosted.weblate.org/user/winie)
+* [Yaron](https://hosted.weblate.org/user/Yaron)
+* [yrd](https://hosted.weblate.org/user/yrd)
+* [YukiYuigishi](https://hosted.weblate.org/user/YukiYuigishi)
+* [zcraber](https://hosted.weblate.org/user/zcraber)

backend/build.clj

@@ -0,0 +1,36 @@
+(ns build
+  (:refer-clojure :exclude [compile])
+  (:require
+   [clojure.tools.build.api :as b]
+   [clojure.java.io]))
+
+(def class-dir "target/classes")
+(def basis (b/create-basis {:project "deps.edn"}))
+(def jar-file "target/penpot.jar")
+
+(defn clean [_]
+  (b/delete {:path "target"}))
+
+(defn jar [_]
+  (b/copy-dir
+   {:src-dirs ["src" "resources"]
+    :target-dir class-dir})
+
+  (b/compile-clj
+   {:basis basis
+    :src-dirs ["src"]
+    :class-dir class-dir})
+
+  (b/uber
+   {:class-dir class-dir
+    :uber-file jar-file
+    :main 'clojure.main
+    :exclude [#"goog.*" #"^javasist.*"]
+    :basis basis}))
+
+(defn compile [_]
+  (b/javac
+   {:src-dirs ["dev/java"]
+    :class-dir class-dir
+    :basis basis
+    :javac-opts ["-source" "17" "-target" "17"]}))

backend/deps.edn

@@ -1,104 +1,89 @@
-{:mvn/repos
- {"central" {:url "https://repo1.maven.org/maven2/"}
-  "clojars" {:url "https://clojars.org/repo"}
-  "jcenter" {:url "https://jcenter.bintray.com/"}}
- :deps
- {org.clojure/clojure {:mvn/version "1.10.1"}
-  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"}
+{:deps
+ {penpot/common {:local/root "../common"}
+  org.clojure/clojure {:mvn/version "1.11.1"}
+  org.clojure/core.async {:mvn/version "1.5.648"}
 
   ;; Logging
-  org.clojure/tools.logging {:mvn/version "1.1.0"}
-  org.apache.logging.log4j/log4j-api {:mvn/version "2.13.3"}
-  org.apache.logging.log4j/log4j-core {:mvn/version "2.13.3"}
-  org.apache.logging.log4j/log4j-web {:mvn/version "2.13.3"}
-  org.apache.logging.log4j/log4j-jul {:mvn/version "2.13.3"}
-  org.apache.logging.log4j/log4j-slf4j-impl {:mvn/version "2.13.3"}
-  org.slf4j/slf4j-api {:mvn/version "1.7.30"}
+  org.zeromq/jeromq {:mvn/version "0.5.2"}
 
-  io.prometheus/simpleclient {:mvn/version "0.9.0"}
-  io.prometheus/simpleclient_hotspot {:mvn/version "0.9.0"}
-  io.prometheus/simpleclient_httpserver {:mvn/version "0.9.0"}
+  com.github.luben/zstd-jni {:mvn/version "1.5.2-4"}
+  org.clojure/data.fressian {:mvn/version "1.0.0"}
 
-  selmer/selmer {:mvn/version "1.12.28"}
-  expound/expound {:mvn/version "0.8.5"}
-  com.cognitect/transit-clj {:mvn/version "1.0.324"}
+  io.prometheus/simpleclient {:mvn/version "0.16.0"}
+  io.prometheus/simpleclient_hotspot {:mvn/version "0.16.0"}
+  io.prometheus/simpleclient_jetty
+  {:mvn/version "0.16.0"
+   :exclusions [org.eclipse.jetty/jetty-server
+                org.eclipse.jetty/jetty-servlet]}
 
-  io.lettuce/lettuce-core {:mvn/version "5.2.2.RELEASE"}
-  java-http-clj/java-http-clj {:mvn/version "0.4.1"}
 
-  info.sunng/ring-jetty9-adapter {:mvn/version "0.14.0"}
-  seancorfield/next.jdbc {:mvn/version "1.1.588"}
-  metosin/reitit-ring {:mvn/version "0.5.5"}
-  org.postgresql/postgresql {:mvn/version "42.2.16"}
-  com.zaxxer/HikariCP {:mvn/version "3.4.5"}
+  io.prometheus/simpleclient_httpserver {:mvn/version "0.16.0"}
 
-  funcool/log4j2-clojure {:mvn/version "2020.11.23-1"}
-  funcool/datoteka {:mvn/version "1.2.0"}
-  funcool/promesa {:mvn/version "5.1.0"}
-  funcool/cuerdas {:mvn/version "2020.03.26-3"}
+  io.lettuce/lettuce-core {:mvn/version "6.2.0.RELEASE"}
+  java-http-clj/java-http-clj {:mvn/version "0.4.3"}
 
-  buddy/buddy-core {:mvn/version "1.9.0"}
-  buddy/buddy-hashers {:mvn/version "1.7.0"}
-  buddy/buddy-sign {:mvn/version "3.3.0"}
+  funcool/yetti
+  {:git/tag "v9.9"
+   :git/sha "f0a455d"
+   :git/url "https://github.com/funcool/yetti.git"
+   :exclusions [org.slf4j/slf4j-api]}
 
-  lambdaisland/uri {:mvn/version "1.4.54"
-                    :exclusions [org.clojure/data.json]}
+  com.github.seancorfield/next.jdbc {:mvn/version "1.3.828"}
+  metosin/reitit-core {:mvn/version "0.5.18"}
+  org.postgresql/postgresql {:mvn/version "42.5.0"}
+  com.zaxxer/HikariCP {:mvn/version "5.0.1"}
 
-  frankiesardo/linked {:mvn/version "1.3.0"}
-  danlentz/clj-uuid {:mvn/version "0.1.9"}
-  org.jsoup/jsoup {:mvn/version "1.13.1"}
-  org.im4java/im4java {:mvn/version "1.4.0"}
-  org.lz4/lz4-java {:mvn/version "1.7.1"}
-  com.github.spullara.mustache.java/compiler {:mvn/version "0.9.6"}
-  commons-io/commons-io {:mvn/version "2.8.0"}
-  com.draines/postal {:mvn/version "2.0.3"
-                      :exclusions [commons-codec/commons-codec]}
+  io.whitfin/siphash {:mvn/version "2.0.0"}
 
-  puppetlabs/clj-ldap {:mvn/version"0.3.0"}
+  buddy/buddy-hashers {:mvn/version "1.8.158"}
+  buddy/buddy-sign {:mvn/version "3.4.333"}
 
-  ;; exception printing
-  io.aviso/pretty {:mvn/version "0.1.37"}
+  org.jsoup/jsoup {:mvn/version "1.15.1"}
+  org.im4java/im4java
+  {:git/tag "1.4.0-penpot-2"
+   :git/sha "e2b3e16"
+   :git/url "https://github.com/penpot/im4java"}
 
-  mount/mount {:mvn/version "0.1.16"}
-  environ/environ {:mvn/version "1.2.0"}}
- :paths ["src" "resources" "../common" "common"]
+  org.lz4/lz4-java {:mvn/version "1.8.0"}
+
+  org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
+  integrant/integrant {:mvn/version "0.8.0"}
+
+  dawran6/emoji {:mvn/version "0.1.5"}
+  markdown-clj/markdown-clj {:mvn/version "1.11.3"}
+
+  ;; Pretty Print specs
+  pretty-spec/pretty-spec {:mvn/version "0.1.4"}
+  software.amazon.awssdk/s3 {:mvn/version "2.17.278"}}
+
+ :paths ["src" "resources" "target/classes"]
  :aliases
  {:dev
   {:extra-deps
-   {com.bhauman/rebel-readline {:mvn/version "0.1.4"}
-    org.clojure/tools.namespace {:mvn/version "1.0.0"}
-    org.clojure/test.check {:mvn/version "1.0.0"}
-    clj-kondo/clj-kondo {:mvn/version "RELEASE"}
+   {com.bhauman/rebel-readline {:mvn/version "RELEASE"}
+    org.clojure/tools.namespace {:mvn/version "RELEASE"}
+    org.clojure/test.check {:mvn/version "RELEASE"}
+    clojure-humanize/clojure-humanize {:mvn/version "0.2.2"}
+    org.clojure/data.csv {:mvn/version "RELEASE"}
+    com.clojure-goes-fast/clj-async-profiler {:mvn/version "RELEASE"}
+    mockery/mockery {:mvn/version "RELEASE"}}
+   :extra-paths ["test" "dev"]}
 
-    fipp/fipp {:mvn/version "0.6.21"}
-    criterium/criterium {:mvn/version "0.4.5"}
-    mockery/mockery {:mvn/version "0.1.4"}}
-   :extra-paths ["tests"]}
+  :build
+  {:extra-deps {io.github.clojure/tools.build {:git/tag "v0.8.3" :git/sha "0d20256"}}
+   :ns-default build}
 
-  ;; :fn-media-loader
-  ;; {:exec-fn app.cli.media-loader/run
-  ;;  :args {}}
-
-  :fn-fixtures
-  {:exec-fn app.cli.fixtures/run
-   :args {}}
-
-  :lint
-  {:main-opts ["-m" "clj-kondo.main"]}
-
-  :tests
-  {:extra-deps {lambdaisland/kaocha {:mvn/version "0.0-581"}}
-   :main-opts ["-m" "kaocha.runner"]}
+  :test
+  {:extra-paths ["test"]
+   :extra-deps
+   {io.github.cognitect-labs/test-runner
+    {:git/tag "v0.5.1" :git/sha "dfb30dd"}}
+   :main-opts ["-m" "cognitect.test-runner"]
+   :exec-fn cognitect.test-runner.api/test}
 
   :outdated
-  {:extra-deps {olical/depot {:mvn/version "1.8.4"}}
-   :main-opts ["-m" "depot.outdated.main"]}
-
-  :jar
-  {:extra-deps {seancorfield/depstar {:mvn/version "RELEASE"}}
-   :main-opts ["-m" "hf.depstar.jar" "-S" "target/app.jar"]}
+  {:extra-deps {com.github.liquidz/antq {:mvn/version "RELEASE"}}
+   :main-opts ["-m" "antq.core"]}
 
   :jmx-remote
   {:jvm-opts ["-Dcom.sun.management.jmxremote"

backend/dev/script-fix-sobjects.clj

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

backend/dev/user.clj

@@ -0,0 +1,115 @@
+;; 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) KALEIDOS INC
+
+(ns user
+  (:require
+   [app.common.data :as d]
+   [app.common.exceptions :as ex]
+   [app.common.geom.matrix :as gmt]
+   [app.common.logging :as l]
+   [app.common.perf :as perf]
+   [app.common.pprint :as pp]
+   [app.common.transit :as t]
+   [app.config :as cfg]
+   [app.main :as main]
+   [app.srepl.main :as srepl]
+   [app.util.blob :as blob]
+   [app.util.fressian :as fres]
+   [app.util.json :as json]
+   [app.util.time :as dt]
+   [clj-async-profiler.core :as prof]
+   [clojure.contrib.humanize :as hum]
+   [clojure.java.io :as io]
+   [clojure.pprint :refer [pprint print-table]]
+   [clojure.repl :refer :all]
+   [clojure.spec.alpha :as s]
+   [clojure.spec.gen.alpha :as sgen]
+   [clojure.test :as test]
+   [clojure.tools.namespace.repl :as repl]
+   [clojure.walk :refer [macroexpand-all]]
+   [datoteka.core]
+   [integrant.core :as ig]))
+
+(repl/disable-reload! (find-ns 'integrant.core))
+(set! *warn-on-reflection* true)
+
+(defonce system nil)
+
+;; --- Benchmarking Tools
+
+(defmacro run-quick-bench
+  [& exprs]
+  `(with-progress-reporting (quick-bench (do ~@exprs) :verbose)))
+
+(defmacro run-quick-bench'
+  [& exprs]
+  `(quick-bench (do ~@exprs)))
+
+(defmacro run-bench
+  [& exprs]
+  `(with-progress-reporting (bench (do ~@exprs) :verbose)))
+
+(defmacro run-bench'
+  [& exprs]
+  `(bench (do ~@exprs)))
+
+;; --- Development Stuff
+
+(defn- run-tests
+  ([] (run-tests #"^app.*-test$"))
+  ([o]
+   (repl/refresh)
+   (cond
+     (instance? java.util.regex.Pattern o)
+     (test/run-all-tests o)
+
+     (symbol? o)
+     (if-let [sns (namespace o)]
+       (do (require (symbol sns))
+           (test/test-vars [(resolve o)]))
+       (test/test-ns o)))))
+
+(defn- start
+  []
+  (alter-var-root #'system (fn [sys]
+                             (when sys (ig/halt! sys))
+                             (-> (merge main/system-config main/worker-config)
+                                 (ig/prep)
+                                 (ig/init))))
+  :started)
+
+(defn- stop
+  []
+  (alter-var-root #'system (fn [sys]
+                             (when sys (ig/halt! sys))
+                             nil))
+  :stoped)
+
+(defn restart
+  []
+  (stop)
+  (repl/refresh :after 'user/start))
+
+(defn restart-all
+  []
+  (stop)
+  (repl/refresh-all :after 'user/start))
+
+(defn compression-bench
+  [data]
+  (let [humanize (fn [v] (hum/filesize v :binary true :format " %.4f "))]
+    (print-table
+     [{:v1 (humanize (alength (blob/encode data {:version 1})))
+       :v2 (humanize (alength (blob/encode data {:version 2})))
+       :v3 (humanize (alength (blob/encode data {:version 3})))
+       :v4 (humanize (alength (blob/encode data {:version 4})))
+       }])))
+
+(defonce debug-tap
+  (do
+    (add-tap #(locking debug-tap
+                (prn "tap debug:" %)))
+    1))

backend/resources/app/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 design and prototyping platform meant for cross-domain 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/app/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 design and prototyping platform meant for cross-domain 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/app/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 design and prototyping platform meant for cross-domain 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/app/emails-mjml/register/en.mjml

@@ -21,22 +21,22 @@
       <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
-          email using the link below adn get started building mockups and
+          Thanks for signing up for your Penpot account! Please verify your
+          email using the link below and get started building mockups and
           prototypes today!
         </mj-text>
         <mj-button href="{{ public-uri }}/#/auth/verify-token?token={{token}}">
           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 design and prototyping platform meant for cross-domain 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/app/emails/change-email/en.html

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

backend/resources/app/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/app/emails/feedback/en.html

@@ -0,0 +1,45 @@
+<!doctype html>
+<html xmlns="http://www.w3.org/1999/xhtml">
+  <head>
+    <title></title>
+    <meta http-equiv="X-UA-Compatible" content="IE=edge">
+    <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
+  </head>
+  <body>
+    <p>
+      <strong>Feedback from:</strong><br />
+      {% if profile %}
+        <span>
+          <span>Name: </span>
+          <span><code>{{profile.fullname}}</code></span>
+        </span>
+        <br />
+
+        <span>
+          <span>Email: </span>
+          <span>{{profile.email}}</span>
+        </span>
+        <br />
+
+        <span>
+          <span>ID: </span>
+          <span><code>{{profile.id}}</code></span>
+        </span>
+      {% else %}
+        <span>
+          <span>Email: </span>
+          <span>{{profile.email}}</span>
+        </span>
+      {% endif %}
+    </p>
+    <p>
+      <strong>Subject:</strong><br />
+      <span>{{subject}}</span>
+    </p>
+
+    <p>
+      <strong>Message:</strong><br />
+      {{content|linebreaks-br|safe}}
+    </p>
+  </body>
+</html>

backend/resources/app/emails/feedback/en.subj

@@ -0,0 +1 @@
+[PENPOT FEEDBACK]: {{subject}}

backend/resources/app/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/app/emails/invite-to-team/en.html

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

backend/resources/app/emails/invite-to-team/en.subj

@@ -0,0 +1 @@
+Invitation to join {{team}}

backend/resources/app/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/app/emails/password-recovery/en.html

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

backend/resources/app/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/app/emails/register/en.html

@@ -173,7 +173,7 @@
                   </tr>
                   <tr>
                     <td align="left" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:16px;line-height:150%;text-align:left;color:#000000;">Thanks for signing up for your Penpot account! Please verify your email using the link below adn get started building mockups and prototypes today!</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:16px;line-height:150%;text-align:left;color:#000000;">Thanks for signing up for your Penpot account! Please verify your email using the link below and get started building mockups and prototypes today!</div>
                     </td>
                   </tr>
                   <tr>
@@ -240,7 +240,7 @@
                 <table border="0" cellpadding="0" cellspacing="0" role="presentation" style="vertical-align:top;" width="100%">
                   <tr>
                     <td align="center" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot is the first Open Source prototyping platform that will be embraced by multidisciplinary teams.</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot is the first Open Source design and prototyping platform meant for cross-domain teams.</div>
                     </td>
                   </tr>
                 </table>
@@ -440,7 +440,7 @@
                 <table border="0" cellpadding="0" cellspacing="0" role="presentation" style="vertical-align:top;" width="100%">
                   <tr>
                     <td align="center" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot © 2020 | Made with &lt;3 and Open Source</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:14px;line-height:150%;text-align:center;color:#64666A;">Penpot | Made with &lt;3 and Open Source</div>
                     </td>
                   </tr>
                 </table>
@@ -465,4 +465,4 @@
   </div>
 </body>
 
-</html>
+</html>

backend/resources/app/emails/register/en.txt

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

backend/resources/app/onboarding.edn

@@ -0,0 +1,32 @@
+[{:id "tutorial-for-beginners"
+  :name "Tutorial for beginners"
+  :thumbnail-uri "https://penpot.app/images/libraries/tutorial-for-beginners.jpg"
+  :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/tutorial-for-beginners.penpot"}
+ {:id "penpot-design-system"
+  :name "Penpot Design System"
+  :thumbnail-uri "https://penpot.app/images/libraries/cover-ds-penpot.jpg"
+  :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/Penpot-Design-system.penpot"}
+ {:id "wireframing-kit"
+  :name "Wireframing Kit"
+  :thumbnail-uri "https://penpot.app/images/libraries/cover-wireframes.jpg"
+  :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/wireframing-kit.penpot"}
+ {:id "ant-design"
+  :name "Ant Design UI Kit (lite)"
+  :thumbnail-uri "https://penpot.app/images/libraries/cover-ant-design.jpg"
+  :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/Ant-Design-UI-Kit-Lite.penpot"}
+ {:id "cocomaterial"
+  :name "Cocomaterial"
+  :thumbnail-uri "https://penpot.app/images/libraries/cover-cocomaterial.jpg"
+  :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/Cocomaterial.penpot"}
+ {:id "circum-icons"
+  :name "Circum Icons pack"
+  :thumbnail-uri "https://penpot.app/images/libraries/cover-circum.jpg"
+  :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/CircumIcons.penpot"}
+ {:id "whiteboarding-kit"
+  :name "Whiteboarding Kit"
+  :thumbnail-uri "https://penpot.app/images/libraries/cover-whiteboards.jpg"
+  :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/Whiteboarding-mapping-kit.penpot"}
+ {:id "material-design-baseline"
+  :name "Material Design (baseline)"
+  :thumbnail-uri "https://penpot.app/images/libraries/cover-material.jpg"
+  :file-uri "https://github.com/penpot/penpot-files/raw/binary-files/Material-Design-Kit.penpot"}]

backend/resources/app/templates/api-doc-entry.tmpl

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

backend/resources/app/templates/api-doc.css

@@ -0,0 +1,145 @@
+* {
+  font-family: "JetBrains Mono", monospace;
+  font-size: 12px;
+}
+
+pre {
+  margin: 0px;
+}
+
+body {
+  margin: 0px;
+  padding: 0px;
+  padding-top: 20px;
+  padding-bottom: 20px;
+  display: flex;
+  justify-content: center;
+}
+
+main {
+  display: flex;
+  flex-direction: column;
+  align-items: center;
+  min-width: 900px;
+  width: 900px;
+}
+
+header {
+  border-bottom: 1px solid #c0c0c0;
+  display: flex;
+  justify-content: center;
+  width: 100%;
+}
+
+.rpc-doc-content {
+  margin-top: 20px;
+  width: 100%;
+  display: flex;
+  flex-direction: column;
+  /* border: 1px solid red; */
+  padding: 5px;
+}
+
+.rpc-doc-content > h2:not(:first-child) {
+  margin-top: 30px;
+}
+
+
+.rpc-items {
+  list-style: none;
+  padding: 0px;
+  margin: 0px;
+}
+
+.rpc-item {
+  /* border: 1px solid red; */
+  /* cursor: pointer; */
+  display: flex;
+  flex-direction: column;
+}
+
+.rpc-item:not(:last-child) {
+  margin-bottom: 3px;
+}
+
+.rpc-row-info {
+  cursor: pointer;
+  display: flex;
+  background-color: #eeeeee;
+  padding: 5px 10px;
+}
+
+.rpc-row-info > *:not(:last-child) {
+  margin-right: 10px;
+}
+
+.rpc-row-info > * {
+  /* border: 1px solid green; */
+}
+
+.rpc-row-info > .type {
+  font-weight: bold;
+  width: 70px;
+}
+
+.rpc-row-info > .name {
+  width: 280px;
+  /* font-weight: bold; */
+  border-right: 1px dotted #777;
+  padding-right: 10px;
+}
+
+.rpc-row-info > .module {
+  width: 120px;
+  font-weight: bold;
+  border-right: 1px dotted #777;
+  text-align: right;
+  padding-right: 10px;
+}
+
+.rpc-row-info > .tags > .tag > span:first-child {
+  font-weight: bold;
+}
+
+.hidden {
+  display: none;
+}
+
+.rpc-row-detail {
+  padding: 5px 10px;
+  padding-bottom: 20px;
+}
+
+.rpc-row-detail p {
+  font-weight: 200;
+}
+
+.rpc-row-detail p.small {
+  margin-top: 2px;
+  margin-bottom: 2px;
+  font-size: 10px;
+}
+
+.rpc-row-detail p.small {
+  margin-top: 2px;
+  margin-bottom: 2px;
+  font-size: 10px;
+}
+
+.rpc-row-detail strong {
+  font-weight: 500;
+}
+
+.rpc-row-detail .changes {
+  font-weight: 200;
+  list-style: none;
+  padding: 0px;
+}
+
+.rpc-row-detail .padded-section {
+  padding: 0px 10px;
+}
+
+p.small strong {
+  font-size: 10px;
+}

backend/resources/app/templates/api-doc.js

@@ -0,0 +1,27 @@
+(function() {
+  document.addEventListener("DOMContentLoaded", function(event) {
+    const rows = document.querySelectorAll(".rpc-row-info");
+
+    const onRowClick = (event) => {
+      const target = event.currentTarget;
+      for (let node of rows) {
+        if (node !== target) {
+          node.nextElementSibling.classList.add("hidden");
+        } else {
+          const sibling = target.nextElementSibling;
+
+          if (sibling.classList.contains("hidden")) {
+            sibling.classList.remove("hidden");
+          } else {
+            sibling.classList.add("hidden");
+          }
+        }
+      }
+    };
+
+    for (let node of rows) {
+      node.addEventListener("click", onRowClick);
+    }
+
+  });
+})();

backend/resources/app/templates/api-doc.tmpl

@@ -0,0 +1,50 @@
+<!DOCTYPE html>
+<html>
+  <head>
+    <meta charset="utf-8" />
+    <meta name="robots" content="noindex,nofollow">
+    <meta http-equiv="x-ua-compatible" content="ie=edge" />
+    <title>Builtin API Documentation - Penpot</title>
+
+    <link rel="preconnect" href="https://fonts.googleapis.com">
+    <link rel="preconnect" href="https://fonts.gstatic.com" crossorigin>
+    <link href="https://fonts.googleapis.com/css2?family=JetBrains+Mono:wght@200;300;400;500;700&display=swap" rel="stylesheet">
+    <style>
+      {% include "app/templates/api-doc.css" %}
+    </style>
+    <script>
+      {% include "app/templates/api-doc.js" %}
+    </script>
+  </head>
+  <body>
+    <main>
+      <header>
+        <h1>Penpot API Documentation (v{{version}})</h1>
+      </header>
+      <section class="rpc-doc-content">
+
+        <h2>RPC COMMAND METHODS:</h2>
+        <ul class="rpc-items">
+          {% for item in command-methods %}
+            {% include "app/templates/api-doc-entry.tmpl" with item=item %}
+          {% endfor %}
+        </ul>
+
+        <h2>RPC QUERY METHODS:</h2>
+        <ul class="rpc-items">
+          {% for item in query-methods %}
+            {% include "app/templates/api-doc-entry.tmpl" with item=item %}
+          {% endfor %}
+        </ul>
+
+        <h2>RPC MUTATION METHODS:</h2>
+        <ul class="rpc-items">
+          {% for item in mutation-methods %}
+            {% include "app/templates/api-doc-entry.tmpl" with item=item %}
+          {% endfor %}
+        </ul>
+      </section>
+    </main>
+  </body>
+</html>
+

backend/resources/app/templates/base.tmpl

@@ -0,0 +1,18 @@
+<!DOCTYPE html>
+<html>
+  <head>
+    <meta charset="utf-8" />
+    <meta name="robots" content="noindex,nofollow">
+    <meta http-equiv="x-ua-compatible" content="ie=edge" />
+    <title>{% block title %}{% endblock %}</title>
+    <link rel="stylesheet" href="https://fonts.googleapis.com/css2?family=JetBrains+Mono">
+    <style>
+      {% include "app/templates/styles.css"  %}
+    </style>
+  </head>
+  <body>
+    {% block content %}
+    {% endblock %}
+  </body>
+</html>
+

backend/resources/app/templates/debug.tmpl

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

backend/resources/app/templates/error-list.tmpl

@@ -0,0 +1,18 @@
+{% extends "app/templates/base.tmpl" %}
+
+{% block title %}
+penpot - error list
+{% endblock %}
+
+{% block content %}
+<nav>
+  <h1>Latest error reports:</h1>
+</nav>
+<main class="horizontal-list">
+  <ul>
+    {% for item in items %}
+    <li><a href="/dbg/error/{{item.id}}">{{item.created-at}}</a></li>
+    {% endfor %}
+  </ul>
+</main>
+{% endblock %}

backend/resources/app/templates/error-report.tmpl

@@ -0,0 +1,98 @@
+{% extends "app/templates/base.tmpl" %}
+
+{% block title %}
+penpot - error report {{id}}
+{% endblock %}
+
+{% block content %}
+<nav>
+  <div>[<a href="/dbg/error">⮜</a>]</div>
+  <div>[<a href="#context">context</a>]</div>
+  <div>[<a href="#params">request params</a>]</div>
+  {% if data %}
+  <div>[<a href="#edata">error data</a>]</div>
+  {% endif %}
+  {% if spec-explain %}
+  <div>[<a href="#spec-explain">spec explain</a>]</div>
+  {% endif %}
+  {% if spec-problems %}
+  <div>[<a href="#spec-problems">spec problems</a>]</div>
+  {% endif %}
+  {% if spec-value %}
+  <div>[<a href="#spec-value">spec value</a>]</div>
+  {% endif %}
+
+  {% if trace %}
+  <div>[<a href="#trace">error trace</a>]</div>
+  {% endif %}
+</nav>
+<main>
+  <div class="table">
+    <div class="table-row multiline">
+      <div id="context" class="table-key">CONTEXT: </div>
+
+      <div class="table-val">
+        <h1>{{hint}}</h1>
+      </div>
+
+      <div class="table-val">
+        <pre>{{context}}</pre>
+      </div>
+    </div>
+
+    {% if params %}
+    <div class="table-row multiline">
+      <div id="params" class="table-key">REQUEST PARAMS: </div>
+      <div class="table-val">
+        <pre>{{params}}</pre>
+      </div>
+    </div>
+    {% endif %}
+
+    {% if data %}
+    <div class="table-row multiline">
+      <div id="edata" class="table-key">ERROR DATA: </div>
+      <div class="table-val">
+        <pre>{{data}}</pre>
+      </div>
+    </div>
+    {% endif %}
+
+    {% if spec-explain %}
+    <div class="table-row multiline">
+      <div id="spec-explain" class="table-key">SPEC EXPLAIN: </div>
+      <div class="table-val">
+        <pre>{{spec-explain}}</pre>
+      </div>
+    </div>
+    {% endif %}
+
+    {% if spec-problems %}
+    <div class="table-row multiline">
+      <div id="spec-problems" class="table-key">SPEC PROBLEMS: </div>
+      <div class="table-val">
+        <pre>{{spec-problems}}</pre>
+      </div>
+    </div>
+    {% endif %}
+
+    {% if spec-value %}
+    <div class="table-row multiline">
+      <div id="spec-value" class="table-key">SPEC VALUE: </div>
+      <div class="table-val">
+        <pre>{{spec-value}}</pre>
+      </div>
+    </div>
+    {% endif %}
+
+    {% if trace %}
+    <div class="table-row multiline">
+      <div id="trace" class="table-key">TRACE:</div>
+      <div class="table-val">
+        <pre>{{trace}}</pre>
+      </div>
+    </div>
+    {% endif %}
+  </div>
+</main>
+{% endblock %}

backend/resources/app/templates/styles.css

@@ -0,0 +1,179 @@
+* {
+  font-family: "JetBrains Mono", monospace;
+  font-size: 12px;
+}
+
+body {
+  margin: 0px;
+  padding: 0px;
+}
+
+pre {
+  margin: 0px;
+  line-height: 16px;
+}
+
+desc {
+  margin-bottom: 10px;
+  font-size: 10px;
+  color: #666;
+}
+
+input[type=text], input[type=submit] {
+  padding: 3px;
+}
+
+main {
+  margin: 20px;
+}
+
+small {
+  font-size: 9px;
+  color: #888;
+}
+
+small > strong {
+  font-size: 9px;
+}
+
+nav {
+  position: fixed;
+  width: 100vw;
+  top: 0;
+  left: 0;
+  padding: 5px 20px;
+  display: flex;
+  background: #e3e3e3;
+}
+
+nav > h1 {
+  padding: 0px;
+  margin: 0px;
+  font-size: 11px;
+}
+
+nav > div {
+  text-transform: uppercase;
+  font-weight: bold;
+}
+
+nav > div:not(:last-child) {
+  margin-right: 10px;
+}
+
+.table {
+  margin-top: 25px;
+  display: flex;
+  flex-direction: column;
+}
+
+.table-row {
+  display: flex;
+  padding-bottom: 15px;
+  /* width: 100%; */
+  /* border: 1px solid red; */
+}
+
+.table-key {
+  font-weight: 600;
+  width: 60px;
+  padding: 4px;
+
+  padding-top: 40px;
+  margin-top: -40px;
+}
+
+.table-val {
+  font-weight: 200;
+  color: #333;
+  padding: 4px;
+}
+
+.multiline {
+  margin-top: 15px;
+  flex-direction: column;
+}
+
+.multiline .table-key {
+  margin-bottom: 10px;
+  border-bottom: 1px dashed #dddddd;
+  /* padding: 4px; */
+  width: unset;
+}
+
+.index {
+  margin-top: 40px;
+  display: flex;
+}
+
+.index > section {
+  padding: 10px;
+  background-color: #e3e3e3;
+  max-width: 400px;
+  margin: 5px;
+  height: fit-content;
+}
+
+.index fieldset:not(:first-child) {
+  margin-top: 15px;
+}
+
+/* .index > section:not(:last-child) { */
+/*   margin-bottom: 10px; */
+/* } */
+
+
+.index > section > h2 {
+  margin-top: 0px;
+}
+
+.horizontal-list {
+  margin: 20px;
+  margin-top: 40px;
+}
+
+.horizontal-list ul {
+  display: flex;
+  margin: 0px;
+  padding: 0px;
+  flex-direction: column;
+  flex-wrap: wrap;
+  height: calc(100vh - 75px);
+  justify-content: flex-start;
+}
+
+.horizontal-list li {
+  list-style: none;
+  padding: 0px;
+  margin: 0px;
+  line-height: 18px;
+  min-width: 210px;
+  margin: 0px 20px;
+  cursor: pointer;
+  display: flex;
+  justify-content: center;
+  border-radius: 3px;
+}
+
+.horizontal-list li:hover {
+  background-color: #e9e9e9;
+}
+
+.horizontal-list li > a {
+  text-decoration: none;
+  color: inherit;
+}
+
+form .row {
+  padding: 5px 0;
+}
+
+.set-of-inputs {
+  flex-direction: column;
+  display: flex;
+}
+
+.set-of-inputs input:not(:last-child) {
+  margin-bottom: 3px;
+}
+

backend/resources/builtin.edn

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

backend/resources/config/default.edn

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

backend/resources/config/test.edn

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

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

@@ -1 +0,0 @@
-Inviation to join {{team}}

backend/resources/emails/register/en.txt

@@ -1,9 +0,0 @@
-Hello {{name}}!
-
-Thanks for signing up for your UXBOX 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.

backend/resources/log4j2-bundle.xml

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

backend/resources/log4j2-devenv.xml

@@ -0,0 +1,57 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<Configuration status="info" monitorInterval="30">
+  <Appenders>
+    <Console name="console" target="SYSTEM_OUT">
+      <PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] %level{length=1} %logger{36} - %msg%n"/>
+    </Console>
+
+    <RollingFile name="main" fileName="logs/main.log" filePattern="logs/main-%i.log">
+      <PatternLayout pattern="[%d{YYYY-MM-dd HH:mm:ss.SSS}] %level{length=1} %logger{36} - %msg%n"/>
+      <Policies>
+        <SizeBasedTriggeringPolicy size="50M"/>
+      </Policies>
+      <DefaultRolloverStrategy max="9"/>
+    </RollingFile>
+
+    <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="io.lettuce" level="error" />
+    <Logger name="com.zaxxer.hikari" level="error"/>
+    <Logger name="org.postgresql" level="error" />
+
+    <Logger name="app.rpc.commands.binfile" level="debug" />
+    <Logger name="app.storage.tmp" level="debug" />
+    <Logger name="app.worker" level="info" />
+    <Logger name="app.msgbus" level="info" />
+    <Logger name="app.http.websocket" level="info" />
+    <Logger name="app.util.websocket" level="info" />
+    <Logger name="app.redis" level="info" />
+    <Logger name="app.rpc.rlimit" level="info" />
+
+    <Logger name="app.cli" level="debug" additivity="false">
+      <AppenderRef ref="console"/>
+    </Logger>
+
+    <Logger name="app.loggers" level="debug" additivity="false">
+      <AppenderRef ref="main" level="debug" />
+    </Logger>
+
+    <Logger name="app" level="all" additivity="false">
+      <AppenderRef ref="main" level="trace" />
+      <AppenderRef ref="zmq" level="debug" />
+    </Logger>
+
+    <Logger name="user" level="trace" additivity="false">
+      <AppenderRef ref="main" level="trace" />
+    </Logger>
+
+    <Root level="info">
+      <AppenderRef ref="main" />
+    </Root>
+  </Loggers>
+</Configuration>

backend/resources/log4j2.xml

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

backend/resources/rlimit.edn

@@ -0,0 +1,6 @@
+^{:refresh "30s"}
+{:default
+ [[:default :window "200000/h"]]
+
+ #{:query/profile}
+ [[:burst :bucket "100/60/1m"]]}

backend/scripts/build

@@ -0,0 +1,22 @@
+#!/usr/bin/env bash
+
+CURRENT_VERSION=$1;
+
+set -ex
+
+rm -rf target;
+mkdir -p target/classes;
+mkdir -p target/dist;
+echo "$CURRENT_VERSION" > target/classes/version.txt;
+cp ../CHANGES.md target/classes/changelog.md;
+
+clojure -T:build jar;
+mv target/penpot.jar target/dist/penpot.jar
+cp scripts/run.template.sh target/dist/run.sh;
+cp scripts/manage.template.sh target/dist/manage.sh;
+chmod +x target/dist/run.sh;
+chmod +x target/dist/manage.sh;
+
+# Prefetch
+bb ./scripts/prefetch-templates.clj resources/app/onboarding.edn builtin-templates/
+cp -r builtin-templates target/dist/

backend/scripts/build.sh

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

backend/scripts/import-generic-collections.sh

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

backend/scripts/manage.template.sh

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

backend/scripts/prefetch-templates.clj

@@ -0,0 +1,40 @@
+#!/usr/bin/env bb
+
+(require '[babashka.curl :as curl]
+         '[babashka.fs :as fs])
+
+(defn download-if-needed!
+  [dest data]
+  (doseq [{:keys [id file-uri] :as item} data]
+    (let [file (fs/file dest id)
+          rsp  (curl/get file-uri {:as :stream})]
+
+      (when (not= 200 (:status rsp))
+        (println (format "unable to download %s (uri: %s)" id file-uri))
+        (System/exit -1))
+
+      (when-not (fs/exists? (str file))
+        (println (format "=> downloading %s" id))
+        (with-open [output (io/output-stream file)]
+          (io/copy (:body rsp) output))))))
+
+(defn read-defs-file
+  [path]
+  (with-open [content (io/reader path)]
+    (edn/read-string (slurp content))))
+
+(let [[path dest] *command-line-args*]
+  (when (or (nil? path)
+            (nil? dest))
+    (println "invalid arguments")
+    (System/exit -1))
+
+  (when-not (fs/exists? path)
+    (println (format "file %s does not exists" path))
+    (System/exit -1))
+
+  (when-not (fs/exists? dest)
+    (fs/create-dirs dest))
+
+  (let [data (read-defs-file path)]
+    (download-if-needed! dest data)))

backend/scripts/prepare-release.sh

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

backend/scripts/psql.sh

@@ -1,2 +0,0 @@
-#!/usr/bin/env bash
-PGPASSWORD=$APP_DATABASE_PASSWORD psql $APP_DATABASE_URI -U $APP_DATABASE_USERNAME

backend/scripts/repl

@@ -1,6 +1,51 @@
 #!/usr/bin/env bash
-set -ex
 
-# clojure -Ojmx-remote -A:dev -e "(set! *warn-on-reflection* true)" -m rebel-readline.main
-# clojure -Ojmx-remote -A:dev -J-XX:+UnlockExperimentalVMOptions -J-XX:+UseZGC -J-Xms128m -J-Xmx128m -m rebel-readline.main
-clojure -A:jmx-remote:dev -J-Xms128m -J-Xmx128m -M -m rebel-readline.main
+export PENPOT_HOST=devenv
+export PENPOT_TENANT=dev
+export PENPOT_FLAGS="$PENPOT_FLAGS enable-backend-asserts enable-audit-log enable-transit-readable-response enable-demo-users disable-secure-session-cookies enable-rpc-rate-limit enable-warn-rpc-rate-limits enable-smtp"
+
+# export PENPOT_DATABASE_URI="postgresql://172.17.0.1:5432/penpot"
+# export PENPOT_DATABASE_USERNAME="penpot"
+# export PENPOT_DATABASE_PASSWORD="penpot"
+# export PENPOT_DATABASE_READONLY=true
+
+# export PENPOT_DATABASE_URI="postgresql://172.17.0.1:5432/penpot_pre"
+# export PENPOT_DATABASE_USERNAME="penpot_pre"
+# export PENPOT_DATABASE_PASSWORD="penpot_pre"
+
+# export PENPOT_LOGGERS_LOKI_URI="http://172.17.0.1:3100/loki/api/v1/push"
+# export PENPOT_AUDIT_LOG_ARCHIVE_URI="http://localhost:6070/api/audit"
+
+export PENPOT_DEFAULT_RATE_LIMIT="default,window,10000/h"
+
+# Initialize MINIO config
+mc alias set penpot-s3/ http://minio:9000 minioadmin minioadmin
+mc admin user add penpot-s3 penpot-devenv penpot-devenv
+mc admin policy set penpot-s3 readwrite user=penpot-devenv
+mc mb penpot-s3/penpot -p
+
+export AWS_ACCESS_KEY_ID=penpot-devenv
+export AWS_SECRET_ACCESS_KEY=penpot-devenv
+export PENPOT_ASSETS_STORAGE_BACKEND=assets-s3
+export PENPOT_STORAGE_ASSETS_S3_ENDPOINT=http://minio:9000
+export PENPOT_STORAGE_ASSETS_S3_BUCKET=penpot
+
+export OPTIONS="
+       -A:dev:jmx-remote \
+       -J-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager \
+       -J-Dlog4j2.configurationFile=log4j2-devenv.xml \
+       -J-XX:+UseG1GC \
+       -J-XX:-OmitStackTraceInFastThrow \
+       -J-Xms50m -J-Xmx1024m \
+       -J-Djdk.attach.allowAttachSelf \
+       -J-XX:+UnlockDiagnosticVMOptions \
+       -J-XX:+DebugNonSafepoints";
+
+# Uncomment for use the ImageMagick v7.x
+# export OPTIONS="-J-Dim4java.useV7=true $OPTIONS";
+
+export OPTIONS_EVAL="nil"
+# export OPTIONS_EVAL="(set! *warn-on-reflection* true)"
+
+set -ex
+exec clojure $OPTIONS -M -e "$OPTIONS_EVAL" -m rebel-readline.main

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

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

backend/scripts/run.template.sh

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

backend/scripts/smtpd.sh

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

backend/scripts/start-dev

@@ -1,13 +1,25 @@
-#!/bin/sh
+#!/usr/bin/env bash
+
+export PENPOT_HOST=devenv
+export PENPOT_TENANT=dev
+export PENPOT_FLAGS="$PENPOT_FLAGS enable-backend-asserts enable-audit-log enable-transit-readable-response enable-demo-users disable-secure-session-cookies enable-smtp"
 
 set -ex
 
-if [ ! -e ~/.fixtures-loaded ]; then
-    echo "Loading fixtures..."
-    clojure -Adev -X:fn-fixtures
-    touch ~/.fixtures-loaded
+if [ "$1" = "--watch" ]; then
+    echo "Start Watch..."
+
+    clojure -A:dev -M -m app.main &
+    PID=$!
+
+    npx nodemon \
+        --watch src \
+        --watch ../common \
+        --ext "clj" \
+        --signal SIGKILL \
+        --exec 'echo "(user/restart)" | nc -N localhost 6062'
+
+    kill -9 $PID
+else
+    clojure -A:dev -M -m app.main
 fi
-
-clojure -M -m app.main
-
-

backend/src/app/auth/ldap.clj

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

backend/src/app/auth/oidc.clj

@@ -0,0 +1,543 @@
+;; 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) KALEIDOS INC
+
+(ns app.auth.oidc
+  "OIDC client implementation."
+  (:require
+   [app.common.data :as d]
+   [app.common.data.macros :as dm]
+   [app.common.exceptions :as ex]
+   [app.common.logging :as l]
+   [app.common.spec :as us]
+   [app.common.uri :as u]
+   [app.config :as cf]
+   [app.db :as db]
+   [app.http.client :as http]
+   [app.http.middleware :as hmw]
+   [app.loggers.audit :as audit]
+   [app.rpc.queries.profile :as profile]
+   [app.tokens :as tokens]
+   [app.util.json :as json]
+   [app.util.time :as dt]
+   [app.worker :as wrk]
+   [clojure.set :as set]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [integrant.core :as ig]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.response :as yrs]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HELPERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- obfuscate-string
+  [s]
+  (if (< (count s) 10)
+    (apply str (take (count s) (repeat "*")))
+    (str (subs s 0 5)
+         (apply str (take (- (count s) 5) (repeat "*"))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; OIDC PROVIDER (GENERIC)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- discover-oidc-config
+  [{:keys [http-client]} {:keys [base-uri] :as opts}]
+  (let [discovery-uri (u/join base-uri ".well-known/openid-configuration")
+        response      (ex/try (http/req! http-client {:method :get :uri (str discovery-uri)} {:sync? true}))]
+    (cond
+      (ex/exception? response)
+      (do
+        (l/warn :hint "unable to discover oidc configuration"
+                :discover-uri (str discovery-uri)
+                :cause response)
+        nil)
+
+      (= 200 (:status response))
+      (let [data (json/read (:body response))]
+        {:token-uri (get data :token_endpoint)
+         :auth-uri  (get data :authorization_endpoint)
+         :user-uri  (get data :userinfo_endpoint)})
+
+      :else
+      (do
+        (l/warn :hint "unable to discover OIDC configuration"
+                :uri (str discovery-uri)
+                :response-status-code (:status response))
+        nil))))
+
+(defn- prepare-oidc-opts
+  [cfg]
+  (let [opts {:base-uri      (:base-uri cfg)
+              :client-id     (:client-id cfg)
+              :client-secret (:client-secret cfg)
+              :token-uri     (:token-uri cfg)
+              :auth-uri      (:auth-uri cfg)
+              :user-uri      (:user-uri cfg)
+              :scopes        (:scopes cfg #{"openid" "profile" "email"})
+              :roles-attr    (:roles-attr cfg)
+              :roles         (:roles cfg)
+              :name          "oidc"}
+
+        opts (d/without-nils opts)]
+
+    (when (and (string? (:base-uri opts))
+               (string? (:client-id opts))
+               (string? (:client-secret opts)))
+      (if (and (string? (:token-uri opts))
+               (string? (:user-uri opts))
+               (string? (:auth-uri opts)))
+        opts
+        (some-> (discover-oidc-config cfg opts)
+                (merge opts {:discover? true}))))))
+
+(defmethod ig/prep-key ::generic-provider
+  [_ cfg]
+  (d/without-nils cfg))
+
+(defmethod ig/init-key ::generic-provider
+  [_ cfg]
+  (when (:enabled? cfg)
+    (if-let [opts (prepare-oidc-opts cfg)]
+      (do
+        (l/info :hint "provider initialized"
+                :provider :oidc
+                :method (if (:discover? opts) "discover" "manual")
+                :client-id (:client-id opts)
+                :client-secret (obfuscate-string (:client-secret opts))
+                :scopes (str/join "," (:scopes opts))
+                :auth-uri (:auth-uri opts)
+                :user-uri (:user-uri opts)
+                :token-uri (:token-uri opts)
+                :roles-attr (:roles-attr opts)
+                :roles      (:roles opts))
+        opts)
+      (do
+        (l/warn :hint "unable to initialize auth provider, missing configuration" :provider :oidc)
+        nil))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; GOOGLE AUTH PROVIDER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod ig/prep-key ::google-provider
+  [_ cfg]
+  (d/without-nils cfg))
+
+(defmethod ig/init-key ::google-provider
+  [_ cfg]
+  (let [opts {:client-id     (:client-id cfg)
+              :client-secret (:client-secret cfg)
+              :scopes        #{"openid" "email" "profile"}
+              :auth-uri      "https://accounts.google.com/o/oauth2/v2/auth"
+              :token-uri     "https://oauth2.googleapis.com/token"
+              :user-uri      "https://openidconnect.googleapis.com/v1/userinfo"
+              :name          "google"}]
+
+    (when (:enabled? cfg)
+      (if (and (string? (:client-id opts))
+               (string? (:client-secret opts)))
+        (do
+          (l/info :hint "provider initialized"
+                  :provider :google
+                  :client-id (:client-id opts)
+                  :client-secret (obfuscate-string (:client-secret opts)))
+          opts)
+
+        (do
+          (l/warn :hint "unable to initialize auth provider, missing configuration" :provider :google)
+          nil)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; GITHUB AUTH PROVIDER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- retrieve-github-email
+  [{:keys [http-client]} tdata info]
+  (or (some-> info :email p/resolved)
+      (-> (http/req! http-client {:uri "https://api.github.com/user/emails"
+                                  :headers {"Authorization" (dm/str (:type tdata) " " (:token tdata))}
+                                  :timeout 6000
+                                  :method :get})
+          (p/then (fn [{:keys [status body] :as response}]
+                    (when-not (s/int-in-range? 200 300 status)
+                      (ex/raise :type :internal
+                                :code :unable-to-retrieve-github-emails
+                                :hint "unable to retrieve github emails"
+                                :http-status status
+                                :http-body body))
+                    (->> response :body json/read (filter :primary) first :email))))))
+
+(defmethod ig/prep-key ::github-provider
+  [_ cfg]
+  (d/without-nils cfg))
+
+(defmethod ig/init-key ::github-provider
+  [_ cfg]
+  (let [opts {:client-id     (:client-id cfg)
+              :client-secret (:client-secret cfg)
+              :scopes        #{"read:user" "user:email"}
+              :auth-uri      "https://github.com/login/oauth/authorize"
+              :token-uri     "https://github.com/login/oauth/access_token"
+              :user-uri      "https://api.github.com/user"
+              :name          "github"
+
+              ;; Additional hooks for provider specific way of
+              ;; retrieve emails.
+              :get-email-fn           (partial retrieve-github-email cfg)}]
+
+    (when (:enabled? cfg)
+      (if (and (string? (:client-id opts))
+               (string? (:client-secret opts)))
+        (do
+          (l/info :hint "provider initialized"
+                  :provider :github
+                  :client-id (:client-id opts)
+                  :client-secret (obfuscate-string (:client-secret opts)))
+          opts)
+
+        (do
+          (l/warn :hint "unable to initialize auth provider, missing configuration" :provider :github)
+          nil)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; GITLAB AUTH PROVIDER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod ig/prep-key ::gitlab-provider
+  [_ cfg]
+  (d/without-nils cfg))
+
+(defmethod ig/init-key ::gitlab-provider
+  [_ cfg]
+  (let [base (:base-uri cfg "https://gitlab.com")
+        opts {:base-uri      base
+              :client-id     (:client-id cfg)
+              :client-secret (:client-secret cfg)
+              :scopes        #{"openid" "profile" "email"}
+              :auth-uri      (str base "/oauth/authorize")
+              :token-uri     (str base "/oauth/token")
+              :user-uri      (str base "/oauth/userinfo")
+              :name          "gitlab"}]
+    (when (:enabled? cfg)
+      (if (and (string? (:client-id opts))
+               (string? (:client-secret opts)))
+        (do
+          (l/info :hint "provider initialized"
+                  :provider :gitlab
+                  :base-uri base
+                  :client-id (:client-id opts)
+                  :client-secret (obfuscate-string (:client-secret opts)))
+          opts)
+
+        (do
+          (l/warn :hint "unable to initialize auth provider, missing configuration" :provider :gitlab)
+          nil)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HANDLERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- build-redirect-uri
+  [{:keys [provider] :as cfg}]
+  (let [public (u/uri (:public-uri cfg))]
+    (str (assoc public :path (str "/api/auth/oauth/" (:name provider) "/callback")))))
+
+(defn- build-auth-uri
+  [{:keys [provider] :as cfg} state]
+  (let [params {:client_id (:client-id provider)
+                :redirect_uri (build-redirect-uri cfg)
+                :response_type "code"
+                :state state
+                :scope (str/join " " (:scopes provider []))}
+        query  (u/map->query-string params)]
+    (-> (u/uri (:auth-uri provider))
+        (assoc :query query)
+        (str))))
+
+(defn- qualify-props
+  [provider props]
+  (reduce-kv (fn [result k v]
+               (assoc result (keyword (:name provider) (name k)) v))
+             {}
+             props))
+
+(defn retrieve-access-token
+  [{:keys [provider http-client] :as cfg} code]
+  (let [params {:client_id (:client-id provider)
+                :client_secret (:client-secret provider)
+                :code code
+                :grant_type "authorization_code"
+                :redirect_uri (build-redirect-uri cfg)}
+        req    {:method :post
+                :headers {"content-type" "application/x-www-form-urlencoded"
+                          "accept" "application/json"}
+                :uri (:token-uri provider)
+                :body (u/map->query-string params)}]
+    (p/then
+     (http/req! http-client req)
+     (fn [{:keys [status body] :as res}]
+       (if (= status 200)
+         (let [data (json/read body)]
+           {:token (get data :access_token)
+            :type (get data :token_type)})
+         (ex/raise :type :internal
+                   :code :unable-to-retrieve-token
+                   :http-status status
+                   :http-body body))))))
+
+(defn- retrieve-user-info
+  [{:keys [provider http-client] :as cfg} tdata]
+  (letfn [(retrieve []
+            (http/req! http-client {:uri (:user-uri provider)
+                                    :headers {"Authorization" (str (:type tdata) " " (:token tdata))}
+                                    :timeout 6000
+                                    :method :get}))
+          (validate-response [response]
+            (when-not (s/int-in-range? 200 300 (:status response))
+              (ex/raise :type :internal
+                        :code :unable-to-retrieve-user-info
+                        :hint "unable to retrieve user info"
+                        :http-status (:status response)
+                        :http-body (:body response)))
+            response)
+
+          (get-email [info]
+            ;; Allow providers hook into this for custom email
+            ;; retrieval method.
+            (if-let [get-email-fn (:get-email-fn provider)]
+              (get-email-fn tdata info)
+              (let [attr-kw (cf/get :oidc-email-attr :email)]
+                (get info attr-kw))))
+
+          (get-name [info]
+            (let [attr-kw (cf/get :oidc-name-attr :name)]
+              (get info attr-kw)))
+
+          (process-response [response]
+            (p/let [info  (-> response :body json/read)
+                    email (get-email info)]
+              {:backend  (:name provider)
+               :email    email
+               :fullname (or (get-name info) email)
+               :props    (->> (dissoc info :name :email)
+                              (qualify-props provider))}))
+
+          (validate-info [info]
+            (when-not (s/valid? ::info info)
+              (l/warn :hint "received incomplete profile info object (please set correct scopes)"
+                      :info (pr-str info))
+              (ex/raise :type :internal
+                        :code :incomplete-user-info
+                        :hint "inconmplete user info"
+                        :info info))
+            info)]
+
+    (-> (retrieve)
+        (p/then validate-response)
+        (p/then process-response)
+        (p/then validate-info))))
+
+(s/def ::backend ::us/not-empty-string)
+(s/def ::email ::us/not-empty-string)
+(s/def ::fullname ::us/not-empty-string)
+(s/def ::props (s/map-of ::us/keyword any?))
+(s/def ::info
+  (s/keys :req-un [::backend
+                   ::email
+                   ::fullname
+                   ::props]))
+
+(defn retrieve-info
+  [{:keys [sprops provider] :as cfg} {:keys [params] :as request}]
+  (letfn [(validate-oidc [info]
+            ;; If the provider is OIDC, we can proceed to check
+            ;; roles if they are defined.
+            (when (and (= "oidc" (:name provider))
+                       (seq (:roles provider)))
+              (let [provider-roles (into #{} (:roles provider))
+                    profile-roles  (let [attr  (cf/get :oidc-roles-attr :roles)
+                                         roles (get info attr)]
+                                     (cond
+                                       (string? roles) (into #{} (str/words roles))
+                                       (vector? roles) (into #{} roles)
+                                       :else #{}))]
+
+                ;; check if profile has a configured set of roles
+                (when-not (set/subset? provider-roles profile-roles)
+                  (ex/raise :type :internal
+                            :code :unable-to-auth
+                            :hint "not enough permissions"))))
+            info)
+
+          (post-process [state info]
+            (cond-> info
+              (some? (:invitation-token state))
+              (assoc :invitation-token (:invitation-token state))
+
+              ;; If state token comes with props, merge them. The state token
+              ;; props can contain pm_ and utm_ prefixed query params.
+              (map? (:props state))
+              (update :props merge (:props state))))]
+
+    (when-let [error (get params :error)]
+      (ex/raise :type :internal
+                :code :error-on-retrieving-code
+                :error-id error
+                :error-desc (get params :error_description)))
+
+    (let [state  (get params :state)
+          code   (get params :code)
+          state  (tokens/verify sprops {:token state :iss :oauth})]
+      (-> (p/resolved code)
+          (p/then #(retrieve-access-token cfg %))
+          (p/then #(retrieve-user-info cfg %))
+          (p/then' validate-oidc)
+          (p/then' (partial post-process state))))))
+
+(defn- retrieve-profile
+  [{:keys [pool executor] :as cfg} info]
+  (px/with-dispatch executor
+    (with-open [conn (db/open pool)]
+      (some->> (:email info)
+               (profile/retrieve-profile-data-by-email conn)
+               (profile/populate-additional-data conn)
+               (profile/decode-profile-row)))))
+
+(defn- redirect-response
+  [uri]
+  (yrs/response :status 302 :headers {"location" (str uri)}))
+
+(defn- generate-error-redirect
+  [cfg error]
+  (let [uri (-> (u/uri (:public-uri cfg))
+                (assoc :path "/#/auth/login")
+                (assoc :query (u/map->query-string {:error "unable-to-auth" :hint (ex-message error)})))]
+    (redirect-response uri)))
+
+(defn- generate-redirect
+  [{:keys [sprops session audit] :as cfg} request info profile]
+  (if profile
+    (let [sxf    ((:create session) (:id profile))
+          token  (or (:invitation-token info)
+                     (tokens/generate sprops {:iss :auth
+                                              :exp (dt/in-future "15m")
+                                              :profile-id (:id profile)}))
+          params {:token token}
+
+          uri    (-> (u/uri (:public-uri cfg))
+                     (assoc :path "/#/auth/verify-token")
+                     (assoc :query (u/map->query-string params)))]
+
+      (when (:is-blocked profile)
+        (ex/raise :type :restriction
+                  :code :profile-blocked))
+
+      (when (fn? audit)
+        (audit :cmd :submit
+               :type "command"
+               :name "login"
+               :profile-id (:id profile)
+               :ip-addr (audit/parse-client-ip request)
+               :props (audit/profile->props profile)))
+
+      (->> (redirect-response uri)
+           (sxf request)))
+
+    (let [info   (assoc info
+                        :iss :prepared-register
+                        :is-active true
+                        :exp (dt/in-future {:hours 48}))
+          token  (tokens/generate sprops info)
+          params (d/without-nils
+                  {:token token
+                   :fullname (:fullname info)})
+          uri    (-> (u/uri (:public-uri cfg))
+                     (assoc :path "/#/auth/register/validate")
+                     (assoc :query (u/map->query-string params)))]
+      (redirect-response uri))))
+
+(defn- auth-handler
+  [{:keys [sprops] :as cfg} {:keys [params] :as request}]
+  (let [props (audit/extract-utm-params params)
+        state (tokens/generate sprops
+                               {:iss :oauth
+                                :invitation-token (:invitation-token params)
+                                :props props
+                                :exp (dt/in-future "4h")})
+        uri   (build-auth-uri cfg state)]
+    (yrs/response 200 {:redirect-uri uri})))
+
+(defn- callback-handler
+  [cfg request]
+  (letfn [(process-request []
+            (p/let [info    (retrieve-info cfg request)
+                    profile (retrieve-profile cfg info)]
+              (generate-redirect cfg request info profile)))
+
+          (handle-error [cause]
+            (l/error :hint "error on oauth process" :cause cause)
+            (generate-error-redirect cfg cause))]
+
+    (-> (process-request)
+        (p/catch handle-error))))
+
+(def provider-lookup
+  {:compile
+   (fn [& _]
+     (fn [handler]
+       (fn [{:keys [providers] :as cfg} request]
+         (let [provider (some-> request :path-params :provider keyword)]
+           (if-let [provider (get providers provider)]
+             (handler (assoc cfg :provider provider) request)
+             (ex/raise :type :restriction
+                       :code :provider-not-configured
+                       :provider provider
+                       :hint "provider not configured"))))))})
+
+(s/def ::public-uri ::us/not-empty-string)
+(s/def ::http-client ::http/client)
+(s/def ::session map?)
+(s/def ::sprops map?)
+(s/def ::providers map?)
+
+(defmethod ig/pre-init-spec ::routes
+  [_]
+  (s/keys :req-un [::public-uri
+                   ::session
+                   ::sprops
+                   ::http-client
+                   ::providers
+                   ::db/pool
+                   ::wrk/executor]))
+
+(defmethod ig/init-key ::routes
+  [_ {:keys [executor session] :as cfg}]
+  (let [cfg (update cfg :provider d/without-nils)]
+    ["" {:middleware [[(:middleware session)]
+                      [hmw/with-dispatch executor]
+                      [hmw/with-config cfg]
+                      [provider-lookup]
+                      ]}
+     ;; We maintain the both URI prefixes for backward compatibility.
+
+     ["/auth/oauth"
+      ["/:provider"
+       {:handler auth-handler
+        :allowed-methods #{:post}}]
+      ["/:provider/callback"
+       {:handler callback-handler
+        :allowed-methods #{:get}}]]
+
+     ["/auth/oidc"
+      ["/:provider"
+       {:handler auth-handler
+        :allowed-methods #{:post}}]
+      ["/:provider/callback"
+       {:handler callback-handler
+        :allowed-methods #{:get}}]]]))

backend/src/app/cli/fixtures.clj

@@ -1,238 +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.cli.fixtures
-  "A initial fixtures."
-  (:require
-   [app.common.pages :as cp]
-   [app.common.uuid :as uuid]
-   [app.config :as cfg]
-   [app.db :as db]
-   [app.migrations]
-   [app.services.mutations.profile :as profile]
-   [app.util.blob :as blob]
-   [buddy.hashers :as hashers]
-   [clojure.tools.logging :as log]
-   [mount.core :as mount]))
-
-(defn- mk-uuid
-  [prefix & args]
-  (uuid/namespaced uuid/zero (apply str prefix (interpose "-" args))))
-
-;; --- Profiles creation
-
-(def password (hashers/derive "123123"))
-
-(def preset-small
-  {:num-teams 5
-   :num-profiles 5
-   :num-profiles-per-team 5
-   :num-projects-per-team 5
-   :num-files-per-project 5
-   :num-draft-files-per-profile 10})
-
-(defn- rng-ids
-  [rng n max]
-  (let [stream (->> (.longs rng 0 max)
-                    (.iterator)
-                    (iterator-seq))]
-    (reduce (fn [acc item]
-              (if (= (count acc) n)
-                (reduced acc)
-                (conj acc item)))
-            #{}
-            stream)))
-
-(defn- rng-vec
-  [rng vdata n]
-  (let [ids (rng-ids rng n (count vdata))]
-    (mapv #(nth vdata %) ids)))
-
-(defn- rng-nth
-  [rng vdata]
-  (let [stream (->> (.longs rng 0 (count vdata))
-                    (.iterator)
-                    (iterator-seq))]
-    (nth vdata (first stream))))
-
-(defn- collect
-  [f items]
-  (reduce #(conj %1 (f %2)) [] items))
-
-(defn- register-profile
-  [conn params]
-  (->> (#'profile/create-profile conn params)
-       (#'profile/create-profile-relations conn)))
-
-(defn impl-run
-  [opts]
-  (let [rng (java.util.Random. 1)]
-    (letfn [(create-profile [conn index]
-              (let [id   (mk-uuid "profile" index)
-                    _    (log/info "create profile" id)
-
-                    prof (register-profile conn
-                                           {:id id
-                                            :fullname (str "Profile " index)
-                                            :password "123123"
-                                            :demo? true
-                                            :email (str "profile" index ".test@penpot.app")})
-                    team-id  (:default-team-id prof)
-                    owner-id id]
-                (let [project-ids (collect (partial create-project conn team-id owner-id)
-                                           (range (:num-projects-per-team opts)))]
-                  (run! (partial create-files conn owner-id) project-ids))
-                prof))
-
-            (create-profiles [conn]
-              (log/info "create profiles")
-              (collect (partial create-profile conn)
-                       (range (:num-profiles opts))))
-
-            (create-team [conn index]
-              (let [id (mk-uuid "team" index)
-                    name (str "Team" index)]
-                (log/info "create team" id)
-                (db/insert! conn :team {:id id
-                                        :name name
-                                        :photo ""})
-                id))
-
-            (create-teams [conn]
-              (log/info "create teams")
-              (collect (partial create-team conn)
-                       (range (:num-teams opts))))
-
-            (create-file [conn owner-id project-id index]
-              (let [id (mk-uuid "file" project-id index)
-                    name (str "file" index)
-                    data (cp/make-file-data)]
-                (log/info "create file" id)
-                (db/insert! conn :file
-                            {:id id
-                             :data (blob/encode data)
-                             :project-id project-id
-                             :name name})
-                (db/insert! conn :file-profile-rel
-                            {:file-id id
-                             :profile-id owner-id
-                             :is-owner true
-                             :is-admin true
-                             :can-edit true})
-                id))
-
-            (create-files [conn owner-id project-id]
-              (log/info "create files")
-              (run! (partial create-file conn owner-id project-id)
-                    (range (:num-files-per-project opts))))
-
-            (create-project [conn team-id owner-id index]
-              (let [id (mk-uuid "project" team-id index)
-                    name (str "project " index)]
-                (log/info "create project" id)
-                (db/insert! conn :project
-                            {:id id
-                             :team-id team-id
-                             :name name})
-                (db/insert! conn :project-profile-rel
-                            {:project-id id
-                             :profile-id owner-id
-                             :is-owner true
-                             :is-admin true
-                             :can-edit true})
-                id))
-
-            (create-projects [conn team-id profile-ids]
-              (log/info "create projects")
-              (let [owner-id (rng-nth rng profile-ids)
-                    project-ids (collect (partial create-project conn team-id owner-id)
-                                         (range (:num-projects-per-team opts)))]
-                (run! (partial create-files conn owner-id) project-ids)))
-
-            (assign-profile-to-team [conn team-id owner? profile-id]
-              (db/insert! conn :team-profile-rel
-                          {:team-id team-id
-                           :profile-id profile-id
-                           :is-owner owner?
-                           :is-admin true
-                           :can-edit true}))
-
-            (setup-team [conn team-id profile-ids]
-              (log/info "setup team" team-id profile-ids)
-              (assign-profile-to-team conn team-id true (first profile-ids))
-              (run! (partial assign-profile-to-team conn team-id false)
-                    (rest profile-ids))
-              (create-projects conn team-id profile-ids))
-
-            (assign-teams-and-profiles [conn teams profiles]
-              (log/info "assign teams and profiles")
-              (loop [team-id (first teams)
-                     teams (rest teams)]
-                (when-not (nil? team-id)
-                  (let [n-profiles-team (:num-profiles-per-team opts)
-                        selected-profiles (rng-vec rng profiles n-profiles-team)]
-                    (setup-team conn team-id selected-profiles)
-                    (recur (first teams)
-                           (rest teams))))))
-
-            (create-draft-file [conn owner index]
-              (let [owner-id   (:id owner)
-                    id         (mk-uuid "file" "draft" owner-id index)
-                    name       (str "file" index)
-                    project-id (:default-project-id owner)
-                    data       (cp/make-file-data)]
-
-                (log/info "create draft file" id)
-                (db/insert! conn :file
-                            {:id id
-                             :data (blob/encode data)
-                             :project-id project-id
-                             :name name})
-                (db/insert! conn :file-profile-rel
-                            {:file-id id
-                             :profile-id owner-id
-                             :is-owner true
-                             :is-admin true
-                             :can-edit true})
-                id))
-
-            (create-draft-files [conn profile]
-              (run! (partial create-draft-file conn profile)
-                    (range (:num-draft-files-per-profile opts))))
-            ]
-      (db/with-atomic [conn db/pool]
-        (let [profiles (create-profiles conn)
-              teams    (create-teams conn)]
-          (assign-teams-and-profiles conn teams (map :id profiles))
-          (run! (partial create-draft-files conn) profiles))))))
-
-(defn run*
-  [preset]
-  (let [preset (if (map? preset)
-                 preset
-                 (case preset
-                   (nil "small" :small) preset-small
-                   ;; "medium" preset-medium
-                   ;; "big" preset-big
-                   preset-small))]
-    (impl-run preset)))
-
-(defn run
-  [{:keys [preset]
-    :or {preset :small}}]
-  (try
-    (-> (mount/only #{#'app.config/config
-                      #'app.db/pool
-                      #'app.migrations/migrations})
-        (mount/start))
-    (run* preset)
-    (catch Exception e
-      (log/errorf e "Unhandled exception."))
-    (finally
-      (mount/stop))))

backend/src/app/cli/manage.clj

@@ -0,0 +1,169 @@
+;; 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) KALEIDOS INC
+
+(ns app.cli.manage
+  "A manage cli api."
+  (:require
+   [app.common.logging :as l]
+   [app.db :as db]
+   [app.main :as main]
+   [app.rpc.commands.auth :as cmd.auth]
+   [app.rpc.mutations.profile :as profile]
+   [app.rpc.queries.profile :refer [retrieve-profile-data-by-email]]
+   [clojure.string :as str]
+   [clojure.tools.cli :refer [parse-opts]]
+   [integrant.core :as ig])
+  (:import
+   java.io.Console))
+
+;; --- IMPL
+
+(defn init-system
+  []
+  (let [data (-> main/system-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
+      (l/error :hint "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)]
+        (->> (cmd.auth/create-profile conn
+                                     {:fullname fullname
+                                      :email email
+                                      :password password
+                                      :is-active true
+                                      :is-demo false})
+             (cmd.auth/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)]
+    (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/cli/media_loader.clj

@@ -1,232 +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.cli.media-loader
-  "Media libraries importer (command line helper)."
-  #_(:require
-   [app.common.spec :as us]
-   [app.common.uuid :as uuid]
-   [app.config]
-   [app.db :as db]
-   [app.media-storage]
-   [app.media]
-   [app.migrations]
-   [app.services.mutations.files :as files]
-   [app.services.mutations.media :as media]
-   [app.services.mutations.projects :as projects]
-   [clojure.java.io :as io]
-   [clojure.spec.alpha :as s]
-   [clojure.tools.logging :as log]
-   [datoteka.core :as fs]
-   [mount.core :as mount])
-  #_(:import
-   java.io.PushbackReader))
-
-;; --- Constants & Helpers
-
-;; (def ^:const +graphics-uuid-ns+ #uuid "3642a582-565f-4070-beba-af797ab27a6a")
-;; (def ^:const +colors-uuid-ns+ #uuid "3642a582-565f-4070-beba-af797ab27a6c")
-
-;; (s/def ::id ::us/uuid)
-;; (s/def ::name ::us/string)
-;; (s/def ::path ::us/string)
-;; (s/def ::regex #(instance? java.util.regex.Pattern %))
-
-;; (s/def ::import-graphics
-;;   (s/keys :req-un [::path ::regex]))
-
-;; (s/def ::import-color
-;;   (s/* (s/cat :name ::us/string :color ::us/color)))
-
-;; (s/def ::import-colors (s/coll-of ::import-color))
-
-;; (s/def ::import-library
-;;   (s/keys :req-un [::name]
-;;           :opt-un [::import-graphics ::import-colors]))
-
-;; (defn exit!
-;;   ([] (exit! 0))
-;;   ([code]
-;;    (System/exit code)))
-
-;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ;; Graphics Importer
-;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; (defn- create-media-object
-;;   [conn file-id media-object-id localpath]
-;;   (s/assert fs/path? localpath)
-;;   (s/assert ::us/uuid file-id)
-;;   (s/assert ::us/uuid media-object-id)
-;;   (let [filename (fs/name localpath)
-;;         extension (second (fs/split-ext filename))
-;;         file (io/as-file localpath)
-;;         mtype (case extension
-;;                 ".jpg"  "image/jpeg"
-;;                 ".png"  "image/png"
-;;                 ".webp" "image/webp"
-;;                 ".svg"  "image/svg+xml")]
-;;     (log/info "Creating image" filename media-object-id)
-;;     (media/create-media-object conn {:content {:tempfile localpath
-;;                                                :filename filename
-;;                                                :content-type mtype
-;;                                                :size (.length file)}
-;;                                      :id media-object-id
-;;                                      :file-id file-id
-;;                                      :name filename
-;;                                      :is-local false})))
-
-;; (defn- media-object-exists?
-;;   [conn id]
-;;   (s/assert ::us/uuid id)
-;;   (let [row (db/get-by-id conn :media-object id)]
-;;     (if row true false)))
-
-;; (defn- import-media-object-if-not-exists
-;;   [conn file-id fpath]
-;;   (s/assert ::us/uuid file-id)
-;;   (s/assert fs/path? fpath)
-;;   (let [media-object-id (uuid/namespaced +graphics-uuid-ns+ (str file-id (fs/name fpath)))]
-;;     (when-not (media-object-exists? conn media-object-id)
-;;       (create-media-object conn file-id media-object-id fpath))
-;;     media-object-id))
-
-;; (defn- import-graphics
-;;   [conn file-id {:keys [path regex]}]
-;;   (run! (fn [fpath]
-;;           (when (re-matches regex (str fpath))
-;;             (import-media-object-if-not-exists conn file-id fpath)))
-;;         (->> (fs/list-dir path)
-;;              (filter fs/regular-file?))))
-
-;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ;; Colors Importer
-;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; (defn- create-color
-;;   [conn file-id name content]
-;;   (s/assert ::us/uuid file-id)
-;;   (s/assert ::us/color content)
-;;   (let [color-id (uuid/namespaced +colors-uuid-ns+ (str file-id content))]
-;;     (log/info "Creating color" color-id "-" name content)
-;;     (colors/create-color conn {:id color-id
-;;                                :file-id file-id
-;;                                :name name
-;;                                :content content})
-;;     color-id))
-
-;; (defn- import-colors
-;;   [conn file-id colors]
-;;   (db/delete! conn :color {:file-id file-id})
-;;   (run! (fn [[name content]]
-;;           (create-color conn file-id name content))
-;;         (partition-all 2 colors)))
-
-
-;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ;; Library files Importer
-;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; (defn- library-file-exists?
-;;   [conn id]
-;;   (s/assert ::us/uuid id)
-;;   (let [row (db/get-by-id conn :file id)]
-;;     (if row true false)))
-
-;; (defn- create-library-file-if-not-exists
-;;   [conn project-id {:keys [name]}]
-;;   (let [id (uuid/namespaced +colors-uuid-ns+ name)]
-;;     (when-not (library-file-exists? conn id)
-;;       (log/info "Creating library-file:" name)
-;;       (files/create-file conn {:id id
-;;                                :profile-id uuid/zero
-;;                                :project-id project-id
-;;                                :name name
-;;                                :is-shared true})
-;;       (files/create-page conn {:file-id id}))
-;;     id))
-
-;; (defn- process-library
-;;   [conn basedir project-id {:keys [graphics colors] :as library}]
-;;   (us/verify ::import-library library)
-;;   (let [library-file-id (create-library-file-if-not-exists conn project-id library)]
-;;     (when graphics
-;;       (->> (assoc graphics :path (fs/join basedir (:path graphics)))
-;;            (import-graphics conn library-file-id)))
-;;     (when colors
-;;       (import-colors conn library-file-id colors))))
-
-
-;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ;; Entry Point
-;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; (defn- project-exists?
-;;   [conn id]
-;;   (s/assert ::us/uuid id)
-;;   (let [row (db/get-by-id conn :project id)]
-;;     (if row true false)))
-
-;; (defn- create-project-if-not-exists
-;;   [conn {:keys [name] :as project}]
-;;   (let [id (uuid/namespaced +colors-uuid-ns+ name)]
-;;     (when-not (project-exists? conn id)
-;;       (log/info "Creating project" name)
-;;       (projects/create-project conn {:id id
-;;                                      :team-id uuid/zero
-;;                                      :name name
-;;                                      :default? false}))
-;;     id))
-
-;; (defn- validate-path
-;;   [path]
-;;   (let [path (if (symbol? path) (str path) path)]
-;;     (log/infof "Trying to load config from '%s'." path)
-;;     (when-not path
-;;       (log/error "No path is provided")
-;;       (exit! -1))
-;;     (when-not (fs/exists? path)
-;;       (log/error "Path does not exists.")
-;;       (exit! -1))
-;;     (when (fs/directory? path)
-;;       (log/error "The provided path is a directory.")
-;;       (exit! -1))
-;;     (fs/path path)))
-
-;; (defn- read-file
-;;   [path]
-;;   (let [reader (PushbackReader. (io/reader path))]
-;;     [(fs/parent path)
-;;      (read reader)]))
-
-;; (defn run*
-;;   [path]
-;;   (let [[basedir libraries] (read-file path)]
-;;     (db/with-atomic [conn db/pool]
-;;       (let [project-id (create-project-if-not-exists conn {:name "System libraries"})]
-;;         (run! #(process-library conn basedir project-id %) libraries)))))
-
-;; (defn run
-;;   [{:keys [path] :as params}]
-;;   (log/infof "Starting media loader.")
-;;   (let [path (validate-path path)]
-
-;;     (try
-;;       (-> (mount/only #{#'app.config/config
-;;                         #'app.db/pool
-;;                         #'app.migrations/migrations
-;;                         #'app.media/semaphore
-;;                         #'app.media-storage/media-storage})
-;;           (mount/start))
-;;       (run* path)
-;;       (catch Exception e
-;;         (log/errorf e "Unhandled exception."))
-;;       (finally
-;;         (mount/stop)))))
-

backend/src/app/config.clj

@@ -2,220 +2,364 @@
 ;; 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
+;; Copyright (c) KALEIDOS INC
 
 (ns app.config
   "A configuration management."
+  (:refer-clojure :exclude [get])
   (:require
+   [app.common.data :as d]
+   [app.common.exceptions :as ex]
+   [app.common.flags :as flags]
    [app.common.spec :as us]
    [app.common.version :as v]
    [app.util.time :as dt]
+   [clojure.core :as c]
+   [clojure.java.io :as io]
+   [clojure.pprint :as pprint]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
+   [datoteka.fs :as fs]
    [environ.core :refer [env]]
-   [mount.core :refer [defstate]]))
+   [integrant.core :as ig]))
+
+(prefer-method print-method
+               clojure.lang.IRecord
+               clojure.lang.IDeref)
+
+(prefer-method pprint/simple-dispatch
+               clojure.lang.IPersistentMap
+               clojure.lang.IDeref)
+
+(defmethod ig/init-key :default
+  [_ data]
+  (d/without-nils data))
+
+(defmethod ig/prep-key :default
+  [_ data]
+  (if (map? data)
+    (d/without-nils data)
+    data))
 
 (def defaults
-  {:http-server-port 6060
-   :http-server-cors "http://localhost:3449"
-   :database-uri "postgresql://127.0.0.1/penpot"
+  {:database-uri "postgresql://postgres/penpot"
    :database-username "penpot"
    :database-password "penpot"
-   :secret-key "default"
 
-   :media-directory "resources/public/media"
-   :assets-directory "resources/public/static"
+   :default-blob-version 4
+   :loggers-zmq-uri "tcp://localhost:45556"
+   :rpc-rlimit-config (fs/path "resources/rlimit.edn")
 
-   :public-uri "http://localhost:3449/"
-   :redis-uri "redis://localhost/0"
-   :media-uri "http://localhost:3449/media/"
-   :assets-uri "http://localhost:3449/static/"
+   :file-change-snapshot-every 5
+   :file-change-snapshot-timeout "3h"
 
-   :image-process-max-threads 2
+   :public-uri "http://localhost:3449"
+   :host "localhost"
+   :tenant "main"
 
-   :smtp-enabled false
-   :smtp-default-reply-to "no-reply@example.com"
-   :smtp-default-from "no-reply@example.com"
+   :redis-uri "redis://redis/0"
+   :srepl-host "127.0.0.1"
+   :srepl-port 6062
 
-   :host "devenv"
+   :assets-storage-backend :assets-fs
+   :storage-assets-fs-directory "assets"
 
-   :allow-demo-users true
-   :registration-enabled true
-   :registration-domain-whitelist ""
-   :debug-humanize-transit true
+   :assets-path "/internal/assets/"
+   :smtp-default-reply-to "Penpot <no-reply@example.com>"
+   :smtp-default-from "Penpot <no-reply@example.com>"
 
-   ;; This is the time should transcurr after the last page
-   ;; modification in order to make the file ellegible for
-   ;; trimming. The value only supports s(econds) m(inutes) and
-   ;; h(ours) as time unit.
-   :file-trimming-threshold "72h"
+   :profile-complaint-max-age (dt/duration {:days 7})
+   :profile-complaint-threshold 2
 
-   ;; 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"
+   :profile-bounce-max-age (dt/duration {:days 7})
+   :profile-bounce-threshold 10
 
-   :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"})
+   :telemetry-uri "https://telemetry.penpot.app/"
 
-(s/def ::http-server-port ::us/integer)
-(s/def ::http-server-debug ::us/boolean)
-(s/def ::http-server-cors ::us/string)
-(s/def ::database-username (s/nilable ::us/string))
+   :ldap-user-query "(|(uid=:username)(mail=:username))"
+   :ldap-attrs-username "uid"
+   :ldap-attrs-email "mail"
+   :ldap-attrs-fullname "cn"
+
+   ;; a server prop key where initial project is stored.
+   :initial-project-skey "initial-project"})
+
+(s/def ::default-rpc-rlimit ::us/vector-of-strings)
+(s/def ::rpc-rlimit-config ::fs/path)
+
+(s/def ::media-max-file-size ::us/integer)
+
+(s/def ::flags ::us/vector-of-keywords)
+(s/def ::telemetry-enabled ::us/boolean)
+
+(s/def ::audit-log-archive-uri ::us/string)
+
+(s/def ::admins ::us/set-of-strings)
+(s/def ::file-change-snapshot-every ::us/integer)
+(s/def ::file-change-snapshot-timeout ::dt/duration)
+
+(s/def ::default-executor-parallelism ::us/integer)
+(s/def ::worker-executor-parallelism ::us/integer)
+
+(s/def ::authenticated-cookie-domain ::us/string)
+(s/def ::authenticated-cookie-name ::us/string)
+(s/def ::auth-token-cookie-name ::us/string)
+(s/def ::auth-token-cookie-max-age ::dt/duration)
+
+(s/def ::secret-key ::us/string)
+(s/def ::allow-demo-users ::us/boolean)
+(s/def ::assets-path ::us/string)
 (s/def ::database-password (s/nilable ::us/string))
 (s/def ::database-uri ::us/string)
-(s/def ::redis-uri ::us/string)
-(s/def ::assets-uri ::us/string)
-(s/def ::assets-directory ::us/string)
-(s/def ::media-uri ::us/string)
-(s/def ::media-directory ::us/string)
-(s/def ::secret-key ::us/string)
+(s/def ::database-username (s/nilable ::us/string))
+(s/def ::database-readonly ::us/boolean)
+(s/def ::database-min-pool-size ::us/integer)
+(s/def ::database-max-pool-size ::us/integer)
 
-(s/def ::host ::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 ::debug-humanize-transit ::us/boolean)
-(s/def ::public-uri ::us/string)
-(s/def ::backend-uri ::us/string)
-
-(s/def ::image-process-max-threads ::us/integer)
-(s/def ::file-trimming-threshold ::dt/duration)
-
-(s/def ::google-client-id ::us/string)
-(s/def ::google-client-secret ::us/string)
-
+(s/def ::user-feedback-destination ::us/string)
+(s/def ::github-client-id ::us/string)
+(s/def ::github-client-secret ::us/string)
+(s/def ::gitlab-base-uri ::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 ::ldap-auth-host ::us/string)
-(s/def ::ldap-auth-port ::us/integer)
+(s/def ::google-client-id ::us/string)
+(s/def ::google-client-secret ::us/string)
+(s/def ::oidc-client-id ::us/string)
+(s/def ::oidc-client-secret ::us/string)
+(s/def ::oidc-base-uri ::us/string)
+(s/def ::oidc-token-uri ::us/string)
+(s/def ::oidc-auth-uri ::us/string)
+(s/def ::oidc-user-uri ::us/string)
+(s/def ::oidc-scopes ::us/set-of-strings)
+(s/def ::oidc-roles ::us/set-of-strings)
+(s/def ::oidc-roles-attr ::us/keyword)
+(s/def ::oidc-email-attr ::us/keyword)
+(s/def ::oidc-name-attr ::us/keyword)
+(s/def ::host ::us/string)
+(s/def ::http-server-port ::us/integer)
+(s/def ::http-server-host ::us/string)
+(s/def ::http-server-max-body-size ::us/integer)
+(s/def ::http-server-max-multipart-body-size ::us/integer)
+(s/def ::http-server-io-threads ::us/integer)
+(s/def ::http-server-worker-threads ::us/integer)
+(s/def ::initial-project-skey ::us/string)
+(s/def ::ldap-attrs-email ::us/string)
+(s/def ::ldap-attrs-fullname ::us/string)
+(s/def ::ldap-attrs-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/set-of-strings)
+
+(s/def ::semaphore-process-font ::us/integer)
+(s/def ::semaphore-process-image ::us/integer)
+(s/def ::semaphore-update-file ::us/integer)
+(s/def ::semaphore-auth ::us/integer)
+
+(s/def ::smtp-default-from ::us/string)
+(s/def ::smtp-default-reply-to ::us/string)
+(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 ::assets-storage-backend ::us/keyword)
+(s/def ::fdata-storage-backend ::us/keyword)
+(s/def ::storage-assets-fs-directory ::us/string)
+(s/def ::storage-assets-s3-bucket ::us/string)
+(s/def ::storage-assets-s3-region ::us/keyword)
+(s/def ::storage-assets-s3-endpoint ::us/string)
+(s/def ::storage-fdata-s3-bucket ::us/string)
+(s/def ::storage-fdata-s3-region ::us/keyword)
+(s/def ::storage-fdata-s3-prefix ::us/string)
+(s/def ::storage-fdata-s3-endpoint ::us/string)
+(s/def ::telemetry-uri ::us/string)
+(s/def ::telemetry-with-taiga ::us/boolean)
+(s/def ::tenant ::us/string)
 
 (s/def ::config
-  (s/keys :opt-un [::http-server-cors
-                   ::http-server-debug
-                   ::http-server-port
-                   ::google-client-id
-                   ::google-client-secret
-                   ::gitlab-client-id
-                   ::gitlab-client-secret
-                   ::gitlab-base-uri
-                   ::redis-uri
-                   ::public-uri
-                   ::database-username
+  (s/keys :opt-un [::secret-key
+                   ::flags
+                   ::admins
+                   ::allow-demo-users
+                   ::audit-log-archive-uri
+                   ::auth-token-cookie-name
+                   ::auth-token-cookie-max-age
+                   ::authenticated-cookie-name
+                   ::authenticated-cookie-domain
                    ::database-password
                    ::database-uri
-                   ::assets-directory
-                   ::assets-uri
-                   ::media-directory
-                   ::media-uri
+                   ::database-username
+                   ::database-readonly
+                   ::database-min-pool-size
+                   ::database-max-pool-size
+                   ::default-blob-version
+                   ::default-rpc-rlimit
                    ::error-report-webhook
-                   ::secret-key
-                   ::smtp-default-from
-                   ::smtp-default-reply-to
-                   ::smtp-enabled
-                   ::smtp-host
-                   ::smtp-port
-                   ::smtp-username
-                   ::smtp-password
-                   ::smtp-tls
-                   ::smtp-ssl
+                   ::default-executor-parallelism
+                   ::worker-executor-parallelism
+                   ::file-change-snapshot-every
+                   ::file-change-snapshot-timeout
+                   ::user-feedback-destination
+                   ::github-client-id
+                   ::github-client-secret
+                   ::gitlab-base-uri
+                   ::gitlab-client-id
+                   ::gitlab-client-secret
+                   ::google-client-id
+                   ::google-client-secret
+                   ::oidc-client-id
+                   ::oidc-client-secret
+                   ::oidc-base-uri
+                   ::oidc-token-uri
+                   ::oidc-auth-uri
+                   ::oidc-user-uri
+                   ::oidc-scopes
+                   ::oidc-roles-attr
+                   ::oidc-email-attr
+                   ::oidc-name-attr
+                   ::oidc-roles
                    ::host
-                   ::file-trimming-threshold
-                   ::debug-humanize-transit
-                   ::allow-demo-users
-                   ::registration-enabled
-                   ::registration-domain-whitelist
-                   ::image-process-max-threads
-                   ::ldap-auth-host
-                   ::ldap-auth-port
+                   ::http-server-host
+                   ::http-server-port
+                   ::http-server-max-body-size
+                   ::http-server-max-multipart-body-size
+                   ::http-server-io-threads
+                   ::http-server-worker-threads
+                   ::initial-project-skey
+                   ::ldap-attrs-email
+                   ::ldap-attrs-fullname
+                   ::ldap-attrs-username
+                   ::ldap-base-dn
                    ::ldap-bind-dn
                    ::ldap-bind-password
-                   ::ldap-auth-ssl
-                   ::ldap-auth-starttls
-                   ::ldap-auth-base-dn
-                   ::ldap-auth-user-query
-                   ::ldap-auth-username-attribute
-                   ::ldap-auth-email-attribute
-                   ::ldap-auth-fullname-attribute
-                   ::ldap-auth-avatar-attribute]))
+                   ::ldap-host
+                   ::ldap-port
+                   ::ldap-ssl
+                   ::ldap-starttls
+                   ::ldap-user-query
+                   ::local-assets-uri
+                   ::loggers-loki-uri
+                   ::loggers-zmq-uri
+                   ::media-max-file-size
+                   ::profile-bounce-max-age
+                   ::profile-bounce-threshold
+                   ::profile-complaint-max-age
+                   ::profile-complaint-threshold
+                   ::public-uri
+                   ::redis-uri
+                   ::registration-domain-whitelist
+                   ::rpc-rlimit-config
 
-(defn env->config
-  [env]
-  (reduce-kv
-   (fn [acc k v]
-     (cond-> acc
-       (str/starts-with? (name k) "penpot-")
-       (assoc (keyword (subs (name k) 7)) v)
+                   ::semaphore-process-font
+                   ::semaphore-process-image
+                   ::semaphore-update-file
+                   ::semaphore-auth
 
-       (str/starts-with? (name k) "app-")
-       (assoc (keyword (subs (name k) 4)) v)))
-   {}
-   env))
+                   ::smtp-default-from
+                   ::smtp-default-reply-to
+                   ::smtp-host
+                   ::smtp-password
+                   ::smtp-port
+                   ::smtp-ssl
+                   ::smtp-tls
+                   ::smtp-username
 
-(defn read-config
-  [env]
-  (->> (env->config env)
-       (merge defaults)
-       (us/conform ::config)))
+                   ::srepl-host
+                   ::srepl-port
 
-(defn read-test-config
-  [env]
-  (assoc (read-config env)
-         :redis-uri "redis://redis/1"
-         :database-uri "postgresql://postgres/penpot_test"
-         :media-directory "/tmp/app/media"
-         :assets-directory "/tmp/app/static"
-         :migrations-verbose false))
+                   ::assets-storage-backend
+                   ::storage-assets-fs-directory
+                   ::storage-assets-s3-bucket
+                   ::storage-assets-s3-region
+                   ::storage-assets-s3-endpoint
+                   ::fdata-storage-backend
+                   ::storage-fdata-s3-bucket
+                   ::storage-fdata-s3-region
+                   ::storage-fdata-s3-prefix
+                   ::storage-fdata-s3-endpoint
+                   ::telemetry-enabled
+                   ::telemetry-uri
+                   ::telemetry-referer
+                   ::telemetry-with-taiga
+                   ::tenant]))
 
-(defstate config
-  :start (read-config env))
+(def default-flags
+  [:enable-backend-api-doc
+   :enable-backend-worker
+   :enable-secure-session-cookies
+   :enable-email-verification])
 
-(def default-deletion-delay
-  (dt/duration {:hours 48}))
+(defn- parse-flags
+  [config]
+  (flags/parse flags/default
+               default-flags
+               (:flags config)))
+
+(defn read-env
+  [prefix]
+  (let [prefix (str prefix "-")
+        len    (count prefix)]
+    (reduce-kv
+     (fn [acc k v]
+       (cond-> acc
+         (str/starts-with? (name k) prefix)
+         (assoc (keyword (subs (name k) len)) v)))
+     {}
+     env)))
+
+(defn- read-config
+  []
+  (try
+    (->> (read-env "penpot")
+         (merge defaults)
+         (us/conform ::config))
+    (catch Throwable e
+      (when (ex/ex-info? e)
+        (println ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;")
+        (println "Error on validating configuration:")
+        (println (us/pretty-explain (ex-data e)))
+        (println ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"))
+      (throw e))))
 
 (def version
-  (delay (v/parse "%version%")))
+  (v/parse (or (some-> (io/resource "version.txt")
+                       (slurp)
+                       (str/trim))
+               "%version%")))
 
-(defn smtp
-  [cfg]
-  {:host (:smtp-host cfg "localhost")
-   :port (:smtp-port cfg 25)
-   :default-reply-to (:smtp-default-reply-to cfg)
-   :default-from (:smtp-default-from cfg)
-   :tls (:smtp-tls cfg)
-   :enabled (:smtp-enabled cfg)
-   :username (:smtp-username cfg)
-   :password (:smtp-password cfg)})
+(defonce ^:dynamic config (read-config))
+(defonce ^:dynamic flags (parse-flags config))
 
+(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)))
+
+;; Set value for all new threads bindings.
+(alter-var-root #'*assert* (constantly (contains? flags :backend-asserts)))

backend/src/app/db.clj

@@ -2,65 +2,164 @@
 ;; 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
+;; Copyright (c) KALEIDOS INC
 
 (ns app.db
+  (:refer-clojure :exclude [get])
   (:require
+   [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.geom.point :as gpt]
-   [app.config :as cfg]
+   [app.common.logging :as l]
+   [app.common.spec :as us]
+   [app.common.transit :as t]
+   [app.common.uuid :as uuid]
+   [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.data.json :as json]
+   [clojure.java.io :as io]
    [clojure.spec.alpha :as s]
-   [clojure.string :as str]
-   [mount.core :as mount :refer [defstate]]
+   [integrant.core :as ig]
    [next.jdbc :as jdbc]
-   [next.jdbc.date-time :as jdbc-dt]
-   [next.jdbc.optional :as jdbc-opt]
-   [next.jdbc.sql :as jdbc-sql]
-   [next.jdbc.sql.builder :as jdbc-bld])
+   [next.jdbc.date-time :as jdbc-dt])
   (:import
    com.zaxxer.hikari.HikariConfig
    com.zaxxer.hikari.HikariDataSource
    com.zaxxer.hikari.metrics.prometheus.PrometheusMetricsTrackerFactory
+   io.whitfin.siphash.SipHasher
+   io.whitfin.siphash.SipHasherContainer
+   java.io.InputStream
+   java.io.OutputStream
+   java.lang.AutoCloseable
    java.sql.Connection
    java.sql.Savepoint
+   org.postgresql.PGConnection
    org.postgresql.geometric.PGpoint
    org.postgresql.jdbc.PgArray
+   org.postgresql.largeobject.LargeObject
+   org.postgresql.largeobject.LargeObjectManager
    org.postgresql.util.PGInterval
    org.postgresql.util.PGobject))
 
+(declare open)
+(declare create-pool)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Initialization
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare apply-migrations!)
+
+(s/def ::connection-timeout ::us/integer)
+(s/def ::max-size ::us/integer)
+(s/def ::min-size ::us/integer)
+(s/def ::migrations map?)
+(s/def ::name keyword?)
+(s/def ::password ::us/string)
+(s/def ::uri ::us/not-empty-string)
+(s/def ::username ::us/string)
+(s/def ::validation-timeout ::us/integer)
+(s/def ::read-only? ::us/boolean)
+
+(s/def ::pool-options
+  (s/keys :opt-un [::uri ::name
+                   ::min-size
+                   ::max-size
+                   ::connection-timeout
+                   ::validation-timeout
+                   ::migrations
+                   ::username
+                   ::password
+                   ::mtx/metrics
+                   ::read-only?]))
+
+(def defaults
+  {:name :main
+   :min-size 0
+   :max-size 60
+   :connection-timeout 10000
+   :validation-timeout 10000
+   :idle-timeout 120000 ; 2min
+   :max-lifetime 1800000 ; 30m
+   :read-only? false})
+
+(defmethod ig/prep-key ::pool
+  [_ cfg]
+  (merge defaults (d/without-nils cfg)))
+
+;; Don't validate here, just validate that a map is received.
+(defmethod ig/pre-init-spec ::pool [_] ::pool-options)
+
+(defmethod ig/init-key ::pool
+  [_ {:keys [migrations read-only? uri] :as cfg}]
+  (if uri
+    (let [pool (create-pool cfg)]
+      (l/info :hint "initialize connection pool"
+              :name (d/name (:name cfg))
+              :uri uri
+              :read-only read-only?
+              :with-credentials (and (contains? cfg :username)
+                                     (contains? cfg :password))
+              :min-size (:min-size cfg)
+              :max-size (:max-size cfg))
+      (when-not read-only?
+        (some->> (seq migrations) (apply-migrations! pool)))
+      pool)
+
+    (do
+      (l/warn :hint "unable to initialize pool, missing url"
+              :name (d/name (:name cfg))
+              :read-only read-only?)
+      nil)))
+
+(defmethod ig/halt-key! ::pool
+  [_ pool]
+  (when pool
+    (.close ^HikariDataSource pool)))
+
+(defn- apply-migrations!
+  [pool migrations]
+  (with-open [conn ^AutoCloseable (open pool)]
+    (mg/setup! conn)
+    (doseq [[name steps] migrations]
+      (mg/migrate! conn {:name (d/name name) :steps steps}))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; API & Impl
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (def initsql
-  (str "SET statement_timeout = 10000;\n"
-       "SET idle_in_transaction_session_timeout = 30000;"))
+  (str "SET statement_timeout = 300000;\n"
+       "SET idle_in_transaction_session_timeout = 300000;"))
 
 (defn- create-datasource-config
-  [cfg]
-  (let [dburi    (:database-uri cfg)
-        username (:database-username cfg)
-        password (:database-password cfg)
-        config (HikariConfig.)
-        mfactory (PrometheusMetricsTrackerFactory. mtx/registry)]
+  [{:keys [metrics uri] :as cfg}]
+  (let [config (HikariConfig.)]
     (doto config
-      (.setJdbcUrl (str "jdbc:" dburi))
-      (.setPoolName "main")
+      (.setJdbcUrl           (str "jdbc:" uri))
+      (.setPoolName          (d/name (:name cfg)))
       (.setAutoCommit true)
-      (.setReadOnly false)
-      (.setConnectionTimeout 8000)  ;; 8seg
-      (.setValidationTimeout 4000)  ;; 4seg
-      (.setIdleTimeout 300000)      ;; 5min
-      (.setMaxLifetime 900000)      ;; 15min
-      (.setMinimumIdle 0)
-      (.setMaximumPoolSize 15)
+      (.setReadOnly          (:read-only? cfg))
+      (.setConnectionTimeout (:connection-timeout cfg))
+      (.setValidationTimeout (:validation-timeout cfg))
+      (.setIdleTimeout       (:idle-timeout cfg))
+      (.setMaxLifetime       (:max-lifetime cfg))
+      (.setMinimumIdle       (:min-size cfg))
+      (.setMaximumPoolSize   (:max-size cfg))
       (.setConnectionInitSql initsql)
-      (.setMetricsTrackerFactory mfactory))
-    (when username (.setUsername config username))
-    (when password (.setPassword config password))
+      (.setInitializationFailTimeout -1))
+
+    ;; When metrics namespace is provided
+    (when metrics
+      (->> (::mtx/registry metrics)
+           (PrometheusMetricsTrackerFactory.)
+           (.setMetricsTrackerFactory config)))
+
+    (some->> ^String (:username cfg) (.setUsername config))
+    (some->> ^String (:password cfg) (.setPassword config))
+
     config))
 
 (defn pool?
@@ -69,96 +168,171 @@
 
 (s/def ::pool pool?)
 
-(defn pool-closed?
+(defn closed?
   [pool]
-  (.isClosed ^com.zaxxer.hikari.HikariDataSource pool))
+  (.isClosed ^HikariDataSource pool))
 
-(defn- create-pool
+(defn read-only?
+  [pool]
+  (.isReadOnly ^HikariDataSource pool))
+
+(defn create-pool
   [cfg]
   (let [dsc (create-datasource-config cfg)]
     (jdbc-dt/read-as-instant)
     (HikariDataSource. dsc)))
 
-(declare pool)
+(defn unwrap
+  [conn klass]
+  (.unwrap ^Connection conn klass))
 
-(defstate pool
-  :start (create-pool cfg/config)
-  :stop (.close pool))
+(defn lobj-manager
+  [conn]
+  (let [conn (unwrap conn org.postgresql.PGConnection)]
+    (.getLargeObjectAPI ^PGConnection conn)))
+
+(defn lobj-create
+  [manager]
+  (.createLO ^LargeObjectManager manager LargeObjectManager/READWRITE))
+
+(defn lobj-open
+  ([manager oid]
+   (lobj-open manager oid {}))
+  ([manager oid {:keys [mode] :or {mode :rw}}]
+   (let [mode (case mode
+                (:r :read) LargeObjectManager/READ
+                (:w :write) LargeObjectManager/WRITE
+                (:rw :read+write) LargeObjectManager/READWRITE)]
+     (.open ^LargeObjectManager manager (long oid) mode))))
+
+(defn lobj-unlink
+  [manager oid]
+  (.unlink ^LargeObjectManager manager (long oid)))
+
+(extend-type LargeObject
+  io/IOFactory
+  (make-reader [lobj opts]
+    (let [^InputStream is (.getInputStream ^LargeObject lobj)]
+      (io/make-reader is opts)))
+  (make-writer [lobj opts]
+    (let [^OutputStream os (.getOutputStream ^LargeObject lobj)]
+      (io/make-writer os opts)))
+  (make-input-stream [lobj opts]
+    (let [^InputStream is (.getInputStream ^LargeObject lobj)]
+      (io/make-input-stream is opts)))
+  (make-output-stream [lobj opts]
+    (let [^OutputStream os (.getOutputStream ^LargeObject lobj)]
+      (io/make-output-stream os opts))))
 
 (defmacro with-atomic
   [& args]
   `(jdbc/with-transaction ~@args))
 
-(defn- kebab-case [s] (str/replace s #"_" "-"))
-(defn- snake-case [s] (str/replace s #"-" "_"))
-(defn- as-kebab-maps
-  [rs opts]
-  (jdbc-opt/as-unqualified-modified-maps rs (assoc opts :label-fn kebab-case)))
-
 (defn open
-  []
+  [pool]
   (jdbc/get-connection pool))
 
 (defn exec!
   ([ds sv]
    (exec! ds sv {}))
   ([ds sv opts]
-   (jdbc/execute! ds sv (assoc opts :builder-fn as-kebab-maps))))
+   (jdbc/execute! ds sv (assoc opts :builder-fn sql/as-kebab-maps))))
 
 (defn exec-one!
   ([ds sv] (exec-one! ds sv {}))
   ([ds sv opts]
-   (jdbc/execute-one! ds sv (assoc opts :builder-fn as-kebab-maps))))
-
-(def ^:private default-options
-  {:table-fn snake-case
-   :column-fn snake-case
-   :builder-fn as-kebab-maps})
+   (jdbc/execute-one! ds sv (assoc opts :builder-fn sql/as-kebab-maps))))
 
 (defn insert!
-  [ds table params]
-  (jdbc-sql/insert! ds table params default-options))
+  ([ds table params] (insert! ds table params nil))
+  ([ds table params opts]
+   (exec-one! ds
+              (sql/insert table params opts)
+              (merge {:return-keys true} opts))))
+
+(defn insert-multi!
+  ([ds table cols rows] (insert-multi! ds table cols rows nil))
+  ([ds table cols rows opts]
+   (exec! ds
+          (sql/insert-multi table cols rows opts)
+          (merge {:return-keys true} opts))))
 
 (defn update!
-  [ds table params where]
-  (let [opts (assoc default-options :return-keys true)]
-    (jdbc-sql/update! ds table params where opts)))
+  ([ds table params where] (update! ds table params where nil))
+  ([ds table params where opts]
+   (exec-one! ds
+              (sql/update table params where opts)
+              (merge {:return-keys true} opts))))
 
 (defn delete!
-  [ds table params]
-  (let [opts (assoc default-options :return-keys true)]
-    (jdbc-sql/delete! ds table params opts)))
+  ([ds table params] (delete! ds table params nil))
+  ([ds table params opts]
+   (exec-one! ds
+              (sql/delete table params opts)
+              (assoc opts :return-keys true))))
+
+(defn is-row-deleted?
+  [{:keys [deleted-at]}]
+  (and (dt/instant? deleted-at)
+       (< (inst-ms deleted-at)
+          (inst-ms (dt/now)))))
+
+(defn get*
+  "Internal function for retrieve a single row from database that
+  matches a simple filters."
+  ([ds table params]
+   (get* ds table params nil))
+  ([ds table params {:keys [check-deleted?] :or {check-deleted? true} :as opts}]
+   (let [rows (exec! ds (sql/select table params opts))
+         rows (cond->> rows
+                check-deleted?
+                (remove is-row-deleted?))]
+     (first rows))))
+
+(defn get
+  ([ds table params]
+   (get ds table params nil))
+  ([ds table params {:keys [check-deleted?] :or {check-deleted? true} :as opts}]
+   (let [row (get* ds table params opts)]
+     (when (and (not row) check-deleted?)
+       (ex/raise :type :not-found
+                 :table table
+                 :hint "database object not found"))
+     row)))
 
 (defn get-by-params
+  "DEPRECATED"
   ([ds table params]
    (get-by-params ds table params nil))
-  ([ds table params opts]
-   (let [opts (cond-> (merge default-options opts)
-                (:for-update opts)
-                (assoc :suffix "for update"))
-         res  (exec-one! ds (jdbc-bld/for-query table params opts) opts)]
-     (when (or (:deleted-at res) (not res))
-       (ex/raise :type :not-found))
-     res)))
+  ([ds table params {:keys [check-not-found] :or {check-not-found true} :as opts}]
+   (let [row (get* ds table params (assoc opts :check-deleted? check-not-found))]
+     (when (and (not row) check-not-found)
+       (ex/raise :type :not-found
+                 :table table
+                 :hint "database object not found"))
+     row)))
 
 (defn get-by-id
   ([ds table id]
-   (get-by-params ds table {:id id} nil))
+   (get ds table {:id id} nil))
   ([ds table id opts]
-   (get-by-params ds table {:id id} opts)))
+   (let [opts (cond-> opts
+                (contains? opts :check-not-found)
+                (assoc :check-deleted? (:check-not-found opts)))]
+     (get ds table {:id id} opts))))
 
 (defn query
   ([ds table params]
    (query ds table params nil))
   ([ds table params opts]
-   (let [opts (cond-> (merge default-options opts)
-                (:for-update opts)
-                (assoc :suffix "for update"))]
-     (exec! ds (jdbc-bld/for-query table params opts) opts))))
+   (exec! ds (sql/select table params opts))))
 
 (defn pgobject?
-  [v]
-  (instance? PGobject v))
+  ([v]
+   (instance? PGobject v))
+  ([v type]
+   (and (instance? PGobject v)
+        (= type (.getType ^PGobject v)))))
 
 (defn pginterval?
   [v]
@@ -169,17 +343,39 @@
   (instance? PGpoint v))
 
 (defn pgarray?
-  [v]
-  (instance? PgArray v))
+  ([v] (instance? PgArray v))
+  ([v type]
+   (and (instance? PgArray v)
+        (= type (.getBaseTypeName ^PgArray v)))))
 
 (defn pgarray-of-uuid?
   [v]
   (and (pgarray? v) (= "uuid" (.getBaseTypeName ^PgArray v))))
 
+(defn decode-pgarray
+  ([v] (some->> ^PgArray v .getArray vec))
+  ([v in] (some->> ^PgArray v .getArray (into in)))
+  ([v in xf]  (some->> ^PgArray v .getArray (into in xf))))
+
+(defn pgarray->set
+  [v]
+  (set (.getArray ^PgArray v)))
+
+(defn pgarray->vector
+  [v]
+  (vec (.getArray ^PgArray v)))
+
 (defn pgpoint
   [p]
   (PGpoint. (:x p) (:y p)))
 
+(defn create-array
+  [conn type objects]
+  (let [^PGConnection conn (unwrap conn org.postgresql.PGConnection)]
+    (if (coll? objects)
+      (.createArrayOf conn ^String type (into-array Object objects))
+      (.createArrayOf conn ^String type objects))))
+
 (defn decode-pgpoint
   [^PGpoint v]
   (gpt/point (.-x v) (.-y v)))
@@ -201,23 +397,23 @@
    (.rollback conn sp)))
 
 (defn interval
-  [data]
+  [o]
   (cond
-    (integer? data)
-    (->> (/ data 1000.0)
+    (or (integer? o)
+        (float? o))
+    (->> (/ o 1000.0)
          (format "%s seconds")
          (pginterval))
 
-    (string? data)
-    (pginterval data)
+    (string? o)
+    (pginterval o)
 
-    (dt/duration? data)
-    (->> (/ (.toMillis data) 1000.0)
-         (format "%s seconds")
-         (pginterval))
+    (dt/duration? o)
+    (interval (inst-ms o))
 
     :else
-    (ex/raise :type :not-implemented)))
+    (ex/raise :type :not-implemented
+              :hint (format "no implementation found for value %s" (pr-str o)))))
 
 (defn decode-json-pgobject
   [^PGobject o]
@@ -225,7 +421,7 @@
         val (.getValue o)]
     (if (or (= typ "json")
             (= typ "jsonb"))
-      (json/read-str val :key-fn keyword)
+      (json/read val)
       val)))
 
 (defn decode-transit-pgobject
@@ -237,12 +433,24 @@
       (t/decode-str val)
       val)))
 
+(defn inet
+  [ip-addr]
+  (doto (org.postgresql.util.PGobject.)
+    (.setType "inet")
+    (.setValue (str ip-addr))))
+
+(defn decode-inet
+  [^PGobject o]
+  (if (= "inet" (.getType o))
+    (.getValue o)
+    nil))
+
 (defn tjson
   "Encode as transit json."
   [data]
   (doto (org.postgresql.util.PGobject.)
     (.setType "jsonb")
-    (.setValue (t/encode-verbose-str data))))
+    (.setValue (t/encode-str data {:type :json-verbose}))))
 
 (defn json
   "Encode as plain json."
@@ -251,18 +459,32 @@
     (.setType "jsonb")
     (.setValue (json/write-str data))))
 
-(defn pgarray->set
-  [v]
-  (set (.getArray ^PgArray v)))
+;; --- Locks
 
-(defn pgarray->vector
-  [v]
-  (vec (.getArray ^PgArray v)))
+(def ^:private siphash-state
+  (SipHasher/container
+   (uuid/get-bytes uuid/zero)))
 
-;; Instrumentation
+(defn uuid->hash-code
+  [o]
+  (.hash ^SipHasherContainer siphash-state
+         ^bytes (uuid/get-bytes o)))
 
-(mtx/instrument-with-counter!
- {:var [#'jdbc/execute-one!
-        #'jdbc/execute!]
-  :id "database__query_counter"
-  :help "An absolute counter of database queries."})
+(defn- xact-check-param
+  [n]
+  (cond
+    (uuid? n) (uuid->hash-code n)
+    (int? n)  n
+    :else (throw (IllegalArgumentException. "uuid or number allowed"))))
+
+(defn xact-lock!
+  [conn n]
+  (let [n (xact-check-param n)]
+    (exec-one! conn ["select pg_advisory_xact_lock(?::bigint) as lock" n])
+    true))
+
+(defn xact-try-lock!
+  [conn n]
+  (let [n   (xact-check-param n)
+        row (exec-one! conn ["select pg_try_advisory_xact_lock(?::bigint) as lock" n])]
+    (:lock row)))

backend/src/app/db/sql.clj

@@ -0,0 +1,62 @@
+;; 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) KALEIDOS INC
+
+(ns app.db.sql
+  (:refer-clojure :exclude [update])
+  (:require
+   [clojure.string :as str]
+   [next.jdbc.optional :as jdbc-opt]
+   [next.jdbc.sql.builder :as sql]))
+
+(defn kebab-case [s] (str/replace s #"_" "-"))
+(defn snake-case [s] (str/replace s #"-" "_"))
+
+(def default-opts
+  {:table-fn snake-case
+   :column-fn snake-case})
+
+(defn as-kebab-maps
+  [rs opts]
+  (jdbc-opt/as-unqualified-modified-maps rs (assoc opts :label-fn kebab-case)))
+
+(defn insert
+  ([table key-map]
+   (insert table key-map nil))
+  ([table key-map opts]
+   (let [opts (merge default-opts opts)
+         opts (cond-> opts
+                (:on-conflict-do-nothing opts)
+                (assoc :suffix "ON CONFLICT DO NOTHING"))]
+     (sql/for-insert table key-map opts))))
+
+(defn insert-multi
+  [table cols rows opts]
+  (let [opts (merge default-opts opts)]
+    (sql/for-insert-multi table cols rows opts)))
+
+(defn select
+  ([table where-params]
+   (select table where-params nil))
+  ([table where-params opts]
+   (let [opts (merge default-opts opts)
+         opts (cond-> opts
+                (:for-update opts)    (assoc :suffix "FOR UPDATE")
+                (:for-key-share opts) (assoc :suffix "FOR KEY SHARE"))]
+     (sql/for-query table where-params opts))))
+
+(defn update
+  ([table key-map where-params]
+   (update table key-map where-params nil))
+  ([table key-map where-params opts]
+   (let [opts (merge default-opts opts)]
+     (sql/for-update table key-map where-params opts))))
+
+(defn delete
+  ([table where-params]
+   (delete table where-params nil))
+  ([table where-params opts]
+   (let [opts (merge default-opts opts)]
+     (sql/for-delete table where-params opts))))

backend/src/app/emails.clj

@@ -2,46 +2,357 @@
 ;; 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
+;; Copyright (c) KALEIDOS INC
 
 (ns app.emails
   "Main api for send emails."
   (:require
+   [app.common.exceptions :as ex]
+   [app.common.logging :as l]
+   [app.common.pprint :as pp]
    [app.common.spec :as us]
-   [app.config :as cfg]
-   [app.tasks :as tasks]
-   [app.util.emails :as emails]
-   [clojure.spec.alpha :as s]))
+   [app.config :as cf]
+   [app.db :as db]
+   [app.db.sql :as sql]
+   [app.emails.invite-to-team :as-alias emails.invite-to-team]
+   [app.metrics :as mtx]
+   [app.util.template :as tmpl]
+   [app.worker :as wrk]
+   [clojure.java.io :as io]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [integrant.core :as ig])
+  (:import
+   jakarta.mail.Message$RecipientType
+   jakarta.mail.Session
+   jakarta.mail.Transport
+   jakarta.mail.internet.InternetAddress
+   jakarta.mail.internet.MimeBodyPart
+   jakarta.mail.internet.MimeMessage
+   jakarta.mail.internet.MimeMultipart
+   java.util.Properties))
 
-;; --- Defaults
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; EMAIL IMPL
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defn default-context
-  []
-  {:assets-uri (:assets-uri cfg/config)
-   :public-uri (:public-uri cfg/config)})
+(defn- parse-address
+  [v]
+  (InternetAddress/parse ^String v))
 
-;; --- Public API
+(defn- resolve-recipient-type
+  ^Message$RecipientType
+  [type]
+  (case type
+    :to  Message$RecipientType/TO
+    :cc  Message$RecipientType/CC
+    :bcc Message$RecipientType/BCC))
+
+(defn- assign-recipient
+  [^MimeMessage mmsg type address]
+  (if (sequential? address)
+    (reduce #(assign-recipient %1 type %2) mmsg address)
+    (let [address (parse-address address)
+          type    (resolve-recipient-type type)]
+      (.addRecipients mmsg type address)
+      mmsg)))
+(defn- assign-recipients
+  [mmsg {:keys [to cc bcc] :as params}]
+  (cond-> mmsg
+    (some? to)  (assign-recipient :to to)
+    (some? cc)  (assign-recipient :cc cc)
+    (some? bcc) (assign-recipient :bcc bcc)))
+
+(defn- assign-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 [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 (parse-address reply-to)]
+        (.setReplyTo ^MimeMessage mmsg reply-to)))))
+
+(defn- assign-subject
+  [mmsg {:keys [subject charset] :or {charset "utf-8"} :as params}]
+  (assert (string? subject) "subject is mandatory")
+  (.setSubject ^MimeMessage mmsg
+               ^String subject
+               ^String charset))
+
+(defn- assign-extra-headers
+  [^MimeMessage mmsg {:keys [headers extra-data] :as params}]
+  (let [headers (assoc headers "X-Penpot-Data" extra-data)]
+    (reduce-kv (fn [^MimeMessage mmsg k v]
+                 (doto mmsg
+                   (.addHeader (name k) (str v))))
+               mmsg
+               headers)))
+
+(defn- assign-body
+  [^MimeMessage mmsg {:keys [body charset] :or {charset "utf-8"}}]
+  (let [mpart (MimeMultipart. "mixed")]
+    (cond
+      (string? body)
+      (let [bpart (MimeBodyPart.)]
+        (.setContent bpart ^String body (str "text/plain; charset=" charset))
+        (.addBodyPart mpart bpart))
+
+      (vector? body)
+      (let [mmp (MimeMultipart. "alternative")
+            mbp (MimeBodyPart.)]
+        (.addBodyPart mpart mbp)
+        (.setContent mbp mmp)
+        (doseq [item body]
+          (let [mbp (MimeBodyPart.)]
+            (.setContent mbp
+                         ^String (:content item)
+                         ^String (str (:type item "text/plain") "; charset=" charset))
+            (.addBodyPart mmp mbp))))
+
+      (map? body)
+      (let [bpart (MimeBodyPart.)]
+        (.setContent bpart
+                     ^String (:content body)
+                     ^String (str (:type body "text/plain") "; charset=" charset))
+        (.addBodyPart mpart bpart))
+
+      :else
+      (throw (ex-info "Unsupported type" {:body body})))
+    (.setContent mmsg mpart)
+    mmsg))
+
+(defn- opts->props
+  [{:keys [username tls host port timeout default-from]
+    :or {timeout 30000}
+    :as opts}]
+  (reduce-kv
+   (fn [^Properties props k v]
+     (if (nil? v)
+       props
+       (doto props (.put ^String k  ^String (str v)))))
+   (Properties.)
+   {"mail.user" username
+    "mail.host" host
+    "mail.debug" (contains? cf/flags :smtp-debug)
+    "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.user" username
+    "mail.smtp.timeout" timeout
+    "mail.smtp.connectiontimeout" timeout}))
+
+(defn- create-smtp-session
+  [opts]
+  (let [props (opts->props opts)]
+    (Session/getInstance props)))
+
+(defn- create-smtp-message
+  ^MimeMessage
+  [cfg session params]
+  (let [mmsg (MimeMessage. ^Session session)]
+    (assign-recipients mmsg params)
+    (assign-from mmsg cfg params)
+    (assign-reply-to mmsg cfg params)
+    (assign-subject mmsg params)
+    (assign-extra-headers mmsg params)
+    (assign-body mmsg params)
+    (.saveChanges ^MimeMessage mmsg)
+    mmsg))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; TEMPLATE EMAIL IMPL
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^:private email-path "app/emails/%(id)s/%(lang)s.%(type)s")
+
+(defn- render-email-template-part
+  [type id context]
+  (let [lang (:lang context :en)
+        path (str/format email-path {:id (name id)
+                                     :lang (name lang)
+                                     :type (name type)})]
+    (some-> (io/resource path)
+            (tmpl/render context))))
+
+(defn- build-email-template
+  [id context]
+  (let [subj (render-email-template-part :subj id context)
+        text (render-email-template-part :txt id context)
+        html (render-email-template-part :html id context)]
+    (when (or (not subj)
+              (and (not text)
+                   (not html)))
+      (ex/raise :type :internal
+                :code :missing-email-templates))
+    {:subject subj
+     :body (into
+            [{:type "text/plain"
+              :content text}]
+            (when html
+              [{:type "text/html"
+                :content html}]))}))
+
+(s/def ::priority #{:high :low})
+(s/def ::to (s/or :single ::us/email
+                  :multi (s/coll-of ::us/email)))
+(s/def ::from ::us/email)
+(s/def ::reply-to ::us/email)
+(s/def ::lang string?)
+(s/def ::extra-data ::us/string)
+
+(s/def ::context
+  (s/keys :req-un [::to]
+          :opt-un [::reply-to ::from ::lang ::priority ::extra-data]))
+
+(defn template-factory
+  ([id] (template-factory id {}))
+  ([id extra-context]
+   (s/assert keyword? id)
+   (fn [context]
+     (us/verify ::context context)
+     (when-let [spec (s/get-spec id)]
+       (s/assert spec context))
+
+     (let [context (merge (if (fn? extra-context)
+                            (extra-context)
+                            extra-context)
+                          context)
+           email   (build-email-template id context)]
+       (when-not email
+         (ex/raise :type :internal
+                   :code :email-template-does-not-exists
+                   :hint "seems like the template is wrong or does not exists."
+                   :context {:id id}))
+       (cond-> (assoc email :id (name id))
+         (:extra-data context)
+         (assoc :extra-data (:extra-data context))
+
+         (:from context)
+         (assoc :from (:from context))
+
+         (:reply-to context)
+         (assoc :reply-to (:reply-to context))
+
+         (:to context)
+         (assoc :to (:to context)))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PUBLIC HIGH-LEVEL API
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defn render
   [email-factory context]
   (email-factory context))
 
 (defn send!
-  "Schedule the email for sending."
-  [conn email-factory context]
-  (us/verify fn? email-factory)
-  (us/verify map? context)
-  (let [email (email-factory context)]
-    (tasks/submit! conn {:name "sendmail"
-                         :delay 0
-                         :max-retries 1
-                         :priority 200
-                         :props email})))
+  "Schedule an already defined email to be sent using asynchronously
+  using worker task."
+  [{:keys [::conn ::factory] :as context}]
+  (us/verify fn? factory)
+  (us/verify some? conn)
+  (let [email (factory context)]
+    (wrk/submit! (assoc email
+                        ::wrk/task :sendmail
+                        ::wrk/delay 0
+                        ::wrk/max-retries 4
+                        ::wrk/priority 200
+                        ::wrk/conn conn))))
 
-;; --- Emails
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SENDMAIL FN / TASK HANDLER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(s/def ::username ::cf/smtp-username)
+(s/def ::password ::cf/smtp-password)
+(s/def ::tls ::cf/smtp-tls)
+(s/def ::ssl ::cf/smtp-ssl)
+(s/def ::host ::cf/smtp-host)
+(s/def ::port ::cf/smtp-port)
+(s/def ::default-reply-to ::cf/smtp-default-reply-to)
+(s/def ::default-from ::cf/smtp-default-from)
+
+(s/def ::smtp-config
+  (s/keys :opt-un [::username
+                   ::password
+                   ::tls
+                   ::ssl
+                   ::host
+                   ::port
+                   ::default-from
+                   ::default-reply-to]))
+
+(declare send-to-logger!)
+
+(s/def ::sendmail fn?)
+
+(defmethod ig/pre-init-spec ::sendmail [_]
+  (s/spec ::smtp-config))
+
+(defmethod ig/init-key ::sendmail
+  [_ cfg]
+  (fn [params]
+    (when (contains? cf/flags :smtp)
+      (let [session (create-smtp-session cfg)]
+        (with-open [transport (.getTransport session (if (:ssl cfg) "smtps" "smtp"))]
+          (.connect ^Transport transport
+                    ^String (:username cfg)
+                    ^String (:password cfg))
+
+          (let [^MimeMessage message (create-smtp-message cfg session params)]
+            (.sendMessage ^Transport transport
+                          ^MimeMessage message
+                          (.getAllRecipients message))))))
+
+    (when (or (contains? cf/flags :log-emails)
+              (not (contains? cf/flags :smtp)))
+      (send-to-logger! cfg params))))
+
+(defmethod ig/pre-init-spec ::handler [_]
+  (s/keys :req-un [::sendmail ::mtx/metrics]))
+
+(defmethod ig/init-key ::handler
+  [_ {:keys [sendmail]}]
+  (fn [{:keys [props] :as task}]
+    (sendmail props)))
+
+(defn- send-to-logger!
+  [_ email]
+  (let [body (:body email)
+        out  (with-out-str
+               (println "email console dump:")
+               (println "******** start email" (:id email) "**********")
+               (pp/pprint (dissoc email :body))
+               (if (string? body)
+                 (println body)
+                 (println (->> body
+                               (filter #(= "text/plain" (:type %)))
+                               (map :content)
+                               first)))
+               (println "******** end email" (:id email) "**********"))]
+    (l/info ::l/raw out)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; EMAIL FACTORIES
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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."
+  (template-factory ::feedback))
 
 (s/def ::name ::us/string)
 (s/def ::register
@@ -49,7 +360,7 @@
 
 (def register
   "A new profile registration welcome email."
-  (emails/template-factory ::register default-context))
+  (template-factory ::register))
 
 (s/def ::token ::us/string)
 (s/def ::password-recovery
@@ -57,7 +368,7 @@
 
 (def password-recovery
   "A password recovery notification email."
-  (emails/template-factory ::password-recovery default-context))
+  (template-factory ::password-recovery))
 
 (s/def ::pending-email ::us/email)
 (s/def ::change-email
@@ -65,17 +376,67 @@
 
 (def change-email
   "Password change confirmation email"
-  (emails/template-factory ::change-email default-context))
+  (template-factory ::change-email))
 
-(s/def :internal.emails.invite-to-team/invited-by ::us/string)
-(s/def :internal.emails.invite-to-team/team ::us/string)
-(s/def :internal.emails.invite-to-team/token ::us/string)
+(s/def ::emails.invite-to-team/invited-by ::us/string)
+(s/def ::emails.invite-to-team/team ::us/string)
+(s/def ::emails.invite-to-team/token ::us/string)
 
 (s/def ::invite-to-team
-  (s/keys :keys [:internal.emails.invite-to-team/invited-by
-                 :internal.emails.invite-to-team/token
-                 :internal.emails.invite-to-team/team]))
+  (s/keys :req-un [::emails.invite-to-team/invited-by
+                   ::emails.invite-to-team/token
+                   ::emails.invite-to-team/team]))
 
 (def invite-to-team
   "Teams member invitation email."
-  (emails/template-factory ::invite-to-team default-context))
+  (template-factory ::invite-to-team))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BOUNCE/COMPLAINS HELPERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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 (cf/get :profile-complaint-threshold)
+          complaint-max-age   (cf/get :profile-complaint-max-age)
+          bounce-threshold    (cf/get :profile-bounce-threshold)
+          bounce-max-age      (cf/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 (< (or complaints 0) complaint-threshold)
+           (< (or bounces 0) 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))))

backend/src/app/error_reporter.clj

@@ -1,83 +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 Andrey Antukh <niwi@niwi.nz>
-
-(ns app.error-reporter
-  "A mattermost integration for error reporting."
-  (:require
-   [app.common.exceptions :as ex]
-   [app.common.spec :as us]
-   [app.config :as cfg]
-   [app.db :as db]
-   [app.tasks :as tasks]
-   [app.util.async :as aa]
-   [app.worker :as wrk]
-   [app.util.http :as http]
-   [clojure.core.async :as a]
-   [clojure.data.json :as json]
-   [clojure.spec.alpha :as s]
-   [clojure.tools.logging :as log]
-   [cuerdas.core :as str]
-   [mount.core :as mount :refer [defstate]]
-   [promesa.exec :as px]))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Public API
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defonce enqueue identity)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Implementation
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defn- send-to-mattermost!
-  [log-event]
-  (try
-    (let [text  (str/fmt "Unhandled exception: `host='%s'`, `version=%s`.\n@channel ⇊\n```%s\n```"
-                         (:host cfg/config)
-                         (:full @cfg/version)
-                         (str log-event))
-          rsp   (http/send! {:uri (:error-reporter-webhook cfg/config)
-                             :method :post
-                             :headers {"content-type" "application/json"}
-                             :body (json/write-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))))
-    (catch Exception e
-      (log/warnf e "Unexpected exception on error reporter."))))
-
-(defn- send!
-  [val]
-  (aa/thread-call wrk/executor (partial send-to-mattermost! val)))
-
-(defn- start
-  []
-  (let [qch (a/chan (a/sliding-buffer 128))]
-    (log/info "Starting error reporter loop.")
-
-    ;; Only enable when a valid URL is provided.
-    (when (:error-reporter-webhook cfg/config)
-      (alter-var-root #'enqueue (constantly #(a/>!! qch %)))
-      (a/go-loop []
-        (let [val (a/<! qch)]
-          (if (nil? val)
-            (do
-              (log/info "Closing error reporting loop.")
-              (alter-var-root #'enqueue (constantly identity)))
-            (do
-              (a/<! (send! val))
-              (recur))))))
-
-    qch))
-
-(defstate reporter
-  :start (start)
-  :stop  (a/close! reporter))

backend/src/app/http.clj

@@ -2,79 +2,179 @@
 ;; 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
+;; Copyright (c) KALEIDOS INC
 
 (ns app.http
   (:require
-   [app.config :as cfg]
-   [app.http.auth :as auth]
-   [app.http.auth.gitlab :as gitlab]
-   [app.http.auth.google :as google]
-   [app.http.auth.ldap :as ldap]
+   [app.common.data :as d]
+   [app.common.logging :as l]
+   [app.common.transit :as t]
    [app.http.errors :as errors]
-   [app.http.handlers :as handlers]
-   [app.http.middleware :as middleware]
-   [app.http.session :as session]
-   [app.http.ws :as ws]
+   [app.http.middleware :as mw]
    [app.metrics :as mtx]
-   [clojure.tools.logging :as log]
-   [mount.core :as mount :refer [defstate]]
-   [reitit.ring :as rring]
-   [ring.adapter.jetty9 :as jetty]))
+   [app.worker :as wrk]
+   [clojure.spec.alpha :as s]
+   [integrant.core :as ig]
+   [reitit.core :as r]
+   [reitit.middleware :as rr]
+   [yetti.adapter :as yt]
+   [yetti.request :as yrq]
+   [yetti.response :as yrs]))
 
-(defn- create-router
-  []
-  (rring/router
-   [["/metrics" {:get mtx/dump}]
-    ["/api" {:middleware [[middleware/format-response-body]
-                          [middleware/parse-request-body]
-                          [middleware/errors errors/handle]
-                          [middleware/params]
-                          [middleware/multipart-params]
-                          [middleware/keyword-params]
-                          [middleware/cookies]]}
+(declare wrap-router)
 
-     ["/oauth"
-      ["/google" {:post google/auth}]
-      ["/google/callback" {:get google/callback}]
-      ["/gitlab" {:post gitlab/auth}]
-      ["/gitlab/callback" {:get gitlab/callback}]]
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HTTP SERVER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-     ["/echo" {:get handlers/echo-handler
-               :post handlers/echo-handler}]
+(s/def ::handler fn?)
+(s/def ::router some?)
+(s/def ::port integer?)
+(s/def ::host string?)
+(s/def ::name string?)
 
-     ["/login" {:handler auth/login-handler
-                :method :post}]
-     ["/logout" {:handler auth/logout-handler
-                 :method :post}]
-     ["/login-ldap" {:handler ldap/auth
-                     :method :post}]
+(s/def ::max-body-size integer?)
+(s/def ::max-multipart-body-size integer?)
+(s/def ::io-threads integer?)
+(s/def ::worker-threads integer?)
 
-     ["/w" {:middleware [session/middleware]}
-      ["/query/:type" {:get handlers/query-handler}]
-      ["/mutation/:type" {:post handlers/mutation-handler}]]]]))
+(defmethod ig/prep-key ::server
+  [_ cfg]
+  (merge {:name "http"
+          :port 6060
+          :host "0.0.0.0"
+          :max-body-size (* 1024 1024 30)             ; 30 MiB
+          :max-multipart-body-size (* 1024 1024 120)} ; 120 MiB
+         (d/without-nils cfg)))
 
-(defn start-server
-  []
-  (let [wsockets {"/ws/notifications" ws/handler}
-        options  {:port (:http-server-port cfg/config)
-                  :h2c? true
-                  :join? false
-                  :allow-null-path-info true
-                  :websockets wsockets}
-        handler  (rring/ring-handler
-                  (create-router)
-                  (constantly {:status 404, :body ""})
-                  {:middleware [[middleware/development-resources]
-                                [middleware/development-cors]
-                                [middleware/metrics]]})]
-    (log/infof "Http server listening on http://localhost:%s/"
-               (:http-server-port cfg/config))
-    (jetty/run-jetty handler options)))
+(defmethod ig/pre-init-spec ::server [_]
+  (s/and
+   (s/keys :req-un [::port ::host ::name ::max-body-size ::max-multipart-body-size]
+           :opt-un [::router ::handler ::io-threads ::worker-threads ::wrk/executor])
+   (fn [cfg]
+     (or (contains? cfg :router)
+         (contains? cfg :handler)))))
 
-(defstate server
-  :start (start-server)
-  :stop (.stop server))
+(defmethod ig/init-key ::server
+  [_ {:keys [handler router port name host] :as cfg}]
+  (l/info :hint "starting http server" :port port :host host :name name)
+  (let [options {:http/port port
+                 :http/host host
+                 :http/max-body-size (:max-body-size cfg)
+                 :http/max-multipart-body-size (:max-multipart-body-size cfg)
+                 :xnio/io-threads (:io-threads cfg)
+                 :xnio/worker-threads (:worker-threads cfg)
+                 :xnio/dispatch (:executor cfg)
+                 :ring/async true}
+
+        handler (if (some? router)
+                  (wrap-router router)
+
+                  handler)
+        server  (yt/server handler (d/without-nils options))]
+    (assoc cfg :server (yt/start! server))))
+
+(defmethod ig/halt-key! ::server
+  [_ {:keys [server name port] :as cfg}]
+  (l/info :msg "stoping http server" :name name :port port)
+  (yt/stop! server))
+
+(defn- not-found-handler
+  [_ respond _]
+  (respond (yrs/response 404)))
+
+(defn- wrap-router
+  [router]
+  (letfn [(handler [request respond raise]
+            (if-let [match (r/match-by-path router (yrq/path request))]
+              (let [params  (:path-params match)
+                    result  (:result match)
+                    handler (or (:handler result) not-found-handler)
+                    request (-> request
+                                (assoc :path-params params)
+                                (update :params merge params))]
+                (handler request respond raise))
+              (not-found-handler request respond raise)))
+
+          (on-error [cause request respond]
+            (let [{:keys [body] :as response} (errors/handle cause request)]
+              (respond
+               (cond-> response
+                 (map? body)
+                 (-> (update :headers assoc "content-type" "application/transit+json")
+                     (assoc :body (t/encode-str body {:type :json-verbose})))))))]
+
+    (fn [request respond _]
+      (try
+        (handler request respond #(on-error % request respond))
+        (catch Throwable cause
+          (on-error cause request respond))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HTTP ROUTER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(s/def ::assets map?)
+(s/def ::audit-handler fn?)
+(s/def ::awsns-handler fn?)
+(s/def ::debug-routes (s/nilable vector?))
+(s/def ::doc-routes (s/nilable vector?))
+(s/def ::feedback fn?)
+(s/def ::oauth map?)
+(s/def ::oidc-routes (s/nilable vector?))
+(s/def ::rpc-routes (s/nilable vector?))
+(s/def ::session map?)
+(s/def ::storage map?)
+(s/def ::ws fn?)
+
+(defmethod ig/pre-init-spec ::router [_]
+  (s/keys :req-un [::mtx/metrics
+                   ::ws
+                   ::storage
+                   ::assets
+                   ::session
+                   ::feedback
+                   ::awsns-handler
+                   ::debug-routes
+                   ::oidc-routes
+                   ::audit-handler
+                   ::rpc-routes
+                   ::doc-routes]))
+
+(defmethod ig/init-key ::router
+  [_ {:keys [ws session metrics assets feedback] :as cfg}]
+  (rr/router
+   [["" {:middleware [[mw/server-timing]
+                      [mw/format-response]
+                      [mw/params]
+                      [mw/parse-request]
+                      [mw/errors errors/handle]
+                      [mw/restrict-methods]]}
+
+     ["/metrics" {:handler (::mtx/handler metrics)
+                  :allowed-methods #{:get}}]
+
+     ["/assets" {:middleware [(:middleware session)]}
+      ["/by-id/:id" {:handler (:objects-handler assets)}]
+      ["/by-file-media-id/:id" {:handler (:file-objects-handler assets)}]
+      ["/by-file-media-id/:id/thumbnail" {:handler (:file-thumbnails-handler assets)}]]
+
+     (:debug-routes cfg)
+
+     ["/webhooks"
+      ["/sns" {:handler (:awsns-handler cfg)
+               :allowed-methods #{:post}}]]
+
+     ["/ws/notifications" {:middleware [(:middleware session)]
+                           :handler ws
+                           :allowed-methods #{:get}}]
+
+     ["/api" {:middleware [[mw/cors]
+                           [(:middleware session)]]}
+      ["/audit/events" {:handler (:audit-handler cfg)
+                        :allowed-methods #{:post}}]
+      ["/feedback" {:handler feedback
+                    :allowed-methods #{:post}}]
+      (:doc-routes cfg)
+      (:oidc-routes cfg)
+      (:rpc-routes cfg)]]]))

backend/src/app/http/assets.clj

@@ -0,0 +1,131 @@
+;; 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) KALEIDOS INC
+
+(ns app.http.assets
+  "Assets related handlers."
+  (:require
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.common.uri :as u]
+   [app.db :as db]
+   [app.metrics :as mtx]
+   [app.storage :as sto]
+   [app.util.time :as dt]
+   [app.worker :as wrk]
+   [clojure.spec.alpha :as s]
+   [integrant.core :as ig]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.response :as yrs]))
+
+(def ^:private cache-max-age
+  (dt/duration {:hours 24}))
+
+(def ^:private signature-max-age
+  (dt/duration {:hours 24 :minutes 15}))
+
+(defn coerce-id
+  [id]
+  (let [res (parse-uuid id)]
+    (when-not (uuid? res)
+      (ex/raise :type :not-found
+                :hint "object not found"))
+    res))
+
+(defn- get-file-media-object
+  [{:keys [pool executor] :as storage} id]
+  (px/with-dispatch executor
+    (let [id   (coerce-id id)
+          mobj (db/exec-one! pool ["select * from file_media_object where id=?" id])]
+      (when-not mobj
+        (ex/raise :type :not-found
+                  :hint "object does not found"))
+      mobj)))
+
+(defn- serve-object
+  "Helper function that returns the appropriate response depending on
+  the storage object backend type."
+  [{:keys [storage] :as cfg} obj]
+  (let [mdata   (meta obj)
+        backend (sto/resolve-backend storage (:backend obj))]
+    (case (:type backend)
+      :s3
+      (p/let [{:keys [host port] :as url} (sto/get-object-url storage obj {:max-age signature-max-age})]
+        (yrs/response :status  307
+                      :headers {"location" (str url)
+                                "x-host"   (cond-> host port (str ":" port))
+                                "x-mtype"  (:content-type mdata)
+                                "cache-control" (str "max-age=" (inst-ms cache-max-age))}))
+
+      :fs
+      (p/let [purl (u/uri (:assets-path cfg))
+              purl (u/join purl (sto/object->relative-path obj))]
+        (yrs/response :status  204
+                      :headers {"x-accel-redirect" (:path purl)
+                                "content-type" (:content-type mdata)
+                                "cache-control" (str "max-age=" (inst-ms cache-max-age))})))))
+
+(defn objects-handler
+  "Handler that servers storage objects by id."
+  [{:keys [storage executor] :as cfg} request respond raise]
+  (-> (px/with-dispatch executor
+        (p/let [id  (get-in request [:path-params :id])
+                id  (coerce-id id)
+                obj (sto/get-object storage id)]
+          (if obj
+            (serve-object cfg obj)
+            (yrs/response 404))))
+
+      (p/bind p/wrap)
+      (p/then' respond)
+      (p/catch raise)))
+
+(defn- generic-handler
+  "A generic handler helper/common code for file-media based handlers."
+  [{:keys [storage] :as cfg} request kf]
+  (p/let [id   (get-in request [:path-params :id])
+          mobj (get-file-media-object storage id)
+          obj  (sto/get-object storage (kf mobj))]
+    (if obj
+      (serve-object cfg obj)
+      (yrs/response 404))))
+
+(defn file-objects-handler
+  "Handler that serves storage objects by file media id."
+  [cfg request respond raise]
+  (-> (generic-handler cfg request :media-id)
+      (p/then respond)
+      (p/catch raise)))
+
+(defn file-thumbnails-handler
+  "Handler that serves storage objects by thumbnail-id and quick
+  fallback to file-media-id if no thumbnail is available."
+  [cfg request respond raise]
+  (-> (generic-handler cfg request #(or (:thumbnail-id %) (:media-id %)))
+      (p/then respond)
+      (p/catch raise)))
+
+;; --- Initialization
+
+(s/def ::storage some?)
+(s/def ::assets-path ::us/string)
+(s/def ::cache-max-age ::dt/duration)
+(s/def ::signature-max-age ::dt/duration)
+
+(defmethod ig/pre-init-spec ::handlers [_]
+  (s/keys :req-un [::storage
+                   ::wrk/executor
+                   ::mtx/metrics
+                   ::assets-path
+                   ::cache-max-age
+                   ::signature-max-age]))
+
+(defmethod ig/init-key ::handlers
+  [_ cfg]
+  {:objects-handler (partial objects-handler cfg)
+   :file-objects-handler (partial file-objects-handler cfg)
+   :file-thumbnails-handler (partial file-thumbnails-handler cfg)})
+

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]
-   [app.services.mutations :as sm]))
-
-(defn login-handler
-  [req]
-  (let [data    (:body-params req)
-        uagent  (get-in req [:headers "user-agent"])
-        profile (sm/handle (assoc data ::sm/type :login))
-        id      (session/create (:id profile) uagent)]
-    {:status 200
-     :cookies (session/cookies id)
-     :body profile}))
-
-(defn logout-handler
-  [req]
-  (some-> (session/extract-auth-token req)
-          (session/delete))
-  {:status 200
-   :cookies (session/cookies "" {:max-age -1})
-   :body ""})

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

@@ -1,147 +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.exceptions :as ex]
-   [app.config :as cfg]
-   [app.http.session :as session]
-   [app.services.mutations :as sm]
-   [app.services.tokens :as tokens]
-   [app.util.http :as http]
-   [app.util.time :as dt]
-   [clojure.data.json :as json]
-   [clojure.tools.logging :as log]
-   [lambdaisland.uri :as uri]))
-
-(def default-base-gitlab-uri "https://gitlab.com")
-
-(def scope "read_user")
-
-(defn- build-redirect-url
-  []
-  (let [public (uri/uri (:public-uri cfg/config))]
-    (str (assoc public :path "/api/oauth/gitlab/callback"))))
-
-
-(defn- build-oauth-uri
-  []
-  (let [base-uri (uri/uri (:gitlab-base-uri cfg/config default-base-gitlab-uri))]
-    (assoc base-uri :path "/oauth/authorize")))
-
-
-(defn- build-token-url
-  []
-  (let [base-uri (uri/uri (:gitlab-base-uri cfg/config default-base-gitlab-uri))]
-    (str (assoc base-uri :path "/oauth/token"))))
-
-
-(defn- build-user-info-url
-  []
-  (let [base-uri (uri/uri (:gitlab-base-uri cfg/config default-base-gitlab-uri))]
-    (str (assoc base-uri :path "/api/v4/user"))))
-
-
-(defn- get-access-token
-  [code]
-  (let [params {:client_id (:gitlab-client-id cfg/config)
-                :client_secret (:gitlab-client-secret cfg/config)
-                :code code
-                :grant_type "authorization_code"
-                :redirect_uri (build-redirect-url)}
-        req    {:method :post
-                :headers {"content-type" "application/x-www-form-urlencoded"}
-                :uri (build-token-url)
-                :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
-  [token]
-  (let [req {:uri (build-user-info-url)
-             :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
-  [_req]
-  (let [token  (tokens/generate
-                {:iss :gitlab-oauth
-                 :exp (dt/in-future "15m")})
-
-        params {:client_id (:gitlab-client-id cfg/config)
-                :redirect_uri (build-redirect-url)
-                :response_type "code"
-                :state token
-                :scope scope}
-        query  (uri/map->query-string params)
-        uri    (-> (build-oauth-uri)
-                   (assoc :query query))]
-    {:status 200
-     :body {:redirect-uri (str uri)}}))
-
-(defn callback
-  [req]
-  (let [token (get-in req [:params :state])
-        _     (tokens/verify token {:iss :gitlab-oauth})
-        info  (some-> (get-in req [:params :code])
-                      (get-access-token)
-                      (get-user-info))]
-
-    (when-not info
-      (ex/raise :type :authentication
-                :code :unable-to-authenticate-with-gitlab))
-
-    (let [profile (sm/handle {::sm/type :login-or-register
-                              :email (:email info)
-                              :fullname (:fullname info)})
-          uagent  (get-in req [:headers "user-agent"])
-
-          token   (tokens/generate
-                   {:iss :auth
-                    :exp (dt/in-future "15m")
-                    :profile-id (:id profile)})
-
-          uri     (-> (uri/uri (:public-uri cfg/config))
-                      (assoc :path "/#/auth/verify-token")
-                      (assoc :query (uri/map->query-string {:token token})))
-          sid     (session/create (:id profile) uagent)]
-
-      {:status 302
-       :headers {"location" (str uri)}
-       :cookies (session/cookies sid)
-       :body ""})))

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

@@ -1,131 +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.config :as cfg]
-   [app.http.session :as session]
-   [app.services.mutations :as sm]
-   [app.services.tokens :as tokens]
-   [app.util.http :as http]
-   [app.util.time :as dt]
-   [clojure.data.json :as json]
-   [clojure.tools.logging :as log]
-   [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
-  []
-  (let [public (uri/uri (:public-uri cfg/config))]
-    (str (assoc public :path "/api/oauth/google/callback"))))
-
-(defn- get-access-token
-  [code]
-  (let [params {:code code
-                :client_id (:google-client-id cfg/config)
-                :client_secret (:google-client-secret cfg/config)
-                :redirect_uri (build-redirect-url)
-                :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
-  [_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)
-                :client_id (:google-client-id cfg/config)}
-        query  (uri/map->query-string params)
-        uri    (-> (uri/uri base-goauth-uri)
-                   (assoc :query query))]
-    {:status 200
-     :body {:redirect-uri (str uri)}}))
-
-
-(defn callback
-  [req]
-  (let [token (get-in req [:params :state])
-        _     (tokens/verify token {:iss :google-oauth})
-        info  (some-> (get-in req [:params :code])
-                      (get-access-token)
-                      (get-user-info))]
-
-    (when-not info
-      (ex/raise :type :authentication
-                :code :unable-to-authenticate-with-google))
-
-    (let [profile (sm/handle {::sm/type :login-or-register
-                              :email (:email info)
-                              :fullname (:fullname info)})
-          uagent  (get-in req [:headers "user-agent"])
-
-          token   (tokens/generate
-                   {:iss :auth
-                    :exp (dt/in-future "15m")
-                    :profile-id (:id profile)})
-          uri     (-> (uri/uri (:public-uri cfg/config))
-                      (assoc :path "/#/auth/verify-token")
-                      (assoc :query (uri/map->query-string {:token token})))
-          sid     (session/create (:id profile) uagent)]
-
-      {:status 302
-       :headers {"location" (str uri)}
-       :cookies (session/cookies sid)
-       :body ""})))

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

@@ -1,80 +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]
-   [app.services.mutations :as sm]
-   [clj-ldap.client :as client]
-   [clojure.set :as set]
-   [clojure.string]
-   [clojure.tools.logging :as log]
-   [mount.core :refer [defstate]]))
-
-(defn replace-several [s & {:as replacements}]
-  (reduce-kv clojure.string/replace s replacements))
-
-(declare *ldap-pool)
-
-(defstate *ldap-pool
-  :start (delay
-           (try
-             (client/connect (merge {:host {:address (:ldap-auth-host cfg/config)
-                                            :port (:ldap-auth-port cfg/config)}}
-                                    (-> cfg/config
-                                        (select-keys [:ldap-auth-ssl
-                                                      :ldap-auth-starttls
-                                                      :ldap-bind-dn
-                                                      :ldap-bind-password])
-                                        (set/rename-keys {:ldap-auth-ssl :ssl?
-                                                          :ldap-auth-starttls :startTLS?
-                                                          :ldap-bind-dn  :bind-dn
-                                                          :ldap-bind-password :password}))))
-             (catch Exception e
-               (log/errorf e "Cannot connect to LDAP %s:%s"
-                             (:ldap-auth-host cfg/config) (:ldap-auth-port cfg/config)))))
-  :stop (when (realized? *ldap-pool)
-          (some-> *ldap-pool deref (.close))))
-
-(defn- auth-with-ldap [username password]
-  (when-some [conn (some-> *ldap-pool deref)]
-    (let [user-search-query (replace-several (:ldap-auth-user-query cfg/config)
-                                             "$username" username)
-          user-attributes (-> cfg/config
-                              (select-keys [:ldap-auth-username-attribute
-                                            :ldap-auth-email-attribute
-                                            :ldap-auth-fullname-attribute
-                                            :ldap-auth-avatar-attribute])
-                              vals)]
-      (when-some [user-entry (-> conn
-                                 (client/search (:ldap-auth-base-dn cfg/config)
-                                                {: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 (:ldap-auth-avatar-attribute cfg/config)) :photo
-                                     (keyword (:ldap-auth-fullname-attribute cfg/config)) :fullname
-                                     (keyword (:ldap-auth-email-attribute cfg/config)) :email})))))
-
-(defn auth [req]
-  (let [data (:body-params req)
-        uagent (get-in req [:headers "user-agent"])]
-    (when-some [info (auth-with-ldap (:email data) (:password data))]
-      (let [profile (sm/handle {::sm/type :login-or-register
-                                :email (:email info)
-                                :fullname (:fullname info)})
-            sid (session/create (:id profile) uagent)]
-        {:status 200
-         :cookies (session/cookies sid)
-         :body profile}))))

backend/src/app/http/awsns.clj

@@ -0,0 +1,214 @@
+;; 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) KALEIDOS INC
+
+(ns app.http.awsns
+  "AWS SNS webhook handler for bounces."
+  (:require
+   [app.common.exceptions :as ex]
+   [app.common.logging :as l]
+   [app.db :as db]
+   [app.db.sql :as sql]
+   [app.http.client :as http]
+   [app.tokens :as tokens]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [integrant.core :as ig]
+   [jsonista.core :as j]
+   [promesa.exec :as px]
+   [yetti.request :as yrq]
+   [yetti.response :as yrs]))
+
+(declare parse-json)
+(declare handle-request)
+(declare parse-notification)
+(declare process-report)
+
+(s/def ::http-client ::http/client)
+(s/def ::sprops map?)
+
+(defmethod ig/pre-init-spec ::handler [_]
+  (s/keys :req-un [::db/pool ::http-client ::sprops]))
+
+(defmethod ig/init-key ::handler
+  [_ {:keys [executor] :as cfg}]
+  (fn [request respond _]
+    (let [data (-> request yrq/body slurp)]
+      (px/run! executor #(handle-request cfg data)))
+    (respond (yrs/response 200))))
+
+(defn handle-request
+  [{:keys [http-client] :as cfg} data]
+  (try
+    (let [body  (parse-json data)
+          mtype (get body "Type")]
+      (cond
+        (= mtype "SubscriptionConfirmation")
+        (let [surl   (get body "SubscribeURL")
+              stopic (get body "TopicArn")]
+          (l/info :action "subscription received" :topic stopic :url surl)
+          (http/req! http-client {:uri surl :method :post :timeout 10000} {:sync? true}))
+
+        (= mtype "Notification")
+        (when-let [message (parse-json (get body "Message"))]
+          (let [notification (parse-notification cfg message)]
+            (process-report cfg notification)))
+
+        :else
+        (l/warn :hint "unexpected data received"
+                :report (pr-str body))))
+
+    (catch Throwable cause
+      (l/error :hint "unexpected exception on awsns"
+               :cause cause))))
+
+(defn- parse-bounce
+  [data]
+  {: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 [sprops]} headers]
+  (let [tdata (get headers "x-penpot-data")]
+    (when-not (str/empty? tdata)
+      (let [result (tokens/verify sprops {: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}]
+  (l/trace :action "processing report" :report (pr-str 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)
+    (l/warn :msg "a notification without identity received from AWS"
+            :report (pr-str report))
+
+    (= "bounce" type)
+    (register-bounce-for-profile cfg report)
+
+    (= "complaint" type)
+    (register-complaint-for-profile cfg report)
+
+    :else
+    (l/warn :msg "unrecognized report received from AWS"
+            :report (pr-str report))))
+
+

backend/src/app/http/client.clj

@@ -0,0 +1,40 @@
+;; 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) KALEIDOS INC
+
+(ns app.http.client
+  "Http client abstraction layer."
+  (:require
+   [app.worker :as wrk]
+   [clojure.spec.alpha :as s]
+   [integrant.core :as ig]
+   [java-http-clj.core :as http]))
+
+(s/def ::client fn?)
+
+(defmethod ig/pre-init-spec :app.http/client [_]
+  (s/keys :req-un [::wrk/executor]))
+
+(defmethod ig/init-key :app.http/client
+  [_ {:keys [executor] :as cfg}]
+  (let [client (http/build-client {:executor executor
+                                   :connect-timeout 30000 ;; 10s
+                                   :follow-redirects :always})]
+    (with-meta
+      (fn send
+        ([req] (send req {}))
+        ([req {:keys [response-type sync?] :or {response-type :string sync? false}}]
+         (if sync?
+           (http/send req {:client client :as response-type})
+           (http/send-async req {:client client :as response-type}))))
+      {::client client})))
+
+(defn req!
+  "A convencience toplevel function for gradual migration to a new API
+  convention."
+  ([client request]
+   (client request))
+  ([client request options]
+   (client request options)))

backend/src/app/http/debug.clj

@@ -0,0 +1,403 @@
+;; 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) KALEIDOS INC
+
+(ns app.http.debug
+  (:refer-clojure :exclude [error-handler])
+  (:require
+   [app.common.exceptions :as ex]
+   [app.common.logging :as l]
+   [app.common.pprint :as pp]
+   [app.common.uuid :as uuid]
+   [app.config :as cf]
+   [app.db :as db]
+   [app.http.middleware :as mw]
+   [app.rpc.commands.binfile :as binf]
+   [app.rpc.mutations.files :refer [create-file]]
+   [app.rpc.queries.profile :as profile]
+   [app.util.blob :as blob]
+   [app.util.template :as tmpl]
+   [app.util.time :as dt]
+   [app.worker :as wrk]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [datoteka.io :as io]
+   [emoji.core :as emj]
+   [integrant.core :as ig]
+   [markdown.core :as md]
+   [markdown.transformers :as mdt]
+   [yetti.request :as yrq]
+   [yetti.response :as yrs]))
+
+;; (selmer.parser/cache-off!)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HELPERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn authorized?
+  [pool {:keys [profile-id]}]
+  (or (= "devenv" (cf/get :host))
+      (let [profile (ex/ignoring (profile/retrieve-profile-data pool profile-id))
+            admins  (or (cf/get :admins) #{})]
+        (contains? admins (:email profile)))))
+
+(defn prepare-response
+  [body]
+  (let [headers {"content-type" "application/transit+json"}]
+    (yrs/response :status 200 :body body :headers headers)))
+
+(defn prepare-download-response
+  [body filename]
+  (let [headers {"content-disposition" (str "attachment; filename=" filename)
+                 "content-type" "application/octet-stream"}]
+    (yrs/response :status 200 :body body :headers headers)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; INDEX
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn index-handler
+  [{:keys [pool]} request]
+  (when-not (authorized? pool request)
+    (ex/raise :type :authentication
+              :code :only-admins-allowed))
+  (yrs/response :status  200
+                :headers {"content-type" "text/html"}
+                :body    (-> (io/resource "app/templates/debug.tmpl")
+                             (tmpl/render {}))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; FILE CHANGES
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def sql:retrieve-range-of-changes
+  "select revn, changes from file_change where file_id=? and revn >= ? and revn <= ? order by revn")
+
+(def sql:retrieve-single-change
+  "select revn, changes, data from file_change where file_id=? and revn = ?")
+
+(defn- retrieve-file-data
+  [{:keys [pool]} {:keys [params profile-id] :as request}]
+  (when-not (authorized? pool request)
+    (ex/raise :type :authentication
+              :code :only-admins-allowed))
+
+  (let [file-id  (some-> params :file-id parse-uuid)
+        revn     (some-> params :revn parse-long)
+        filename (str file-id)]
+
+    (when-not file-id
+      (ex/raise :type :validation
+                :code :missing-arguments))
+
+    (let [data (if (integer? revn)
+                 (some-> (db/exec-one! pool [sql:retrieve-single-change file-id revn]) :data)
+                 (some-> (db/get-by-id pool :file file-id) :data))]
+
+      (when-not data
+        (ex/raise :type :not-found
+                  :code :enpty-data
+                  :hint "empty response"))
+      (cond
+        (contains? params :download)
+        (prepare-download-response data filename)
+
+        (contains? params :clone)
+        (let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)
+              data       (some-> data blob/decode)]
+          (create-file pool {:id (uuid/next)
+                             :name (str "Cloned file: " filename)
+                             :project-id project-id
+                             :profile-id profile-id
+                             :data data})
+          (yrs/response 201 "OK CREATED"))
+
+        :else
+        (prepare-response (some-> data blob/decode))))))
+
+(defn- is-file-exists?
+  [pool id]
+  (let [sql "select exists (select 1 from file where id=?) as exists;"]
+    (-> (db/exec-one! pool [sql id]) :exists)))
+
+(defn- upload-file-data
+  [{:keys [pool]} {:keys [profile-id params] :as request}]
+  (let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)
+        data       (some-> params :file :path io/read-as-bytes blob/decode)]
+
+    (if (and data project-id)
+      (let [fname      (str "Imported file *: " (dt/now))
+            overwrite? (contains? params :overwrite?)
+            file-id    (or (and overwrite? (ex/ignoring (-> params :file :filename parse-uuid)))
+                           (uuid/next))]
+
+        (if (and overwrite? file-id
+                 (is-file-exists? pool file-id))
+          (do
+            (db/update! pool :file
+                        {:data (blob/encode data)}
+                        {:id file-id})
+            (yrs/response 200 "OK UPDATED"))
+
+          (do
+            (create-file pool {:id file-id
+                               :name fname
+                               :project-id project-id
+                               :profile-id profile-id
+                               :data data})
+            (yrs/response 201 "OK CREATED"))))
+
+      (yrs/response 500 "ERROR"))))
+
+(defn file-data-handler
+  [cfg request]
+  (case (yrq/method request)
+    :get (retrieve-file-data cfg request)
+    :post (upload-file-data cfg request)
+    (ex/raise :type :http
+              :code :method-not-found)))
+
+(defn file-changes-handler
+  [{:keys [pool]} {:keys [params] :as request}]
+  (when-not (authorized? pool request)
+    (ex/raise :type :authentication
+              :code :only-admins-allowed))
+
+  (letfn [(retrieve-changes [file-id revn]
+            (if (str/includes? revn ":")
+              (let [[start end] (->> (str/split revn #":")
+                                     (map str/trim)
+                                     (map parse-long))]
+                (some->> (db/exec! pool [sql:retrieve-range-of-changes file-id start end])
+                         (map :changes)
+                         (map blob/decode)
+                         (mapcat identity)
+                         (vec)))
+
+              (if-let [revn (parse-long revn)]
+                (let [item (db/exec-one! pool [sql:retrieve-single-change file-id revn])]
+                  (some-> item :changes blob/decode vec))
+                (ex/raise :type :validation :code :invalid-arguments))))]
+
+    (let [file-id  (some-> params :id parse-uuid)
+          revn     (or (some-> params :revn parse-long) "latest")
+          filename (str file-id)]
+
+      (when (or (not file-id) (not revn))
+        (ex/raise :type :validation
+                  :code :invalid-arguments
+                  :hint "missing arguments"))
+
+      (let [data (retrieve-changes file-id revn)]
+        (if (contains? params :download)
+          (prepare-download-response data filename)
+          (prepare-response data))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ERROR BROWSER
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn error-handler
+  [{:keys [pool]} request]
+  (letfn [(parse-id [request]
+            (let [id (get-in request [:path-params :id])
+                  id (parse-uuid id)]
+              (when (uuid? id)
+                id)))
+
+          (retrieve-report [id]
+            (ex/ignoring
+             (some-> (db/get-by-id pool :server-error-report id) :content db/decode-transit-pgobject)))
+
+          (render-template [report]
+            (let [context (dissoc report
+                                  :trace :cause :params :data :spec-problems :message
+                                  :spec-explain :spec-value :error :explain :hint)
+                  params  {:context       (pp/pprint-str context :width 200)
+                           :hint          (:hint report)
+                           :spec-explain  (:spec-explain report)
+                           :spec-problems (:spec-problems report)
+                           :spec-value    (:spec-value report)
+                           :data          (:data report)
+                           :trace         (or (:trace report)
+                                              (some-> report :error :trace))
+                           :params        (:params report)}]
+              (-> (io/resource "app/templates/error-report.tmpl")
+                  (tmpl/render params))))]
+
+    (when-not (authorized? pool request)
+      (ex/raise :type :authentication
+                :code :only-admins-allowed))
+
+    (let [result (some-> (parse-id request)
+                         (retrieve-report)
+                         (render-template))]
+      (if result
+        (yrs/response :status 200
+                      :body result
+                      :headers {"content-type" "text/html; charset=utf-8"
+                                "x-robots-tag" "noindex"})
+        (yrs/response 404 "not found")))))
+
+(def sql:error-reports
+  "select id, created_at from server_error_report order by created_at desc limit 100")
+
+(defn error-list-handler
+  [{:keys [pool]} request]
+  (when-not (authorized? pool request)
+    (ex/raise :type :authentication
+              :code :only-admins-allowed))
+  (let [items (db/exec! pool [sql:error-reports])
+        items (map #(update % :created-at dt/format-instant :rfc1123) items)]
+    (yrs/response :status 200
+                  :body (-> (io/resource "app/templates/error-list.tmpl")
+                            (tmpl/render {:items items}))
+                  :headers {"content-type" "text/html; charset=utf-8"
+                            "x-robots-tag" "noindex"})))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; EXPORT/IMPORT
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn export-handler
+  [{:keys [pool] :as cfg} {:keys [params profile-id] :as request}]
+
+  (let [file-ids (->> (:file-ids params)
+                      (remove empty?)
+                      (mapv parse-uuid))
+        libs?    (contains? params :includelibs)
+        clone?   (contains? params :clone)
+        embed?   (contains? params :embedassets)]
+
+    (when-not (seq file-ids)
+      (ex/raise :type :validation
+                :code :missing-arguments))
+
+    (let [path (-> cfg
+                   (assoc ::binf/file-ids file-ids)
+                   (assoc ::binf/embed-assets? embed?)
+                   (assoc ::binf/include-libraries? libs?)
+                   (binf/export-to-tmpfile!))]
+      (if clone?
+        (let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)]
+          (binf/import!
+           (assoc cfg
+                  ::binf/input path
+                  ::binf/overwrite? false
+                  ::binf/ignore-index-errors? true
+                  ::binf/profile-id profile-id
+                  ::binf/project-id project-id))
+
+          (yrs/response
+           :status  200
+           :headers {"content-type" "text/plain"}
+           :body    "OK CLONED"))
+
+        (yrs/response
+         :status  200
+         :headers {"content-type" "application/octet-stream"
+                   "content-disposition" (str "attachmen; filename=" (first file-ids) ".penpot")}
+         :body    (io/input-stream path))))))
+
+
+(defn import-handler
+  [{:keys [pool] :as cfg} {:keys [params profile-id] :as request}]
+  (when-not (contains? params :file)
+    (ex/raise :type :validation
+              :code :missing-upload-file
+              :hint "missing upload file"))
+
+  (let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)
+        overwrite? (contains? params :overwrite)
+        migrate? (contains? params :migrate)
+        ignore-index-errors? (contains? params :ignore-index-errors)]
+
+    (when-not project-id
+      (ex/raise :type :validation
+                :code :missing-project
+                :hint "project not found"))
+
+    (binf/import!
+     (assoc cfg
+            ::binf/input (-> params :file :path)
+            ::binf/overwrite? overwrite?
+            ::binf/migrate? migrate?
+            ::binf/ignore-index-errors? ignore-index-errors?
+            ::binf/profile-id profile-id
+            ::binf/project-id project-id))
+
+    (yrs/response
+     :status  200
+     :headers {"content-type" "text/plain"}
+     :body    "OK")))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; OTHER SMALL VIEWS/HANDLERS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn health-handler
+  "Mainly a task that performs a health check."
+  [{:keys [pool]} _]
+  (db/with-atomic [conn pool]
+    (try
+      (db/exec-one! conn ["select count(*) as count from server_prop;"])
+      (yrs/response 200 "OK")
+      (catch Throwable cause
+        (l/warn :hint "unable to execute query on health handler"
+                :cause cause)
+        (yrs/response 503 "KO")))))
+
+(defn changelog-handler
+  [_ _]
+  (letfn [(transform-emoji [text state]
+            [(emj/emojify text) state])
+          (md->html [text]
+            (md/md-to-html-string text :replacement-transformers (into [transform-emoji] mdt/transformer-vector)))]
+    (if-let [clog (io/resource "changelog.md")]
+      (yrs/response :status 200
+                    :headers {"content-type" "text/html; charset=utf-8"}
+                    :body (-> clog slurp md->html))
+      (yrs/response :status 404 :body "NOT FOUND"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; INIT
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def with-authorization
+  {:compile
+   (fn [& _]
+     (fn [handler pool]
+       (fn [request respond raise]
+         (if (authorized? pool request)
+           (handler request respond raise)
+           (raise (ex/error :type :authentication
+                            :code :only-admins-allowed))))))})
+
+
+(s/def ::session map?)
+
+(defmethod ig/pre-init-spec ::routes [_]
+  (s/keys :req-un [::db/pool ::wrk/executor ::session]))
+
+(defmethod ig/init-key ::routes
+  [_ {:keys [session pool executor] :as cfg}]
+  [["/readyz" {:middleware [[mw/with-dispatch executor]
+                            [mw/with-config cfg]]
+               :handler health-handler}]
+   ["/dbg" {:middleware [[(:middleware session)]
+                         [with-authorization pool]
+                         [mw/with-dispatch executor]
+                         [mw/with-config cfg]]}
+    ["" {:handler index-handler}]
+    ["/health" {:handler health-handler}]
+    ["/changelog" {:handler changelog-handler}]
+    ;; ["/error-by-id/:id" {:handler error-handler}]
+    ["/error/:id" {:handler error-handler}]
+    ["/error" {:handler error-list-handler}]
+    ["/file/export" {:handler export-handler}]
+    ["/file/import" {:handler import-handler}]
+    ["/file/data" {:handler file-data-handler}]
+    ["/file/changes" {:handler file-changes-handler}]]])

backend/src/app/http/errors.clj

@@ -2,18 +2,40 @@
 ;; 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
+;; Copyright (c) KALEIDOS INC
 
 (ns app.http.errors
   "A errors handling for the http server."
   (:require
    [app.common.exceptions :as ex]
-   [clojure.tools.logging :as log]
+   [app.common.logging :as l]
+   [app.common.spec :as us]
+   [app.http :as-alias http]
+   [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
-   [expound.alpha :as expound]))
+   [yetti.request :as yrq]
+   [yetti.response :as yrs]))
+
+(def ^:dynamic *context* {})
+
+(defn- parse-client-ip
+  [request]
+  (or (some-> (yrq/get-header request "x-forwarded-for") (str/split ",") first)
+      (yrq/get-header request "x-real-ip")
+      (yrq/remote-addr request)))
+
+(defn get-context
+  [request]
+  (merge
+   *context*
+   {:path          (:path request)
+    :method        (:method request)
+    :params        (:params request)
+    :ip-addr       (parse-client-ip request)
+    :profile-id    (:profile-id request)}
+   (let [headers (:headers request)]
+     {:user-agent (get headers "user-agent")
+      :frontend-version (get headers "x-frontend-version" "unknown")})))
 
 (defmulti handle-exception
   (fn [err & _rest]
@@ -21,90 +43,122 @@
       (or (:type edata)
           (class err)))))
 
-(defmethod handle-exception :authorization
+(defmethod handle-exception :authentication
   [err _]
-  {:status 403
-   :body (ex-data err)})
+  (yrs/response 401 (ex-data err)))
+
+(defmethod handle-exception :restriction
+  [err _]
+  (yrs/response 400 (ex-data err)))
+
+(defmethod handle-exception :rate-limit
+  [err _]
+  (let [headers (-> err ex-data ::http/headers)]
+    (yrs/response :status 429 :body "" :headers headers)))
 
 (defmethod handle-exception :validation
-  [err req]
-  (let [header (get-in req [:headers "accept"])
-        edata  (ex-data err)]
+  [err _]
+  (let [{:keys [code] :as data} (ex-data err)]
     (cond
-      (and (str/starts-with? header "text/html")
-           (= :spec-validation (:code edata)))
-      {:status 400
-       :headers {"content-type" "text/html"}
-       :body (str "<pre style='font-size:16px'>"
-                  (with-out-str
-                    (:data edata))
-                  "</pre>\n")}
-      :else
-      {:status 400
-       :body edata})))
+      (= code :spec-validation)
+      (let [explain (us/pretty-explain data)]
+        (yrs/response :status 400
+                      :body   (-> data
+                                  (dissoc ::s/problems ::s/value)
+                                  (cond-> explain (assoc :explain explain)))))
 
-(defmethod handle-exception :ratelimit
-  [_ _]
-  {:status 429
-   :headers {"retry-after" 1000}
-   :body ""})
+      (= code :request-body-too-large)
+      (yrs/response :status 413 :body data)
+
+      :else
+      (yrs/response :status 400 :body data))))
+
+(defmethod handle-exception :assertion
+  [error request]
+  (let [edata (ex-data error)
+        explain (us/pretty-explain edata)]
+    (l/error ::l/raw (str (ex-message error) "\n" explain)
+             ::l/context (get-context request)
+             :cause error)
+    (yrs/response :status 500
+                  :body   {:type :server-error
+                           :code :assertion
+                           :data (-> edata
+                                     (dissoc ::s/problems ::s/value ::s/spec)
+                                     (cond-> explain (assoc :explain explain)))})))
 
 (defmethod handle-exception :not-found
   [err _]
-  (let [response (ex-data err)]
-    {:status 404
-     :body response}))
+  (yrs/response 404 (ex-data err)))
 
-(defmethod handle-exception :service-error
-  [err req]
-  (handle-exception (.getCause ^Throwable err) req))
+(defmethod handle-exception org.postgresql.util.PSQLException
+  [error request]
+  (let [state (.getSQLState ^java.sql.SQLException error)]
+    (l/error ::l/raw (ex-message error)
+             ::l/context (get-context request)
+             :cause error)
+    (cond
+      (= state "57014")
+      (yrs/response 504 {:type :server-error
+                         :code :statement-timeout
+                         :hint (ex-message error)})
 
-(defmethod handle-exception :parse
-  [err _]
-  {:status 400
-   :body {:type :parse
-          :message (ex-message err)}})
+      (= state "25P03")
+      (yrs/response 504 {:type :server-error
+                         :code :idle-in-transaction-timeout
+                         :hint (ex-message error)})
 
-(defn get-context-string
-  [err request]
-  (str
-   "=| uri:          " (pr-str (:uri request)) "\n"
-   "=| method:       " (pr-str (:request-method request)) "\n"
-   "=| path-params:  " (pr-str (:path-params request)) "\n"
-   "=| query-params: " (pr-str (:query-params request)) "\n"
-
-   (when-let [bparams (:body-params request)]
-     (str "=| body-params:  " (pr-str bparams) "\n"))
-
-   (when (ex/ex-info? err)
-     (str "=| ex-data:      " (pr-str (ex-data err)) "\n"))
-
-   "\n"))
-
-
-(defmethod handle-exception :assertion
-  [err request]
-  (let [{:keys [data] :as edata} (ex-data err)]
-    (log/errorf err
-                (str "Assertion error\n"
-                     (get-context-string err request)
-                     (with-out-str (expound/printer data))))
-    {:status 500
-     :body {:type :internal-error
-            :message "Assertion error"
-            :data (ex-data err)}}))
+      :else
+      (yrs/response 500 {:type :server-error
+                         :code :unexpected
+                         :hint (ex-message error)
+                         :state state}))))
 
 (defmethod handle-exception :default
-  [err request]
-  (log/errorf err (str "Internal Error\n" (get-context-string err request)))
-  {:status 500
-   :body {:type :internal-error
-          :message (ex-message err)
-          :data (ex-data err)}})
+  [error request]
+  (let [edata (ex-data error)]
+    (cond
+      ;; This means that exception is not a controlled exception.
+      (nil? edata)
+      (do
+        (l/error ::l/raw (ex-message error)
+                 ::l/context (get-context request)
+                 :cause error)
+        (yrs/response 500 {:type :server-error
+                           :code :unexpected
+                           :hint (ex-message error)}))
+
+      ;; This is a special case for the idle-in-transaction error;
+      ;; when it happens, the connection is automatically closed and
+      ;; next-jdbc combines the two errors in a single ex-info. We
+      ;; only need the :handling error, because the :rollback error
+      ;; will be always "connection closed".
+      (and (ex/exception? (:rollback edata))
+           (ex/exception? (:handling edata)))
+      (handle-exception (:handling edata) request)
+
+      :else
+      (do
+        (l/error ::l/raw (ex-message error)
+                 ::l/context (get-context request)
+                 :cause error)
+        (yrs/response 500 {:type :server-error
+                           :code :unhandled
+                           :hint (ex-message error)
+                           :data edata})))))
 
 (defn handle
-  [error req]
-  (if (or (instance? java.util.concurrent.CompletionException error)
-          (instance? java.util.concurrent.ExecutionException error))
-    (handle-exception (.getCause ^Throwable error) req)
-    (handle-exception error req)))
+  [cause request]
+  (cond
+    (or (instance? java.util.concurrent.CompletionException cause)
+        (instance? java.util.concurrent.ExecutionException cause))
+    (handle-exception (.getCause ^Throwable cause) request)
+
+    (ex/wrapped? cause)
+    (let [context (meta cause)
+          cause   (deref cause)]
+      (binding [*context* context]
+        (handle-exception cause request)))
+
+    :else
+    (handle-exception cause request)))

backend/src/app/http/feedback.clj

@@ -0,0 +1,80 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) KALEIDOS INC
+
+(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 cf]
+   [app.db :as db]
+   [app.emails :as eml]
+   [app.rpc.queries.profile :as profile]
+   [app.worker :as wrk]
+   [clojure.spec.alpha :as s]
+   [integrant.core :as ig]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.request :as yrq]
+   [yetti.response :as yrs]))
+
+(declare ^:private send-feedback)
+(declare ^:private handler)
+
+(defmethod ig/pre-init-spec ::handler [_]
+  (s/keys :req-un [::db/pool ::wrk/executor]))
+
+(defmethod ig/init-key ::handler
+  [_ {:keys [executor] :as cfg}]
+  (let [enabled? (contains? cf/flags :user-feedback)]
+    (if enabled?
+      (fn [request respond raise]
+        (-> (px/submit! executor #(handler cfg request))
+            (p/then' respond)
+            (p/catch raise)))
+      (fn [_ _ raise]
+        (raise (ex/error :type :validation
+                         :code :feedback-disabled
+                         :hint "feedback module is disabled"))))))
+
+(defn- handler
+  [{:keys [pool] :as cfg} {:keys [profile-id] :as request}]
+  (let [ftoken (cf/get :feedback-token ::no-token)
+        token  (yrq/get-header request "x-feedback-token")
+        params (d/merge (:params request)
+                        (:body-params request))]
+    (cond
+      (uuid? profile-id)
+      (let [profile (profile/retrieve-profile-data pool profile-id)
+            params  (assoc params :from (:email profile))]
+        (send-feedback pool profile params))
+
+      (= token ftoken)
+      (send-feedback cfg nil params))
+
+    (yrs/response 204)))
+
+(s/def ::content ::us/string)
+(s/def ::from    ::us/email)
+(s/def ::subject ::us/string)
+(s/def ::feedback
+  (s/keys :req-un [::from ::subject ::content]))
+
+(defn- send-feedback
+  [pool profile params]
+  (let [params      (us/conform ::feedback params)
+        destination (cf/get :feedback-destination)]
+    (eml/send! {::eml/conn pool
+                ::eml/factory eml/feedback
+                :from     destination
+                :to       destination
+                :profile  profile
+                :reply-to (:from params)
+                :email    (:from params)
+                :subject  (:subject params)
+                :content  (:content params)})
+    nil))

backend/src/app/http/handlers.clj

@@ -1,76 +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.handlers
-  (:require
-   [app.common.data :as d]
-   [app.common.exceptions :as ex]
-   [app.emails :as emails]
-   [app.http.session :as session]
-   [app.services.init]
-   [app.services.mutations :as sm]
-   [app.services.queries :as sq]))
-
-(def unauthorized-services
-  #{:create-demo-profile
-    :logout
-    :profile
-    :verify-token
-    :recover-profile
-    :register-profile
-    :request-profile-recovery
-    :viewer-bundle
-    :login})
-
-(defn query-handler
-  [{:keys [profile-id] :as request}]
-  (let [type (keyword (get-in request [:path-params :type]))
-        data (assoc (:params request) ::sq/type type)
-        data (if profile-id
-               (assoc data :profile-id profile-id)
-               (dissoc data :profile-id))]
-
-    (if (or (uuid? profile-id)
-            (contains? unauthorized-services type))
-      {:status 200
-       :body (sq/handle (with-meta data {:req request}))}
-      {:status 403
-       :body {:type :authentication
-              :code :unauthorized}})))
-
-(defn mutation-handler
-  [{:keys [profile-id] :as request}]
-  (let [type (keyword (get-in request [:path-params :type]))
-        data (d/merge (:params request)
-                      (:body-params request)
-                      (:uploads request)
-                      {::sm/type type})
-        data (if profile-id
-               (assoc data :profile-id profile-id)
-               (dissoc data :profile-id))]
-
-    (if (or (uuid? profile-id)
-            (contains? unauthorized-services type))
-      (let [result (sm/handle (with-meta data {:req request}))
-            mdata  (meta result)
-            resp   {:status (if (nil? (seq result)) 204 200)
-                    :body result}]
-        (cond->> resp
-          (:transform-response mdata) ((:transform-response mdata) request)))
-      {:status 403
-       :body {:type :authentication
-              :code :unauthorized}})))
-
-(defn echo-handler
-  [req]
-  {:status 200
-   :body {:params (:params req)
-          :cookies (:cookies req)
-          :headers (:headers req)}})
-

backend/src/app/http/middleware.clj

@@ -2,136 +2,215 @@
 ;; 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
+;; Copyright (c) KALEIDOS INC
 
 (ns app.http.middleware
   (:require
    [app.common.exceptions :as ex]
-   [app.config :as cfg]
-   [app.metrics :as mtx]
-   [app.util.transit :as t]
-   [ring.middleware.cookies :refer [wrap-cookies]]
-   [ring.middleware.keyword-params :refer [wrap-keyword-params]]
-   [ring.middleware.multipart-params :refer [wrap-multipart-params]]
-   [ring.middleware.params :refer [wrap-params]]
-   [ring.middleware.resource :refer [wrap-resource]]))
+   [app.common.logging :as l]
+   [app.common.transit :as t]
+   [app.config :as cf]
+   [app.util.json :as json]
+   [cuerdas.core :as str]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.adapter :as yt]
+   [yetti.middleware :as ymw]
+   [yetti.request :as yrq]
+   [yetti.response :as yrs])
+  (:import
+   com.fasterxml.jackson.core.io.JsonEOFException
+   io.undertow.server.RequestTooBigException
+   java.io.OutputStream))
 
-(defn- wrap-parse-request-body
+(def server-timing
+  {:name ::server-timing
+   :compile (constantly ymw/wrap-server-timing)})
+
+(def params
+  {:name ::params
+   :compile (constantly ymw/wrap-params)})
+
+(defn wrap-parse-request
   [handler]
-  (letfn [(parse-body [body]
-            (try
-              (let [reader (t/reader body)]
-                (t/read! reader))
-              (catch Exception e
-                (ex/raise :type :parse
-                          :message "Unable to parse transit from request body."
-                          :cause e))))]
-    (fn [{:keys [headers body request-method] :as request}]
-      (handler
-       (cond-> request
-         (and (= "application/transit+json" (get headers "content-type"))
-              (not= request-method :get))
-         (assoc :body-params (parse-body body)))))))
+  (letfn [(process-request [request]
+            (let [header (yrq/get-header request "content-type")]
+              (cond
+                (str/starts-with? header "application/transit+json")
+                (with-open [is (yrq/body request)]
+                  (let [params (t/read! (t/reader is))]
+                    (-> request
+                        (assoc :body-params params)
+                        (update :params merge params))))
 
-(def parse-request-body
-  {:name ::parse-request-body
-   :compile (constantly wrap-parse-request-body)})
+                (str/starts-with? header "application/json")
+                (with-open [is (yrq/body request)]
+                  (let [params (json/read is)]
+                    (-> request
+                        (assoc :body-params params)
+                        (update :params merge params))))
 
-(defn- impl-format-response-body
-  [response]
-  (let [body (:body response)
-        type (if (:debug-humanize-transit cfg/config)
-               :json-verbose
-               :json)]
-    (cond
-      (coll? body)
-      (-> response
-          (assoc :body (t/encode body {:type type}))
-          (update :headers assoc
-                  "content-type"
-                  "application/transit+json"))
+                :else
+                request)))
 
-      (nil? body)
-      (assoc response :status 204 :body "")
+          (handle-error [raise cause]
+            (cond
+              (instance? RequestTooBigException cause)
+              (raise (ex/error :type :validation
+                               :code :request-body-too-large
+                               :hint (ex-message cause)))
 
-      :else
-      response)))
+              (instance? JsonEOFException cause)
+              (raise (ex/error :type :validation
+                               :code :malformed-json
+                               :hint (ex-message cause)))
+              :else
+              (raise cause)))]
 
-(defn- wrap-format-response-body
+    (fn [request respond raise]
+      (when-let [request (try
+                           (process-request request)
+                           (catch RuntimeException cause
+                             (handle-error raise (or (.getCause cause) cause)))
+                           (catch Throwable cause
+                             (handle-error raise cause)))]
+        (handler request respond raise)))))
+
+(def parse-request
+  {:name ::parse-request
+   :compile (constantly wrap-parse-request)})
+
+(defn buffered-output-stream
+  "Returns a buffered output stream that ignores flush calls. This is
+  needed because transit-java calls flush very aggresivelly on each
+  object write."
+  [^java.io.OutputStream os ^long chunk-size]
+  (proxy [java.io.BufferedOutputStream] [os (int chunk-size)]
+    ;; Explicitly do not forward flush
+    (flush [])
+    (close []
+      (proxy-super flush)
+      (proxy-super close))))
+
+(def ^:const buffer-size (:xnio/buffer-size yt/defaults))
+
+(defn wrap-format-response
   [handler]
-  (fn [request]
-    (let [response (handler request)]
-      (cond-> response
-        (map? response) (impl-format-response-body)))))
+  (letfn [(transit-streamable-body [data opts]
+            (reify yrs/StreamableResponseBody
+              (-write-body-to-stream [_ _ output-stream]
+                (try
+                  (with-open [bos (buffered-output-stream output-stream buffer-size)]
+                    (let [tw (t/writer bos opts)]
+                      (t/write! tw data)))
 
-(def format-response-body
-  {:name ::format-response-body
-   :compile (constantly wrap-format-response-body)})
+                  (catch java.io.IOException _cause
+                    ;; Do nothing, EOF means client closes connection abruptly
+                    nil)
+                  (catch Throwable cause
+                    (l/warn :hint "unexpected error on encoding response"
+                            :cause cause))
+                  (finally
+                    (.close ^OutputStream output-stream))))))
 
-(defn- wrap-errors
+          (format-response [response request]
+            (let [body (yrs/body response)]
+              (if (or (boolean? body) (coll? body))
+                (let [qs   (yrq/query request)
+                      opts (if (or (contains? cf/flags :transit-readable-response)
+                                   (str/includes? qs "transit_verbose"))
+                             {:type :json-verbose}
+                             {:type :json})]
+                  (-> response
+                      (update :headers assoc "content-type" "application/transit+json")
+                      (assoc :body (transit-streamable-body body opts))))
+                response)))
+
+          (process-response [response request]
+            (cond-> response
+              (map? response) (format-response request)))]
+
+    (fn [request respond raise]
+      (handler request
+               (fn [response]
+                 (let [response (process-response response request)]
+                   (respond response)))
+               raise))))
+
+(def format-response
+  {:name ::format-response
+   :compile (constantly wrap-format-response)})
+
+(defn wrap-errors
   [handler on-error]
-  (fn [request]
-    (try
-      (handler request)
-      (catch Throwable e
-        (on-error e request)))))
+  (fn [request respond _]
+    (handler request respond (fn [cause]
+                               (-> cause (on-error request) respond)))))
 
 (def errors
   {:name ::errors
    :compile (constantly wrap-errors)})
 
-(def metrics
-  {:name ::metrics
-   :wrap (fn [handler]
-           (mtx/wrap-counter handler {:id "http__requests_counter"
-                                      :help "Absolute http requests counter."}))})
-
-(def cookies
-  {:name ::cookies
-   :compile (constantly wrap-cookies)})
-
-(def params
-  {:name ::params
-   :compile (constantly wrap-params)})
-
-(def multipart-params
-  {:name ::multipart-params
-   :compile (constantly wrap-multipart-params)})
-
-(def keyword-params
-  {:name ::keyword-params
-   :compile (constantly wrap-keyword-params)})
-
-(defn- wrap-development-cors
+(defn wrap-cors
   [handler]
-  (letfn [(add-cors-headers [response]
-            (update response :headers
-                    (fn [headers]
-                      (-> headers
-                          (assoc "access-control-allow-origin" "http://localhost:3449")
-                          (assoc "access-control-allow-methods" "GET,POST,DELETE,OPTIONS,PUT,HEAD,PATCH")
-                          (assoc "access-control-allow-credentials" "true")
-                          (assoc "access-control-expose-headers" "x-requested-with, content-type, cookie")
-                          (assoc "access-control-allow-headers" "content-type")))))]
-    (fn [request]
-      (if (= (:request-method request) :options)
-        (-> {:status 200 :body ""}
-            (add-cors-headers))
-        (let [response (handler request)]
-          (add-cors-headers response))))))
+  (if-not (contains? cf/flags :cors)
+    handler
+    (letfn [(add-headers [headers request]
+              (let [origin (yrq/get-header request "origin")]
+                (-> headers
+                    (assoc "access-control-allow-origin" origin)
+                    (assoc "access-control-allow-methods" "GET,POST,DELETE,OPTIONS,PUT,HEAD,PATCH")
+                    (assoc "access-control-allow-credentials" "true")
+                    (assoc "access-control-expose-headers" "x-requested-with, content-type, cookie")
+                    (assoc "access-control-allow-headers" "x-frontend-version, content-type, accept, x-requested-width"))))
 
-(def development-cors
-  {:name ::development-cors
-   :compile (fn [& _args]
-              (when *assert*
-                wrap-development-cors))})
+            (update-response [response request]
+              (update response :headers add-headers request))]
 
-(def development-resources
-  {:name ::development-resources
-   :compile (fn [& _args]
-              (when *assert*
-                #(wrap-resource % "public")))})
+      (fn [request respond raise]
+        (if (= (yrq/method request) :options)
+          (-> (yrs/response 200)
+              (update-response request)
+              (respond))
+          (handler request
+                   (fn [response]
+                     (respond (update-response response request)))
+                   raise))))))
 
+(def cors
+  {:name ::cors
+   :compile (constantly wrap-cors)})
+
+(defn compile-restrict-methods
+  [data _]
+  (when-let [allowed (:allowed-methods data)]
+    (fn [handler]
+      (fn [request respond raise]
+        (let [method (yrq/method request)]
+          (if (contains? allowed method)
+            (handler request respond raise)
+            (respond (yrs/response 405))))))))
+
+(def restrict-methods
+  {:name ::restrict-methods
+   :compile compile-restrict-methods})
+
+(def with-dispatch
+  {:name ::with-dispatch
+   :compile
+   (fn [& _]
+     (fn [handler executor]
+       (fn [request respond raise]
+         (-> (px/submit! executor #(handler request))
+             (p/bind p/wrap)
+             (p/then respond)
+             (p/catch raise)))))})
+
+(def with-config
+  {:name ::with-config
+   :compile
+   (fn [& _]
+     (fn [handler config]
+       (fn
+         ([request] (handler config request))
+         ([request respond raise] (handler config request respond raise)))))})

backend/src/app/http/session.clj

@@ -2,65 +2,309 @@
 ;; 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
-
-;; TODO: move to services.
+;; Copyright (c) KALEIDOS INC
 
 (ns app.http.session
   (:require
+   [app.common.data :as d]
+   [app.common.logging :as l]
+   [app.config :as cf]
    [app.db :as db]
-   [buddy.core.codecs :as bc]
-   [buddy.core.nonce :as bn]))
+   [app.db.sql :as sql]
+   [app.tokens :as tokens]
+   [app.util.time :as dt]
+   [app.worker :as wrk]
+   [clojure.spec.alpha :as s]
+   [integrant.core :as ig]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.request :as yrq]))
 
-(defn next-token
-  [n]
-  (-> (bn/random-nonce n)
-      (bc/bytes->b64u)
-      (bc/bytes->str)))
+;; A default cookie name for storing the session.
+(def default-auth-token-cookie-name "auth-token")
 
-(defn extract-auth-token
-  [request]
-  (get-in request [:cookies "auth-token" :value]))
+;; A cookie that we can use to check from other sites of the same
+;; domain if a user is authenticated.
+(def default-authenticated-cookie-name "authenticated")
 
-(defn retrieve
-  [conn token]
-  (when token
-    (-> (db/exec-one! conn ["select profile_id from http_session where id = ?" token])
-        (:profile-id))))
+;; Default value for cookie max-age
+(def default-cookie-max-age (dt/duration {:days 7}))
 
-(defn retrieve-from-request
-  [conn request]
-  (->> (extract-auth-token request)
-       (retrieve conn)))
+;; Default age for automatic session renewal
+(def default-renewal-max-age (dt/duration {:hours 6}))
 
-(defn create
-  [profile-id user-agent]
-  (let [id (next-token 64)]
-    (db/insert! db/pool :http-session {:id id
-                                       :profile-id profile-id
-                                       :user-agent user-agent})
-    id))
+(defprotocol ISessionStore
+  (read-session [store key])
+  (write-session [store key data])
+  (update-session [store data])
+  (delete-session [store key]))
 
-(defn delete
-  [token]
-  (db/delete! db/pool :http-session {:id token})
-  nil)
+(defn- make-database-store
+  [{:keys [pool sprops executor]}]
+  (reify ISessionStore
+    (read-session [_ token]
+      (px/with-dispatch executor
+        (db/exec-one! pool (sql/select :http-session {:id token}))))
 
-(defn cookies
-  ([id] (cookies id {}))
-  ([id opts]
-   {"auth-token" (merge opts {:value id :path "/" :http-only true})}))
+    (write-session [_ _ data]
+      (px/with-dispatch executor
+        (let [profile-id (:profile-id data)
+              user-agent (:user-agent data)
+              created-at (or (:created-at data) (dt/now))
+              token      (tokens/generate sprops {:iss "authentication"
+                                                  :iat created-at
+                                                  :uid profile-id})
+              params     {:user-agent user-agent
+                          :profile-id profile-id
+                          :created-at created-at
+                          :updated-at created-at
+                          :id token}]
+          (db/insert! pool :http-session params))))
 
-(defn wrap-session
-  [handler]
-  (fn [request]
-    (if-let [profile-id (retrieve-from-request db/pool request)]
-      (handler (assoc request :profile-id profile-id))
-      (handler request))))
+    (update-session [_ data]
+      (let [updated-at (dt/now)]
+        (px/with-dispatch executor
+          (db/update! pool :http-session
+                      {:updated-at updated-at}
+                      {:id (:id data)})
+          (assoc data :updated-at updated-at))))
 
-(def middleware
-  {:nane ::middleware
-   :compile (constantly wrap-session)})
+    (delete-session [_ token]
+      (px/with-dispatch executor
+        (db/delete! pool :http-session {:id token})
+        nil))))
+
+(defn make-inmemory-store
+  [{:keys [sprops]}]
+  (let [cache (atom {})]
+    (reify ISessionStore
+      (read-session [_ token]
+        (p/do (get @cache token)))
+
+      (write-session [_ _ data]
+        (p/do
+          (let [profile-id (:profile-id data)
+                user-agent (:user-agent data)
+                created-at (or (:created-at data) (dt/now))
+                token      (tokens/generate sprops {:iss "authentication"
+                                                    :iat created-at
+                                                    :uid profile-id})
+                params     {:user-agent user-agent
+                            :created-at created-at
+                            :updated-at created-at
+                            :profile-id profile-id
+                            :id token}]
+
+            (swap! cache assoc token params)
+            params)))
+
+      (update-session [_ data]
+        (let [updated-at (dt/now)]
+          (swap! cache update (:id data) assoc :updated-at updated-at)
+          (assoc data :updated-at updated-at)))
+
+      (delete-session [_ token]
+        (p/do
+          (swap! cache dissoc token)
+          nil)))))
+
+(s/def ::sprops map?)
+(defmethod ig/pre-init-spec ::store [_]
+  (s/keys :req-un [::db/pool ::wrk/executor ::sprops]))
+
+(defmethod ig/init-key ::store
+  [_ {:keys [pool] :as cfg}]
+  (if (db/read-only? pool)
+    (make-inmemory-store cfg)
+    (make-database-store cfg)))
+
+(defmethod ig/halt-key! ::store
+  [_ _])
+
+;; --- IMPL
+
+(defn- create-session!
+  [store profile-id user-agent]
+  (let [params {:user-agent user-agent
+                :profile-id profile-id}]
+    (write-session store nil params)))
+
+(defn- update-session!
+  [store session]
+  (update-session store session))
+
+(defn- delete-session!
+  [store {:keys [cookies] :as request}]
+  (let [name (cf/get :auth-token-cookie-name default-auth-token-cookie-name)]
+    (when-let [token (get-in cookies [name :value])]
+      (delete-session store token))))
+
+(defn- retrieve-session
+  [store request]
+  (let [cookie-name (cf/get :auth-token-cookie-name default-auth-token-cookie-name)]
+    (when-let [cookie (yrq/get-cookie request cookie-name)]
+      (read-session store (:value cookie)))))
+
+(defn assign-auth-token-cookie
+  [response {token :id updated-at :updated-at}]
+  (let [max-age    (cf/get :auth-token-cookie-max-age default-cookie-max-age)
+        created-at (or updated-at (dt/now))
+        renewal    (dt/plus created-at default-renewal-max-age)
+        expires    (dt/plus created-at max-age)
+        secure?    (contains? cf/flags :secure-session-cookies)
+        cors?      (contains? cf/flags :cors)
+        name       (cf/get :auth-token-cookie-name default-auth-token-cookie-name)
+        comment    (str "Renewal at: " (dt/format-instant renewal :rfc1123))
+        cookie     {:path "/"
+                    :http-only true
+                    :expires expires
+                    :value token
+                    :comment comment
+                    :same-site (if cors? :none :lax)
+                    :secure secure?}]
+    (update response :cookies assoc name cookie)))
+
+(defn assign-authenticated-cookie
+  [response {updated-at :updated-at}]
+  (let [max-age    (cf/get :auth-token-cookie-max-age default-cookie-max-age)
+        created-at (or updated-at (dt/now))
+        renewal    (dt/plus created-at default-renewal-max-age)
+        expires    (dt/plus created-at max-age)
+        comment    (str "Renewal at: " (dt/format-instant renewal :rfc1123))
+        secure?    (contains? cf/flags :secure-session-cookies)
+        domain     (cf/get :authenticated-cookie-domain)
+        name       (cf/get :authenticated-cookie-name "authenticated")
+        cookie     {:domain domain
+                    :expires expires
+                    :path "/"
+                    :comment comment
+                    :value true
+                    :same-site :strict
+                    :secure secure?}]
+    (cond-> response
+      (string? domain)
+      (update :cookies assoc name cookie))))
+
+(defn clear-auth-token-cookie
+  [response]
+  (let [name (cf/get :auth-token-cookie-name default-auth-token-cookie-name)]
+    (update response :cookies assoc name {:path "/" :value "" :max-age -1})))
+
+(defn- clear-authenticated-cookie
+  [response]
+  (let [name   (cf/get :authenticated-cookie-name default-authenticated-cookie-name)
+        domain (cf/get :authenticated-cookie-domain)]
+    (cond-> response
+      (string? domain)
+      (update :cookies assoc name {:domain domain :path "/" :value "" :max-age -1}))))
+
+(defn- make-middleware
+  [{:keys [store] :as cfg}]
+  (letfn [;; Check if time reached for automatic session renewal
+          (renew-session? [{:keys [updated-at] :as session}]
+            (and (dt/instant? updated-at)
+                 (let [elapsed (dt/diff updated-at (dt/now))]
+                   (neg? (compare default-renewal-max-age elapsed)))))
+
+          ;; Wrap respond with session renewal code
+          (wrap-respond [respond session]
+            (fn [response]
+              (p/let [session (update-session! store session)]
+                (-> response
+                    (assign-auth-token-cookie session)
+                    (assign-authenticated-cookie session)
+                    (respond)))))]
+
+    {:name :session
+     :compile (fn [& _]
+                (fn [handler]
+                  (fn [request respond raise]
+                    (try
+                      (-> (retrieve-session store request)
+                          (p/finally (fn [session cause]
+                                       (cond
+                                         (some? cause)
+                                         (raise cause)
+
+                                         (nil? session)
+                                         (handler request respond raise)
+
+                                         :else
+                                         (let [request (-> request
+                                                           (assoc :profile-id (:profile-id session))
+                                                           (assoc :session-id (:id session)))
+                                               respond (cond-> respond
+                                                         (renew-session? session)
+                                                         (wrap-respond session))]
+                                           (handler request respond raise))))))
+
+                      (catch Throwable cause
+                        (raise cause))))))}))
+
+
+;; --- STATE INIT: SESSION
+
+(s/def ::store #(satisfies? ISessionStore %))
+
+(defmethod ig/pre-init-spec :app.http/session [_]
+  (s/keys :req-un [::store]))
+
+(defmethod ig/prep-key :app.http/session
+  [_ cfg]
+  (d/merge {:buffer-size 128}
+           (d/without-nils cfg)))
+
+(defmethod ig/init-key :app.http/session
+  [_ {:keys [store] :as cfg}]
+  (-> cfg
+      (assoc :middleware (make-middleware cfg))
+      (assoc :create (fn [profile-id]
+                       (fn [request response]
+                         (p/let [uagent  (yrq/get-header request "user-agent")
+                                 session (create-session! store profile-id uagent)]
+                           (-> response
+                               (assign-auth-token-cookie session)
+                               (assign-authenticated-cookie session))))))
+      (assoc :delete (fn [request response]
+                       (p/do
+                         (delete-session! store request)
+                         (-> response
+                             (assoc :status 204)
+                             (assoc :body nil)
+                             (clear-auth-token-cookie)
+                             (clear-authenticated-cookie)))))))
+
+;; --- 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 default-cookie-max-age}
+         (d/without-nils cfg)))
+
+(defmethod ig/init-key ::gc-task
+  [_ {:keys [pool max-age] :as cfg}]
+  (l/debug :hint "initializing session gc task" :max-age max-age)
+  (fn [_]
+    (db/with-atomic [conn pool]
+      (let [interval (db/interval max-age)
+            result   (db/exec-one! conn [sql:delete-expired interval interval])
+            result   (:next.jdbc/update-count result)]
+        (l/debug :task "gc"
+                 :hint "clean http sessions"
+                 :deleted result)
+        result))))
+
+(def ^:private
+  sql:delete-expired
+  "delete from http_session
+    where updated_at < now() - ?::interval
+       or (updated_at is null and
+           created_at < now() - ?::interval)")

backend/src/app/http/websocket.clj

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

backend/src/app/http/ws.clj

@@ -1,61 +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.ws
-  "Web Socket handlers"
-  (:require
-   [app.common.spec :as us]
-   [app.db :as db]
-   [app.http.session :refer [wrap-session]]
-   [app.services.notifications :as nf]
-   [clojure.spec.alpha :as s]
-   [ring.middleware.cookies :refer [wrap-cookies]]
-   [ring.middleware.keyword-params :refer [wrap-keyword-params]]
-   [ring.middleware.params :refer [wrap-params]]))
-
-(s/def ::file-id ::us/uuid)
-(s/def ::session-id ::us/uuid)
-
-(s/def ::websocket-params
-  (s/keys :req-un [::file-id ::session-id]))
-
-(def sql:retrieve-file
-  "select f.id as id,
-          p.team_id as team_id
-     from file as f
-     join project as p on (p.id = f.project_id)
-    where f.id = ?")
-
-(defn retrieve-file
-  [conn id]
-  (db/exec-one! conn [sql:retrieve-file id]))
-
-(defn websocket
-  [{:keys [profile-id] :as req}]
-  (let [params (us/conform ::websocket-params (:params req))
-        file   (retrieve-file db/pool (:file-id params))
-        params (assoc params
-                      :profile-id profile-id
-                      :team-id (:team-id file))]
-    (cond
-      (not profile-id)
-      {:error {:code 403 :message "Authentication required"}}
-
-      (not file)
-      {:error {:code 404 :message "File does not exists"}}
-
-      :else
-      (nf/websocket params))))
-
-(def handler
-  (-> websocket
-      (wrap-session)
-      (wrap-keyword-params)
-      (wrap-cookies)
-      (wrap-params)))

backend/src/app/loggers/audit.clj

@@ -0,0 +1,362 @@
+;; 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) KALEIDOS INC
+
+(ns app.loggers.audit
+  "Services related to the user activity (audit log)."
+  (:require
+   [app.common.data :as d]
+   [app.common.exceptions :as ex]
+   [app.common.logging :as l]
+   [app.common.spec :as us]
+   [app.common.transit :as t]
+   [app.common.uuid :as uuid]
+   [app.config :as cf]
+   [app.db :as db]
+   [app.tokens :as tokens]
+   [app.util.async :as aa]
+   [app.util.time :as dt]
+   [app.worker :as wrk]
+   [clojure.core.async :as a]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [integrant.core :as ig]
+   [lambdaisland.uri :as u]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [yetti.request :as yrq]
+   [yetti.response :as yrs]))
+
+(defn parse-client-ip
+  [request]
+  (or (some-> (yrq/get-header request "x-forwarded-for") (str/split ",") first)
+      (yrq/get-header request "x-real-ip")
+      (some-> (yrq/remote-addr request) str)))
+
+(defn extract-utm-params
+  "Extracts additional data from params and namespace them under
+  `penpot` ns."
+  [params]
+  (letfn [(process-param [params k v]
+            (let [sk (d/name k)]
+              (cond-> params
+                (str/starts-with? sk "utm_")
+                (assoc (->> sk str/kebab (keyword "penpot")) v)
+
+                (str/starts-with? sk "mtm_")
+                (assoc (->> sk str/kebab (keyword "penpot")) v))))]
+    (reduce-kv process-param {} params)))
+
+(defn profile->props
+  [profile]
+  (-> profile
+      (select-keys [:id :is-active :is-muted :auth-backend :email :default-team-id :default-project-id :fullname :lang])
+      (merge (:props profile))
+      (d/without-nils)))
+
+(defn clean-props
+  [{:keys [profile-id] :as event}]
+  (let [invalid-keys #{:session-id
+                       :password
+                       :old-password
+                       :token}
+        xform (comp
+               (remove (fn [kv]
+                         (qualified-keyword? (first kv))))
+               (remove (fn [kv]
+                         (contains? invalid-keys (first kv))))
+               (remove (fn [[k v]]
+                         (and (= k :profile-id)
+                              (= v profile-id))))
+               (filter (fn [[_ v]]
+                         (or (string? v)
+                             (keyword? v)
+                             (uuid? v)
+                             (boolean? v)
+                             (number? v)))))]
+
+    (update event :props #(into {} xform %))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HTTP Handler
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare persist-http-events)
+
+(s/def ::profile-id ::us/uuid)
+(s/def ::name ::us/string)
+(s/def ::type ::us/string)
+(s/def ::props (s/map-of ::us/keyword any?))
+(s/def ::timestamp dt/instant?)
+(s/def ::context (s/map-of ::us/keyword any?))
+
+(s/def ::frontend-event
+  (s/keys :req-un [::type ::name ::props ::timestamp ::profile-id]
+          :opt-un [::context]))
+
+(s/def ::frontend-events (s/every ::frontend-event))
+
+(defmethod ig/init-key ::http-handler
+  [_  {:keys [executor pool] :as cfg}]
+  (if (or (db/read-only? pool) (not (contains? cf/flags :audit-log)))
+    (do
+      (l/warn :hint "audit log http handler disabled or db is read-only")
+      (fn [_ respond _]
+        (respond (yrs/response 204))))
+
+    (letfn [(handler [{:keys [profile-id] :as request}]
+              (let [events  (->> (:events (:params request))
+                                 (remove #(not= profile-id (:profile-id %)))
+                                 (us/conform ::frontend-events))
+
+                    ip-addr (parse-client-ip request)
+                    cfg     (-> cfg
+                                (assoc :source "frontend")
+                                (assoc :events events)
+                                (assoc :ip-addr ip-addr))]
+                (persist-http-events cfg)))
+
+            (handle-error [cause]
+              (let [xdata (ex-data cause)]
+                (if (= :spec-validation (:code xdata))
+                  (l/error ::l/raw (str "spec validation on persist-events:\n" (us/pretty-explain xdata)))
+                  (l/error :hint "error on persist-events" :cause cause))))]
+
+      (fn [request respond _]
+        ;; Fire and forget, log error in case of errro
+        (-> (px/submit! executor #(handler request))
+            (p/catch handle-error))
+
+        (respond (yrs/response 204))))))
+
+(defn- persist-http-events
+  [{:keys [pool events ip-addr source] :as cfg}]
+  (let [columns    [:id :name :source :type :tracked-at :profile-id :ip-addr :props :context]
+        prepare-xf (map (fn [event]
+                          [(uuid/next)
+                           (:name event)
+                           source
+                           (:type event)
+                           (:timestamp event)
+                           (:profile-id event)
+                           (db/inet ip-addr)
+                           (db/tjson (:props event))
+                           (db/tjson (d/without-nils (:context event)))]))]
+    (when (seq events)
+      (->> (into [] prepare-xf events)
+           (db/insert-multi! pool :audit-log columns)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Collector
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Defines a service that collects the audit/activity log using
+;; internal database. Later this audit log can be transferred to
+;; an external storage and data cleared.
+
+(declare persist-events)
+
+(defmethod ig/pre-init-spec ::collector [_]
+  (s/keys :req-un [::db/pool ::wrk/executor]))
+
+(s/def ::ip-addr string?)
+(s/def ::backend-event
+  (s/keys :req-un [::type ::name ::profile-id]
+          :opt-un [::ip-addr ::props]))
+
+(def ^:private backend-event-xform
+  (comp
+   (filter #(us/valid? ::backend-event %))
+   (map clean-props)))
+
+(defmethod ig/init-key ::collector
+  [_ {:keys [pool] :as cfg}]
+  (cond
+    (not (contains? cf/flags :audit-log))
+    (do
+      (l/info :hint "audit log collection disabled")
+      (constantly nil))
+
+    (db/read-only? pool)
+    (do
+      (l/warn :hint "audit log collection disabled, db is read-only")
+      (constantly nil))
+
+    :else
+    (let [input  (a/chan 512 backend-event-xform)
+          buffer (aa/batch input {:max-batch-size 100
+                                  :max-batch-age (* 10 1000) ; 10s
+                                  :init []})]
+      (l/info :hint "audit log collector initialized")
+      (a/go-loop []
+        (when-let [[_type events] (a/<! buffer)]
+          (let [res (a/<! (persist-events cfg events))]
+            (when (ex/exception? res)
+              (l/error :hint "error on persisting events" :cause res))
+            (recur))))
+
+      (fn [& {:keys [cmd] :as params}]
+        (case cmd
+          :stop
+          (a/close! input)
+
+          :submit
+          (let [params (-> params
+                           (dissoc :cmd)
+                           (assoc :tracked-at (dt/now)))]
+            (when-not (a/offer! input params)
+              (l/warn :hint "activity channel is full"))))))))
+
+(defn- persist-events
+  [{:keys [pool executor] :as cfg} events]
+  (letfn [(event->row [event]
+            [(uuid/next)
+             (:name event)
+             (:type event)
+             (:profile-id event)
+             (:tracked-at event)
+             (some-> (:ip-addr event) db/inet)
+             (db/tjson (:props event))
+             "backend"])]
+    (aa/with-thread executor
+      (when (seq events)
+        (db/with-atomic [conn pool]
+          (db/insert-multi! conn :audit-log
+                            [:id :name :type :profile-id :tracked-at :ip-addr :props :source]
+                            (sequence (keep event->row) events)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Archive Task
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; This is a task responsible to send the accumulated events to an
+;; external service for archival.
+
+(declare archive-events)
+
+(s/def ::http-client fn?)
+(s/def ::uri ::us/string)
+(s/def ::sprops map?)
+
+(defmethod ig/pre-init-spec ::archive-task [_]
+  (s/keys :req-un [::db/pool ::sprops ::http-client]
+          :opt-un [::uri]))
+
+(defmethod ig/init-key ::archive-task
+  [_ {:keys [uri] :as cfg}]
+  (fn [props]
+    ;; NOTE: this let allows overwrite default configured values from
+    ;; the repl, when manually invoking the task.
+    (let [enabled (or (contains? cf/flags :audit-log-archive)
+                      (:enabled props false))
+          uri     (or uri (:uri props))
+          cfg     (assoc cfg :uri uri)]
+
+      (when (and enabled (not uri))
+        (ex/raise :type :internal
+                  :code :task-not-configured
+                  :hint "archive task not configured, missing uri"))
+
+      (when enabled
+        (loop [total 0]
+          (let [n (archive-events cfg)]
+            (if n
+              (do
+                (aa/thread-sleep 100)
+                (recur (+ total n)))
+              (when (pos? total)
+                (l/trace :hint "events chunk archived" :num total)))))))))
+
+(def sql:retrieve-batch-of-audit-log
+  "select * from audit_log
+    where archived_at is null
+    order by created_at asc
+    limit 256
+      for update skip locked;")
+
+(defn archive-events
+  [{:keys [pool uri sprops http-client] :as cfg}]
+  (letfn [(decode-row [{:keys [props ip-addr context] :as row}]
+            (cond-> row
+              (db/pgobject? props)
+              (assoc :props (db/decode-transit-pgobject props))
+
+              (db/pgobject? context)
+              (assoc :context (db/decode-transit-pgobject context))
+
+              (db/pgobject? ip-addr "inet")
+              (assoc :ip-addr (db/decode-inet ip-addr))))
+
+          (row->event [row]
+            (select-keys row [:type
+                              :name
+                              :source
+                              :created-at
+                              :tracked-at
+                              :profile-id
+                              :ip-addr
+                              :props
+                              :context]))
+
+          (send [events]
+            (let [token   (tokens/generate sprops {:iss "authentication"
+                                                   :iat (dt/now)
+                                                   :uid uuid/zero})
+                  body    (t/encode {:events events})
+                  headers {"content-type" "application/transit+json"
+                           "origin" (cf/get :public-uri)
+                           "cookie" (u/map->query-string {:auth-token token})}
+                  params  {:uri uri
+                           :timeout 6000
+                           :method :post
+                           :headers headers
+                           :body body}
+                  resp    (http-client params {:sync? true})]
+              (if (= (:status resp) 204)
+                true
+                (do
+                  (l/error :hint "unable to archive events"
+                           :resp-status (:status resp)
+                           :resp-body (:body resp))
+                  false))))
+
+          (mark-as-archived [conn rows]
+            (db/exec-one! conn ["update audit_log set archived_at=now() where id = ANY(?)"
+                                (->> (map :id rows)
+                                     (into-array java.util.UUID)
+                                     (db/create-array conn "uuid"))]))]
+
+    (db/with-atomic [conn pool]
+      (let [rows   (db/exec! conn [sql:retrieve-batch-of-audit-log])
+            xform  (comp (map decode-row)
+                         (map row->event))
+            events (into [] xform rows)]
+        (when-not (empty? events)
+          (l/debug :action "archive-events" :uri uri :events (count events))
+          (when (send events)
+            (mark-as-archived conn rows)
+            (count events)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; GC Task
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def sql:clean-archived
+  "delete from audit_log
+    where archived_at is not null")
+
+(defn- clean-archived
+  [{:keys [pool]}]
+  (let [result (db/exec-one! pool [sql:clean-archived])
+        result (:next.jdbc/update-count result)]
+    (l/debug :hint "delete archived audit log entries" :deleted result)
+    result))
+
+(defmethod ig/pre-init-spec ::gc-task [_]
+  (s/keys :req-un [::db/pool]))
+
+(defmethod ig/init-key ::gc-task
+  [_ cfg]
+  (partial clean-archived cfg))

backend/src/app/loggers/database.clj

@@ -0,0 +1,93 @@
+;; 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) KALEIDOS INC
+
+(ns app.loggers.database
+  "A specific logger impl that persists errors on the database."
+  (:require
+   [app.common.logging :as l]
+   [app.common.uuid :as uuid]
+   [app.config :as cf]
+   [app.db :as db]
+   [app.util.async :as aa]
+   [app.worker :as wrk]
+   [clojure.core.async :as a]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [integrant.core :as ig]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Error Listener
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare handle-event)
+
+(defonce enabled (atom true))
+
+(defn- persist-on-database!
+  [{:keys [pool] :as cfg} {:keys [id] :as event}]
+  (when-not (db/read-only? pool)
+    (db/insert! pool :server-error-report {:id id :content (db/tjson event)})))
+
+(defn- parse-event-data
+  [event]
+  (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)))
+   {}
+   event))
+
+(defn parse-event
+  [event]
+  (-> (parse-event-data event)
+      (assoc :hint (or (:hint event) (:message event)))
+      (assoc :tenant (cf/get :tenant))
+      (assoc :host (cf/get :host))
+      (assoc :public-uri (cf/get :public-uri))
+      (assoc :version (:full cf/version))
+      (update :id #(or % (uuid/next)))))
+
+(defn handle-event
+  [{:keys [executor] :as cfg} event]
+  (aa/with-thread executor
+    (try
+      (let [event (parse-event event)
+            uri   (cf/get :public-uri)]
+
+        (l/debug :hint "registering error on database" :id (:id event)
+                 :uri (str uri "/dbg/error/" (:id event)))
+
+        (persist-on-database! cfg event))
+      (catch Exception cause
+        (l/warn :hint "unexpected exception on database error logger" :cause cause)))))
+
+(defmethod ig/pre-init-spec ::reporter [_]
+  (s/keys :req-un [::wrk/executor ::db/pool ::receiver]))
+
+(defn error-event?
+  [event]
+  (= "error" (:logger/level event)))
+
+(defmethod ig/init-key ::reporter
+  [_ {:keys [receiver] :as cfg}]
+  (l/info :msg "initializing database error persistence")
+  (let [output (a/chan (a/sliding-buffer 5) (filter error-event?))]
+    (receiver :sub output)
+    (a/go-loop []
+      (let [msg (a/<! output)]
+        (if (nil? msg)
+          (l/info :msg "stoping error reporting loop")
+          (do
+            (a/<! (handle-event cfg msg))
+            (recur)))))
+    output))
+
+(defmethod ig/halt-key! ::reporter
+  [_ output]
+  (a/close! output))