♻️ Make the namespacing independent of the branding.

backend/src/app/cli/fixtures.clj

@@ -0,0 +1,275 @@
+;; 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
+   [clojure.tools.logging :as log]
+   [mount.core :as mount]
+   [sodi.pwhash :as pwhash]
+   [app.common.data :as d]
+   [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]))
+
+(defn- mk-uuid
+  [prefix & args]
+  (uuid/namespaced uuid/zero (apply str prefix (interpose "-" args))))
+
+;; --- Profiles creation
+
+(def password (pwhash/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-pages-per-file 3
+   :num-draft-files-per-profile 10
+   :num-draft-pages-per-file 3})
+
+(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)
+
+        create-profile
+        (fn [conn index]
+          (let [id (mk-uuid "profile" index)]
+            (log/info "create profile" id)
+            (register-profile conn
+                              {:id id
+                               :fullname (str "Profile " index)
+                               :password "123123"
+                               :demo? true
+                               :email (str "profile" index ".test@app.io")})))
+
+        create-profiles
+        (fn [conn]
+          (log/info "create profiles")
+          (collect (partial create-profile conn)
+                   (range (:num-profiles opts))))
+
+        create-team
+        (fn [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
+        (fn [conn]
+          (log/info "create teams")
+          (collect (partial create-team conn)
+                   (range (:num-teams opts))))
+
+        create-page
+        (fn [conn owner-id project-id file-id index]
+          (let [id (mk-uuid "page" project-id file-id index)
+                data cp/default-page-data
+                name (str "page " index)
+                version 0
+                ordering index
+                data (blob/encode data)]
+            (log/info "create page" id)
+            (db/insert! conn :page
+                        {:id id
+                         :file-id file-id
+                         :name name
+                         :ordering ordering
+                         :data data})))
+
+        create-pages
+        (fn [conn owner-id project-id file-id]
+          (log/info "create pages")
+          (run! (partial create-page conn owner-id project-id file-id)
+                (range (:num-pages-per-file opts))))
+
+        create-file
+        (fn [conn owner-id project-id index]
+          (let [id (mk-uuid "file" project-id index)
+                name (str "file" index)]
+            (log/info "create file" id)
+            (db/insert! conn :file
+                        {:id id
+                         :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
+        (fn [conn owner-id project-id]
+          (log/info "create files")
+          (let [file-ids (collect (partial create-file conn owner-id project-id)
+                                  (range (:num-files-per-project opts)))]
+            (run! (partial create-pages conn owner-id project-id) file-ids)))
+
+        create-project
+        (fn [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
+        (fn [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
+        (fn [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
+        (fn [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
+        (fn [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-pages
+        (fn [conn owner-id file-id]
+          (log/info "create draft pages")
+          (run! (partial create-page conn owner-id nil file-id)
+                (range (:num-draft-pages-per-file opts))))
+
+        create-draft-file
+        (fn [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)]
+            (log/info "create draft file" id)
+            (db/insert! conn :file
+                        {:id id
+                         :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
+        (fn [conn profile]
+          (let [file-ids (collect (partial create-draft-file conn profile)
+                                    (range (:num-draft-files-per-profile opts)))]
+            (run! (partial create-draft-pages conn (:id profile)) file-ids)))
+        ]
+
+    (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/media_loader.clj

@@ -0,0 +1,233 @@
+;; 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) 2016-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.cli.media-loader
+  "Media libraries importer (command line helper)."
+  (:require
+   [clojure.tools.logging :as log]
+   [clojure.spec.alpha :as s]
+   [clojure.java.io :as io]
+   [mount.core :as mount]
+   [datoteka.core :as fs]
+   [app.config]
+   [app.common.spec :as us]
+   [app.db :as db]
+   [app.media]
+   [app.media-storage]
+   [app.migrations]
+   [app.common.uuid :as uuid]
+   [app.services.mutations.projects :as projects]
+   [app.services.mutations.files :as files]
+   [app.services.mutations.colors :as colors]
+   [app.services.mutations.media :as media])
+  (: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

@@ -0,0 +1,190 @@
+;; 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.config
+  "A configuration management."
+  (:require
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [cuerdas.core :as str]
+   [environ.core :refer [env]]
+   [mount.core :refer [defstate]]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.util.time :as dt]))
+
+(def defaults
+  {:http-server-port 6060
+   :http-server-cors "http://localhost:3449"
+   :database-uri "postgresql://127.0.0.1/app"
+   :database-username "app"
+   :database-password "app"
+
+   :media-directory "resources/public/media"
+   :assets-directory "resources/public/static"
+
+   :public-uri "http://localhost:3449/"
+   :redis-uri "redis://redis/0"
+   :media-uri "http://localhost:3449/media/"
+   :assets-uri "http://localhost:3449/static/"
+
+   :image-process-max-threads 2
+
+   :sendmail-backend "console"
+   :sendmail-reply-to "no-reply@example.com"
+   :sendmail-from "no-reply@example.com"
+
+   :allow-demo-users true
+   :registration-enabled true
+   :registration-domain-whitelist ""
+   :debug-humanize-transit true
+
+   ;; 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-max-age "72h"
+
+   ;; LDAP auth disabled by default. Set ldap-auth-host to enable
+   ;:ldap-auth-host "ldap.mysupercompany.com"
+   ;:ldap-auth-port 389
+   ;:ldap-bind-dn "cn=admin,dc=ldap,dc=mysupercompany,dc=com"
+   ;:ldap-bind-password "verysecure"
+   ;:ldap-auth-ssl false
+   ;:ldap-auth-starttls false
+   ;:ldap-auth-base-dn "ou=People,dc=ldap,dc=mysupercompany,dc=com"
+
+   :ldap-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"})
+
+(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))
+(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 ::sendmail-backend ::us/string)
+(s/def ::sendmail-backend-apikey ::us/string)
+(s/def ::sendmail-reply-to ::us/email)
+(s/def ::sendmail-from ::us/email)
+(s/def ::smtp-host ::us/string)
+(s/def ::smtp-port ::us/integer)
+(s/def ::smtp-user (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 ::google-client-id ::us/string)
+(s/def ::google-client-secret ::us/string)
+
+(s/def ::ldap-auth-host ::us/string)
+(s/def ::ldap-auth-port ::us/integer)
+(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 ::file-trimming-threshold ::dt/duration)
+
+(s/def ::config
+  (s/keys :opt-un [::http-server-cors
+                   ::http-server-debug
+                   ::http-server-port
+                   ::google-client-id
+                   ::google-client-secret
+                   ::public-uri
+                   ::database-username
+                   ::database-password
+                   ::database-uri
+                   ::assets-directory
+                   ::assets-uri
+                   ::media-directory
+                   ::media-uri
+                   ::sendmail-reply-to
+                   ::sendmail-from
+                   ::sendmail-backend
+                   ::sendmail-backend-apikey
+                   ::smtp-host
+                   ::smtp-port
+                   ::smtp-user
+                   ::smtp-password
+                   ::smtp-tls
+                   ::smtp-ssl
+                   ::file-trimming-max-age
+                   ::debug-humanize-transit
+                   ::allow-demo-users
+                   ::registration-enabled
+                   ::registration-domain-whitelist
+                   ::image-process-max-threads
+                   ::ldap-auth-host
+                   ::ldap-auth-port
+                   ::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]))
+
+(defn env->config
+  [env]
+  (reduce-kv
+   (fn [acc k v]
+     (cond-> acc
+       (str/starts-with? (name k) "uxbox-")
+       (assoc (keyword (subs (name k) 6)) v)
+
+       (str/starts-with? (name k) "app-")
+       (assoc (keyword (subs (name k) 4)) v)))
+   {}
+   env))
+
+(defn read-config
+  [env]
+  (->> (env->config env)
+       (merge defaults)
+       (us/conform ::config)))
+
+(defn read-test-config
+  [env]
+  (assoc (read-config env)
+         :redis-uri "redis://redis/1"
+         :database-uri "postgresql://postgres/app_test"
+         :media-directory "/tmp/app/media"
+         :assets-directory "/tmp/app/static"
+         :migrations-verbose false))
+
+(defstate config
+  :start (read-config env))
+
+(def default-deletion-delay
+  (dt/duration {:hours 48}))

backend/src/app/db.clj

@@ -0,0 +1,231 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.db
+  (:require
+   [clojure.spec.alpha :as s]
+   [clojure.data.json :as json]
+   [clojure.string :as str]
+   [clojure.tools.logging :as log]
+   [lambdaisland.uri :refer [uri]]
+   [mount.core :as mount :refer [defstate]]
+   [next.jdbc :as jdbc]
+   [next.jdbc.date-time :as jdbc-dt]
+   [next.jdbc.optional :as jdbc-opt]
+   [next.jdbc.result-set :as jdbc-rs]
+   [next.jdbc.sql :as jdbc-sql]
+   [next.jdbc.sql.builder :as jdbc-bld]
+   [app.common.exceptions :as ex]
+   [app.config :as cfg]
+   [app.metrics :as mtx]
+   [app.util.time :as dt]
+   [app.util.transit :as t]
+   [app.util.data :as data])
+  (:import
+   org.postgresql.util.PGobject
+   org.postgresql.util.PGInterval
+   com.zaxxer.hikari.metrics.prometheus.PrometheusMetricsTrackerFactory
+   com.zaxxer.hikari.HikariConfig
+   com.zaxxer.hikari.HikariDataSource))
+
+(def initsql
+  (str "SET statement_timeout = 10000;\n"
+       "SET idle_in_transaction_session_timeout = 30000;"))
+
+(defn- create-datasource-config
+  [cfg]
+  (let [dburi    (:database-uri cfg)
+        username (:database-username cfg)
+        password (:database-password cfg)
+        config (HikariConfig.)
+        mfactory (PrometheusMetricsTrackerFactory. mtx/registry)]
+    (doto config
+      (.setJdbcUrl (str "jdbc:" dburi))
+      (.setPoolName "main")
+      (.setAutoCommit true)
+      (.setReadOnly false)
+      (.setConnectionTimeout 8000)  ;; 8seg
+      (.setValidationTimeout 4000)  ;; 4seg
+      (.setIdleTimeout 300000)      ;; 5min
+      (.setMaxLifetime 900000)      ;; 15min
+      (.setMinimumIdle 0)
+      (.setMaximumPoolSize 15)
+      (.setConnectionInitSql initsql)
+      (.setMetricsTrackerFactory mfactory))
+    (when username (.setUsername config username))
+    (when password (.setPassword config password))
+    config))
+
+(defn pool?
+  [v]
+  (instance? javax.sql.DataSource v))
+
+(s/def ::pool pool?)
+
+(defn pool-closed?
+  [pool]
+  (.isClosed ^com.zaxxer.hikari.HikariDataSource pool))
+
+(defn- create-pool
+  [cfg]
+  (let [dsc (create-datasource-config cfg)]
+    (jdbc-dt/read-as-instant)
+    (HikariDataSource. dsc)))
+
+(defstate pool
+  :start (create-pool cfg/config)
+  :stop (.close pool))
+
+(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
+  []
+  (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))))
+
+(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})
+
+(defn insert!
+  [ds table params]
+  (jdbc-sql/insert! ds table params default-options))
+
+(defn update!
+  [ds table params where]
+  (let [opts (assoc default-options :return-keys true)]
+    (jdbc-sql/update! ds table params where opts)))
+
+(defn delete!
+  [ds table params]
+  (let [opts (assoc default-options :return-keys true)]
+    (jdbc-sql/delete! ds table params opts)))
+
+(defn get-by-params
+  ([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 (:deleted-at res)
+       (ex/raise :type :not-found))
+     res)))
+
+(defn get-by-id
+  ([ds table id]
+   (get-by-params ds table {:id id} nil))
+  ([ds table id opts]
+   (get-by-params 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))))
+
+(defn pgobject?
+  [v]
+  (instance? PGobject v))
+
+(defn pginterval?
+  [v]
+  (instance? PGInterval v))
+
+(defn pginterval
+  [data]
+  (org.postgresql.util.PGInterval. ^String data))
+
+(defn interval
+  [data]
+  (cond
+    (integer? data)
+    (->> (/ data 1000.0)
+         (format "%s seconds")
+         (pginterval))
+
+    (string? data)
+    (pginterval data)
+
+    (dt/duration? data)
+    (->> (/ (.toMillis data) 1000.0)
+         (format "%s seconds")
+         (pginterval))
+
+    :else
+    (ex/raise :type :not-implemented)))
+
+(defn decode-pgobject
+  [^PGobject obj]
+  (let [typ (.getType obj)
+        val (.getValue obj)]
+    (if (or (= typ "json")
+            (= typ "jsonb"))
+      (json/read-str val)
+      val)))
+
+(defn decode-json-pgobject
+  [^PGobject o]
+  (let [typ (.getType o)
+        val (.getValue o)]
+    (if (or (= typ "json")
+            (= typ "jsonb"))
+      (json/read-str val :key-fn keyword)
+      val)))
+
+(defn decode-transit-pgobject
+  [^PGobject o]
+  (let [typ (.getType o)
+        val (.getValue o)]
+    (if (or (= typ "json")
+            (= typ "jsonb"))
+      (t/decode-str val)
+      val)))
+
+(defn tjson
+  "Encode as transit json."
+  [data]
+  (doto (org.postgresql.util.PGobject.)
+    (.setType "jsonb")
+    (.setValue (t/encode-verbose-str data))))
+
+(defn json
+  "Encode as plain json."
+  [data]
+  (doto (org.postgresql.util.PGobject.)
+    (.setType "jsonb")
+    (.setValue (json/write-str data))))
+
+;; Instrumentation
+
+(mtx/instrument-with-counter!
+ {:var [#'jdbc/execute-one!
+        #'jdbc/execute!]
+  :id "database__query_counter"
+  :help "An absolute counter of database queries."})

backend/src/app/emails.clj

@@ -0,0 +1,76 @@
+;; 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.emails
+  "Main api for send emails."
+  (:require
+   [clojure.spec.alpha :as s]
+   [promesa.core :as p]
+   [app.config :as cfg]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.db :as db]
+   [app.tasks :as tasks]
+   [app.util.emails :as emails]))
+
+;; --- Defaults
+
+(defn default-context
+  []
+  {:assets-uri (:assets-uri cfg/config)
+   :public-uri (:public-uri cfg/config)})
+
+;; --- Public API
+
+(defn render
+  [email context]
+  (let [defaults {:from (:sendmail-from cfg/config)
+                  :reply-to (:sendmail-reply-to cfg/config)}]
+    (email (merge defaults context))))
+
+(defn send!
+  "Schedule the email for sending."
+  ([email context] (send! db/pool email context))
+  ([conn email-factory context]
+   (us/verify fn? email-factory)
+   (us/verify map? context)
+   (let [defaults {:from (:sendmail-from cfg/config)
+                   :reply-to (:sendmail-reply-to cfg/config)}
+         data (merge defaults context)
+         email (email-factory data)]
+     (tasks/submit! conn {:name "sendmail"
+                          :delay 0
+                          :priority 200
+                          :props email}))))
+
+;; --- Emails
+
+(s/def ::name ::us/string)
+(s/def ::register
+  (s/keys :req-un [::name]))
+
+(def register
+  "A new profile registration welcome email."
+  (emails/build ::register default-context))
+
+(s/def ::token ::us/string)
+(s/def ::password-recovery
+  (s/keys :req-un [::name ::token]))
+
+(def password-recovery
+  "A password recovery notification email."
+  (emails/build ::password-recovery default-context))
+
+(s/def ::pending-email ::us/email)
+(s/def ::change-email
+  (s/keys :req-un [::name ::pending-email ::token]))
+
+(def change-email
+  "Password change confirmation email"
+  (emails/build ::change-email default-context))

backend/src/app/http.clj

@@ -0,0 +1,79 @@
+;; 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
+  (:require
+   [clojure.tools.logging :as log]
+   [mount.core :as mount :refer [defstate]]
+   [reitit.ring :as rring]
+   [ring.adapter.jetty9 :as jetty]
+   [app.config :as cfg]
+   [app.http.auth :as auth]
+   [app.http.auth.google :as google]
+   [app.http.auth.ldap :as ldap]
+   [app.http.debug :as debug]
+   [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.metrics :as mtx]
+   [app.services.notifications :as usn]))
+
+(defn- create-router
+  []
+  (rring/router
+   [["/metrics" {:get mtx/dump}]
+    ["/api" {:middleware [[middleware/format-response-body]
+                          [middleware/errors errors/handle]
+                          [middleware/parse-request-body]
+                          [middleware/params]
+                          [middleware/multipart-params]
+                          [middleware/keyword-params]
+                          [middleware/cookies]]}
+
+     ["/oauth"
+      ["/google" {:post google/auth}]
+      ["/google/callback" {:get google/callback}]]
+
+     ["/echo" {:get handlers/echo-handler
+               :post handlers/echo-handler}]
+
+     ["/login" {:handler auth/login-handler
+                :method :post}]
+     ["/logout" {:handler auth/logout-handler
+                 :method :post}]
+     ["/login-ldap" {:handler ldap/auth
+                     :method :post}]
+
+     ["/w" {:middleware [session/middleware]}
+      ["/query/:type" {:get handlers/query-handler}]
+      ["/mutation/:type" {:post handlers/mutation-handler}]]]]))
+
+(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)))
+
+(defstate server
+  :start (start-server)
+  :stop (.stop server))

backend/src/app/http/auth.clj

@@ -0,0 +1,33 @@
+;; 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.common.exceptions :as ex]
+   [app.common.uuid :as uuid]
+   [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"])]
+    (let [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/google.clj

@@ -0,0 +1,136 @@
+;; 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
+   [clojure.data.json :as json]
+   [clojure.tools.logging :as log]
+   [lambdaisland.uri :as uri]
+   [app.common.exceptions :as ex]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.services.tokens :as tokens]
+   [app.services.mutations :as sm]
+   [app.http.session :as session]
+   [app.util.http :as http]))
+
+(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 tooken 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 tooken request" e)
+        nil))))
+
+(defn auth
+  [req]
+  (let [token  (tokens/create! db/pool {:type :google-oauth})
+        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])
+        tdata (tokens/retrieve db/pool token)
+        info  (some-> (get-in req [:params :code])
+                      (get-access-token)
+                      (get-user-info))]
+
+    (when (not= :google-oauth (:type tdata))
+      (ex/raise :type :validation
+                :code ::tokens/invalid-token))
+
+    (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"])
+
+          tdata   {:type :authentication
+                   :profile profile}
+          token   (tokens/create! db/pool tdata {:valid {:minutes 10}})
+
+          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

@@ -0,0 +1,69 @@
+(ns app.http.auth.ldap
+  (:require
+    [clj-ldap.client :as client]
+    [clojure.set :as set]
+    [mount.core :refer [defstate]]
+    [app.common.exceptions :as ex]
+    [app.config :as cfg]
+    [app.services.mutations :as sm]
+    [app.http.session :as session]
+    [clojure.tools.logging :as log]))
+
+
+(defn replace-several [s & {:as replacements}]
+  (reduce-kv clojure.string/replace s replacements))
+
+(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/debug.clj

@@ -0,0 +1,24 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.http.debug
+  "Debug related handlers."
+  (:require
+   [clojure.tools.logging :as log]
+   [promesa.core :as p]
+   [app.http.errors :as errors]
+   [app.http.session :as session]
+   [app.common.uuid :as uuid]))
+
+(defn emails-list
+  [req]
+  {:status 200
+   :body "Hello world\n"})
+
+(defn email
+  [req]
+  {:status 200
+   :body "Hello world\n"})

backend/src/app/http/errors.clj

@@ -0,0 +1,71 @@
+;; 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) 2016-2019 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.http.errors
+  "A errors handling for the http server."
+  (:require
+   [clojure.tools.logging :as log]
+   [cuerdas.core :as str]
+   [app.metrics :as mtx]
+   [io.aviso.exception :as e]))
+
+(defmulti handle-exception
+  (fn [err & rest]
+    (:type (ex-data err))))
+
+(defmethod handle-exception :validation
+  [err req]
+  (let [header (get-in req [:headers "accept"])
+        response (ex-data err)]
+    (cond
+      (and (str/starts-with? header "text/html")
+           (= :spec-validation (:code response)))
+      {:status 400
+       :headers {"content-type" "text/html"}
+       :body (str "<pre style='font-size:16px'>" (:explain response) "</pre>\n")}
+
+      :else
+      {:status 400
+       :body response})))
+
+(defmethod handle-exception :ratelimit
+  [err req]
+  {:status 429
+   :headers {"retry-after" 1000}
+   :body ""})
+
+(defmethod handle-exception :not-found
+  [err req]
+  (let [response (ex-data err)]
+    {:status 404
+     :body response}))
+
+(defmethod handle-exception :service-error
+  [err req]
+  (handle-exception (.getCause ^Throwable err) req))
+
+(defmethod handle-exception :parse
+  [err req]
+  {:status 400
+   :body {:type :parse
+          :message (ex-message err)}})
+
+(defmethod handle-exception :default
+  [err req]
+  (log/error "Unhandled exception on request:" (:path req) "\n"
+             (with-out-str
+                (.printStackTrace ^Throwable err (java.io.PrintWriter. *out*))))
+  {:status 500
+   :body {:type :exception
+          :message (ex-message err)
+          :data (ex-data err)}})
+
+(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)))

backend/src/app/http/handlers.clj

@@ -0,0 +1,76 @@
+;; 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.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-profile-token
+    :recover-profile
+    :register-profile
+    :request-profile-recovery
+    :viewer-bundle
+    :login})
+
+(defn query-handler
+  [req]
+  (let [type (keyword (get-in req [:path-params :type]))
+        data (merge (:params req)
+                    {::sq/type type})
+        data (cond-> data
+               (:profile-id req) (assoc :profile-id (:profile-id req)))]
+    (if (or (:profile-id req)
+            (contains? unauthorized-services type))
+      {:status 200
+       :body (sq/handle (with-meta data {:req req}))}
+      {:status 403
+       :body {:type :authentication
+              :code :unauthorized}})))
+
+(defn mutation-handler
+  [req]
+  (let [type (keyword (get-in req [:path-params :type]))
+        data (merge (:params req)
+                    (:body-params req)
+                    (:uploads req)
+                    {::sm/type type})
+        data (cond-> data
+               (:profile-id req) (assoc :profile-id (:profile-id req)))]
+    (if (or (:profile-id req)
+            (contains? unauthorized-services type))
+      (let [body (sm/handle (with-meta data {:req req}))]
+        (if (= type :delete-profile)
+          (do
+            (some-> (session/extract-auth-token req)
+                    (session/delete))
+            {:status 204
+             :cookies (session/cookies "" {:max-age -1})
+             :body ""})
+          {:status 200
+           :body body}))
+      {: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

@@ -0,0 +1,138 @@
+;; 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) 2019-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.http.middleware
+  (:require
+   [clojure.tools.logging :as log]
+   [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.metrics :as mtx]
+   [app.common.exceptions :as ex]
+   [app.config :as cfg]
+   [app.util.transit :as t]))
+
+(defn- wrap-parse-request-body
+  [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)))))))
+
+(def parse-request-body
+  {:name ::parse-request-body
+   :compile (constantly wrap-parse-request-body)})
+
+(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"))
+
+      (nil? body)
+      (assoc response :status 204 :body "")
+
+      :else
+      response)))
+
+(defn- wrap-format-response-body
+  [handler]
+  (fn [request]
+    (let [response (handler request)]
+      (cond-> response
+        (map? response) (impl-format-response-body)))))
+
+(def format-response-body
+  {:name ::format-response-body
+   :compile (constantly wrap-format-response-body)})
+
+(defn- wrap-errors
+  [handler on-error]
+  (fn [request]
+    (try
+      (handler request)
+      (catch Throwable e
+        (on-error e request)))))
+
+(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
+  [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))))))
+
+(def development-cors
+  {:name ::development-cors
+   :compile (fn [& args]
+              (when *assert*
+                wrap-development-cors))})
+
+(def development-resources
+  {:name ::development-resources
+   :compile (fn [& args]
+              (when *assert*
+                #(wrap-resource % "public")))})
+

backend/src/app/http/session.clj

@@ -0,0 +1,57 @@
+;; 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.session
+  (:require
+   [app.db :as db]
+   [app.services.tokens :as tokens]))
+
+(defn extract-auth-token
+  [request]
+  (get-in request [:cookies "auth-token" :value]))
+
+(defn retrieve
+  [conn token]
+  (when token
+    (-> (db/exec-one! conn ["select profile_id from http_session where id = ?" token])
+        (:profile-id))))
+
+(defn retrieve-from-request
+  [conn request]
+  (->> (extract-auth-token request)
+       (retrieve conn)))
+
+(defn create
+  [profile-id user-agent]
+  (let [id (tokens/next-token)]
+    (db/insert! db/pool :http-session {:id id
+                                       :profile-id profile-id
+                                       :user-agent user-agent})
+    id))
+
+(defn delete
+  [token]
+  (db/delete! db/pool :http-session {:id token})
+  nil)
+
+(defn cookies
+  ([id] (cookies id {}))
+  ([id opts]
+   {"auth-token" (merge opts {:value id :path "/" :http-only true})}))
+
+(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))))
+
+(def middleware
+  {:nane ::middleware
+   :compile (constantly wrap-session)})

backend/src/app/http/ws.clj

@@ -0,0 +1,53 @@
+;; 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
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [ring.adapter.jetty9 :as jetty]
+   [ring.middleware.cookies :refer [wrap-cookies]]
+   [ring.middleware.keyword-params :refer [wrap-keyword-params]]
+   [ring.middleware.params :refer [wrap-params]]
+   [app.common.spec :as us]
+   [app.db :as db]
+   [app.http.session :refer [wrap-session]]
+   [app.services.notifications :as nf]))
+
+(s/def ::file-id ::us/uuid)
+(s/def ::session-id ::us/uuid)
+
+(s/def ::websocket-params
+  (s/keys :req-un [::file-id ::session-id]))
+
+(defn websocket
+  [{:keys [profile-id] :as req}]
+  (let [params (us/conform ::websocket-params (:params req))
+        file   (db/get-by-id db/pool :file (:file-id params))
+        params (assoc params
+                      :profile-id profile-id
+                      :file 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/main.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/.
+;;
+;; 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.main
+  (:require
+   [mount.core :as mount]))
+
+(defn- enable-asserts
+  [_]
+  (let [m (System/getProperty "app.enable-asserts")]
+    (or (nil? m) (= "true" m))))
+
+;; Set value for all new threads bindings.
+(alter-var-root #'*assert* enable-asserts)
+
+;; Set value for current thread binding.
+(set! *assert* (enable-asserts nil))
+
+;; --- Entry point
+
+(defn run
+  [params]
+  (require 'app.config
+           'app.migrations
+           'app.worker
+           'app.media
+           'app.http)
+  (mount/start))
+
+
+
+(defn -main
+  [& args]
+  (run {}))

backend/src/app/media.clj

@@ -0,0 +1,203 @@
+;; 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.media
+  "Media postprocessing."
+  (:require
+   [clojure.core.async :as a]
+   [clojure.java.io :as io]
+   [clojure.spec.alpha :as s]
+   [datoteka.core :as fs]
+   [mount.core :refer [defstate]]
+   [app.config :as cfg]
+   [app.common.data :as d]
+   [app.common.media :as cm]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.media-storage :as mst]
+   [app.util.storage :as ust]
+   [app.util.http :as http])
+  (:import
+   java.io.ByteArrayInputStream
+   java.io.InputStream
+   java.util.concurrent.Semaphore
+   org.im4java.core.ConvertCmd
+   org.im4java.core.Info
+   org.im4java.core.IMOperation))
+
+(defstate semaphore
+  :start (Semaphore. (:image-process-max-threads cfg/config 1)))
+
+;; --- Thumbnails Generation
+
+(s/def ::cmd keyword?)
+
+(s/def ::path (s/or :path fs/path?
+                    :string string?
+                    :file fs/file?))
+
+(s/def ::input
+  (s/keys :req-un [::path]
+          :opt-un [::cm/mtype]))
+
+(s/def ::width integer?)
+(s/def ::height integer?)
+(s/def ::format #{:jpeg :webp :png})
+(s/def ::quality #(< 0 % 101))
+
+(s/def ::thumbnail-params
+  (s/keys :req-un [::cmd ::input ::format ::width ::height]))
+
+;; Related info on how thumbnails generation
+;;  http://www.imagemagick.org/Usage/thumbnails/
+
+(defn- generic-process
+  [{:keys [input format quality operation] :as params}]
+  (let [{:keys [path mtype]} input
+        format (or (cm/mtype->format mtype) format)
+        ext    (cm/format->extension format)
+        tmp (fs/create-tempfile :suffix ext)]
+
+    (doto (ConvertCmd.)
+      (.run operation (into-array (map str [path tmp]))))
+
+    (let [thumbnail-data (fs/slurp-bytes tmp)]
+      (fs/delete tmp)
+      (assoc params
+             :format format
+             :mtype  (cm/format->mtype format)
+             :data   (ByteArrayInputStream. thumbnail-data)))))
+
+(defmulti process :cmd)
+
+(defmethod process :generic-thumbnail
+  [{:keys [quality width height] :as params}]
+  (us/assert ::thumbnail-params params)
+  (let [op (doto (IMOperation.)
+             (.addImage)
+             (.autoOrient)
+             (.strip)
+             (.thumbnail (int width) (int height) ">")
+             (.quality (double quality))
+             (.addImage))]
+    (generic-process (assoc params :operation op))))
+
+(defmethod process :profile-thumbnail
+  [{:keys [quality width height] :as params}]
+  (us/assert ::thumbnail-params params)
+  (let [op (doto (IMOperation.)
+             (.addImage)
+             (.autoOrient)
+             (.strip)
+             (.thumbnail (int width) (int height) "^")
+             (.gravity "center")
+             (.extent (int width) (int height))
+             (.quality (double quality))
+             (.addImage))]
+    (generic-process (assoc params :operation op))))
+
+(defmethod process :info
+  [{:keys [input] :as params}]
+  (us/assert ::input input)
+  (let [{:keys [path mtype]} input]
+    (if (= mtype "image/svg+xml")
+      {:width 100
+       :height 100
+       :mtype mtype}
+      (let [instance (Info. (str path))
+            mtype'   (.getProperty instance "Mime type")]
+        (when (and (string? mtype)
+                   (not= mtype mtype'))
+          (ex/raise :type :validation
+                    :code :media-type-mismatch
+                    :hint "Seems like you are uploading a file whose content does not match the extension."))
+        {:width  (.getImageWidth instance)
+         :height (.getImageHeight instance)
+         :mtype  mtype'}))))
+
+(defmethod process :default
+  [{:keys [cmd] :as params}]
+  (ex/raise :type :internal
+            :code :not-implemented
+            :hint (str "No impl found for process cmd:" cmd)))
+
+(defn run
+  [params]
+  (try
+    (.acquire semaphore)
+    (let [res (a/<!! (a/thread
+                       (try
+                         (process params)
+                         (catch Throwable e
+                           e))))]
+      (if (instance? Throwable res)
+        (throw res)
+        res))
+    (finally
+      (.release semaphore))))
+
+
+;; --- Utility functions
+
+(defn resolve-urls
+  [row src dst]
+  (s/assert map? row)
+  (if (and src dst)
+    (let [src (if (vector? src) src [src])
+          dst (if (vector? dst) dst [dst])
+          value (get-in row src)]
+      (if (empty? value)
+        row
+        (let [url (ust/public-uri mst/media-storage value)]
+          (assoc-in row dst (str url)))))
+    row))
+
+(defn- resolve-uri
+  [storage row src dst]
+  (let [src (if (vector? src) src [src])
+        dst (if (vector? dst) dst [dst])
+        value (get-in row src)]
+    (if (empty? value)
+      row
+      (let [url (ust/public-uri mst/media-storage value)]
+        (assoc-in row dst (str url))))))
+
+(defn resolve-media-uris
+  [row & pairs]
+  (us/assert map? row)
+  (us/assert (s/coll-of vector?) pairs)
+  (reduce #(resolve-uri mst/media-storage %1 (nth %2 0) (nth %2 1)) row pairs))
+
+(defn validate-media-type
+  [media-type]
+  (when-not (cm/valid-media-types media-type)
+    (ex/raise :type :validation
+              :code :media-type-not-allowed
+              :hint "Seems like you are uploading an invalid media object")))
+
+(defn download-media-object
+  [url]
+  (let [result (http/get! url {:as :byte-array})
+        data (:body result)
+        content-type (get (:headers result) "content-type")
+        format (cm/mtype->format content-type)]
+    (if (nil? format)
+      (ex/raise :type :validation
+                :code :media-type-not-allowed
+                :hint "Seems like the url points to an invalid media object.")
+      (let [tempfile (fs/create-tempfile)
+            base-filename (first (fs/split-ext (fs/name tempfile)))
+            filename (str base-filename (cm/format->extension format))]
+        (with-open [ostream (io/output-stream tempfile)]
+          (.write ostream data))
+        {:filename filename
+         :size (count data)
+         :tempfile tempfile
+         :content-type content-type}))))
+

backend/src/app/media_storage.clj

@@ -0,0 +1,36 @@
+;; 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) 2017-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.media-storage
+  "A media storage impl for app."
+  (:require
+   [mount.core :refer [defstate]]
+   [clojure.java.io :as io]
+   [cuerdas.core :as str]
+   [datoteka.core :as fs]
+   [app.util.storage :as ust]
+   [app.config :refer [config]]))
+
+;; --- State
+
+(defstate assets-storage
+  :start (ust/create {:base-path (:assets-directory config)
+                      :base-uri (:assets-uri config)}))
+
+(defstate media-storage
+  :start (ust/create {:base-path (:media-directory config)
+                      :base-uri (:media-uri config)
+                      :xf (comp ust/random-path
+                                ust/slugify-filename)}))
+
+;; --- Public Api
+
+(defn resolve-asset
+  [path]
+  (str (ust/public-uri assets-storage path)))

backend/src/app/metrics.clj

@@ -0,0 +1,181 @@
+;; 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.metrics
+  (:require
+   [clojure.tools.logging :as log]
+   [cuerdas.core :as str])
+  (:import
+   io.prometheus.client.CollectorRegistry
+   io.prometheus.client.Counter
+   io.prometheus.client.Gauge
+   io.prometheus.client.Summary
+   io.prometheus.client.exporter.common.TextFormat
+   io.prometheus.client.hotspot.DefaultExports
+   java.io.StringWriter))
+
+(defn- create-registry
+  []
+  (let [registry (CollectorRegistry.)]
+    (DefaultExports/register registry)
+    registry))
+
+(defonce registry (create-registry))
+(defonce cache (atom {}))
+
+(defmacro with-measure
+  [sym expr teardown]
+  `(let [~sym (System/nanoTime)]
+     (try
+       ~expr
+       (finally
+         (let [~sym (/ (- (System/nanoTime) ~sym) 1000000)]
+           ~teardown)))))
+
+(defn make-counter
+  [{:keys [id help] :as props}]
+  (let [instance (doto (Counter/build)
+                   (.name id)
+                   (.help help))
+        instance (.register instance registry)]
+    (reify
+      clojure.lang.IDeref
+      (deref [_] instance)
+
+      clojure.lang.IFn
+      (invoke [_ cmd]
+        (.inc ^Counter instance))
+
+      (invoke [_ cmd val]
+        (case cmd
+          :wrap (fn
+                  ([a]
+                   (.inc ^Counter instance)
+                   (val a))
+                  ([a b]
+                   (.inc ^Counter instance)
+                   (val a b))
+                  ([a b c]
+                   (.inc ^Counter instance)
+                   (val a b c)))
+
+          (throw (IllegalArgumentException. "invalid arguments")))))))
+
+(defn counter
+  [{:keys [id] :as props}]
+  (or (get @cache id)
+      (let [v (make-counter props)]
+        (swap! cache assoc id v)
+        v)))
+
+(defn make-gauge
+  [{:keys [id help] :as props}]
+  (let [instance (doto (Gauge/build)
+                   (.name id)
+                   (.help help))
+        instance (.register instance registry)]
+    (reify
+      clojure.lang.IDeref
+      (deref [_] instance)
+
+      clojure.lang.IFn
+      (invoke [_ cmd]
+        (case cmd
+          :inc (.inc ^Gauge instance)
+          :dec (.dec ^Gauge instance))))))
+
+(defn gauge
+  [{:keys [id] :as props}]
+  (or (get @cache id)
+      (let [v (make-gauge props)]
+        (swap! cache assoc id v)
+        v)))
+
+(defn make-summary
+  [{:keys [id help] :as props}]
+  (let [instance (doto (Summary/build)
+                   (.name id)
+                   (.help help)
+                   (.quantile 0.5 0.05)
+                   (.quantile 0.9 0.01)
+                   (.quantile 0.99 0.001))
+        instance  (.register instance registry)]
+    (reify
+      clojure.lang.IDeref
+      (deref [_] instance)
+
+      clojure.lang.IFn
+      (invoke [_ val]
+        (.observe ^Summary instance val))
+
+      (invoke [_ cmd val]
+        (case cmd
+          :wrap (fn
+                  ([a]
+                   (with-measure $$
+                     (val a)
+                     (.observe ^Summary instance $$)))
+                  ([a b]
+                   (with-measure $$
+                     (val a b)
+                     (.observe ^Summary instance $$)))
+                  ([a b c]
+                   (with-measure $$
+                     (val a b c)
+                     (.observe ^Summary instance $$))))
+
+          (throw (IllegalArgumentException. "invalid arguments")))))))
+
+(defn summary
+  [{:keys [id] :as props}]
+  (or (get @cache id)
+      (let [v (make-summary props)]
+        (swap! cache assoc id v)
+        v)))
+
+(defn wrap-summary
+  [f props]
+  (let [sm (summary props)]
+    (sm :wrap f)))
+
+(defn wrap-counter
+  [f props]
+  (let [cnt (counter props)]
+    (cnt :wrap f)))
+
+(defn instrument-with-counter!
+  [{:keys [var] :as props}]
+  (let [cnt  (counter props)
+        vars (if (var? var) [var] var)]
+    (doseq [var vars]
+      (alter-var-root var (fn [root]
+                            (let [mdata (meta root)
+                                  original (::counter-original mdata root)]
+                              (with-meta
+                                (cnt :wrap original)
+                                (assoc mdata ::counter-original original))))))))
+
+(defn instrument-with-summary!
+  [{:keys [var] :as props}]
+  (let [sm (summary props)]
+    (alter-var-root var (fn [root]
+                          (let [mdata (meta root)
+                                original (::summary-original mdata root)]
+                            (with-meta
+                              (sm :wrap original)
+                              (assoc mdata ::summary-original original)))))))
+
+(defn dump
+  [& args]
+  (let [samples (.metricFamilySamples ^CollectorRegistry registry)
+        writer  (StringWriter.)]
+    (TextFormat/write004 writer samples)
+    {:headers {"content-type" TextFormat/CONTENT_TYPE_004}
+     :body (.toString writer)}))
+

backend/src/app/migrations.clj

@@ -0,0 +1,116 @@
+;; 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.migrations
+  (:require
+   [mount.core :as mount :refer [defstate]]
+   [app.db :as db]
+   [app.config :as cfg]
+   [app.util.migrations :as mg]))
+
+(def +migrations+
+  {:name "uxbox-main"
+   :steps
+   [{:desc "Add initial extensions and functions."
+     :name "0001-add-extensions"
+     :fn (mg/resource "migrations/0001-add-extensions.sql")}
+
+    {:desc "Add profile related tables"
+     :name "0002-add-profile-tables"
+     :fn (mg/resource "migrations/0002-add-profile-tables.sql")}
+
+    {:desc "Add project related tables"
+     :name "0003-add-project-tables"
+     :fn (mg/resource "migrations/0003-add-project-tables.sql")}
+
+    {:desc "Add tasks related tables"
+     :name "0004-add-tasks-tables"
+     :fn (mg/resource "migrations/0004-add-tasks-tables.sql")}
+
+    {:desc "Add libraries related tables"
+     :name "0005-add-libraries-tables"
+     :fn (mg/resource "migrations/0005-add-libraries-tables.sql")}
+
+    {:desc "Add presence related tables"
+     :name "0006-add-presence-tables"
+     :fn (mg/resource "migrations/0006-add-presence-tables.sql")}
+
+    {:desc "Drop version field from page table."
+     :name "0007-drop-version-field-from-page-table"
+     :fn (mg/resource "migrations/0007-drop-version-field-from-page-table.sql")}
+
+    {:desc "Add generic token related tables."
+     :name "0008-add-generic-token-table"
+     :fn (mg/resource "migrations/0008-add-generic-token-table.sql")}
+
+    {:desc "Drop the profile_email table"
+     :name "0009-drop-profile-email-table"
+     :fn (mg/resource "migrations/0009-drop-profile-email-table.sql")}
+
+    {:desc "Add new HTTP session table"
+     :name "0010-add-http-session-table"
+     :fn (mg/resource "migrations/0010-add-http-session-table.sql")}
+
+    {:desc "Add session_id field to page_change table"
+     :name "0011-add-session-id-field-to-page-change-table"
+     :fn (mg/resource "migrations/0011-add-session-id-field-to-page-change-table.sql")}
+
+    {:desc "Make libraries linked to a file"
+     :name "0012-make-libraries-linked-to-a-file"
+     :fn (mg/resource "migrations/0012-make-libraries-linked-to-a-file.sql")}
+
+    {:desc "Mark files shareable"
+     :name "0013-mark-files-shareable"
+     :fn (mg/resource "migrations/0013-mark-files-shareable.sql")}
+
+    {:desc "Refactor media storage"
+     :name "0014-refactor-media-storage.sql"
+     :fn (mg/resource "migrations/0014-refactor-media-storage.sql")}
+
+    {:desc "Improve and partition task related tables"
+     :name "0015-improve-tasks-tables"
+     :fn (mg/resource "migrations/0015-improve-tasks-tables.sql")}
+
+    {:desc "Truncate & alter tokens tables"
+     :name "0016-truncate-and-alter-tokens-table"
+     :fn (mg/resource "migrations/0016-truncate-and-alter-tokens-table.sql")}
+
+    {:desc "Link files to libraries"
+     :name "0017-link-files-to-libraries"
+     :fn (mg/resource "migrations/0017-link-files-to-libraries.sql")}
+
+    {:desc "Add file triming triggers"
+     :name "0018-add-file-trimming-triggers"
+     :fn (mg/resource "migrations/0018-add-file-trimming-triggers.sql")}
+
+    {:desc "Improve scheduled task tables"
+     :name "0019-add-improved-scheduled-tasks"
+     :fn (mg/resource "migrations/0019-add-improved-scheduled-tasks.sql")}
+
+    {:desc "Minor fixes to media object"
+     :name "0020-minor-fixes-to-media-object"
+     :fn (mg/resource "migrations/0020-minor-fixes-to-media-object.sql")}
+
+    {:desc "Improve http session tables"
+     :name "0021-http-session-improvements"
+     :fn (mg/resource "migrations/0021-http-session-improvements.sql")}
+    ]})
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Entry point
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn migrate
+  []
+  (with-open [conn (db/open)]
+    (mg/setup! conn)
+    (mg/migrate! conn +migrations+)))
+
+(defstate migrations
+  :start (migrate))

backend/src/app/redis.clj

@@ -0,0 +1,49 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.redis
+  (:refer-clojure :exclude [run!])
+  (:require
+   [clojure.tools.logging :as log]
+   [lambdaisland.uri :refer [uri]]
+   [mount.core :as mount :refer [defstate]]
+   [app.common.exceptions :as ex]
+   [app.config :as cfg]
+   [app.util.data :as data]
+   [app.util.redis :as redis])
+  (:import
+   java.lang.AutoCloseable))
+
+;; --- Connection Handling & State
+
+(defn- create-client
+  [config]
+  (let [uri (:redis-uri config "redis://redis/0")]
+    (redis/client uri)))
+
+(defstate client
+  :start (create-client cfg/config)
+  :stop (.close ^AutoCloseable client))
+
+(defstate conn
+  :start (redis/connect client)
+  :stop (.close ^AutoCloseable conn))
+
+;; --- API FORWARD
+
+(defn subscribe
+  ([topic]
+   (redis/subscribe client topic))
+  ([topic xf]
+   (redis/subscribe client topic xf)))
+
+(defn run!
+  [cmd params]
+  (redis/run! conn cmd params))
+
+(defn run
+  [cmd params]
+  (redis/run conn cmd params))

backend/src/app/services/init.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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2019-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.services.init
+  "A initialization of services."
+  (:require
+   [mount.core :as mount :refer [defstate]]))
+
+(defn- load-query-services
+  []
+  (require 'app.services.queries.media)
+  (require 'app.services.queries.colors)
+  (require 'app.services.queries.projects)
+  (require 'app.services.queries.files)
+  (require 'app.services.queries.pages)
+  (require 'app.services.queries.profile)
+  (require 'app.services.queries.recent-files)
+  (require 'app.services.queries.viewer))
+
+(defn- load-mutation-services
+  []
+  (require 'app.services.mutations.demo)
+  (require 'app.services.mutations.media)
+  (require 'app.services.mutations.colors)
+  (require 'app.services.mutations.projects)
+  (require 'app.services.mutations.files)
+  (require 'app.services.mutations.pages)
+  (require 'app.services.mutations.profile))
+
+(defstate query-services
+  :start (load-query-services))
+
+(defstate mutation-services
+  :start (load-mutation-services))

backend/src/app/services/middleware.clj

@@ -0,0 +1,73 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2020 UXBOX Labs SL
+
+(ns app.services.middleware
+  "Common middleware for services."
+  (:require
+   [clojure.tools.logging :as log]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [expound.alpha :as expound]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.metrics :as mtx]))
+
+(defn wrap-spec
+  [handler]
+  (let [mdata (meta handler)
+        spec (s/get-spec (:spec mdata))]
+    (if (nil? spec)
+      handler
+      (with-meta
+        (fn [params]
+          (let [result (us/conform spec params)]
+            (handler result)))
+        (assoc mdata ::wrap-spec true)))))
+
+(defn wrap-error
+  [handler]
+  (let [mdata (meta handler)]
+    (with-meta
+      (fn [params]
+        (try
+          (handler params)
+          (catch Throwable error
+            (ex/raise :type :service-error
+                      :name (:spec mdata)
+                      :cause error))))
+      (assoc mdata ::wrap-error true))))
+
+(defn- get-prefix
+  [nsname]
+  (let [[a b c] (str/split nsname ".")]
+    c))
+
+(defn wrap-metrics
+  [handler]
+  (let [mdata  (meta handler)
+        nsname (namespace (:spec mdata))
+        smname (name (:spec mdata))
+        prefix (get-prefix nsname)
+
+        sname  (str prefix "/" smname)
+
+        props  {:id (str/join "__" [prefix
+                                    (str/snake smname)
+                                    "response_time"])
+                :help (str "Service timing measures for: " sname ".")}]
+    (with-meta
+      (mtx/wrap-summary handler props)
+      (assoc mdata ::wrap-metrics true))))
+
+(defn wrap
+  [handler]
+  (-> handler
+      (wrap-spec)
+      (wrap-error)
+      (wrap-metrics)))

backend/src/app/services/mutations.clj

@@ -0,0 +1,21 @@
+;; 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.services.mutations
+  (:require
+   [app.services.middleware :as middleware]
+   [app.util.dispatcher :as uds]))
+
+(uds/defservice handle
+  :dispatch-by ::type
+  :wrap middleware/wrap)
+
+(defmacro defmutation
+  [key & rest]
+  `(uds/defmethod handle ~key ~@rest))

backend/src/app/services/mutations/colors.clj

@@ -0,0 +1,150 @@
+;; 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.services.mutations.colors
+  (:require
+   [clojure.spec.alpha :as s]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.services.mutations :as sm]
+   [app.services.queries.teams :as teams]
+   [app.tasks :as tasks]
+   [app.util.time :as dt]))
+
+;; --- Helpers & Specs
+
+(s/def ::id ::us/uuid)
+(s/def ::name ::us/string)
+(s/def ::profile-id ::us/uuid)
+(s/def ::team-id ::us/uuid)
+(s/def ::library-id ::us/uuid)
+(s/def ::content ::us/string)
+
+;; --- Mutation: Create Color
+
+(declare select-file-for-update)
+(declare create-color)
+
+(s/def ::create-color
+  (s/keys :req-un [::profile-id ::name ::content ::file-id]
+          :opt-un [::id]))
+
+(sm/defmutation ::create-color
+  [{:keys [profile-id file-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [file (select-file-for-update conn file-id)]
+      (teams/check-edition-permissions! conn profile-id (:team-id file))
+      (create-color conn params))))
+
+(def ^:private sql:create-color
+  "insert into color (id, name, file_id, content)
+   values ($1, $2, $3, $4) returning *")
+
+(defn create-color
+  [conn {:keys [id name file-id content]}]
+  (let [id (or id (uuid/next))]
+    (db/insert! conn :color {:id id
+                             :name name
+                             :file-id file-id
+                             :content content})))
+
+(def ^:private sql:select-file-for-update
+  "select file.*,
+          project.team_id as team_id
+     from file
+    inner join project on (project.id = file.project_id)
+    where file.id = ?
+      for update of file")
+
+(defn- select-file-for-update
+  [conn id]
+  (let [row (db/exec-one! conn [sql:select-file-for-update id])]
+    (when-not row
+      (ex/raise :type :not-found))
+    row))
+
+
+;; --- Mutation: Rename Color
+
+(declare select-color-for-update)
+
+(s/def ::rename-color
+  (s/keys :req-un [::id ::profile-id ::name]))
+
+(sm/defmutation ::rename-color
+  [{:keys [id profile-id name] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [clr (select-color-for-update conn id)]
+      (teams/check-edition-permissions! conn profile-id (:team-id clr))
+      (db/update! conn :color
+                  {:name name}
+                  {:id id}))))
+
+(def ^:private sql:select-color-for-update
+  "select c.*,
+          p.team_id as team_id
+     from color as c
+    inner join file as f on f.id = c.file_id
+    inner join project as p on p.id = f.project_id
+    where c.id = ?
+      for update of c")
+
+(defn- select-color-for-update
+  [conn id]
+  (let [row (db/exec-one! conn [sql:select-color-for-update id])]
+    (when-not row
+      (ex/raise :type :not-found))
+    row))
+
+
+;; --- Mutation: Update Color
+
+(s/def ::update-color
+  (s/keys :req-un [::profile-id ::id ::content]))
+
+(sm/defmutation ::update-color
+  [{:keys [profile-id id content] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [clr (select-color-for-update conn id)
+          ;; IMPORTANT: if the previous name was equal to the hex content,
+          ;; we must rename it in addition to changing the value.
+          new-name (if (= (:name clr) (:content clr))
+                     content
+                     (:name clr))]
+      (teams/check-edition-permissions! conn profile-id (:team-id clr))
+      (db/update! conn :color
+                  {:name new-name
+                   :content content}
+                  {:id id}))))
+
+;; --- Delete Color
+
+(declare delete-color)
+
+(s/def ::delete-color
+  (s/keys :req-un [::id ::profile-id]))
+
+(sm/defmutation ::delete-color
+  [{:keys [profile-id id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [clr (select-color-for-update conn id)]
+      (teams/check-edition-permissions! conn profile-id (:team-id clr))
+
+      ;; Schedule object deletion
+      (tasks/submit! conn {:name "delete-object"
+                           :delay cfg/default-deletion-delay
+                           :props {:id id :type :color}})
+
+      (db/update! conn :color
+                  {:deleted-at (dt/now)}
+                  {:id id})
+      nil)))

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

@@ -0,0 +1,47 @@
+;; 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) 2016-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.services.mutations.demo
+  "A demo specific mutations."
+  (:require
+   [clojure.spec.alpha :as s]
+   [sodi.prng]
+   [sodi.util]
+   [app.common.exceptions :as ex]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.services.mutations :as sm]
+   [app.services.mutations.profile :as profile]
+   [app.tasks :as tasks]
+   [app.common.uuid :as uuid]
+   [app.util.time :as tm]))
+
+(sm/defmutation ::create-demo-profile
+  [_]
+  (let [id (uuid/next)
+        sem (System/currentTimeMillis)
+        email    (str "demo-" sem ".demo@nodomain.com")
+        fullname (str "Demo User " sem)
+        password (-> (sodi.prng/random-bytes 12)
+                     (sodi.util/bytes->b64s))
+        params   {:id id
+                  :email email
+                  :fullname fullname
+                  :demo? true
+                  :password password}]
+    (db/with-atomic [conn db/pool]
+      (->> (#'profile/create-profile conn params)
+           (#'profile/create-profile-relations conn))
+
+      ;; Schedule deletion of the demo profile
+      (tasks/submit! conn {:name "delete-profile"
+                           :delay cfg/default-deletion-delay
+                           :props {:profile-id id}})
+      {:email email
+       :password password})))

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

@@ -0,0 +1,197 @@
+;; 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) 2019-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.services.mutations.files
+  (:require
+   [clojure.spec.alpha :as s]
+   [datoteka.core :as fs]
+   [promesa.core :as p]
+   [app.common.exceptions :as ex]
+   [app.common.pages :as cp]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.services.mutations :as sm]
+   [app.services.mutations.projects :as proj]
+   [app.services.queries.files :as files]
+   [app.tasks :as tasks]
+   [app.util.blob :as blob]
+   [app.util.storage :as ust]
+   [app.util.time :as dt]))
+
+;; --- Helpers & Specs
+
+(s/def ::id ::us/uuid)
+(s/def ::name ::us/string)
+(s/def ::profile-id ::us/uuid)
+(s/def ::project-id ::us/uuid)
+(s/def ::url ::us/url)
+
+;; --- Mutation: Create File
+
+(declare create-file)
+(declare create-page)
+
+(s/def ::is-shared ::us/boolean)
+(s/def ::create-file
+  (s/keys :req-un [::profile-id ::name ::project-id]
+          :opt-un [::id ::is-shared]))
+
+(sm/defmutation ::create-file
+  [{:keys [profile-id project-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [file (create-file conn params)
+          page (create-page conn (assoc params :file-id (:id file)))]
+      (assoc file :pages [(:id page)]))))
+
+(defn- create-file-profile
+  [conn {:keys [profile-id file-id] :as params}]
+  (db/insert! conn :file-profile-rel
+              {:profile-id profile-id
+               :file-id file-id
+               :is-owner true
+               :is-admin true
+               :can-edit true}))
+
+(defn create-file
+  [conn {:keys [id profile-id name project-id is-shared]
+         :or {is-shared false}
+         :as params}]
+  (let [id      (or id (uuid/next))
+        file (db/insert! conn :file
+                         {:id id
+                          :project-id project-id
+                          :name name
+                          :is-shared is-shared})]
+    (->> (assoc params :file-id id)
+         (create-file-profile conn))
+    file))
+
+(defn create-page
+  [conn {:keys [file-id] :as params}]
+  (let [id  (uuid/next)]
+    (db/insert! conn :page
+                {:id id
+                 :file-id file-id
+                 :name "Page 1"
+                 :ordering 1
+                 :data (blob/encode cp/default-page-data)})))
+
+
+;; --- Mutation: Rename File
+
+(declare rename-file)
+
+(s/def ::rename-file
+  (s/keys :req-un [::profile-id ::name ::id]))
+
+(sm/defmutation ::rename-file
+  [{:keys [id profile-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (files/check-edition-permissions! conn profile-id id)
+    (rename-file conn params)))
+
+(defn- rename-file
+  [conn {:keys [id name] :as params}]
+  (db/update! conn :file
+              {:name name}
+              {:id id}))
+
+
+;; --- Mutation: Set File shared
+
+(declare set-file-shared)
+
+(s/def ::set-file-shared
+  (s/keys :req-un [::profile-id ::id ::is-shared]))
+
+(sm/defmutation ::set-file-shared
+  [{:keys [id profile-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (files/check-edition-permissions! conn profile-id id)
+    (set-file-shared conn params)))
+
+(defn- set-file-shared
+  [conn {:keys [id is-shared] :as params}]
+  (db/update! conn :file
+              {:is-shared is-shared}
+              {:id id}))
+
+
+;; --- Mutation: Delete File
+
+(declare mark-file-deleted)
+
+(s/def ::delete-file
+  (s/keys :req-un [::id ::profile-id]))
+
+(sm/defmutation ::delete-file
+  [{:keys [id profile-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (files/check-edition-permissions! conn profile-id id)
+
+    ;; Schedule object deletion
+    (tasks/submit! conn {:name "delete-object"
+                         :delay cfg/default-deletion-delay
+                         :props {:id id :type :file}})
+
+    (mark-file-deleted conn params)))
+
+(defn mark-file-deleted
+  [conn {:keys [id] :as params}]
+  (db/update! conn :file
+              {:deleted-at (dt/now)}
+              {:id id})
+  nil)
+
+
+;; --- Mutation: Link file to library
+
+(declare link-file-to-library)
+
+(s/def ::link-file-to-library
+  (s/keys :req-un [::profile-id ::file-id ::library-id]))
+
+(sm/defmutation ::link-file-to-library
+  [{:keys [profile-id file-id library-id] :as params}]
+  (when (= file-id library-id)
+    (ex/raise :type :validation
+              :code :invalid-library
+              :hint "A file cannot be linked to itself"))
+  (db/with-atomic [conn db/pool]
+    (files/check-edition-permissions! conn profile-id file-id)
+    (link-file-to-library conn params)))
+
+(defn- link-file-to-library
+  [conn {:keys [file-id library-id] :as params}]
+  (db/insert! conn :file-library-rel
+              {:file-id file-id
+               :library-file-id library-id}))
+
+
+;; --- Mutation: Unlink file from library
+
+(declare unlink-file-from-library)
+
+(s/def ::unlink-file-from-library
+  (s/keys :req-un [::profile-id ::file-id ::library-id]))
+
+(sm/defmutation ::unlink-file-from-library
+  [{:keys [profile-id file-id library-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (files/check-edition-permissions! conn profile-id file-id)
+    (unlink-file-from-library conn params)))
+
+(defn- unlink-file-from-library
+  [conn {:keys [file-id library-id] :as params}]
+  (db/delete! conn :file-library-rel
+              {:file-id file-id
+               :library-file-id library-id}))
+

backend/src/app/services/mutations/media.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/.
+;;
+;; 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.services.mutations.media
+  (:require
+   [clojure.spec.alpha :as s]
+   [datoteka.core :as fs]
+   [app.common.media :as cm]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.media :as media]
+   [app.services.mutations :as sm]
+   [app.services.queries.teams :as teams]
+   [app.tasks :as tasks]
+   [app.media-storage :as mst]
+   [app.util.storage :as ust]
+   [app.util.time :as dt]))
+
+(def thumbnail-options
+  {:width 100
+   :height 100
+   :quality 85
+   :format :jpeg})
+
+(s/def ::id ::us/uuid)
+(s/def ::name ::us/string)
+(s/def ::profile-id ::us/uuid)
+(s/def ::file-id ::us/uuid)
+(s/def ::team-id ::us/uuid)
+(s/def ::url ::us/url)
+
+
+;; --- Create Media object (Upload and create from url)
+
+(declare create-media-object)
+(declare select-file-for-update)
+(declare persist-media-object-on-fs)
+(declare persist-media-thumbnail-on-fs)
+
+(s/def :app$upload/filename ::us/string)
+(s/def :app$upload/size ::us/integer)
+(s/def :app$upload/content-type cm/valid-media-types)
+(s/def :app$upload/tempfile any?)
+
+(s/def ::upload
+  (s/keys :req-un [:app$upload/filename
+                   :app$upload/size
+                   :app$upload/tempfile
+                   :app$upload/content-type]))
+
+(s/def ::content ::upload)
+
+(s/def ::is-local ::us/boolean)
+
+(s/def ::add-media-object-from-url
+  (s/keys :req-un [::profile-id ::file-id ::is-local ::url]
+          :opt-un [::id]))
+
+(s/def ::upload-media-object
+  (s/keys :req-un [::profile-id ::file-id ::is-local ::name ::content]
+          :opt-un [::id]))
+
+(sm/defmutation ::add-media-object-from-url
+  [{:keys [profile-id file-id url] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [file (select-file-for-update conn file-id)]
+      (teams/check-edition-permissions! conn profile-id (:team-id file))
+      (let [content (media/download-media-object url)
+            params' (merge params {:content content
+                                   :name (:filename content)})]
+        (create-media-object conn params')))))
+
+(sm/defmutation ::upload-media-object
+  [{:keys [profile-id file-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [file (select-file-for-update conn file-id)]
+      (teams/check-edition-permissions! conn profile-id (:team-id file))
+      (create-media-object conn params))))
+
+(defn create-media-object
+  [conn {:keys [id file-id is-local name content]}]
+  (media/validate-media-type (:content-type content))
+  (let [info  (media/run {:cmd :info :input {:path (:tempfile content)
+                                             :mtype (:content-type content)}})
+        path  (persist-media-object-on-fs content)
+        opts  (assoc thumbnail-options
+                     :input {:mtype (:mtype info)
+                             :path path})
+        thumb (if-not (= (:mtype info) "image/svg+xml")
+                (persist-media-thumbnail-on-fs opts)
+                (assoc info
+                       :path path
+                       :quality 0))
+
+        id (or id (uuid/next))
+
+        media-object (db/insert! conn :media-object
+                                 {:id id
+                                  :file-id file-id
+                                  :is-local is-local
+                                  :name name
+                                  :path (str path)
+                                  :width (:width info)
+                                  :height (:height info)
+                                  :mtype  (:mtype info)})
+
+        media-thumbnail (db/insert! conn :media-thumbnail
+                                    {:id (uuid/next)
+                                     :media-object-id id
+                                     :path (str (:path thumb))
+                                     :width (:width thumb)
+                                     :height (:height thumb)
+                                     :quality (:quality thumb)
+                                     :mtype (:mtype thumb)})]
+    (assoc media-object :thumb-path (:path media-thumbnail))))
+
+(def ^:private sql:select-file-for-update
+  "select file.*,
+          project.team_id as team_id
+     from file
+    inner join project on (project.id = file.project_id)
+    where file.id = ?
+      for update of file")
+
+(defn- select-file-for-update
+  [conn id]
+  (let [row (db/exec-one! conn [sql:select-file-for-update id])]
+    (when-not row
+      (ex/raise :type :not-found))
+    row))
+
+(defn persist-media-object-on-fs
+  [{:keys [filename tempfile]}]
+  (let [filename (fs/name filename)]
+    (ust/save! mst/media-storage filename tempfile)))
+
+(defn persist-media-thumbnail-on-fs
+  [{:keys [input] :as params}]
+  (let [path  (ust/lookup mst/media-storage (:path input))
+        thumb (media/run
+                (-> params
+                    (assoc :cmd :generic-thumbnail)
+                    (update :input assoc :path path)))
+
+        name  (str "thumbnail-"
+                   (first (fs/split-ext (fs/name (:path input))))
+                   (cm/format->extension (:format thumb)))
+        path  (ust/save! mst/media-storage name (:data thumb))]
+
+    (-> thumb
+        (dissoc :data :input)
+        (assoc :path path))))
+
+;; --- Mutation: Rename Media object
+
+(declare select-media-object-for-update)
+
+(s/def ::rename-media-object
+  (s/keys :req-un [::id ::profile-id ::name]))
+
+(sm/defmutation ::rename-media-object
+  [{:keys [id profile-id name] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [obj (select-media-object-for-update conn id)]
+      (teams/check-edition-permissions! conn profile-id (:team-id obj))
+      (db/update! conn :media-object
+                  {:name name}
+                  {:id id}))))
+
+(def ^:private sql:select-media-object-for-update
+  "select obj.*,
+          p.team_id as team_id
+     from media_object as obj
+    inner join file as f on (f.id = obj.file_id)
+    inner join project as p on (p.id = f.project_id)
+    where obj.id = ?
+      for update of obj")
+
+(defn- select-media-object-for-update
+  [conn id]
+  (let [row (db/exec-one! conn [sql:select-media-object-for-update id])]
+    (when-not row
+      (ex/raise :type :not-found))
+    row))
+
+;; --- Delete Media object
+
+(s/def ::delete-media-object
+  (s/keys :req-un [::id ::profile-id]))
+
+(sm/defmutation ::delete-media-object
+  [{:keys [profile-id id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [obj (select-media-object-for-update conn id)]
+      (teams/check-edition-permissions! conn profile-id (:team-id obj))
+
+      ;; Schedule object deletion
+      (tasks/submit! conn {:name "delete-object"
+                           :delay cfg/default-deletion-delay
+                           :props {:id id :type :media-object}})
+
+      (db/update! conn :media-object
+                  {:deleted-at (dt/now)}
+                  {:id id})
+      nil)))

backend/src/app/services/mutations/pages.clj

@@ -0,0 +1,255 @@
+;; 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) 2019-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.services.mutations.pages
+  (:require
+   [clojure.spec.alpha :as s]
+   [app.common.data :as d]
+   [app.common.exceptions :as ex]
+   [app.common.pages :as cp]
+   [app.common.pages-migrations :as pmg]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.services.mutations :as sm]
+   [app.services.queries.files :as files]
+   [app.services.queries.pages :refer [decode-row]]
+   [app.tasks :as tasks]
+   [app.redis :as redis]
+   [app.util.blob :as blob]
+   [app.util.time :as dt]
+   [app.util.transit :as t]))
+
+;; --- Helpers & Specs
+
+(s/def ::id ::us/uuid)
+(s/def ::name ::us/string)
+(s/def ::data ::cp/data)
+(s/def ::profile-id ::us/uuid)
+(s/def ::project-id ::us/uuid)
+(s/def ::ordering ::us/number)
+(s/def ::file-id ::us/uuid)
+
+;; --- Mutation: Create Page
+
+(declare create-page)
+
+(s/def ::create-page
+  (s/keys :req-un [::profile-id ::file-id ::name ::ordering ::data]
+          :opt-un [::id]))
+
+(sm/defmutation ::create-page
+  [{:keys [profile-id file-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (files/check-edition-permissions! conn profile-id file-id)
+    (create-page conn params)))
+
+(defn- create-page
+  [conn {:keys [id file-id name ordering data] :as params}]
+  (let [id   (or id (uuid/next))
+        data (blob/encode data)]
+    (-> (db/insert! conn :page
+                    {:id id
+                     :file-id file-id
+                     :name name
+                     :ordering ordering
+                     :data data})
+        (decode-row))))
+
+
+;; --- Mutation: Rename Page
+
+(declare rename-page)
+(declare select-page-for-update)
+
+(s/def ::rename-page
+  (s/keys :req-un [::id ::name ::profile-id]))
+
+(sm/defmutation ::rename-page
+  [{:keys [id name profile-id]}]
+  (db/with-atomic [conn db/pool]
+    (let [page (select-page-for-update conn id)]
+      (files/check-edition-permissions! conn profile-id (:file-id page))
+      (rename-page conn (assoc page :name name)))))
+
+(defn- select-page-for-update
+  [conn id]
+  (db/get-by-id conn :page id {:for-update true}))
+
+(defn- rename-page
+  [conn {:keys [id name] :as params}]
+  (db/update! conn :page
+              {:name name}
+              {:id id}))
+
+
+;; --- Mutation: Sort Pages
+
+(s/def ::page-ids (s/every ::us/uuid :kind vector?))
+(s/def ::reorder-pages
+  (s/keys :req-un [::profile-id ::file-id ::page-ids]))
+
+(declare update-page-ordering)
+
+(sm/defmutation ::reorder-pages
+  [{:keys [profile-id file-id page-ids]}]
+  (db/with-atomic [conn db/pool]
+    (run! #(update-page-ordering conn file-id %)
+          (d/enumerate page-ids))
+    nil))
+
+(defn- update-page-ordering
+  [conn file-id [ordering page-id]]
+  (db/update! conn :page
+              {:ordering ordering}
+              {:file-id file-id
+               :id page-id}))
+
+
+;; --- Mutation: Generate Share Token
+
+(declare assign-page-share-token)
+
+(s/def ::generate-page-share-token
+  (s/keys :req-un [::id]))
+
+(sm/defmutation ::generate-page-share-token
+  [{:keys [id] :as params}]
+  (let [token (-> (sodi.prng/random-bytes 16)
+                  (sodi.util/bytes->b64s))]
+    (db/with-atomic [conn db/pool]
+      (db/update! conn :page
+                  {:share-token token}
+                  {:id id}))))
+
+
+;; --- Mutation: Clear Share Token
+
+(s/def ::clear-page-share-token
+  (s/keys :req-un [::id]))
+
+(sm/defmutation ::clear-page-share-token
+  [{:keys [id] :as params}]
+  (db/with-atomic [conn db/pool]
+      (db/update! conn :page
+                  {:share-token nil}
+                  {:id id})))
+
+
+
+;; --- Mutation: Update Page
+
+;; A generic, Changes based (granular) page update method.
+
+(s/def ::changes
+  (s/coll-of map? :kind vector?))
+
+(s/def ::session-id ::us/uuid)
+(s/def ::revn ::us/integer)
+(s/def ::update-page
+  (s/keys :req-un [::id ::session-id ::profile-id ::revn ::changes]))
+
+(declare update-page)
+(declare retrieve-lagged-changes)
+(declare insert-page-change!)
+
+(sm/defmutation ::update-page
+  [{:keys [id profile-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [{:keys [file-id] :as page} (select-page-for-update conn id)]
+      (files/check-edition-permissions! conn profile-id file-id)
+      (update-page conn page params))))
+
+(defn- update-page
+  [conn page params]
+  (when (> (:revn params)
+           (:revn page))
+    (ex/raise :type :validation
+              :code :revn-conflict
+              :hint "The incoming revision number is greater that stored version."
+              :context {:incoming-revn (:revn params)
+                        :stored-revn (:revn page)}))
+  (let [sid      (:session-id params)
+        changes  (:changes params)
+        page     (-> page
+                     (update :data blob/decode)
+                     (update :data pmg/migrate-data)
+                     (update :data cp/process-changes changes)
+                     (update :data blob/encode)
+                     (update :revn inc)
+                     (assoc :changes (blob/encode changes)
+                            :session-id sid))
+
+        chng     (insert-page-change! conn page)
+        msg      {:type :page-change
+                  :profile-id (:profile-id params)
+                  :page-id (:id page)
+                  :session-id sid
+                  :revn (:revn page)
+                  :changes changes}]
+
+    @(redis/run! :publish {:channel (str (:file-id page))
+                           :message (t/encode-str msg)})
+
+    (db/update! conn :page
+                {:revn (:revn page)
+                 :data (:data page)}
+                {:id (:id page)})
+
+    (retrieve-lagged-changes conn chng params)))
+
+(defn- insert-page-change!
+  [conn {:keys [revn data changes session-id] :as page}]
+  (let [id (uuid/next)
+        page-id (:id page)]
+    (db/insert! conn :page-change
+                {:id id
+                 :session-id session-id
+                 :page-id page-id
+                 :revn revn
+                 :data data
+                 :changes changes})))
+
+(def ^:private
+  sql:lagged-changes
+  "select s.id, s.revn, s.page_id,
+          s.session_id, s.changes
+     from page_change as s
+    where s.page_id = ?
+      and s.revn > ?
+    order by s.created_at asc")
+
+(defn- retrieve-lagged-changes
+  [conn snapshot params]
+  (->> (db/exec! conn [sql:lagged-changes (:id params) (:revn params)])
+       (mapv decode-row)))
+
+;; --- Mutation: Delete Page
+
+(declare mark-page-deleted)
+
+(s/def ::delete-page
+  (s/keys :req-un [::profile-id ::id]))
+
+(sm/defmutation ::delete-page
+  [{:keys [id profile-id]}]
+  (db/with-atomic [conn db/pool]
+    (let [page (select-page-for-update conn id)]
+      (files/check-edition-permissions! conn profile-id (:file-id page))
+
+      ;; Schedule object deletion
+      (tasks/submit! conn {:name "delete-object"
+                           :delay cfg/default-deletion-delay
+                           :props {:id id :type :page}})
+
+      (db/update! conn :page
+                  {:deleted-at (dt/now)}
+                  {:id id})
+      nil)))

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

@@ -0,0 +1,516 @@
+;; 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) 2016-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.services.mutations.profile
+  (:require
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [datoteka.core :as fs]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [sodi.prng]
+   [sodi.pwhash]
+   [sodi.util]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.common.media :as cm]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.emails :as emails]
+   [app.media :as media]
+   [app.media-storage :as mst]
+   [app.services.tokens :as tokens]
+   [app.services.mutations :as sm]
+   [app.services.mutations.media :as media-mutations]
+   [app.services.mutations.projects :as projects]
+   [app.services.mutations.teams :as teams]
+   [app.services.queries.profile :as profile]
+   [app.tasks :as tasks]
+   [app.util.blob :as blob]
+   [app.util.storage :as ust]
+   [app.util.time :as dt]))
+
+;; --- Helpers & Specs
+
+(s/def ::email ::us/email)
+(s/def ::fullname ::us/string)
+(s/def ::lang ::us/string)
+(s/def ::path ::us/string)
+(s/def ::profile-id ::us/uuid)
+(s/def ::password ::us/string)
+(s/def ::old-password ::us/string)
+(s/def ::theme ::us/string)
+
+;; --- Mutation: Register Profile
+
+(declare check-profile-existence!)
+(declare create-profile)
+(declare create-profile-relations)
+
+(s/def ::register-profile
+  (s/keys :req-un [::email ::password ::fullname]))
+
+(defn email-domain-in-whitelist?
+  "Returns true if email's domain is in the given whitelist or if given
+  whitelist is an empty string."
+  [whitelist email]
+  (if (str/blank? whitelist)
+    true
+    (let [domains (str/split whitelist #",\s*")
+          email-domain (second (str/split email #"@"))]
+      (contains? (set domains) email-domain))))
+
+(sm/defmutation ::register-profile
+  [params]
+  (when-not (:registration-enabled cfg/config)
+    (ex/raise :type :restriction
+              :code ::registration-disabled))
+
+  (when-not (email-domain-in-whitelist? (:registration-domain-whitelist cfg/config)
+                                        (:email params))
+    (ex/raise :type :validation
+              :code ::email-domain-is-not-allowed))
+
+  (db/with-atomic [conn db/pool]
+    (check-profile-existence! conn params)
+    (let [profile (->> (create-profile conn params)
+                       (create-profile-relations conn))
+          payload {:type :verify-email
+                   :profile-id (:id profile)
+                   :email (:email profile)}
+
+          token   (tokens/create! conn payload {:valid {:days 30}})]
+
+      (emails/send! conn emails/register
+                    {:to (:email profile)
+                     :name (:fullname profile)
+                     :token token})
+      profile)))
+
+(def ^:private sql:profile-existence
+  "select exists (select * from profile
+                   where email = ?
+                     and deleted_at is null) as val")
+
+(defn- check-profile-existence!
+  [conn {:keys [email] :as params}]
+  (let [email  (str/lower email)
+        result (db/exec-one! conn [sql:profile-existence email])]
+    (when (:val result)
+      (ex/raise :type :validation
+                :code ::email-already-exists))
+    params))
+
+(defn- create-profile
+  "Create the profile entry on the database with limited input
+  filling all the other fields with defaults."
+  [conn {:keys [id fullname email password demo?] :as params}]
+  (let [id (or id (uuid/next))
+        demo? (if (boolean? demo?) demo? false)
+        password (sodi.pwhash/derive password)]
+    (db/insert! conn :profile
+                {:id id
+                 :fullname fullname
+                 :email (str/lower email)
+                 :pending-email (if demo? nil email)
+                 :photo ""
+                 :password password
+                 :is-demo demo?})))
+
+(defn- create-profile-relations
+  [conn profile]
+  (let [team (teams/create-team conn {:profile-id (:id profile)
+                                      :name "Default"
+                                      :default? true})
+        proj (projects/create-project conn {:profile-id (:id profile)
+                                            :team-id (:id team)
+                                            :name "Drafts"
+                                            :default? true})]
+    (teams/create-team-profile conn {:team-id (:id team)
+                                     :profile-id (:id profile)})
+    (projects/create-project-profile conn {:project-id (:id proj)
+                                           :profile-id (:id profile)})
+
+    (merge (profile/strip-private-attrs profile)
+           {:default-team-id (:id team)
+            :default-project-id (:id proj)})))
+
+;; --- Mutation: Login
+
+(declare retrieve-profile-by-email)
+
+(s/def ::email ::us/email)
+(s/def ::scope ::us/string)
+
+(s/def ::login
+  (s/keys :req-un [::email ::password]
+          :opt-un [::scope]))
+
+(sm/defmutation ::login
+  [{:keys [email password scope] :as params}]
+  (letfn [(check-password [profile password]
+            (when (= (:password profile) "!")
+              (ex/raise :type :validation
+                        :code ::account-without-password))
+            (let [result (sodi.pwhash/verify password (:password profile))]
+              (:valid result)))
+
+          (validate-profile [profile]
+            (when-not profile
+              (ex/raise :type :validation
+                        :code ::wrong-credentials))
+            (when-not (check-password profile password)
+              (ex/raise :type :validation
+                        :code ::wrong-credentials))
+            profile)]
+    (db/with-atomic [conn db/pool]
+      (let [prof (-> (retrieve-profile-by-email conn email)
+                     (validate-profile)
+                     (profile/strip-private-attrs))
+            addt (profile/retrieve-additional-data conn (:id prof))]
+        (merge prof addt)))))
+
+(def sql:profile-by-email
+  "select * from profile
+    where email=? and deleted_at is null
+      for update")
+
+(defn- retrieve-profile-by-email
+  [conn email]
+  (let [email (str/lower email)]
+    (db/exec-one! conn [sql:profile-by-email email])))
+
+
+;; --- Mutation: Register if not exists
+
+(sm/defmutation ::login-or-register
+  [{:keys [email fullname] :as params}]
+  (letfn [(populate-additional-data [conn profile]
+            (let [data (profile/retrieve-additional-data conn (:id profile))]
+              (merge profile data)))
+
+          (create-profile [conn {:keys [fullname email]}]
+            (db/insert! conn :profile
+                        {:id (uuid/next)
+                         :fullname fullname
+                         :email (str/lower email)
+                         :pending-email nil
+                         :photo ""
+                         :password "!"
+                         :is-demo false}))
+
+          (register-profile [conn params]
+            (->> (create-profile conn params)
+                 (create-profile-relations conn)))]
+
+    (db/with-atomic [conn db/pool]
+      (let [profile (retrieve-profile-by-email conn email)
+            profile (if profile
+                      (populate-additional-data conn profile)
+                      (register-profile conn params))]
+        (profile/strip-private-attrs profile)))))
+
+
+;; --- Mutation: Update Profile (own)
+
+(defn- update-profile
+  [conn {:keys [id fullname lang theme] :as params}]
+  (db/update! conn :profile
+              {:fullname fullname
+               :lang lang
+               :theme theme}
+              {:id id}))
+
+(s/def ::update-profile
+  (s/keys :req-un [::id ::fullname ::lang ::theme]))
+
+(sm/defmutation ::update-profile
+  [params]
+  (db/with-atomic [conn db/pool]
+    (update-profile conn params)
+    nil))
+
+
+;; --- Mutation: Update Password
+
+(defn- validate-password!
+  [conn {:keys [profile-id old-password] :as params}]
+  (let [profile (profile/retrieve-profile-data conn profile-id)
+        result  (sodi.pwhash/verify old-password (:password profile))]
+    (when-not (:valid result)
+      (ex/raise :type :validation
+                :code ::old-password-not-match))))
+
+(s/def ::update-profile-password
+  (s/keys :req-un [::profile-id ::password ::old-password]))
+
+(sm/defmutation ::update-profile-password
+  [{:keys [password profile-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (validate-password! conn params)
+    (db/update! conn :profile
+                {:password (sodi.pwhash/derive password)}
+                {:id profile-id})
+    nil))
+
+
+
+;; --- Mutation: Update Photo
+
+(declare upload-photo)
+(declare update-profile-photo)
+
+(s/def ::file ::media-mutations/upload)
+(s/def ::update-profile-photo
+  (s/keys :req-un [::profile-id ::file]))
+
+(sm/defmutation ::update-profile-photo
+  [{:keys [profile-id file] :as params}]
+  (media/validate-media-type (:content-type file))
+  (db/with-atomic [conn db/pool]
+    (let [profile (profile/retrieve-profile conn profile-id)
+          _       (media/run {:cmd :info :input {:path (:tempfile file)
+                                                 :mtype (:content-type file)}})
+          photo   (upload-photo conn params)]
+
+      ;; Schedule deletion of old photo
+      (when (and (string? (:photo profile))
+                 (not (str/blank? (:photo profile))))
+        (tasks/submit! conn {:name "remove-media"
+                             :props {:path (:photo profile)}}))
+      ;; Save new photo
+      (update-profile-photo conn profile-id photo))))
+
+(defn- upload-photo
+  [conn {:keys [file profile-id]}]
+  (let [prefix (-> (sodi.prng/random-bytes 8)
+                   (sodi.util/bytes->b64s))
+        thumb  (media/run
+                 {:cmd :profile-thumbnail
+                  :format :jpeg
+                  :quality 85
+                  :width 256
+                  :height 256
+                  :input  {:path (fs/path (:tempfile file))
+                           :mtype (:content-type file)}})
+        name   (str prefix (cm/format->extension (:format thumb)))]
+    (ust/save! mst/media-storage name (:data thumb))))
+
+(defn- update-profile-photo
+  [conn profile-id path]
+  (db/update! conn :profile
+              {:photo (str path)}
+              {:id profile-id})
+  nil)
+
+;; --- Mutation: Request Email Change
+
+(declare select-profile-for-update)
+
+(s/def ::request-email-change
+  (s/keys :req-un [::email]))
+
+(sm/defmutation ::request-email-change
+  [{:keys [profile-id email] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [email   (str/lower email)
+          profile (select-profile-for-update conn profile-id)
+          payload {:type :change-email
+                   :profile-id profile-id
+                   :email email}
+
+          token   (tokens/create! conn payload)]
+
+      (when (not= email (:email profile))
+        (check-profile-existence! conn params))
+
+      (db/update! conn :profile
+                  {:pending-email email}
+                  {:id profile-id})
+
+      (emails/send! conn emails/change-email
+                    {:to (:email profile)
+                     :name (:fullname profile)
+                     :pending-email email
+                     :token token})
+      nil)))
+
+(defn- select-profile-for-update
+  [conn id]
+  (db/get-by-id conn :profile id {:for-update true}))
+
+
+;; --- Mutation: Verify Profile Token
+
+;; Generic mutation for perform token based verification for auth
+;; domain.
+
+(s/def ::verify-profile-token
+  (s/keys :req-un [::token]))
+
+(sm/defmutation ::verify-profile-token
+  [{:keys [token] :as params}]
+  (letfn [(handle-email-change [conn tdata]
+            (let [profile (select-profile-for-update conn (:profile-id tdata))]
+              (when (not= (:email tdata)
+                          (:pending-email profile))
+                (ex/raise :type :validation
+                          :code ::email-does-not-match))
+              (check-profile-existence! conn {:email (:pending-email profile)})
+              (db/update! conn :profile
+                            {:pending-email nil
+                             :email (:pending-email profile)}
+                            {:id (:id profile)})
+
+              tdata))
+
+          (handle-email-verify [conn tdata]
+            (let [profile (select-profile-for-update conn (:profile-id tdata))]
+              (when (or (not= (:email profile)
+                              (:pending-email profile))
+                        (not= (:email profile)
+                              (:email tdata)))
+                (ex/raise :type :validation
+                          :code ::tokens/invalid-token))
+
+              (db/update! conn :profile
+                          {:pending-email nil}
+                          {:id (:id profile)})
+              tdata))]
+
+    (db/with-atomic [conn db/pool]
+      (let [tdata (tokens/retrieve conn token {:delete true})]
+        (tokens/delete! conn token)
+        (case (:type tdata)
+          :change-email   (handle-email-change conn tdata)
+          :verify-email   (handle-email-verify conn tdata)
+          :authentication tdata
+          (ex/raise :type :validation
+                    :code ::tokens/invalid-token))))))
+
+;; --- Mutation: Cancel Email Change
+
+(s/def ::cancel-email-change
+  (s/keys :req-un [::profile-id]))
+
+(sm/defmutation ::cancel-email-change
+  [{:keys [profile-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [profile (select-profile-for-update conn profile-id)]
+      (when (= (:email profile)
+               (:pending-email profile))
+        (ex/raise :type :validation
+                  :code ::unexpected-request))
+
+      (db/update! conn :profile {:pending-email nil} {:id profile-id})
+      nil)))
+
+;; --- Mutation: Request Profile Recovery
+
+(s/def ::request-profile-recovery
+  (s/keys :req-un [::email]))
+
+(sm/defmutation ::request-profile-recovery
+  [{:keys [email] :as params}]
+  (letfn [(create-recovery-token [conn {:keys [id] :as profile}]
+            (let [payload {:type :password-recovery-token
+                           :profile-id id}
+                  token   (tokens/create! conn payload)]
+              (assoc profile :token token)))
+
+          (send-email-notification [conn profile]
+            (emails/send! conn emails/password-recovery
+                          {:to (:email profile)
+                           :token (:token profile)
+                           :name (:fullname profile)}))]
+
+    (db/with-atomic [conn db/pool]
+      (some->> email
+               (retrieve-profile-by-email conn)
+               (create-recovery-token conn)
+               (send-email-notification conn))
+      nil)))
+
+
+;; --- Mutation: Recover Profile
+
+(s/def ::token ::us/not-empty-string)
+(s/def ::recover-profile
+  (s/keys :req-un [::token ::password]))
+
+(sm/defmutation ::recover-profile
+  [{:keys [token password]}]
+  (letfn [(validate-token [conn token]
+            (let [tpayload (tokens/retrieve conn token)]
+              (when (not= (:type tpayload) :password-recovery-token)
+                (ex/raise :type :validation
+                          :code ::tokens/invalid-token))
+              (:profile-id tpayload)))
+
+          (update-password [conn profile-id]
+            (let [pwd (sodi.pwhash/derive password)]
+              (db/update! conn :profile {:password pwd} {:id profile-id})))
+
+          (delete-token [conn token]
+            (db/delete! conn :generic-token {:token token}))]
+
+
+    (db/with-atomic [conn db/pool]
+      (->> (validate-token conn token)
+           (update-password conn))
+      (delete-token conn token)
+      nil)))
+
+
+;; --- Mutation: Delete Profile
+
+(declare check-teams-ownership!)
+(declare mark-profile-as-deleted!)
+
+(s/def ::delete-profile
+  (s/keys :req-un [::profile-id]))
+
+(sm/defmutation ::delete-profile
+  [{:keys [profile-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (check-teams-ownership! conn profile-id)
+
+    ;; Schedule a complete deletion of profile
+    (tasks/submit! conn {:name "delete-profile"
+                         :delay (dt/duration {:hours 48})
+                         :props {:profile-id profile-id}})
+
+    (db/update! conn :profile
+                {:deleted-at (dt/now)}
+                {:id profile-id})
+    nil))
+
+(def ^:private sql:teams-ownership-check
+  "with teams as (
+     select tpr.team_id as id
+       from team_profile_rel as tpr
+      where tpr.profile_id = ?
+        and tpr.is_owner is true
+   )
+   select tpr.team_id,
+          count(tpr.profile_id) as num_profiles
+     from team_profile_rel as tpr
+    where tpr.team_id in (select id from teams)
+    group by tpr.team_id
+   having count(tpr.profile_id) > 1")
+
+(defn- check-teams-ownership!
+  [conn profile-id]
+  (let [rows (db/exec! conn [sql:teams-ownership-check profile-id])]
+    (when-not (empty? rows)
+      (ex/raise :type :validation
+                :code ::owner-teams-with-people
+                :hint "The user need to transfer ownership of owned teams."
+                :context {:teams (mapv :team-id rows)}))))

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

@@ -0,0 +1,142 @@
+;; 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) 2019-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.services.mutations.projects
+  (:require
+   [clojure.spec.alpha :as s]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.services.mutations :as sm]
+   [app.tasks :as tasks]
+   [app.util.blob :as blob]))
+
+;; --- Helpers & Specs
+
+(s/def ::id ::us/uuid)
+(s/def ::name ::us/string)
+(s/def ::profile-id ::us/uuid)
+
+;; --- Permissions Checks
+
+(def ^:private sql:project-permissions
+  "select tpr.is_owner,
+          tpr.is_admin,
+          tpr.can_edit
+     from team_profile_rel as tpr
+    inner join project as p on (p.team_id = tpr.team_id)
+    where p.id = ?
+      and tpr.profile_id = ?
+   union all
+   select ppr.is_owner,
+          ppr.is_admin,
+          ppr.can_edit
+     from project_profile_rel as ppr
+    where ppr.project_id = ?
+      and ppr.profile_id = ?")
+
+(defn check-edition-permissions!
+  [conn profile-id project-id]
+  (let [rows (db/exec! conn [sql:project-permissions
+                             project-id profile-id
+                             project-id profile-id])]
+    (when (empty? rows)
+      (ex/raise :type :not-found))
+    (when-not (or (some :can-edit rows)
+                  (some :is-admin rows)
+                  (some :is-owner rows))
+      (ex/raise :type :validation
+                :code :not-authorized))))
+
+
+;; --- Mutation: Create Project
+
+(declare create-project)
+(declare create-project-profile)
+
+(s/def ::team-id ::us/uuid)
+(s/def ::create-project
+  (s/keys :req-un [::profile-id ::team-id ::name]
+          :opt-un [::id]))
+
+(sm/defmutation ::create-project
+  [params]
+  (db/with-atomic [conn db/pool]
+    (let [proj (create-project conn params)]
+      (create-project-profile conn (assoc params :project-id (:id proj)))
+      proj)))
+
+(defn create-project
+  [conn {:keys [id profile-id team-id name default?] :as params}]
+  (let [id (or id (uuid/next))
+        default? (if (boolean? default?) default? false)]
+    (db/insert! conn :project
+                {:id id
+                 :team-id team-id
+                 :name name
+                 :is-default default?})))
+
+(defn create-project-profile
+  [conn {:keys [project-id profile-id] :as params}]
+  (db/insert! conn :project-profile-rel
+              {:project-id project-id
+               :profile-id profile-id
+               :is-owner true
+               :is-admin true
+               :can-edit true}))
+
+
+
+;; --- Mutation: Rename Project
+
+(declare rename-project)
+
+(s/def ::rename-project
+  (s/keys :req-un [::profile-id ::name ::id]))
+
+(sm/defmutation ::rename-project
+  [{:keys [id profile-id name] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [project (db/get-by-id conn :project id {:for-update true})]
+      (check-edition-permissions! conn profile-id id)
+      (db/update! conn :project
+                  {:name name}
+                  {:id id}))))
+
+;; --- Mutation: Delete Project
+
+(declare mark-project-deleted)
+
+(s/def ::delete-project
+  (s/keys :req-un [::id ::profile-id]))
+
+(sm/defmutation ::delete-project
+  [{:keys [id profile-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (check-edition-permissions! conn profile-id id)
+
+    ;; Schedule object deletion
+    (tasks/submit! conn {:name "delete-object"
+                         :delay cfg/default-deletion-delay
+                         :props {:id id :type :project}})
+
+    (mark-project-deleted conn params)))
+
+(def ^:private sql:mark-project-deleted
+  "update project
+      set deleted_at = clock_timestamp()
+    where id = ?
+   returning id")
+
+(defn mark-project-deleted
+  [conn {:keys [id profile-id] :as params}]
+  (db/exec! conn [sql:mark-project-deleted id])
+  nil)

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

@@ -0,0 +1,79 @@
+;; 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.services.mutations.teams
+  (:require
+   [clojure.spec.alpha :as s]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.db :as db]
+   [app.services.mutations :as sm]
+   [app.util.blob :as blob]))
+
+;; --- Helpers & Specs
+
+(s/def ::id ::us/uuid)
+(s/def ::name ::us/string)
+(s/def ::profile-id ::us/uuid)
+
+;; --- Mutation: Create Team
+
+(declare create-team)
+(declare create-team-profile)
+
+(s/def ::create-team
+  (s/keys :req-un [::profile-id ::name]
+          :opt-un [::id]))
+
+(sm/defmutation ::create-team
+  [params]
+  (db/with-atomic [conn db/pool]
+    (let [team (create-team conn params)]
+      (create-team-profile conn (assoc params :team-id (:id team)))
+      team)))
+
+(defn create-team
+  [conn {:keys [id profile-id name default?] :as params}]
+  (let [id (or id (uuid/next))
+        default? (if (boolean? default?) default? false)]
+    (db/insert! conn :team
+                {:id id
+                 :name name
+                 :photo ""
+                 :is-default default?})))
+
+(defn create-team-profile
+  [conn {:keys [team-id profile-id] :as params}]
+  (db/insert! conn :team-profile-rel
+              {:team-id team-id
+               :profile-id profile-id
+               :is-owner true
+               :is-admin true
+               :can-edit true}))
+
+;; --- Mutation: Team Edition Permissions
+
+(def ^:private sql:team-permissions
+  "select tpr.is_owner,
+          tpr.is_admin,
+          tpr.can_edit
+     from team_profile_rel as tpr
+    where tpr.profile_id = ?
+      and tpr.team_id = ?")
+
+(defn check-edition-permissions!
+  [conn profile-id team-id]
+  (let [row (db/exec-one! conn [sql:team-permissions profile-id team-id])]
+    (when-not (or (= team-id uuid/zero)
+                  (:can-edit row)
+                  (:is-admin row)
+                  (:is-owner row))
+      (ex/raise :type :validation
+                :code :not-authorized))))

backend/src/app/services/notifications.clj

@@ -0,0 +1,236 @@
+;; 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.services.notifications
+  "A websocket based notifications mechanism."
+  (:require
+   [clojure.core.async :as a :refer [>! <!]]
+   [clojure.tools.logging :as log]
+   [promesa.core :as p]
+   [ring.adapter.jetty9 :as jetty]
+   [app.common.exceptions :as ex]
+   [app.common.uuid :as uuid]
+   [app.db :as db]
+   [app.redis :as redis]
+   [app.metrics :as mtx]
+   [app.util.time :as dt]
+   [app.util.transit :as t]))
+
+(defmacro go-try
+  [& body]
+  `(a/go
+     (try
+       ~@body
+       (catch Throwable e# e#))))
+
+(defmacro <?
+  [ch]
+  `(let [r# (a/<! ~ch)]
+     (if (instance? Throwable r#)
+       (throw r#)
+       r#)))
+
+(defmacro thread-try
+  [& body]
+  `(a/thread
+     (try
+       ~@body
+       (catch Throwable e#
+         e#))))
+
+;; --- Redis Interactions
+
+(defn- publish
+  [channel message]
+  (go-try
+   (let [message (t/encode-str message)]
+     (<? (redis/run :publish {:channel (str channel)
+                              :message message})))))
+
+(def ^:private
+  sql:retrieve-presence
+  "select * from presence
+    where file_id=?
+      and (clock_timestamp() - updated_at) < '5 min'::interval")
+
+(defn- retrieve-presence
+  [file-id]
+  (thread-try
+   (let [rows (db/exec! db/pool [sql:retrieve-presence file-id])]
+     (mapv (juxt :session-id :profile-id) rows))))
+
+(def ^:private
+  sql:update-presence
+  "insert into presence (file_id, session_id, profile_id, updated_at)
+   values (?, ?, ?, clock_timestamp())
+       on conflict (file_id, session_id, profile_id)
+       do update set updated_at=clock_timestamp()")
+
+(defn- update-presence
+  [file-id session-id profile-id]
+  (thread-try
+   (let [now (dt/now)
+         sql [sql:update-presence file-id session-id profile-id]]
+     (db/exec-one! db/pool sql))))
+
+(defn- delete-presence
+  [file-id session-id profile-id]
+  (thread-try
+   (db/delete! db/pool :presence {:file-id file-id
+                                  :profile-id profile-id
+                                  :session-id session-id})))
+
+;; --- WebSocket Messages Handling
+
+(defmulti handle-message
+  (fn [ws message] (:type message)))
+
+;; TODO: check permissions for join a file-id channel (probably using
+;; single use token for avoid explicit database query).
+
+(defmethod handle-message :connect
+  [{:keys [file-id profile-id session-id output] :as ws} message]
+  (log/debugf "profile '%s' is connected to file '%s'" profile-id file-id)
+  (go-try
+   (<? (update-presence file-id session-id profile-id))
+   (let [members (<? (retrieve-presence file-id))]
+     (<? (publish file-id {:type :presence :sessions members})))))
+
+(defmethod handle-message :disconnect
+  [{:keys [profile-id file-id session-id] :as ws} message]
+  (log/debugf "profile '%s' is disconnected from '%s'" profile-id file-id)
+  (go-try
+   (<? (delete-presence file-id session-id profile-id))
+   (let [members (<? (retrieve-presence file-id))]
+     (<? (publish file-id {:type :presence :sessions members})))))
+
+(defmethod handle-message :keepalive
+  [{:keys [profile-id file-id session-id] :as ws} message]
+  (update-presence file-id session-id profile-id))
+
+(defmethod handle-message :pointer-update
+  [{:keys [profile-id file-id session-id] :as ws} message]
+  (let [message (assoc message
+                       :profile-id profile-id
+                       :session-id session-id)]
+    (publish file-id message)))
+
+(defmethod handle-message :default
+  [ws message]
+  (a/go
+    (log/warnf "received unexpected message: " message)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; WebSocket Handler
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- forward-message
+  [{:keys [out session-id profile-id] :as ws} message]
+  (go-try
+   (when-not (= (:session-id message) session-id)
+     (>! out message))))
+
+(defn start-loop!
+  [{:keys [in out sub] :as ws}]
+  (go-try
+   (loop []
+     (let [timeout (a/timeout 30000)
+           [val port] (a/alts! [in sub timeout])]
+       ;; (prn "alts" val "from" (cond (= port in)  "input"
+       ;;                              (= port sub) "redis"
+       ;;                              :else "timeout"))
+
+       (cond
+         ;; Process message coming from connected client
+         (and (= port in) (not (nil? val)))
+         (do
+           (<? (handle-message ws val))
+           (recur))
+
+         ;; Forward message to the websocket
+         (and (= port sub) (not (nil? val)))
+         (do
+           (<? (forward-message ws val))
+           (recur))
+
+         ;; Timeout channel signaling
+         (= port timeout)
+         (do
+           (>! out {:type :ping})
+           (recur))
+
+         :else
+         nil)))))
+
+(defn disconnect!
+  [conn]
+  (let [session (.getSession conn)]
+    (when session
+      (.disconnect session))))
+
+(defn- on-subscribed
+  [{:keys [conn] :as ws}]
+  (a/go
+    (try
+      (<? (handle-message ws {:type :connect}))
+      (<? (start-loop! ws))
+      (<? (handle-message ws {:type :disconnect}))
+      (catch Throwable err
+        (log/errorf err "Unexpected exception on websocket handler.")
+        (disconnect! conn)))))
+
+(defrecord WebSocket [conn in out sub])
+
+(defn- start-rcv-loop!
+  [{:keys [conn out] :as ws}]
+  (a/go-loop []
+    (let [val (a/<! out)]
+      (when-not (nil? val)
+        (jetty/send! conn (t/encode-str val))
+        (recur)))))
+
+(defonce metrics-active-connections
+  (mtx/gauge {:id "notificatons__active_connections"
+              :help "Active connections to the notifications service."}))
+
+(defonce metrics-message-counter
+  (mtx/counter {:id "notificatons__messages_counter"
+                :help "A total number of messages handled by the notifications service."}))
+
+(defn websocket
+  [{:keys [file-id profile-id] :as params}]
+  (let [in  (a/chan 32)
+        out (a/chan 32)]
+    {:on-connect (fn [conn]
+                   (metrics-active-connections :inc)
+                   (let [xf  (map t/decode-str)
+                         sub (redis/subscribe (str file-id) xf)
+                         ws  (WebSocket. conn in out sub nil params)]
+                     (start-rcv-loop! ws)
+                     (a/go
+                       (a/<! (on-subscribed ws))
+                       (a/close! sub))))
+
+     :on-error (fn [conn e]
+                 (a/close! out)
+                 (a/close! in))
+
+     :on-close (fn [conn status-code reason]
+                 (metrics-active-connections :dec)
+                 (a/close! out)
+                 (a/close! in))
+
+     :on-text (fn [ws message]
+                (metrics-message-counter :inc)
+                (let [message (t/decode-str message)]
+                  (a/>!! in message)))
+
+     :on-bytes (constantly nil)}))
+
+

backend/src/app/services/queries.clj

@@ -0,0 +1,21 @@
+;; 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.services.queries
+  (:require
+   [app.services.middleware :as middleware]
+   [app.util.dispatcher :as uds]))
+
+(uds/defservice handle
+  :dispatch-by ::type
+  :wrap middleware/wrap)
+
+(defmacro defquery
+  [key & rest]
+  `(uds/defmethod handle ~key ~@rest))

backend/src/app/services/queries/colors.clj

@@ -0,0 +1,104 @@
+;; 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) 2019 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.services.queries.colors
+  (:require
+   [clojure.spec.alpha :as s]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.db :as db]
+   [app.services.queries :as sq]
+   [app.services.queries.teams :as teams]
+   [app.util.blob :as blob]
+   [app.util.data :as data]))
+
+;; --- Helpers & Specs
+
+(s/def ::id ::us/uuid)
+(s/def ::profile-id ::us/uuid)
+(s/def ::team-id ::us/uuid)
+(s/def ::file-id ::us/uuid)
+
+
+;; --- Query: Colors (by file)
+
+(declare retrieve-colors)
+(declare retrieve-file)
+
+(s/def ::colors
+  (s/keys :req-un [::profile-id ::file-id]))
+
+(sq/defquery ::colors
+  [{:keys [profile-id file-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [file (retrieve-file conn file-id)]
+      (teams/check-read-permissions! conn profile-id (:team-id file))
+      (retrieve-colors conn file-id))))
+
+(def ^:private sql:colors
+  "select *
+     from color
+    where color.deleted_at is null
+      and color.file_id = ?
+   order by created_at desc")
+
+(defn- retrieve-colors
+  [conn file-id]
+  (db/exec! conn [sql:colors file-id]))
+
+(def ^:private sql:retrieve-file
+  "select file.*,
+          project.team_id as team_id
+     from file
+    inner join project on (project.id = file.project_id)
+    where file.id = ?")
+
+(defn- retrieve-file
+  [conn id]
+  (let [row (db/exec-one! conn [sql:retrieve-file id])]
+    (when-not row
+      (ex/raise :type :not-found))
+    row))
+
+
+;; --- Query: Color (by ID)
+
+(declare retrieve-color)
+
+(s/def ::id ::us/uuid)
+(s/def ::color
+  (s/keys :req-un [::profile-id ::id]))
+
+(sq/defquery ::color
+  [{:keys [profile-id id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [color (retrieve-color conn id)]
+      (teams/check-read-permissions! conn profile-id (:team-id color))
+      color)))
+
+(def ^:private sql:single-color
+  "select color.*,
+          p.team_id as team_id
+     from color as color
+    inner join file as f on (color.file_id = f.id)
+    inner join project as p on (p.id = f.project_id)
+    where color.deleted_at is null
+      and color.id = ?
+   order by created_at desc")
+
+(defn retrieve-color
+  [conn id]
+  (let [row (db/exec-one! conn [sql:single-color id])]
+    (when-not row
+      (ex/raise :type :not-found))
+    row))
+

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

@@ -0,0 +1,355 @@
+;; 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) 2019-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.services.queries.files
+  (:require
+   [clojure.spec.alpha :as s]
+   [promesa.core :as p]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.db :as db]
+   [app.media :as media]
+   [app.services.queries :as sq]
+   [app.util.blob :as blob]))
+
+(declare decode-row)
+
+;; --- Helpers & Specs
+
+(s/def ::id ::us/uuid)
+(s/def ::name ::us/string)
+(s/def ::project-id ::us/uuid)
+(s/def ::file-id ::us/uuid)
+(s/def ::profile-id ::us/uuid)
+(s/def ::team-id ::us/uuid)
+(s/def ::search-term ::us/string)
+
+;; --- Query: Files search
+
+(def ^:private sql:search-files
+  "with projects as (
+     select p.*
+       from project as p
+      inner join team_profile_rel as tpr on (tpr.team_id = p.team_id)
+      where tpr.profile_id = ?
+        and p.team_id = ?
+        and p.deleted_at is null
+        and (tpr.is_admin = true or
+             tpr.is_owner = true or
+             tpr.can_edit = true)
+      union
+     select p.*
+       from project as p
+      inner join project_profile_rel as ppr on (ppr.project_id = p.id)
+      where ppr.profile_id = ?
+        and p.team_id = ?
+        and p.deleted_at is null
+        and (ppr.is_admin = true or
+             ppr.is_owner = true or
+             ppr.can_edit = true)
+      union
+     select p.*
+       from project as p
+      where p.team_id = uuid_nil()
+        and p.deleted_at is null
+   )
+   select distinct
+          file.*,
+          array_agg(page.id) over pages_w as pages,
+          first_value(page.data) over pages_w as data
+     from file
+    inner join projects as pr on (file.project_id = pr.id)
+     left join page on (file.id = page.file_id)
+    where file.name ilike ('%' || ? || '%')
+      and file.deleted_at is null
+   window pages_w as (partition by file.id order by page.created_at
+                      range between unbounded preceding
+                                and unbounded following)
+    order by file.created_at asc")
+
+(s/def ::search-files
+  (s/keys :req-un [::profile-id ::team-id ::search-term]))
+
+(sq/defquery ::search-files
+  [{:keys [profile-id team-id search-term] :as params}]
+  (let [rows (db/exec! db/pool [sql:search-files
+                                profile-id team-id
+                                profile-id team-id
+                                search-term])]
+    (mapv decode-row rows)))
+
+
+;; --- Query: Project Files
+
+(def ^:private sql:files
+  "with projects as (
+     select p.*
+       from project as p
+      inner join team_profile_rel as tpr on (tpr.team_id = p.team_id)
+      where tpr.profile_id = ?
+        and p.deleted_at is null
+        and (tpr.is_admin = true or
+             tpr.is_owner = true or
+             tpr.can_edit = true)
+      union
+     select p.*
+       from project as p
+      inner join project_profile_rel as ppr on (ppr.project_id = p.id)
+      where ppr.profile_id = ?
+        and p.deleted_at is null
+        and (ppr.is_admin = true or
+             ppr.is_owner = true or
+             ppr.can_edit = true)
+      union
+     select p.*
+       from project as p
+      where p.team_id = uuid_nil()
+        and p.deleted_at is null
+   )
+   select distinct
+          f.*,
+          array_agg(pg.id) over pages_w as pages,
+          first_value(pg.data) over pages_w as data
+     from file as f
+     left join page as pg on (f.id = pg.file_id)
+    where f.project_id = ?
+      and (exists (select *
+                    from file_profile_rel as fp_r
+                   where fp_r.profile_id = ?
+                     and fp_r.file_id = f.id
+                     and (fp_r.is_admin = true or
+                          fp_r.is_owner = true or
+                          fp_r.can_edit = true))
+           or exists (select *
+                        from projects as p
+                       where p.id = f.project_id))
+      and f.deleted_at is null
+      and pg.deleted_at is null
+   window pages_w as (partition by f.id order by pg.ordering
+                      range between unbounded preceding
+                                and unbounded following)
+    order by f.modified_at desc")
+
+(s/def ::project-id ::us/uuid)
+(s/def ::files
+  (s/keys :req-un [::profile-id ::project-id]))
+
+(sq/defquery ::files
+  [{:keys [profile-id project-id] :as params}]
+  (->> (db/exec! db/pool [sql:files
+                          profile-id profile-id
+                          project-id profile-id])
+       (mapv decode-row)))
+
+
+;; --- Query: File Permissions
+
+(def ^:private sql:file-permissions
+  "select fpr.is_owner,
+          fpr.is_admin,
+          fpr.can_edit
+     from file_profile_rel as fpr
+    where fpr.file_id = ?
+      and fpr.profile_id = ?
+   union all
+   select tpr.is_owner,
+          tpr.is_admin,
+          tpr.can_edit
+     from team_profile_rel as tpr
+    inner join project as p on (p.team_id = tpr.team_id)
+    inner join file as f on (p.id = f.project_id)
+    where f.id = ?
+      and tpr.profile_id = ?
+   union all
+   select ppr.is_owner,
+          ppr.is_admin,
+          ppr.can_edit
+     from project_profile_rel as ppr
+    inner join file as f on (f.project_id = ppr.project_id)
+    where f.id = ?
+      and ppr.profile_id = ?
+   union all
+   select true, true, true
+     from file as f
+    inner join project as p on (f.project_id = p.id)
+      and p.team_id = uuid_nil();")
+
+(defn check-edition-permissions!
+  [conn profile-id file-id]
+  (let [rows (db/exec! conn [sql:file-permissions
+                             file-id profile-id
+                             file-id profile-id
+                             file-id profile-id])]
+    (when (empty? rows)
+      (ex/raise :type :not-found))
+
+    (when-not (or (some :can-edit rows)
+                  (some :is-admin rows)
+                  (some :is-owner rows))
+      (ex/raise :type :validation
+                :code :not-authorized))))
+
+
+;; --- Query: File (By ID)
+
+(def ^:private sql:file
+  "select f.*,
+          array_agg(pg.id) over pages_w as pages
+     from file as f
+     left join page as pg on (f.id = pg.file_id)
+    where f.id = ?
+      and f.deleted_at is null
+      and pg.deleted_at is null
+   window pages_w as (partition by f.id order by pg.ordering
+                      range between unbounded preceding
+                                and unbounded following)")
+
+(defn retrieve-file
+  [conn id]
+  (let [row (db/exec-one! conn [sql:file id])]
+    (when-not row
+      (ex/raise :type :not-found))
+    (decode-row row)))
+
+(s/def ::file
+  (s/keys :req-un [::profile-id ::id]))
+
+(sq/defquery ::file
+  [{:keys [profile-id id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (check-edition-permissions! conn profile-id id)
+    (retrieve-file conn id)))
+
+
+;; --- Query: File users
+
+(def ^:private sql:file-users
+  "select pf.id, pf.fullname, pf.photo
+     from profile as pf
+    inner join file_profile_rel as fpr on (fpr.profile_id = pf.id)
+    where fpr.file_id = ?
+    union
+   select pf.id, pf.fullname, pf.photo
+     from profile as pf
+    inner join team_profile_rel as tpr on (tpr.profile_id = pf.id)
+    inner join project as p on (tpr.team_id = p.team_id)
+    inner join file as f on (p.id = f.project_id)
+    where f.id = ?")
+
+(defn retrieve-file-users
+  [conn id]
+  (->> (db/exec! conn [sql:file-users id id])
+       (mapv #(media/resolve-media-uris % [:photo :photo-uri]))))
+
+(s/def ::file-users
+  (s/keys :req-un [::profile-id ::id]))
+
+(sq/defquery ::file-users
+  [{:keys [profile-id id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (check-edition-permissions! conn profile-id id)
+    (retrieve-file-users conn id)))
+
+
+;; --- Query: Shared Library Files
+
+(def ^:private sql:shared-files
+  "select distinct
+          f.*,
+          array_agg(pg.id) over pages_w as pages,
+          first_value(pg.data) over pages_w as data,
+          (select count(*) from color as c
+            where c.file_id = f.id
+              and c.deleted_at is null) as colors_count,
+          (select count(*) from media_object as m
+            where m.file_id = f.id
+              and m.is_local = false
+              and m.deleted_at is null) as graphics_count
+     from file as f
+     left join page as pg on (f.id = pg.file_id)
+    where is_shared = true
+      and f.deleted_at is null
+      and pg.deleted_at is null
+   window pages_w as (partition by f.id order by pg.ordering
+                      range between unbounded preceding
+                                and unbounded following)
+    order by f.modified_at desc")
+
+(s/def ::shared-files
+  (s/keys :req-un [::profile-id]))
+
+(sq/defquery ::shared-files
+  [{:keys [profile-id] :as params}]
+  (->> (db/exec! db/pool [sql:shared-files])
+       (mapv decode-row)))
+
+
+;; --- Query: File Libraries used by a File
+
+(def ^:private sql:file-libraries
+  "select fl.*,
+          array_agg(pg.id) over pages_w as pages,
+          first_value(pg.data) over pages_w as data
+     from file as fl
+     left join page as pg on (fl.id = pg.file_id)
+    inner join file_library_rel as flr on (flr.library_file_id = fl.id)
+    where flr.file_id = ?
+      and fl.deleted_at is null
+      and pg.deleted_at is null
+   window pages_w as (partition by fl.id order by pg.ordering
+                      range between unbounded preceding
+                                and unbounded following)")
+
+(defn retrieve-file-libraries
+  [conn file-id]
+  (->> (db/exec! conn [sql:file-libraries file-id])
+       (mapv decode-row)))
+
+(s/def ::file-libraries
+  (s/keys :req-un [::profile-id ::file-id]))
+
+(sq/defquery ::file-libraries
+  [{:keys [profile-id file-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (check-edition-permissions! conn profile-id file-id)
+    (retrieve-file-libraries conn file-id)))
+
+
+;; --- Query: Single File Library
+
+(def ^:private sql:file-library
+  "select fl.*
+     from file as fl
+    where fl.id = ?")
+
+(defn retrieve-file-library
+  [conn file-id]
+  (let [row (db/exec-one! conn [sql:file-library file-id])]
+    (when-not row
+      (ex/raise :type :not-found))
+    row))
+
+(s/def ::file-library
+  (s/keys :req-un [::profile-id ::file-id]))
+
+(sq/defquery ::file-library
+  [{:keys [profile-id file-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (check-edition-permissions! conn profile-id file-id) ;; TODO: this should check read permissions
+    (retrieve-file-library conn file-id)))
+
+
+;; --- Helpers
+
+(defn decode-row
+  [{:keys [pages data] :as row}]
+  (when row
+    (cond-> row
+      data (assoc :data (blob/decode data))
+      pages (assoc :pages (vec (.getArray pages))))))

backend/src/app/services/queries/media.clj

@@ -0,0 +1,109 @@
+;; 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) 2019-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.services.queries.media
+  (:require
+   [clojure.spec.alpha :as s]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.db :as db]
+   [app.media :as media]
+   [app.services.queries :as sq]
+   [app.services.queries.teams :as teams]))
+
+(s/def ::id ::us/uuid)
+(s/def ::name ::us/string)
+(s/def ::profile-id ::us/uuid)
+(s/def ::team-id ::us/uuid)
+(s/def ::file-id ::us/uuid)
+
+
+;; --- Query: Media objects (by file)
+
+(declare retrieve-media-objects)
+(declare retrieve-file)
+
+(s/def ::is-local ::us/boolean)
+(s/def ::media-objects
+  (s/keys :req-un [::profile-id ::file-id ::is-local]))
+
+;; TODO: check if we can resolve url with transducer for reduce
+;; garbage generation for each request
+
+(sq/defquery ::media-objects
+  [{:keys [profile-id file-id is-local] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [file (retrieve-file conn file-id)]
+      (teams/check-read-permissions! conn profile-id (:team-id file))
+      (->> (retrieve-media-objects conn file-id is-local)
+           (mapv #(media/resolve-urls % :path :uri))
+           (mapv #(media/resolve-urls % :thumb-path :thumb-uri))))))
+
+(def ^:private sql:media-objects
+  "select obj.*,
+          thumb.path as thumb_path
+     from media_object as obj
+    inner join media_thumbnail as thumb on obj.id = thumb.media_object_id
+    where obj.deleted_at is null
+      and obj.file_id = ?
+      and obj.is_local = ?
+   order by obj.created_at desc")
+
+(defn retrieve-media-objects
+  [conn file-id is-local]
+  (db/exec! conn [sql:media-objects file-id is-local]))
+
+(def ^:private sql:retrieve-file
+  "select file.*,
+          project.team_id as team_id
+     from file
+    inner join project on (project.id = file.project_id)
+    where file.id = ?")
+
+(defn- retrieve-file
+  [conn id]
+  (let [row (db/exec-one! conn [sql:retrieve-file id])]
+    (when-not row
+      (ex/raise :type :not-found))
+    row))
+
+
+;; --- Query: Media object (by ID)
+
+(declare retrieve-media-object)
+
+(s/def ::id ::us/uuid)
+(s/def ::media-object
+  (s/keys :req-un [::profile-id ::id]))
+
+(sq/defquery ::media-object
+  [{:keys [profile-id id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [media-object (retrieve-media-object conn id)]
+      (teams/check-read-permissions! conn profile-id (:team-id media-object))
+      (-> media-object
+          (media/resolve-urls :path :uri)))))
+
+(def ^:private sql:media-object
+  "select obj.*,
+          p.team_id as team_id
+     from media_object as obj
+    inner join file as f on (f.id = obj.file_id)
+    inner join project as p on (p.id = f.project_id)
+    where obj.deleted_at is null
+      and obj.id = ?
+   order by created_at desc")
+
+(defn retrieve-media-object
+  [conn id]
+  (let [row (db/exec-one! conn [sql:media-object id])]
+    (when-not row
+      (ex/raise :type :not-found))
+    row))
+

backend/src/app/services/queries/pages.clj

@@ -0,0 +1,122 @@
+;; 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) 2019-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.services.queries.pages
+  (:require
+   [clojure.spec.alpha :as s]
+   [promesa.core :as p]
+   [app.common.spec :as us]
+   [app.common.exceptions :as ex]
+   [app.common.pages-migrations :as pmg]
+   [app.db :as db]
+   [app.services.queries :as sq]
+   [app.services.queries.files :as files]
+   [app.util.blob :as blob]))
+
+;; --- Helpers & Specs
+
+(declare decode-row)
+
+(s/def ::id ::us/uuid)
+(s/def ::profile-id ::us/uuid)
+(s/def ::project-id ::us/uuid)
+(s/def ::file-id ::us/uuid)
+
+;; --- Query: Pages (By File ID)
+
+(declare retrieve-pages)
+
+(s/def ::pages
+  (s/keys :req-un [::profile-id ::file-id]))
+
+(sq/defquery ::pages
+  [{:keys [profile-id file-id] :as params}]
+  (db/with-atomic [conn db/pool]
+    (files/check-edition-permissions! conn profile-id file-id)
+    (->> (retrieve-pages conn params)
+         (mapv #(update % :data pmg/migrate-data)))))
+
+(def ^:private sql:pages
+  "select p.*
+     from page as p
+    where p.file_id = ?
+      and p.deleted_at is null
+    order by p.created_at asc")
+
+(defn- retrieve-pages
+  [conn {:keys [profile-id file-id] :as params}]
+  (->> (db/exec! conn [sql:pages file-id])
+       (mapv decode-row)))
+
+;; --- Query: Single Page (By ID)
+
+(declare retrieve-page)
+
+(s/def ::page
+  (s/keys :req-un [::profile-id ::id]))
+
+(sq/defquery ::page
+  [{:keys [profile-id id] :as params}]
+  (with-open [conn (db/open)]
+    (let [page (retrieve-page conn id)]
+      (files/check-edition-permissions! conn profile-id (:file-id page))
+      (-> page
+          (update :data pmg/migrate-data)))))
+
+(def ^:private sql:page
+  "select p.* from page as p where id=?")
+
+(defn retrieve-page
+  [conn id]
+  (let [row (db/exec-one! conn [sql:page id])]
+    (when-not row
+      (ex/raise :type :not-found))
+    (decode-row row)))
+
+;; --- Query: Page Changes
+
+(def ^:private
+  sql:page-changes
+  "select pc.id,
+          pc.created_at,
+          pc.changes,
+          pc.revn
+     from page_change as pc
+    where pc.page_id=?
+    order by pc.revn asc
+    limit ?
+   offset ?")
+
+
+(s/def ::skip ::us/integer)
+(s/def ::limit ::us/integer)
+
+(s/def ::page-changes
+  (s/keys :req-un [::profile-id ::id ::skip ::limit]))
+
+(defn retrieve-page-changes
+  [conn id skip limit]
+  (->> (db/exec! conn [sql:page-changes id limit skip])
+       (mapv decode-row)))
+
+(sq/defquery ::page-changes
+  [{:keys [profile-id id skip limit]}]
+  (when *assert*
+    (-> (db/exec! db/pool [sql:page-changes id limit skip])
+        (mapv decode-row))))
+
+
+;; --- Helpers
+
+(defn decode-row
+  [{:keys [data metadata changes] :as row}]
+  (when row
+    (cond-> row
+      data (assoc :data (blob/decode data))
+      changes (assoc :changes (blob/decode changes)))))

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

@@ -0,0 +1,95 @@
+;; 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) 2016 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.services.queries.profile
+  (:require
+   [clojure.spec.alpha :as s]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.db :as db]
+   [app.media :as media]
+   [app.services.queries :as sq]
+   [app.common.uuid :as uuid]
+   [app.util.blob :as blob]))
+
+;; --- Helpers & Specs
+
+(declare strip-private-attrs)
+
+(s/def ::email ::us/email)
+(s/def ::fullname ::us/string)
+(s/def ::metadata any?)
+(s/def ::old-password ::us/string)
+(s/def ::password ::us/string)
+(s/def ::path ::us/string)
+(s/def ::user ::us/uuid)
+(s/def ::profile-id ::us/uuid)
+(s/def ::theme ::us/string)
+
+;; --- Query: Profile (own)
+
+(declare retrieve-profile)
+(declare retrieve-additional-data)
+
+(s/def ::profile
+  (s/keys :opt-un [::profile-id]))
+
+(sq/defquery ::profile
+  [{:keys [profile-id] :as params}]
+  (if profile-id
+    (with-open [conn (db/open)]
+      (retrieve-profile conn profile-id))
+    {:id uuid/zero
+     :fullname "Anonymous User"}))
+
+;; NOTE: this query make the assumption that union all preserves the
+;; order so the first id will always be the team id and the second the
+;; project_id; this is a postgresql behavior because UNION ALL works
+;; like APPEND operation.
+
+(def ^:private sql:default-team-and-project
+  "select t.id
+     from team as t
+    inner join team_profile_rel as tpr on (tpr.team_id = t.id)
+    where tpr.profile_id = ?
+      and tpr.is_owner is true
+      and t.is_default is true
+    union all
+   select p.id
+     from project as p
+    inner join project_profile_rel as tpr on (tpr.project_id = p.id)
+    where tpr.profile_id = ?
+      and tpr.is_owner is true
+      and p.is_default is true")
+
+(defn retrieve-additional-data
+  [conn id]
+  (let [[team project] (db/exec! conn [sql:default-team-and-project id id])]
+    {:default-team-id (:id team)
+     :default-project-id (:id project)}))
+
+(defn retrieve-profile-data
+  [conn id]
+  (db/get-by-id conn :profile id))
+
+(defn retrieve-profile
+  [conn id]
+  (let [profile (some-> (retrieve-profile-data conn id)
+                        (media/resolve-urls :photo :photo-uri)
+                        (strip-private-attrs)
+                        (merge (retrieve-additional-data conn id)))]
+    (when (nil? profile)
+      (ex/raise :type :not-found
+                :hint "Object doest not exists."))
+
+    profile))
+
+;; --- Attrs Helpers
+
+(defn strip-private-attrs
+  "Only selects a publicy visible profile attrs."
+  [row]
+  (dissoc row :password :deleted-at))

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

@@ -0,0 +1,92 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.services.queries.projects
+  (:require
+   [clojure.spec.alpha :as s]
+   [promesa.core :as p]
+   [app.common.spec :as us]
+   [app.db :as db]
+   [app.services.queries :as sq]
+   [app.util.blob :as blob]))
+
+(declare decode-row)
+
+;; TODO: this module should be refactored for to separate the
+;; permissions checks from the main queries in the same way as pages
+;; and files. This refactor will make this functions more "reusable"
+;; and will prevent duplicating queries on `queries.view` ns as
+;; example.
+
+;; --- Query: Projects
+
+(def ^:private sql:projects
+  "with projects as (
+     select p.*,
+            (select count(*) from file as f
+              where f.project_id = p.id
+                and deleted_at is null) as file_count
+       from project as p
+      inner join team_profile_rel as tpr on (tpr.team_id = p.team_id)
+      where tpr.profile_id = ?
+        and p.deleted_at is null
+        and (tpr.is_admin = true or
+             tpr.is_owner = true or
+             tpr.can_edit = true)
+      union
+     select p.*,
+            (select count(*) from file as f
+              where f.project_id = p.id
+                and deleted_at is null)
+       from project as p
+      inner join project_profile_rel as ppr on (ppr.project_id = p.id)
+      where ppr.profile_id = ?
+        and p.deleted_at is null
+        and (ppr.is_admin = true or
+             ppr.is_owner = true or
+             ppr.can_edit = true)
+   )
+   select *
+     from projects
+    where team_id = ?
+    order by modified_at desc")
+
+(def ^:private sql:project-by-id
+  "select p.*
+     from project as p
+    inner join project_profile_rel as ppr on (ppr.project_id = p.id)
+    where ppr.profile_id = ?
+      and p.id = ?
+      and p.deleted_at is null
+      and (ppr.is_admin = true or
+           ppr.is_owner = true or
+           ppr.can_edit = true)")
+
+(s/def ::team-id ::us/uuid)
+(s/def ::profile-id ::us/uuid)
+(s/def ::project-id ::us/uuid)
+
+(s/def ::projects-by-team
+  (s/keys :req-un [::profile-id ::team-id]))
+
+(s/def ::project-by-id
+  (s/keys :req-un [::profile-id ::project-id]))
+
+(defn retrieve-projects
+  [conn profile-id team-id]
+  (db/exec! conn [sql:projects profile-id profile-id team-id]))
+
+(defn retrieve-project
+  [conn profile-id id]
+  (db/exec-one! conn [sql:project-by-id profile-id id]))
+
+(sq/defquery ::projects-by-team
+  [{:keys [profile-id team-id]}]
+  (retrieve-projects db/pool profile-id team-id))
+
+(sq/defquery ::project-by-id
+  [{:keys [profile-id project-id]}]
+  (retrieve-project db/pool profile-id project-id))

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

@@ -0,0 +1,60 @@
+;; 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) 2019-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.services.queries.recent-files
+  (:require
+   [clojure.spec.alpha :as s]
+   [promesa.core :as p]
+   [app.db :as db]
+   [app.common.spec :as us]
+   [app.services.queries :as sq]
+   [app.services.queries.projects :refer [retrieve-projects]]
+   [app.services.queries.files :refer [decode-row]]))
+
+(def ^:private sql:project-files-recent
+  "select distinct
+          f.*,
+          array_agg(pg.id) over pages_w as pages,
+          first_value(pg.data) over pages_w as data
+     from file as f
+    inner join file_profile_rel as fp_r on (fp_r.file_id = f.id)
+     left join page as pg on (f.id = pg.file_id)
+    where fp_r.profile_id = ?
+      and f.project_id = ?
+      and f.deleted_at is null
+      and pg.deleted_at is null
+      and (fp_r.is_admin = true or
+           fp_r.is_owner = true or
+           fp_r.can_edit = true)
+   window pages_w as (partition by f.id order by pg.ordering
+                      range between unbounded preceding
+                                and unbounded following)
+    order by f.modified_at desc
+    limit 5")
+
+(defn recent-by-project
+  [profile-id project]
+  (let [project-id (:id project)]
+    (->> (db/exec! db/pool [sql:project-files-recent profile-id project-id])
+         (mapv decode-row))))
+
+(s/def ::team-id ::us/uuid)
+(s/def ::profile-id ::us/uuid)
+
+(s/def ::recent-files
+  (s/keys :req-un [::profile-id ::team-id]))
+
+(sq/defquery ::recent-files
+  [{:keys [profile-id team-id]}]
+  (->> (retrieve-projects db/pool profile-id team-id)
+       ;; Retrieve for each proyect the 5 more recent files
+       (map (partial recent-by-project profile-id))
+       ;; Change the structure so it's a map with project-id as keys
+       (flatten)
+       (group-by :project-id)))

backend/src/app/services/queries/teams.clj

@@ -0,0 +1,48 @@
+;; 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.services.queries.teams
+  (:require
+   [clojure.spec.alpha :as s]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.db :as db]
+   [app.services.queries :as sq]
+   [app.util.blob :as blob]))
+
+;; --- Team Edition Permissions
+
+(def ^:private sql:team-permissions
+  "select tpr.is_owner,
+          tpr.is_admin,
+          tpr.can_edit
+     from team_profile_rel as tpr
+    where tpr.profile_id = ?
+      and tpr.team_id = ?")
+
+(defn check-edition-permissions!
+  [conn profile-id team-id]
+  (let [row (db/exec-one! conn [sql:team-permissions profile-id team-id])]
+    (when-not (or (= team-id uuid/zero) ;; We can write global-project owned items
+                  (:can-edit row)
+                  (:is-admin row)
+                  (:is-owner row))
+      (ex/raise :type :validation
+                :code :not-authorized))))
+
+(defn check-read-permissions!
+  [conn profile-id team-id]
+  (let [row (db/exec-one! conn [sql:team-permissions profile-id team-id])]
+    (when-not (or (= team-id uuid/zero) ;; We can read global-project owned items
+                  (:can-edit row)
+                  (:is-admin row)
+                  (:is-owner row))
+      (ex/raise :type :validation
+                :code :not-authorized))))

backend/src/app/services/queries/viewer.clj

@@ -0,0 +1,64 @@
+;; 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.services.queries.viewer
+  (:require
+   [clojure.spec.alpha :as s]
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.db :as db]
+   [app.services.queries :as sq]
+   [app.services.queries.files :as files]
+   [app.services.queries.media :as media-queries]
+   [app.services.queries.pages :as pages]
+   [app.util.blob :as blob]
+   [app.util.data :as data]))
+
+;; --- Helpers & Specs
+
+(s/def ::id ::us/uuid)
+(s/def ::page-id ::us/uuid)
+
+;; --- Query: Viewer Bundle (by Page ID)
+
+(def ^:private
+  sql:project
+  "select p.id, p.name
+     from project as p
+    where p.id = ?
+      and p.deleted_at is null")
+
+(defn- retrieve-project
+  [conn id]
+  (db/exec-one! conn [sql:project id]))
+
+(s/def ::share-token ::us/string)
+(s/def ::viewer-bundle
+  (s/keys :req-un [::page-id]
+          :opt-un [::profile-id ::share-token]))
+
+(sq/defquery ::viewer-bundle
+  [{:keys [profile-id page-id share-token] :as params}]
+  (db/with-atomic [conn db/pool]
+    (let [page (pages/retrieve-page conn page-id)
+          file (files/retrieve-file conn (:file-id page))
+          images (media-queries/retrieve-media-objects conn (:file-id page) true)
+          project (retrieve-project conn (:project-id file))]
+      (if (string? share-token)
+        (when (not= share-token (:share-token page))
+          (ex/raise :type :validation
+                    :code :not-authorized))
+        (files/check-edition-permissions! conn profile-id (:file-id page)))
+      {:page page
+       :file file
+       :images images
+       :project project})))

backend/src/app/services/tokens.clj

@@ -0,0 +1,77 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; 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.services.tokens
+  (:require
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [sodi.prng]
+   [sodi.util]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.util.time :as dt]
+   [app.db :as db]))
+
+(defn next-token
+  ([] (next-token 96))
+  ([n]
+   (-> (sodi.prng/random-nonce n)
+       (sodi.util/bytes->b64s))))
+
+(def default-duration
+  (dt/duration {:hours 48}))
+
+(defn- decode-row
+  [{:keys [content] :as row}]
+  (when row
+    (cond-> row
+      (db/pgobject? content)
+      (assoc :content (db/decode-transit-pgobject content)))))
+
+(defn create!
+  ([conn payload] (create! conn payload {}))
+  ([conn payload {:keys [valid] :or {valid default-duration}}]
+   (let [token (next-token)
+         until (dt/plus (dt/now) (dt/duration valid))]
+     (db/insert! conn :generic-token
+                 {:content (db/tjson payload)
+                  :token token
+                  :valid-until until})
+     token)))
+
+(defn delete!
+  [conn token]
+  (db/delete! conn :generic-token {:token token}))
+
+(defn retrieve
+  ([conn token] (retrieve conn token {}))
+  ([conn token {:keys [delete] :or {delete false}}]
+   (let [row (->> (db/query conn :generic-token {:token token})
+                  (map decode-row)
+                  (first))]
+
+     (when-not row
+       (ex/raise :type :validation
+                 :code ::invalid-token))
+
+     ;; Validate the token expiration
+     (when (> (inst-ms (dt/now))
+              (inst-ms (:valid-until row)))
+       (ex/raise :type :validation
+                 :code ::invalid-token))
+
+     (when delete
+       (db/delete! conn :generic-token {:token token}))
+
+     (-> row
+         (dissoc :content)
+         (merge (:content row))))))
+
+
+

backend/src/app/tasks.clj

@@ -0,0 +1,53 @@
+;; 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.tasks
+  (:require
+   [cuerdas.core :as str]
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.db :as db]
+   [app.util.time :as dt]
+   [app.metrics :as mtx]))
+
+(s/def ::name ::us/string)
+(s/def ::delay
+  (s/or :int ::us/integer
+        :duration dt/duration?))
+(s/def ::queue ::us/string)
+
+(s/def ::task-options
+  (s/keys :req-un [::name]
+          :opt-un [::delay ::props ::queue]))
+
+(def ^:private sql:insert-new-task
+  "insert into task (id, name, props, queue, priority, max_retries, scheduled_at)
+   values (?, ?, ?, ?, ?, ?, clock_timestamp() + ?)
+   returning id")
+
+(defn submit!
+  ([opts] (submit! db/pool opts))
+  ([conn {:keys [name delay props queue priority max-retries]
+          :or {delay 0 props {} queue "default" priority 100 max-retries 3}
+          :as options}]
+   (us/verify ::task-options options)
+   (let [duration  (dt/duration delay)
+         interval  (db/interval duration)
+         props     (db/tjson props)
+         id        (uuid/next)]
+     (log/info (str/format "Submit task '%s' to be executed in '%s'." name (str duration)))
+     (db/exec-one! conn [sql:insert-new-task id name props queue priority max-retries interval])
+     id)))
+
+(mtx/instrument-with-counter!
+ {:var #'submit!
+  :id "tasks__submit_counter"
+  :help "Absolute task submit counter."})

backend/src/app/tasks/delete_object.clj

@@ -0,0 +1,67 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; 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.tasks.delete-object
+  "Generic task for permanent deletion of objects."
+  (:require
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.db :as db]
+   [app.metrics :as mtx]
+   [app.util.storage :as ust]))
+
+(s/def ::type keyword?)
+(s/def ::id ::us/uuid)
+
+(s/def ::props
+  (s/keys :req-un [::id ::type]))
+
+(defmulti handle-deletion (fn [conn props] (:type props)))
+
+(defmethod handle-deletion :default
+  [conn {:keys [type id] :as props}]
+  (log/warn "no handler found for" type))
+
+(defn handler
+  [{:keys [props] :as task}]
+  (us/verify ::props props)
+  (db/with-atomic [conn db/pool]
+    (handle-deletion conn props)))
+
+(mtx/instrument-with-summary!
+ {:var #'handler
+  :id "tasks__delete_object"
+  :help "Timing of remove-object task."})
+
+(defmethod handle-deletion :file
+  [conn {:keys [id] :as props}]
+  (let [sql "delete from file where id=? and deleted_at is not null"]
+    (db/exec-one! conn [sql id])))
+
+(defmethod handle-deletion :project
+  [conn {:keys [id] :as props}]
+  (let [sql "delete from project where id=? and deleted_at is not null"]
+    (db/exec-one! conn [sql id])))
+
+(defmethod handle-deletion :media-object
+  [conn {:keys [id] :as props}]
+  (let [sql "delete from media_object where id=? and deleted_at is not null"]
+    (db/exec-one! conn [sql id])))
+
+(defmethod handle-deletion :color
+  [conn {:keys [id] :as props}]
+  (let [sql "delete from color where id=? and deleted_at is not null"]
+    (db/exec-one! conn [sql id])))
+
+(defmethod handle-deletion :page
+  [conn {:keys [id] :as props}]
+  (let [sql "delete from page where id=? and deleted_at is not null"]
+    (db/exec-one! conn [sql id])))

backend/src/app/tasks/delete_profile.clj

@@ -0,0 +1,101 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2020 UXBOX Labs SL
+
+(ns app.tasks.delete-profile
+  "Task for permanent deletion of profiles."
+  (:require
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.db :as db]
+   [app.metrics :as mtx]
+   [app.util.storage :as ust]))
+
+(declare delete-profile-data)
+(declare delete-teams)
+(declare delete-files)
+(declare delete-profile)
+
+(s/def ::profile-id ::us/uuid)
+(s/def ::props
+  (s/keys :req-un [::profile-id]))
+
+(defn handler
+  [{:keys [props] :as task}]
+  (us/verify ::props props)
+  (db/with-atomic [conn db/pool]
+    (let [id (:profile-id props)
+          profile (db/get-by-id conn :profile id {:for-update true})]
+      (if (or (:is-demo profile)
+              (not (nil? (:deleted-at profile))))
+        (delete-profile-data conn (:id profile))
+        (log/warn "Profile " (:id profile)
+                  "does not match constraints for deletion")))))
+
+(mtx/instrument-with-summary!
+ {:var #'handler
+  :id "tasks__delete_profile"
+  :help "Timing of delete-profile task."})
+
+(defn- delete-profile-data
+  [conn profile-id]
+  (log/info "Proceding to delete all data related to profile" profile-id)
+  (delete-teams conn profile-id)
+  (delete-files conn profile-id)
+  (delete-profile conn profile-id))
+
+(def ^:private sql:select-profile
+  "select id, is_demo, deleted_at
+     from profile
+    where id=? for update")
+
+(def ^:private sql:remove-owned-teams
+  "with teams as (
+     select distinct
+            tpr.team_id as id
+       from team_profile_rel as tpr
+      where tpr.profile_id = ?
+        and tpr.is_owner is true
+   ), to_delete_teams as (
+     select tpr.team_id as id
+       from team_profile_rel as tpr
+      where tpr.team_id in (select id from teams)
+      group by tpr.team_id
+     having count(tpr.profile_id) = 1
+   )
+   delete from team
+    where id in (select id from to_delete_teams)
+   returning id")
+
+(defn- delete-teams
+  [conn profile-id]
+  (db/exec-one! conn [sql:remove-owned-teams profile-id]))
+
+(def ^:private sql:remove-owned-files
+  "with files_to_delete as (
+     select distinct
+            fpr.file_id as id
+       from file_profile_rel as fpr
+      inner join file as f on (fpr.file_id = f.id)
+      where fpr.profile_id = ?
+        and fpr.is_owner is true
+        and f.project_id is null
+   )
+   delete from file
+    where id in (select id from files_to_delete)
+   returning id")
+
+(defn- delete-files
+  [conn profile-id]
+  (db/exec-one! conn [sql:remove-owned-files profile-id]))
+
+(defn delete-profile
+  [conn profile-id]
+  (db/delete! conn :profile {:id profile-id}))

backend/src/app/tasks/gc.clj

@@ -0,0 +1,76 @@
+;; 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.tasks.gc
+  (:require
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [cuerdas.core :as str]
+   [postal.core :as postal]
+   [promesa.core :as p]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.tasks :as tasks]
+   [app.media-storage :as mst]
+   [app.util.blob :as blob]
+   [app.util.storage :as ust]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Task: Remove deleted media
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; The main purpose of this task is analize the `pending_to_delete`
+;; table. This table stores the references to the physical files on
+;; the file system thanks to `handle_delete()` trigger.
+
+;; Example:
+;; (1) You delete an media-object. (2) This media object is marked as
+;; deleted. (3) A task (`delete-object`) is scheduled for permanent
+;; delete the object.  - If that object stores media, the database
+;; will execute the `handle_delete()` trigger which will place
+;; filesystem paths into the `pendint_to_delete` table. (4) This
+;; task (`remove-deleted-media`) permanently delete the file from the
+;; filesystem when is executed (by scheduler).
+
+(def ^:private
+  sql:retrieve-peding-to-delete
+  "with items_part as (
+     select i.id
+       from pending_to_delete as i
+      order by i.created_at
+      limit ?
+      for update skip locked
+   )
+   delete from pending_to_delete
+    where id in (select id from items_part)
+   returning *")
+
+(defn remove-deleted-media
+  [{:keys [props] :as task}]
+  (letfn [(decode-row [{:keys [data] :as row}]
+            (cond-> row
+              (db/pgobject? data) (assoc :data (db/decode-pgobject data))))
+          (retrieve-items [conn]
+            (->> (db/exec! conn [sql:retrieve-peding-to-delete 10])
+                 (map decode-row)
+                 (map :data)))
+          (remove-media [rows]
+            (run! (fn [item]
+                    (let [path (get item "path")]
+                      (ust/delete! mst/media-storage path)))
+                  rows))]
+    (loop []
+      (let [rows (retrieve-items db/pool)]
+        (when-not (empty? rows)
+          (remove-media rows)
+          (recur))))))
+
+

backend/src/app/tasks/impl.clj

@@ -0,0 +1,304 @@
+;; 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.tasks.impl
+  "Async tasks implementation."
+  (:require
+   [cuerdas.core :as str]
+   [clojure.core.async :as a]
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [promesa.exec :as px]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.util.async :as aa]
+   [app.util.blob :as blob]
+   [app.util.time :as dt])
+  (:import
+   java.util.concurrent.ScheduledExecutorService
+   java.util.concurrent.Executors
+   java.time.Duration
+   java.time.Instant
+   java.util.Date))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Tasks
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- string-strack-trace
+  [^Throwable err]
+  (with-out-str
+    (.printStackTrace err (java.io.PrintWriter. *out*))))
+
+(def ^:private
+  sql:mark-as-retry
+  "update task
+      set scheduled_at = clock_timestamp() + '5 seconds'::interval,
+          modified_at = clock_timestamp(),
+          error = ?,
+          status = 'retry',
+          retry_num = retry_num + 1
+    where id = ?")
+
+(defn- mark-as-retry
+  [conn task error]
+  (let [explain (ex-message error)
+        sqlv [sql:mark-as-retry explain (:id task)]]
+    (db/exec-one! conn sqlv)
+    nil))
+
+(defn- mark-as-failed
+  [conn task error]
+  (let [explain (ex-message error)]
+    (db/update! conn :task
+                {:error explain
+                 :modified-at (dt/now)
+                 :status "failed"}
+                {:id (:id task)})
+    nil))
+
+(defn- mark-as-completed
+  [conn task]
+  (let [now (dt/now)]
+    (db/update! conn :task
+                {:completed-at now
+                 :modified-at now
+                 :status "completed"}
+                {:id (:id task)})
+    nil))
+
+
+(def ^:private
+  sql:select-next-task
+  "select * from task as t
+    where t.scheduled_at <= now()
+      and t.queue = ?
+      and (t.status = 'new' or t.status = 'retry')
+    order by t.priority desc, t.scheduled_at
+    limit 1
+      for update skip locked")
+
+(defn- decode-task-row
+  [{:keys [props] :as row}]
+  (when row
+    (cond-> row
+      (db/pgobject? props) (assoc :props (db/decode-transit-pgobject props)))))
+
+
+(defn- log-task-error
+  [item err]
+  (log/error (str/format "Unhandled exception on task '%s' (retry: %s)\n" (:name item) (:retry-num item))
+             (str/format "Props: %s\n" (pr-str (:props item)))
+             (with-out-str
+               (.printStackTrace ^Throwable err (java.io.PrintWriter. *out*)))))
+
+(defn- handle-task
+  [tasks {:keys [name] :as item}]
+  (let [task-fn (get tasks name)]
+    (if task-fn
+      (task-fn item)
+      (do
+        (log/warn "no task handler found for" (pr-str name))
+        nil))))
+
+(defn- run-task
+  [{:keys [tasks conn]} item]
+  (try
+    (log/debug (str/format "Started task '%s/%s'." (:name item) (:id item)))
+    (handle-task tasks item)
+    (log/debug (str/format "Finished task '%s/%s'." (:name item) (:id item)))
+    (mark-as-completed conn item)
+    (catch Exception e
+      (log-task-error item e)
+      (if (>= (:retry-num item) (:max-retries item))
+        (mark-as-failed conn item e)
+        (mark-as-retry conn item e)))))
+
+(defn- event-loop-fn
+  [{:keys [tasks] :as opts}]
+  (aa/thread-try
+   (db/with-atomic [conn db/pool]
+     (let [queue (:queue opts "default")
+           item  (-> (db/exec-one! conn [sql:select-next-task queue])
+                     (decode-task-row))
+           opts  (assoc opts :conn conn)]
+
+       (cond
+         (nil? item)
+         ::empty
+
+         (or (= "new" (:status item))
+             (= "retry" (:status item)))
+         (do
+           (run-task opts item)
+           ::handled)
+
+         :else
+         (do
+           (log/warn "Unexpected condition on worker event loop:" (pr-str item))
+           ::handled))))))
+
+(s/def ::poll-interval ::us/integer)
+(s/def ::fn (s/or :var var? :fn fn?))
+(s/def ::tasks (s/map-of string? ::fn))
+(s/def ::start-worker-params
+  (s/keys :req-un [::tasks]
+          :opt-un [::poll-interval]))
+
+(defn start-worker!
+  [{:keys [poll-interval]
+    :or {poll-interval 5000}
+    :as opts}]
+  (us/assert ::start-worker-params opts)
+  (log/info (str/format "Starting worker '%s' on queue '%s'."
+                        (:name opts "anonymous")
+                        (:queue opts "default")))
+  (let [cch (a/chan 1)]
+    (a/go-loop []
+      (let [[val port] (a/alts! [cch (event-loop-fn opts)] :priority true)]
+        (cond
+          ;; Terminate the loop if close channel is closed or
+          ;; event-loop-fn returns nil.
+          (or (= port cch) (nil? val))
+          (log/info (str/format "Stop condition found. Shutdown worker: '%s'"
+                                (:name opts "anonymous")))
+
+          (db/pool-closed? db/pool)
+          (do
+            (log/info "Worker eventloop is aborted because pool is closed.")
+            (a/close! cch))
+
+          (and (instance? java.sql.SQLException val)
+               (contains? #{"08003" "08006" "08001" "08004"} (.getSQLState val)))
+          (do
+            (log/error "Connection error, trying resume in some instants.")
+            (a/<! (a/timeout poll-interval))
+            (recur))
+
+          (and (instance? java.sql.SQLException val)
+               (= "40001" (.getSQLState ^java.sql.SQLException val)))
+          (do
+            (log/debug "Serialization failure (retrying in some instants).")
+            (a/<! (a/timeout 1000))
+            (recur))
+
+          (instance? Exception val)
+          (do
+            (log/error "Unexpected error ocurried on polling the database." val)
+            (log/info "Trying resume operations in some instants.")
+            (a/<! (a/timeout poll-interval))
+            (recur))
+
+          (= ::handled val)
+          (recur)
+
+          (= ::empty val)
+          (do
+            (a/<! (a/timeout poll-interval))
+            (recur)))))
+
+    (reify
+      java.lang.AutoCloseable
+      (close [_]
+        (a/close! cch)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Scheduled Tasks
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^:private
+  sql:upsert-scheduled-task
+  "insert into scheduled_task (id, cron_expr)
+   values (?, ?)
+       on conflict (id)
+       do update set cron_expr=?")
+
+(defn- synchronize-schedule-item
+  [conn {:keys [id cron] :as item}]
+  (let [cron (str cron)]
+    (db/exec-one! conn [sql:upsert-scheduled-task id cron cron])))
+
+(defn- synchronize-schedule!
+  [schedule]
+  (db/with-atomic [conn db/pool]
+    (run! (partial synchronize-schedule-item conn) schedule)))
+
+(def ^:private sql:lock-scheduled-task
+  "select id from scheduled_task where id=? for update skip locked")
+
+(declare schedule-task!)
+
+(defn- log-scheduled-task-error
+  [item err]
+  (log/error "Unhandled exception on scheduled task '" (:id item) "' \n"
+             (with-out-str
+               (.printStackTrace ^Throwable err (java.io.PrintWriter. *out*)))))
+
+(defn- execute-scheduled-task
+  [{:keys [id cron ::xtor] :as task}]
+  (try
+    (db/with-atomic [conn db/pool]
+      ;; First we try to lock the task in the database, if locking is
+      ;; successful, then we execute the scheduled task; if locking is
+      ;; not possible (because other instance is already locked id) we
+      ;; just skip it and schedule to be executed in the next slot.
+      (when (db/exec-one! conn [sql:lock-scheduled-task id])
+        (log/info "Executing scheduled task" id)
+        ((:fn task) task)))
+
+    (catch Exception e
+      (log-scheduled-task-error task e))
+    (finally
+      (schedule-task! xtor task))))
+
+(defn ms-until-valid
+  [cron]
+  (s/assert dt/cron? cron)
+  (let [^Instant now  (dt/now)
+        ^Instant next (dt/next-valid-instant-from cron now)]
+    (inst-ms (dt/duration-between now next))))
+
+(defn- schedule-task!
+  [xtor {:keys [cron] :as task}]
+  (let [ms    (ms-until-valid cron)
+        task  (assoc task ::xtor xtor)]
+    (px/schedule! xtor ms (partial execute-scheduled-task task))))
+
+(s/def ::fn (s/or :var var? :fn fn?))
+(s/def ::id string?)
+(s/def ::cron dt/cron?)
+;; (s/def ::xtor #(instance? ScheduledExecutorService %))
+(s/def ::props (s/nilable map?))
+(s/def ::scheduled-task
+  (s/keys :req-un [::id ::cron ::fn]
+          :opt-un [::props]))
+
+(s/def ::schedule (s/coll-of ::scheduled-task))
+(s/def ::start-scheduler-worker-params
+  (s/keys :req-un [::schedule]))
+
+(defn start-scheduler-worker!
+  [{:keys [schedule] :as opts}]
+  (us/assert ::start-scheduler-worker-params opts)
+  (let [xtor (Executors/newScheduledThreadPool (int 1))]
+    (synchronize-schedule! schedule)
+    (run! (partial schedule-task! xtor) schedule)
+    (reify
+      java.lang.AutoCloseable
+      (close [_]
+        (.shutdownNow ^ScheduledExecutorService xtor)))))
+
+(defn stop!
+  [worker]
+  (.close ^java.lang.AutoCloseable worker))
+
+;; --- Submit API

backend/src/app/tasks/remove_media.clj

@@ -0,0 +1,35 @@
+;; 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.tasks.remove-media
+  "Demo accounts garbage collector."
+  (:require
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.media-storage :as mst]
+   [app.metrics :as mtx]
+   [app.util.storage :as ust]))
+
+(s/def ::path ::us/not-empty-string)
+(s/def ::props
+  (s/keys :req-un [::path]))
+
+(defn handler
+  [{:keys [props] :as task}]
+  (us/verify ::props props)
+  (when (ust/exists? mst/media-storage (:path props))
+    (ust/delete! mst/media-storage (:path props))
+    (log/debug "Media " (:path props) " removed.")))
+
+(mtx/instrument-with-summary!
+ {:var #'handler
+  :id "tasks__remove_media"
+  :help "Timing of remove-media task."})

backend/src/app/tasks/sendmail.clj

@@ -0,0 +1,101 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2020 UXBOX Labs SL
+
+(ns app.tasks.sendmail
+  (:require
+   [clojure.data.json :as json]
+   [clojure.tools.logging :as log]
+   [postal.core :as postal]
+   [app.common.data :as d]
+   [app.common.exceptions :as ex]
+   [app.config :as cfg]
+   [app.metrics :as mtx]
+   [app.util.http :as http]))
+
+(defmulti sendmail (fn [config email] (:sendmail-backend config)))
+
+(defmethod sendmail "console"
+  [config email]
+  (let [out (with-out-str
+              (println "email console dump:")
+              (println "******** start email" (:id email) "**********")
+              (println " from: " (:from email))
+              (println " to: " (:to email "---"))
+              (println " reply-to: " (:reply-to email))
+              (println " subject: " (:subject email))
+              (println " content:")
+              (doseq [item (:content email)]
+                (when (= (:type item) "text/plain")
+                  (println (:value item))))
+              (println "******** end email "(:id email) "**********"))]
+    (log/info out)))
+
+(defmethod sendmail "sendgrid"
+  [config email]
+  (let [apikey  (:sendmail-backend-apikey config)
+        dest    (mapv #(array-map :email %) (:to email))
+        params  {:personalizations [{:to dest
+                                     :subject (:subject email)}]
+                 :from {:email (:from email)}
+                 :reply_to {:email (:reply-to email)}
+                 :content (:content email)}
+        headers {"Authorization" (str "Bearer " apikey)
+                 "Content-Type" "application/json"}
+        body    (json/write-str params)]
+
+
+    (try
+      (let [response (http/send! {:method :post
+                                  :headers headers
+                                  :uri "https://api.sendgrid.com/v3/mail/send"
+                                  :body body})]
+        (when-not (= 202 (:status response))
+          (log/error "Unexpected status from sendgrid:" (pr-str response))))
+      (catch Throwable error
+        (log/error "Error on sending email to sendgrid:" (pr-str error))))))
+
+(defn- get-smtp-config
+  [config]
+  {:host (:smtp-host config)
+   :port (:smtp-port config)
+   :user (:smtp-user config)
+   :pass (:smtp-password config)
+   :ssl (:smtp-ssl config)
+   :tls (:smtp-tls config)})
+
+(defn- email->postal
+  [email]
+  {:from (:from email)
+   :to (:to email)
+   :subject (:subject email)
+   :body (d/concat [:alternative]
+                   (map (fn [{:keys [type value]}]
+                          {:type (str type "; charset=utf-8")
+                           :content value})
+                        (:content email)))})
+
+(defmethod sendmail "smtp"
+  [config email]
+  (let [config (get-smtp-config config)
+        email  (email->postal email)
+        result (postal/send-message config email)]
+    (when (not= (:error result) :SUCCESS)
+      (ex/raise :type :sendmail-error
+                :code :email-not-sent
+                :context result))))
+
+(defn handler
+  {:app.tasks/name "sendmail"}
+  [{:keys [props] :as task}]
+  (sendmail cfg/config props))
+
+(mtx/instrument-with-summary!
+ {:var #'handler
+  :id "tasks__sendmail"
+  :help "Timing of sendmail task."})

backend/src/app/tasks/trim_file.clj

@@ -0,0 +1,95 @@
+;; 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.tasks.trim-file
+  (:require
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.tasks :as tasks]
+   [app.util.blob :as blob]
+   [app.util.time :as dt]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Task: Trim File
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; This is the task responsible of removing unnecesary media-objects
+;; associated with file but not used by any page.
+
+(defn decode-row
+  [{:keys [data metadata changes] :as row}]
+  (cond-> row
+    (bytes? data) (assoc :data (blob/decode data))))
+
+(def sql:retrieve-files-to-trim
+  "select id from file as f
+    where f.has_media_trimmed is false
+      and f.modified_at < now() - ?::interval
+    order by f.modified_at asc
+    limit 10")
+
+(defn retrieve-candidates
+  [conn]
+  (let [interval (:file-trimming-max-age cfg/config)]
+    (->> (db/exec! conn [sql:retrieve-files-to-trim interval])
+         (map :id))))
+
+(defn collect-used-media
+  [pages]
+  (let [xf (comp (filter #(= :image (:type %)))
+                 (map :metadata)
+                 (map :id))]
+    (reduce conj #{} (->> pages
+                          (map :data)
+                          (map :objects)
+                          (mapcat vals)
+                          (filter #(= :image (:type %)))
+                          (map :metadata)
+                          (map :id)))))
+
+(defn process-file
+  [file-id]
+  (log/debugf "Processing file: '%s'." file-id)
+  (db/with-atomic [conn db/pool]
+    (let [mobjs  (db/query conn :media-object {:file-id file-id})
+          pages  (->> (db/query conn :page {:file-id file-id})
+                      (map decode-row))
+          used   (collect-used-media pages)
+          unused (into #{} (comp (map :id)
+                                 (remove #(contains? used %))) mobjs)]
+      (log/debugf "Collected media ids: '%s'." (pr-str used))
+      (log/debugf "Unused media ids: '%s'." (pr-str unused))
+
+      (db/update! conn :file
+                  {:has-media-trimmed true}
+                  {:id file-id})
+
+      (doseq [id unused]
+        (tasks/submit! conn {:name "delete-object"
+                             ;; :delay cfg/default-deletion-delay
+                             :delay 10000
+                             :props {:id id :type :media-object}})
+
+        (db/update! conn :media-object
+                    {:deleted-at (dt/now)}
+                    {:id id}))
+      nil)))
+
+(defn handler
+  [{:keys [props] :as task}]
+  (log/debug "Running 'trim-file' task.")
+  (loop []
+    (let [files (retrieve-candidates db/pool)]
+      (when (seq files)
+        (run! process-file files)
+        (recur)))))

backend/src/app/util/async.clj

@@ -0,0 +1,56 @@
+;; 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) 2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.util.async
+  (:require
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [clojure.core.async :as a])
+  (:import
+   java.util.concurrent.Executor))
+
+(defmacro go-try
+  [& body]
+  `(a/go
+     (try
+       ~@body
+       (catch Exception e# e#))))
+
+(defmacro <?
+  [ch]
+  `(let [r# (a/<! ~ch)]
+     (if (instance? Exception r#)
+       (throw r#)
+       r#)))
+
+(defmacro thread-try
+  [& body]
+  `(a/thread
+     (try
+       ~@body
+       (catch Exception e#
+         e#))))
+
+
+(s/def ::executor #(instance? Executor %))
+
+(defn thread-call
+  [^Executor executor f]
+  (let [c (a/chan 1)]
+    (try
+      (.execute executor
+                (fn []
+                  (try
+                    (let [ret (try (f) (catch Exception e e))]
+                      (when-not (nil? ret)
+                        (a/>!! c ret)))
+                    (finally
+                      (a/close! c)))))
+      c
+      (catch java.util.concurrent.RejectedExecutionException e
+        (a/offer! c e)
+        (a/close! c)
+        c))))

backend/src/app/util/blob.clj

@@ -0,0 +1,70 @@
+;; 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) 2016-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.util.blob
+  "A generic blob storage encoding. Mainly used for
+  page data, page options and txlog payload storage."
+  (:require [app.util.transit :as t])
+  (:import
+   java.io.ByteArrayInputStream
+   java.io.ByteArrayOutputStream
+   java.io.DataInputStream
+   java.io.DataOutputStream
+   net.jpountz.lz4.LZ4Factory
+   net.jpountz.lz4.LZ4FastDecompressor
+   net.jpountz.lz4.LZ4Compressor))
+
+(defprotocol IDataToBytes
+  (->bytes [data] "convert data to bytes"))
+
+(extend-protocol IDataToBytes
+  (Class/forName "[B")
+  (->bytes [data] data)
+
+  String
+  (->bytes [data] (.getBytes ^String data "UTF-8")))
+
+(def lz4-factory (LZ4Factory/fastestInstance))
+
+(defn encode
+  [data]
+  (let [data (t/encode data {:type :json})
+        data-len (alength ^bytes data)
+        cp (.fastCompressor ^LZ4Factory lz4-factory)
+        max-len (.maxCompressedLength cp data-len)
+        cdata (byte-array max-len)
+        clen (.compress ^LZ4Compressor cp ^bytes data 0 data-len cdata 0 max-len)]
+    (with-open [^ByteArrayOutputStream baos (ByteArrayOutputStream. (+ (alength cdata) 2 4))
+                ^DataOutputStream dos (DataOutputStream. baos)]
+      (.writeShort dos (short 1)) ;; version number
+      (.writeInt dos (int data-len))
+      (.write dos ^bytes cdata (int 0) clen)
+      (.toByteArray baos))))
+
+(declare decode-v1)
+
+(defn decode
+  "A function used for decode persisted blobs in the database."
+  [data]
+  (let [data (->bytes data)]
+    (with-open [bais (ByteArrayInputStream. data)
+                dis  (DataInputStream. bais)]
+      (let [version (.readShort dis)
+            udata-len (.readInt dis)]
+        (case version
+          1 (decode-v1 data udata-len)
+          (throw (ex-info "unsupported version" {:version version})))))))
+
+(defn- decode-v1
+  [^bytes cdata ^long udata-len]
+  (let [^LZ4FastDecompressor dcp (.fastDecompressor ^LZ4Factory lz4-factory)
+        ^bytes udata (byte-array udata-len)]
+    (.decompress dcp cdata 6 udata 0 udata-len)
+    (t/decode udata {:type :json})))
+

backend/src/app/util/cli.clj

@@ -0,0 +1,12 @@
+(ns app.util.cli
+  "Command line interface helpers.")
+
+(defn exit!
+  ([] (exit! 0))
+  ([code]
+   (System/exit code)))
+
+(defmacro print-err!
+  [& args]
+  `(binding [*out* *err*]
+     (println ~@args)))

backend/src/app/util/closeable.clj

@@ -0,0 +1,31 @@
+;; 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) 2016 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.util.closeable
+  "A closeable abstraction. A drop in replacement for
+  clojure builtin `with-open` syntax abstraction."
+  (:refer-clojure :exclude [with-open]))
+
+(defprotocol ICloseable
+  (-close [_] "Close the resource."))
+
+(defmacro with-open
+  [bindings & body]
+  {:pre [(vector? bindings)
+         (even? (count bindings))
+         (pos? (count bindings))]}
+  (reduce (fn [acc bindings]
+            `(let ~(vec bindings)
+               (try
+                 ~acc
+                 (finally
+                   (-close ~(first bindings))))))
+          `(do ~@body)
+          (reverse (partition 2 bindings))))
+
+(extend-protocol ICloseable
+  java.lang.AutoCloseable
+  (-close [this] (.close this)))

backend/src/app/util/data.clj

@@ -0,0 +1,54 @@
+;; 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) 2016 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.util.data
+  "Data transformations utils."
+  (:require [clojure.walk :as walk]
+            [cuerdas.core :as str]))
+
+;; TODO: move to app.common.helpers
+
+(defn dissoc-in
+  [m [k & ks :as keys]]
+  (if ks
+    (if-let [nextmap (get m k)]
+      (let [newmap (dissoc-in nextmap ks)]
+        (if (seq newmap)
+          (assoc m k newmap)
+          (dissoc m k)))
+      m)
+    (dissoc m k)))
+
+(defn normalize-attrs
+  "Recursively transforms all map keys from strings to keywords."
+  [m]
+  (letfn [(tf [[k v]]
+            (let [ks (-> (name k)
+                         (str/replace "_" "-"))]
+              [(keyword ks) v]))
+          (walker [x]
+            (if (map? x)
+              (into {} (map tf) x)
+              x))]
+    (walk/postwalk walker m)))
+
+(defn strip-delete-attrs
+  [m]
+  (dissoc m :deleted-at))
+
+(defn normalize
+  "Perform a common normalization transformation
+  for a entity (database retrieved) data structure."
+  [m]
+  (-> m normalize-attrs strip-delete-attrs))
+
+(defn deep-merge
+  [& maps]
+  (letfn [(merge' [& maps]
+            (if (every? map? maps)
+              (apply merge-with merge' maps)
+              (last maps)))]
+    (apply merge' (remove nil? maps))))

backend/src/app/util/dispatcher.clj

@@ -0,0 +1,98 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.util.dispatcher
+  "A generic service dispatcher implementation."
+  (:refer-clojure :exclude [defmethod])
+  (:require
+   [clojure.spec.alpha :as s]
+   [expound.alpha :as expound]
+   [app.common.exceptions :as ex])
+  (:import
+   clojure.lang.IDeref
+   clojure.lang.MapEntry
+   java.util.Map
+   java.util.HashMap))
+
+(definterface IDispatcher
+  (^void add [key f]))
+
+(deftype Dispatcher [reg attr wrap]
+  IDispatcher
+  (add [this key f]
+    (.put ^Map reg key (wrap f))
+    this)
+
+
+  clojure.lang.IDeref
+  (deref [_]
+    {:registry reg
+     :attr attr
+     :wrap wrap})
+
+  clojure.lang.IFn
+  (invoke [_ params]
+    (let [key (get params attr)
+          f   (.get ^Map reg key)]
+      (when (nil? f)
+        (ex/raise :type :method-not-found
+                  :hint "No method found for the current request."
+                  :context {:key key}))
+      (f params))))
+
+(defn dispatcher?
+  [v]
+  (instance? IDispatcher v))
+
+(defmacro defservice
+  [sname & {:keys [dispatch-by wrap]}]
+  `(def ~sname (Dispatcher. (HashMap.) ~dispatch-by ~wrap)))
+
+(defn parse-defmethod
+  [args]
+  (loop [r {}
+         s 0
+         v (first args)
+         n (rest args)]
+    (case s
+      0 (if (symbol? v)
+          (recur (assoc r :sym v) 1 (first n) (rest n))
+          (throw (ex-info "first arg to `defmethod` should be a symbol" {})))
+      1 (if (qualified-keyword? v)
+          (recur (-> r
+                     (assoc :key (keyword (name v)))
+                     (assoc :meta {:spec v :doc nil}))
+                 3 (first n) (rest n))
+          (recur r (inc s) v n))
+      2  (if (simple-keyword? v)
+          (recur (-> r
+                     (assoc :key v)
+                     (assoc :meta {:doc nil}))
+                 3 (first n) (rest n))
+          (throw (ex-info "second arg to `defmethod` should be a keyword" {})))
+      3 (if (string? v)
+          (recur (update r :meta assoc :doc v) (inc s) (first n) (rest n))
+          (recur r 4 v n))
+      4 (if (map? v)
+          (recur (update r :meta merge v) (inc s) (first n) (rest n))
+          (recur r 5 v n))
+      5 (if (vector? v)
+          (assoc r :args v :body n)
+          (throw (ex-info "missing arguments vector" {}))))))
+
+(defn add-method
+  [^Dispatcher dsp key f meta]
+  (let [f (with-meta f meta)]
+    (.add dsp key f)
+    dsp))
+
+(defmacro defmethod
+  [& args]
+  (let [{:keys [key meta sym args body]} (parse-defmethod args)
+        f `(fn ~args ~@body)]
+    `(do
+       (s/assert dispatcher? ~sym)
+       (add-method ~sym ~key ~f ~meta))))

backend/src/app/util/emails.clj

@@ -0,0 +1,91 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.util.emails
+  (:require
+   [clojure.java.io :as io]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [app.common.spec :as us]
+   [app.common.exceptions :as ex]
+   [app.util.template :as tmpl]))
+
+;; --- Impl.
+
+(def ^:private email-path "emails/%(id)s/%(lang)s.%(type)s")
+
+(defn- build-base-email
+  [data context]
+  (when-not (s/valid? ::parsed-email data)
+    (ex/raise :type :internal
+              :code :template-parse-error
+              :hint "Seems like the email template has invalid data."
+              :contex data))
+  {:subject (:subject data)
+   :content (cond-> []
+              (:body-text data) (conj {:type "text/plain"
+                                       :value (:body-text data)})
+              (:body-html data) (conj {:type "text/html"
+                                       :value (:body-html data)}))})
+
+(defn- render-email-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- impl-build-email
+  [id context]
+  (let [lang (:lang context :en)
+        subj (render-email-part :subj id context)
+        html (render-email-part :html id context)
+        text (render-email-part :txt id context)]
+
+    {:subject subj
+     :content (cond-> []
+                text (conj {:type "text/plain"
+                             :value text})
+                html (conj {:type "text/html"
+                            :value html}))}))
+
+;; --- Public API
+
+(s/def ::priority #{:high :low})
+(s/def ::to ::us/email)
+(s/def ::from ::us/email)
+(s/def ::reply-to ::us/email)
+(s/def ::lang string?)
+
+(s/def ::context
+  (s/keys :req-un [::to]
+          :opt-un [::reply-to ::from ::lang ::priority]))
+
+(defn build
+  ([id] (build 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 (impl-build-email 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."
+                   ::id id))
+       (cond-> (assoc email :id (name id))
+         (:to context) (assoc :to [(:to context)])
+         (:from context) (assoc :from (:from context))
+         (:reply-to context) (assoc :reply-to (:reply-to context)))))))

backend/src/app/util/http.clj

@@ -0,0 +1,26 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.util.http
+  "Http client abstraction layer."
+  (:require
+   [promesa.core :as p]
+   [promesa.exec :as px]
+   [java-http-clj.core :as http]))
+
+(def default-client
+  (delay (http/build-client {:executor @px/default-executor})))
+
+(defn get!
+  [url opts]
+  (let [opts' (merge {:client @default-client :as :string} opts)]
+    (http/get url nil opts')))
+
+(defn send!
+  ([req]
+   (http/send req {:client @default-client :as :string}))
+  ([req opts]
+   (http/send req (merge {:client @default-client :as :string} opts))))

backend/src/app/util/migrations.clj

@@ -0,0 +1,86 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.util.migrations
+  (:require
+   [clojure.tools.logging :as log]
+   [clojure.java.io :as io]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [next.jdbc :as jdbc]))
+
+(s/def ::name string?)
+(s/def ::step (s/keys :req-un [::name ::desc ::fn]))
+(s/def ::steps (s/every ::step :kind vector?))
+(s/def ::migrations
+  (s/keys :req-un [::name ::steps]))
+
+;; --- Implementation
+
+(defn- registered?
+  "Check if concrete migration is already registred."
+  [pool modname stepname]
+  (let [sql  "select * from migrations where module=? and step=?"
+        rows (jdbc/execute! pool [sql modname stepname])]
+    (pos? (count rows))))
+
+(defn- register!
+  "Register a concrete migration into local migrations database."
+  [pool modname stepname]
+  (let [sql "insert into migrations (module, step) values (?, ?)"]
+    (jdbc/execute! pool [sql modname stepname])
+    nil))
+
+(defn- impl-migrate-single
+  [pool modname {:keys [name] :as migration}]
+  (letfn [(execute []
+            (register! pool modname name)
+            ((:fn migration) pool))]
+    (when-not (registered? pool modname (:name migration))
+      (log/info (str/format "applying migration %s/%s" modname name))
+      (register! pool modname name)
+      ((:fn migration) pool))))
+
+(defn- impl-migrate
+  [conn migrations {:keys [fake] :or {fake false}}]
+  (s/assert ::migrations migrations)
+  (let [mname (:name migrations)
+        steps (:steps migrations)]
+    (jdbc/with-transaction [conn conn]
+      (run! #(impl-migrate-single conn mname %) steps))))
+
+(defprotocol IMigrationContext
+  (-migrate [_ migration options]))
+
+;; --- Public Api
+(defn setup!
+  "Initialize the database if it is not initialized."
+  [conn]
+  (let [sql (str "create table if not exists migrations ("
+                 " module text,"
+                 " step text,"
+                 " created_at timestamp DEFAULT current_timestamp,"
+                 " unique(module, step)"
+                 ");")]
+    (jdbc/execute! conn [sql])
+    nil))
+
+(defn migrate!
+  "Main entry point for apply a migration."
+  ([conn migrations]
+   (impl-migrate conn migrations nil))
+  ([conn migrations options]
+   (impl-migrate conn migrations options)))
+
+(defn resource
+  "Helper for setup migration functions
+  just using a simple path to sql file
+  located in the class path."
+  [path]
+  (fn [pool]
+    (let [sql (slurp (io/resource path))]
+      (jdbc/execute! pool [sql])
+      true)))

backend/src/app/util/redis.clj

@@ -0,0 +1,155 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.util.redis
+  "Asynchronous posgresql client."
+  (:refer-clojure :exclude [run!])
+  (:require
+   [promesa.core :as p]
+   [clojure.core.async :as a])
+  (:import
+   io.lettuce.core.RedisClient
+   io.lettuce.core.RedisURI
+   io.lettuce.core.codec.StringCodec
+   io.lettuce.core.api.async.RedisAsyncCommands
+   io.lettuce.core.api.StatefulRedisConnection
+   io.lettuce.core.pubsub.RedisPubSubListener
+   io.lettuce.core.pubsub.StatefulRedisPubSubConnection
+   io.lettuce.core.pubsub.api.async.RedisPubSubAsyncCommands
+   io.lettuce.core.pubsub.api.sync.RedisPubSubCommands
+   ))
+
+(defrecord Client [client uri]
+  java.lang.AutoCloseable
+  (close [_]
+    (.shutdown ^RedisClient client)))
+
+(defrecord Connection [^RedisAsyncCommands cmd]
+  java.lang.AutoCloseable
+  (close [_]
+    (let [conn (.getStatefulConnection cmd)]
+      (.close ^StatefulRedisConnection conn))))
+
+(defn client
+  [uri]
+  (->Client (RedisClient/create) (RedisURI/create uri)))
+
+(defn connect
+  [client]
+  (let [^RedisURI uri (:uri client)
+        ^RedisClient client (:client client)
+        ^StatefulRedisConnection conn (.connect client StringCodec/UTF8 uri)]
+    (->Connection (.async conn))))
+
+(defn- impl-subscribe
+  [^String topic xf ^StatefulRedisPubSubConnection conn]
+  (let [cmd    (.sync conn)
+        output (a/chan 1 (comp (filter string?) xf))
+        buffer (a/chan (a/sliding-buffer 64))
+        sub    (reify RedisPubSubListener
+                 (message [it pattern channel message])
+                 (message [it channel message]
+                   ;; There are no back pressure, so we use a slidding
+                   ;; buffer for cases when the pubsub broker sends
+                   ;; more messages that we can process.
+                   (a/put! buffer message))
+                 (psubscribed [it pattern count])
+                 (punsubscribed [it pattern count])
+                 (subscribed [it channel count])
+                 (unsubscribed [it channel count]))]
+    (.addListener conn sub)
+
+    (a/go-loop []
+      (let [[val port] (a/alts! [buffer (a/timeout 5000)])
+            message (if (= port buffer) val ::keepalive)]
+        (if (a/>! output message)
+          (recur)
+          (do
+            (a/close! buffer)
+            (.removeListener conn sub)
+            (when (.isOpen conn)
+              (.close conn))))))
+
+    (.subscribe ^RedisPubSubCommands cmd (into-array String [topic]))
+    output))
+
+(defn subscribe
+  ([client topic]
+   (subscribe client topic (map identity)))
+  ([client topic xf]
+   (let [^RedisURI uri (:uri client)
+         ^RedisClient client (:client client)]
+     (->> (.connectPubSub client StringCodec/UTF8 uri)
+          (impl-subscribe topic xf)))))
+
+(defn- resolve-to-bool
+  [v]
+  (if (= v 1)
+    true
+    false))
+
+(defmulti impl-run (fn [conn cmd parmas] cmd))
+
+(defn run!
+  [conn cmd params]
+  (let [^RedisAsyncCommands conn (:cmd conn)]
+    (impl-run conn cmd params)))
+
+(defn run
+  [conn cmd params]
+  (let [res (a/chan 1)]
+    (if (instance? Connection conn)
+      (-> (run! conn cmd params)
+          (p/finally (fn [v e]
+                       (if e
+                         (a/offer! res e)
+                         (a/offer! res v)))))
+      (a/close! res))
+    res))
+
+(defmethod impl-run :get
+  [conn _ {:keys [key]}]
+  (.get ^RedisAsyncCommands conn ^String key))
+
+(defmethod impl-run :set
+  [conn _ {:keys [key val]}]
+  (.set ^RedisAsyncCommands conn ^String key ^String val))
+
+(defmethod impl-run :smembers
+  [conn _ {:keys [key]}]
+  (-> (.smembers ^RedisAsyncCommands conn ^String key)
+      (p/then' #(into #{} %))))
+
+(defmethod impl-run :sadd
+  [conn _ {:keys [key val]}]
+  (let [keys (into-array String [val])]
+    (-> (.sadd ^RedisAsyncCommands conn ^String key ^"[S;" keys)
+        (p/then resolve-to-bool))))
+
+(defmethod impl-run :srem
+  [conn _ {:keys [key val]}]
+  (let [keys (into-array String [val])]
+    (-> (.srem ^RedisAsyncCommands conn ^String key ^"[S;" keys)
+        (p/then resolve-to-bool))))
+
+(defmethod impl-run :publish
+  [conn _ {:keys [channel message]}]
+  (-> (.publish ^RedisAsyncCommands conn ^String channel ^String message)
+      (p/then resolve-to-bool)))
+
+(defmethod impl-run :hset
+  [^RedisAsyncCommands conn _ {:keys [key field value]}]
+  (.hset conn key field value))
+
+(defmethod impl-run :hgetall
+  [^RedisAsyncCommands conn _ {:keys [key]}]
+  (.hgetall conn key))
+
+(defmethod impl-run :hdel
+  [^RedisAsyncCommands conn _ {:keys [key field]}]
+  (let [fields (into-array String [field])]
+    (.hdel conn key fields)))
+

backend/src/app/util/sql.clj

@@ -0,0 +1,198 @@
+;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; * Redistributions of source code must retain the above copyright notice, this
+;;   list of conditions and the following disclaimer.
+;;
+;; * Redistributions in binary form must reproduce the above copyright notice,
+;;   this list of conditions and the following disclaimer in the documentation
+;;   and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(ns app.util.sql
+  "A composable sql helpers."
+  (:refer-clojure :exclude [test update set format])
+  (:require [clojure.core :as c]
+            [cuerdas.core :as str]))
+
+;; --- Low Level Helpers
+
+(defn raw-expr
+  [m]
+  (cond
+    (string? m)
+    {::type :raw-expr
+     :sql m
+     :params []}
+
+    (vector? m)
+    {::type :raw-expr
+     :sql (first m)
+     :params (vec (rest m))}
+
+    (and (map? m)
+         (= :raw-expr (::type m)))
+    m
+
+    :else
+    (throw (ex-info "unexpected input" {:m m}))))
+
+(defn alias-expr
+  [m]
+  (cond
+    (string? m)
+    {::type :alias-expr
+     :sql m
+     :alias nil
+     :params []}
+
+    (vector? m)
+    {::type :alias-expr
+     :sql (first m)
+     :alias (second m)
+     :params (vec (drop 2 m))}
+
+    :else
+    (throw (ex-info "unexpected input" {:m m}))))
+
+;; --- SQL API (Select only)
+
+(defn from
+  [name]
+  {::type :query
+   ::from [(alias-expr name)]
+   ::order []
+   ::select []
+   ::join []
+   ::where []})
+
+(defn select
+  [m & fields]
+  (c/update m ::select into (map alias-expr fields)))
+
+(defn limit
+  [m n]
+  (assoc m ::limit [(raw-expr ["LIMIT ?" n])]))
+
+(defn offset
+  [m n]
+  (assoc m ::offset [(raw-expr ["OFFSET ?" n])]))
+
+(defn order
+  [m e]
+  (c/update m ::order conj (raw-expr e)))
+
+(defn- join*
+  [m type table condition]
+  (c/update m ::join conj
+            {::type :join-expr
+             :type type
+             :table (alias-expr table)
+             :condition (raw-expr condition)}))
+
+(defn join
+  [m table condition]
+  (join* m :inner table condition))
+
+(defn ljoin
+  [m table condition]
+  (join* m :left table condition))
+
+(defn rjoin
+  [m table condition]
+  (join* m :right table condition))
+
+(defn where
+  [m & conditions]
+  (->> (filter identity conditions)
+       (reduce #(c/update %1 ::where conj (raw-expr %2)) m)))
+
+;; --- Formating
+
+(defmulti format-expr ::type)
+
+(defmethod format-expr :raw-expr
+  [{:keys [sql params]}]
+  [sql params])
+
+(defmethod format-expr :alias-expr
+  [{:keys [sql alias params]}]
+  (if alias
+    [(str sql " AS " alias) params]
+    [sql params]))
+
+(defmethod format-expr :join-expr
+  [{:keys [table type condition]}]
+  (let [[csql cparams] (format-expr condition)
+        [tsql tparams] (format-expr table)
+        prefix (str/upper (name type))]
+    [(str prefix " JOIN " tsql " ON (" csql ")") (into cparams tparams)]))
+
+(defn- format-exprs
+  ([items] (format-exprs items {}))
+  ([items {:keys [prefix suffix join-with]
+           :or {prefix ""
+                suffix ""
+                join-with ","}}]
+   (loop [rs []
+          rp []
+          v (first items)
+          n (rest items)]
+     (if v
+       (let [[s p] (format-expr v)]
+         (recur (conj rs s)
+                (into rp p)
+                (first n)
+                (rest n)))
+       (if (empty? rs)
+         ["" []]
+         [(str prefix (str/join join-with rs) suffix) rp])))))
+
+(defn- process-param-tokens
+  [sql]
+  (let [cnt (java.util.concurrent.atomic.AtomicInteger. 1)]
+    (str/replace sql #"\?" (fn [& args]
+                             (str "$" (.getAndIncrement cnt))))))
+
+(def ^:private select-formatters
+  [#(format-exprs (::select %) {:prefix "SELECT "})
+   #(format-exprs (::from %) {:prefix "FROM "})
+   #(format-exprs (::join %) {:join-with " "})
+   #(format-exprs (::where %) {:prefix "WHERE ("
+                               :join-with ") AND ("
+                               :suffix ")"})
+   #(format-exprs (::order %) {:prefix "ORDER BY "} )
+   #(format-exprs (::limit %))
+   #(format-exprs (::offset %))])
+
+(defn- collect
+  [formatters qdata]
+  (loop [sqls []
+         params []
+         f (first formatters)
+         r (rest formatters)]
+    (if (fn? f)
+      (let [[s p] (f qdata)]
+        (recur (conj sqls s)
+               (into params p)
+               (first r)
+               (rest r)))
+      [(str/join " " sqls) params])))
+
+(defn fmt
+  [qdata]
+  (let [[sql params] (collect select-formatters qdata)]
+    (into [(process-param-tokens sql)] params)))

backend/src/app/util/storage.clj

@@ -0,0 +1,194 @@
+;; 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.util.storage
+  "A local filesystem storage implementation."
+  (:require
+   [clojure.java.io :as io]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [datoteka.core :as fs]
+   [datoteka.proto :as fp]
+   [sodi.prng :as sodi.prng]
+   [sodi.util :as sodi.util]
+   [app.common.exceptions :as ex])
+  (:import
+   java.io.ByteArrayInputStream
+   java.io.InputStream
+   java.io.OutputStream
+   java.net.URI
+   java.nio.file.Files
+   java.nio.file.NoSuchFileException
+   java.nio.file.Path
+   java.security.MessageDigest))
+
+(defn uri
+  [v]
+  (cond
+    (instance? URI v) v
+    (string? v) (URI. v)
+    :else (throw (IllegalArgumentException. "unexpected input"))))
+
+(defn- normalize-path
+  [^Path base ^Path path]
+  (when (fs/absolute? path)
+    (ex/raise :type :filesystem-error
+              :code :suspicious-operation
+              :hint "Suspicios operation: absolute path not allowed."
+              :contex {:path path :base base}))
+  (let [^Path fullpath (.resolve base path)
+        ^Path fullpath (.normalize fullpath)]
+    (when-not (.startsWith fullpath base)
+      (ex/raise :type :filesystem-error
+                :code :suspicious-operation
+                :hint "Suspicios operation: go to parent dir is not allowed."
+                :contex {:path path :base base}))
+    fullpath))
+
+(defn- transform-path
+  [storage ^Path path]
+  (if-let [xf (::xf storage)]
+    ((xf (fn [a b] b)) nil path)
+    path))
+
+(defn blob
+  [^String v]
+  (let [data (.getBytes v "UTF-8")]
+    (ByteArrayInputStream. ^bytes data)))
+
+(defn save!
+  [storage path content]
+  (s/assert ::storage storage)
+  (let [^Path base (::base-path storage)
+        ^Path path (->> (fs/path path)
+                        (transform-path storage))
+        ^Path fullpath (normalize-path base path)]
+    (when-not (fs/exists? (.getParent fullpath))
+      (fs/create-dir (.getParent fullpath)))
+    (loop [iteration nil]
+      (let [[basepath ext] (fs/split-ext fullpath)
+            candidate (fs/path (str basepath iteration ext))]
+        (if (fs/exists? candidate)
+          (recur (if (nil? iteration) 1 (inc iteration)))
+          (with-open [^InputStream src (io/input-stream content)
+                      ^OutputStream dst (io/output-stream candidate)]
+            (io/copy src dst)
+            (fs/relativize candidate base)))))))
+
+(defn delete!
+  [storage path]
+  (s/assert ::storage storage)
+  (try
+    (->> (fs/path path)
+         (normalize-path (::base-path storage))
+         (fs/delete))
+    true
+    (catch java.nio.file.NoSuchFileException e
+      false)))
+
+(defn clear!
+  [storage]
+  (s/assert ::storage storage)
+  (fs/delete (::base-path storage))
+  (fs/create-dir (::base-path storage))
+  nil)
+
+(defn exists?
+  [storage path]
+  (s/assert ::storage storage)
+  (->> (fs/path path)
+       (normalize-path (::base-path storage))
+       (fs/exists?)))
+
+(defn lookup
+  [storage path]
+  (s/assert ::storage storage)
+  (->> (fs/path path)
+       (normalize-path (::base-path storage))))
+
+(defn public-uri
+  [storage path]
+  (s/assert ::storage storage)
+  (let [^URI base (::base-uri storage)
+        ^String path (str path)]
+    (.resolve base path)))
+
+(s/def ::base-path (s/or :path fs/path? :str string?))
+(s/def ::base-uri (s/or :uri #(instance? URI %) :str string?))
+(s/def ::xf fn?)
+
+(s/def ::storage
+  (s/keys :req [::base-path] :opt [::xf ::base-uri]))
+
+(s/def ::create-options
+  (s/keys :req-un [::base-path] :opt-un [::xf ::base-uri]))
+
+(defn create
+  "Create an instance of local FileSystem storage providing an
+  absolute base path.
+
+  If that path does not exists it will be automatically created,
+  if it exists but is not a directory, an exception will be
+  raised.
+
+  This function expects a map with the following options:
+  - `:base-path`: a fisical directory on your local machine
+  - `:base-uri`: a base uri used for resolve the files
+  "
+  [{:keys [base-path base-uri xf] :as options}]
+  (s/assert ::create-options options)
+  (let [^Path base-path (fs/path base-path)]
+    (when (and (fs/exists? base-path)
+               (not (fs/directory? base-path)))
+      (ex/raise :type :filesystem-error
+                :code :file-already-exists
+                :hint "File already exists, expects directory."))
+    (when-not (fs/exists? base-path)
+      (fs/create-dir base-path))
+    (cond-> {::base-path base-path}
+      base-uri (assoc ::base-uri (uri base-uri))
+      xf (assoc ::xf xf))))
+
+;; This is don't need to be secure and we dont need to reseed it; the
+;; security guarranties of this prng instance are very low (we only
+;; use it for generate a random path where store the file).
+
+(def ^:private prng
+  (delay
+    (doto (java.security.SecureRandom/getInstance "SHA1PRNG")
+      (.setSeed ^bytes (sodi.prng/random-bytes 64)))))
+
+(defn with-xf
+  [storage xfm]
+  (let [xf (::xf storage)]
+    (if (nil? xf)
+      (assoc storage ::xf xfm)
+      (assoc storage ::xf (comp xf xfm)))))
+
+(def random-path
+  (map (fn [^Path path]
+         (let [name (str (.getFileName path))
+               hash (-> (sodi.prng/random-bytes @prng 10)
+                        (sodi.util/bytes->b64s))
+               tokens (re-seq #"[\w\d\-\_]{2}" hash)
+               path-tokens (take 3 tokens)
+               rest-tokens (drop 3 tokens)
+               path (fs/path path-tokens)
+               frest (apply str rest-tokens)]
+           (fs/path (list path frest name))))))
+
+(def slugify-filename
+  (map (fn [path]
+         (let [parent (or (fs/parent path) "")
+               [name ext] (fs/split-ext (fs/name path))]
+           (fs/path parent (str (str/uslug name) ext))))))
+
+(defn prefix-path
+  [prefix]
+  (map (fn [^Path path] (fs/join (fs/path prefix) path))))

backend/src/app/util/svg.clj

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

backend/src/app/util/template.clj

@@ -0,0 +1,37 @@
+;; 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) 2016-2019 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.util.template
+  "A lightweight abstraction over mustache.java template engine.
+  The documentation can be found: http://mustache.github.io/mustache.5.html"
+  (:require
+   [clojure.tools.logging :as log]
+   [clojure.walk :as walk]
+   [clojure.java.io :as io]
+   [cuerdas.core :as str]
+   [selmer.parser :as sp]
+   [app.common.exceptions :as ex]))
+
+;; (sp/cache-off!)
+
+(defn render
+  [path context]
+  (try
+    (sp/render-file path context)
+    (catch Exception cause
+      (ex/raise :type :internal
+                :code :template-render-error
+                :cause cause))))
+
+(defn render-string
+  [content context]
+  (try
+    (sp/render content context)
+    (catch Exception cause
+      (ex/raise :type :internal
+                :code :template-render-error
+                :cause cause))))
+

backend/src/app/util/time.clj

@@ -0,0 +1,256 @@
+;; 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) 2016-2020 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.util.time
+  (:require
+   [clojure.spec.alpha :as s]
+   [app.common.exceptions :as ex]
+   [cognitect.transit :as t])
+  (:import
+   java.time.Instant
+   java.time.OffsetDateTime
+   java.time.Duration
+   java.util.Date
+   java.time.temporal.TemporalAmount
+   org.apache.logging.log4j.core.util.CronExpression))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Instant & Duration
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn from-string
+  [s]
+  {:pre [(string? s)]}
+  (Instant/parse s))
+
+(defn now
+  []
+  (Instant/now))
+
+(defn plus
+  [d ta]
+  (.plus d ^TemporalAmount ta))
+
+(defn- obj->duration
+  [{:keys [days minutes seconds hours nanos millis]}]
+  (cond-> (Duration/ofMillis (if (int? millis) ^long millis 0))
+    (int? days) (.plusDays ^long days)
+    (int? hours) (.plusHours ^long hours)
+    (int? minutes) (.plusMinutes ^long minutes)
+    (int? seconds) (.plusSeconds ^long seconds)
+    (int? nanos) (.plusNanos ^long nanos)))
+
+(defn duration?
+  [v]
+  (instance? Duration v))
+
+(defn duration
+  [ms-or-obj]
+  (cond
+    (duration? ms-or-obj)
+    ms-or-obj
+
+    (integer? ms-or-obj)
+    (Duration/ofMillis ms-or-obj)
+
+    (string? ms-or-obj)
+    (Duration/parse ms-or-obj)
+
+    :else
+    (obj->duration ms-or-obj)))
+
+(defn duration-between
+  [t1 t2]
+  (Duration/between t1 t2))
+
+(defn parse-duration
+  [s]
+  (Duration/parse (str "PT" s)))
+
+(extend-protocol clojure.core/Inst
+  java.time.Duration
+  (inst-ms* [v] (.toMillis ^Duration v)))
+
+(defmethod print-method Duration
+  [mv ^java.io.Writer writer]
+  (.write writer (str "#app/duration \"" (.toString ^Duration mv) "\"")))
+
+(defmethod print-dup Duration [o w]
+  (print-method o w))
+
+(letfn [(conformer [v]
+          (cond
+            (duration? v) v
+            (string? v)
+            (try
+              (parse-duration v)
+              (catch java.time.format.DateTimeParseException e
+                ::s/invalid))
+
+            :else
+            ::s/invalid))
+        (unformer [v]
+          (subs (str v) 2))]
+  (s/def ::duration (s/conformer conformer unformer)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Cron Expression
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Cron expressions are comprised of 6 required fields and one
+;; optional field separated by white space. The fields respectively
+;; are described as follows:
+;;
+;; Field Name          Allowed Values	 	Allowed Special Characters
+;; Seconds                 0-59                    , - * /
+;; Minutes                 0-59                    , - * /
+;; Hours                   0-23                    , - * /
+;; Day-of-month	           1-31                  , - * ? / L W
+;; Month               0-11 or JAN-DEC             , - * /
+;; Day-of-Week          1-7 or SUN-SAT           , - * ? / L #
+;; Year (Optional)    empty, 1970-2199             , - * /
+;;
+;; The '*' character is used to specify all values. For example, "*"
+;; in the minute field means "every minute".
+;;
+;; The '?' character is allowed for the day-of-month and day-of-week
+;; fields. It is used to specify 'no specific value'. This is useful
+;; when you need to specify something in one of the two fields, but
+;; not the other.
+;;
+;; The '-' character is used to specify ranges For example "10-12" in
+;; the hour field means "the hours 10, 11 and 12".
+;;
+;; The ',' character is used to specify additional values. For
+;; example "MON,WED,FRI" in the day-of-week field means "the days
+;; Monday, Wednesday, and Friday".
+;;
+;; The '/' character is used to specify increments. For example "0/15"
+;; in the seconds field means "the seconds 0, 15, 30, and
+;; 45". And "5/15" in the seconds field means "the seconds 5, 20, 35,
+;; and 50". Specifying '*' before the '/' is equivalent to specifying
+;; 0 is the value to start with. Essentially, for each field in the
+;; expression, there is a set of numbers that can be turned on or
+;; off. For seconds and minutes, the numbers range from 0 to 59. For
+;; hours 0 to 23, for days of the month 0 to 31, and for months 0 to
+;; 11 (JAN to DEC). The "/" character simply helps you turn on
+;; every "nth" value in the given set. Thus "7/6" in the month field
+;; only turns on month "7", it does NOT mean every 6th month, please
+;; note that subtlety.
+;;
+;; The 'L' character is allowed for the day-of-month and day-of-week
+;; fields. This character is short-hand for "last", but it has
+;; different meaning in each of the two fields. For example, the
+;; value "L" in the day-of-month field means "the last day of the
+;; month" - day 31 for January, day 28 for February on non-leap
+;; years. If used in the day-of-week field by itself, it simply
+;; means "7" or "SAT". But if used in the day-of-week field after
+;; another value, it means "the last xxx day of the month" - for
+;; example "6L" means "the last friday of the month". You can also
+;; specify an offset from the last day of the month, such as "L-3"
+;; which would mean the third-to-last day of the calendar month. When
+;; using the 'L' option, it is important not to specify lists, or
+;; ranges of values, as you'll get confusing/unexpected results.
+;;
+;; The 'W' character is allowed for the day-of-month field. This
+;; character is used to specify the weekday (Monday-Friday) nearest
+;; the given day. As an example, if you were to specify "15W" as the
+;; value for the day-of-month field, the meaning is: "the nearest
+;; weekday to the 15th of the month". So if the 15th is a Saturday,
+;; the trigger will fire on Friday the 14th. If the 15th is a Sunday,
+;; the trigger will fire on Monday the 16th. If the 15th is a Tuesday,
+;; then it will fire on Tuesday the 15th. However if you specify "1W"
+;; as the value for day-of-month, and the 1st is a Saturday, the
+;; trigger will fire on Monday the 3rd, as it will not 'jump' over the
+;; boundary of a month's days. The 'W' character can only be specified
+;; when the day-of-month is a single day, not a range or list of days.
+;;
+;; The 'L' and 'W' characters can also be combined for the
+;; day-of-month expression to yield 'LW', which translates to "last
+;; weekday of the month".
+;;
+;; The '#' character is allowed for the day-of-week field. This
+;; character is used to specify "the nth" XXX day of the month. For
+;; example, the value of "6#3" in the day-of-week field means the
+;; third Friday of the month (day 6 = Friday and "#3" = the 3rd one in
+;; the month). Other examples: "2#1" = the first Monday of the month
+;; and "4#5" = the fifth Wednesday of the month. Note that if you
+;; specify "#5" and there is not 5 of the given day-of-week in the
+;; month, then no firing will occur that month. If the '#' character
+;; is used, there can only be one expression in the day-of-week
+;; field ("3#1,6#3" is not valid, since there are two expressions).
+;;
+;; The legal characters and the names of months and days of the week
+;; are not case sensitive.
+
+(defn cron
+  "Creates an instance of CronExpression from string."
+  [s]
+  (try
+    (CronExpression. s)
+    (catch java.text.ParseException e
+      (ex/raise :type :parse
+                :code :invalid-cron-expression
+                :cause e
+                :context {:expr s}))))
+
+(defn cron?
+  [v]
+  (instance? CronExpression v))
+
+(defn next-valid-instant-from
+  [^CronExpression cron ^Instant now]
+  (s/assert cron? cron)
+  (.toInstant (.getNextValidTimeAfter cron (Date/from now))))
+
+(defmethod print-method CronExpression
+  [mv ^java.io.Writer writer]
+  (.write writer (str "#app/cron \"" (.toString ^CronExpression mv) "\"")))
+
+(defmethod print-dup CronExpression
+  [o w]
+  (print-ctor o (fn [o w] (print-dup (.toString ^CronExpression o) w)) w))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Serialization
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare from-string)
+
+(def ^:private instant-write-handler
+  (t/write-handler
+   (constantly "m")
+   (fn [v] (str (.toEpochMilli ^Instant v)))))
+
+(def ^:private offset-datetime-write-handler
+  (t/write-handler
+   (constantly "m")
+   (fn [v] (str (.toEpochMilli (.toInstant ^OffsetDateTime v))))))
+
+(def ^:private read-handler
+  (t/read-handler
+   (fn [v] (-> (Long/parseLong v)
+               (Instant/ofEpochMilli)))))
+
+(def +read-handlers+
+  {"m" read-handler})
+
+(def +write-handlers+
+  {Instant instant-write-handler
+   OffsetDateTime offset-datetime-write-handler})
+
+(defmethod print-method Instant
+  [mv ^java.io.Writer writer]
+  (.write writer (str "#app/instant \"" (.toString ^Instant mv) "\"")))
+
+(defmethod print-dup Instant [o w]
+  (print-method o w))
+
+

backend/src/app/util/transit.clj

@@ -0,0 +1,144 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2020 UXBOX Labs SL
+
+(ns app.util.transit
+  (:require
+   [cognitect.transit :as t]
+   [clojure.java.io :as io]
+   [linked.core :as lk]
+   [app.util.time :as dt]
+   [app.util.data :as data]
+   [app.common.geom.point :as gpt]
+   [app.common.geom.matrix :as gmt])
+  (:import
+   linked.set.LinkedSet
+   java.io.ByteArrayInputStream
+   java.io.ByteArrayOutputStream
+   java.io.File
+   app.common.geom.point.Point
+   app.common.geom.matrix.Matrix))
+
+;; --- Handlers
+
+(def ^:private file-write-handler
+  (t/write-handler
+   (constantly "file")
+   (fn [v] (str v))))
+
+(def point-write-handler
+  (t/write-handler
+   (constantly "point")
+   (fn [v] (into {} v))))
+
+(def point-read-handler
+  (t/read-handler gpt/map->Point))
+
+(def matrix-write-handler
+  (t/write-handler
+   (constantly "matrix")
+   (fn [v] (into {} v))))
+
+(def matrix-read-handler
+  (t/read-handler gmt/map->Matrix))
+
+(def ordered-set-write-handler
+  (t/write-handler
+   (constantly "ordered-set")
+   (fn [v] (vec v))))
+
+(def ordered-set-read-handler
+  (t/read-handler #(into (lk/set) %)))
+
+(def +read-handlers+
+  (assoc dt/+read-handlers+
+         "matrix" matrix-read-handler
+         "ordered-set" ordered-set-read-handler
+         "point" point-read-handler))
+
+(def +write-handlers+
+  (assoc dt/+write-handlers+
+         File file-write-handler
+         LinkedSet ordered-set-write-handler
+         Matrix matrix-write-handler
+         Point point-write-handler))
+
+;; --- Low-Level Api
+
+(defn reader
+  ([istream]
+   (reader istream nil))
+  ([istream {:keys [type] :or {type :json}}]
+   (t/reader istream type {:handlers +read-handlers+})))
+
+(defn read!
+  "Read value from streamed transit reader."
+  [reader]
+  (t/read reader))
+
+(defn writer
+  ([ostream]
+   (writer ostream nil))
+  ([ostream {:keys [type] :or {type :json}}]
+   (t/writer ostream type {:handlers +write-handlers+})))
+
+(defn write!
+  [writer data]
+  (t/write writer data))
+
+;; --- High-Level Api
+
+(declare str->bytes)
+(declare bytes->str)
+
+(defn decode
+  ([data]
+   (decode data nil))
+  ([data opts]
+   (with-open [input (ByteArrayInputStream. ^bytes data)]
+     (read! (reader input opts)))))
+
+(defn encode
+  ([data]
+   (encode data nil))
+  ([data opts]
+   (with-open [out (ByteArrayOutputStream.)]
+     (let [w (writer out opts)]
+       (write! w data)
+       (.toByteArray out)))))
+
+(defn decode-str
+  [message]
+  (->> (str->bytes message)
+       (decode)))
+
+(defn encode-str
+  [message]
+  (->> (encode message)
+       (bytes->str)))
+
+(defn encode-verbose-str
+  [message]
+  (->> (encode message {:type :json-verbose})
+       (bytes->str)))
+
+;; --- Helpers
+
+(defn str->bytes
+  "Convert string to byte array."
+  ([^String s]
+   (str->bytes s "UTF-8"))
+  ([^String s, ^String encoding]
+   (.getBytes s encoding)))
+
+(defn bytes->str
+  "Convert byte array to String."
+  ([^bytes data]
+   (bytes->str data "UTF-8"))
+  ([^bytes data, ^String encoding]
+   (String. data encoding)))

backend/src/app/util/workers.clj

@@ -0,0 +1,74 @@
+;; 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) 2016 Andrey Antukh <niwi@niwi.nz>
+
+(ns app.util.workers
+  "A distributed asynchronous tasks queue implementation on top
+  of PostgreSQL reliable advirsory locking mechanism."
+  #_(:require
+     [suricatta.core :as sc]
+     [app.db :as db]))
+
+;; (defn- poll-for-task
+;;   [conn queue]
+;;   (let [sql (sql/acquire-task {:queue queue})]
+;;     (sc/fetch-one conn sql)))
+
+;; (defn- mark-task-done
+;;   [conn {:keys [id]}]
+;;   (let [sql (sql/mark-task-done {:id id})]
+;;     (sc/execute conn sql)))
+
+;; (defn- mark-task-failed
+;;   [conn {:keys [id]} error]
+;;   (let [sql (sql/mark-task-done {:id id :error (.getMessage error)})]
+;;     (sc/execute conn sql)))
+
+;; (defn- watch-unit
+;;   [conn queue callback]
+;;   (let [task (poll-for-task conn queue)]
+;;     (if (nil? task)
+;;       (Thread/sleep 1000)
+;;       (try
+;;         (sc/atomic conn
+;;           (callback conn task)
+;;           (mark-task-done conn task))
+;;         (catch Exception e
+;;           (mark-task-failed conn task e))))))
+
+;; (defn- watch-loop
+;;   "Watch tasks on the specified queue and executes a
+;;   callback for each task is received.
+;;   NOTE: This function blocks the current thread."
+;;   [queue callback]
+;;   (try
+;;     (loop []
+;;       (with-open [conn (db/connection)]
+;;         (sc/atomic conn (watch-unit conn queue callback)))
+;;       (recur))
+;;     (catch InterruptedException e
+;;       ;; just ignoring
+;;       )))
+
+;; (defn watch!
+;;   [queue callback]
+;;   (let [runnable #(watch-loop queue callback)
+;;         thread (Thread. ^Runnable runnable)]
+;;     (.setDaemon thread true)
+;;     (.start thread)
+;;     (reify
+;;       java.lang.AutoCloseable
+;;       (close [_]
+;;         (.interrupt thread)
+;;         (.join thread 2000))
+
+;;       clojure.lang.IDeref
+;;       (deref [_]
+;;         (.join thread))
+
+;;        clojure.lang.IBlockingDeref
+;;        (deref [_ ms default]
+;;          (.join thread ms)
+;;          default))))

backend/src/app/worker.clj

@@ -0,0 +1,63 @@
+;; 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.worker
+  (:require
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [mount.core :as mount :refer [defstate]]
+   [app.common.spec :as us]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.metrics :as mtx]
+   [app.tasks.delete-object]
+   [app.tasks.delete-profile]
+   [app.tasks.gc]
+   [app.tasks.remove-media]
+   [app.tasks.sendmail]
+   [app.tasks.trim-file]
+   [app.util.time :as dt]
+   [app.worker-impl :as impl]))
+
+;; --- State initialization
+
+(def ^:private tasks
+  {"delete-profile" #'app.tasks.delete-profile/handler
+   "delete-object" #'app.tasks.delete-object/handler
+   "remove-media" #'app.tasks.remove-media/handler
+   "sendmail" #'app.tasks.sendmail/handler})
+
+(def ^:private schedule
+  [{:id "remove-deleted-media"
+    :cron (dt/cron "0 0 0 */1 * ? *") ;; daily
+    :fn #'app.tasks.gc/remove-deleted-media}
+   {:id "trim-file"
+    :cron (dt/cron "0 0 0 */1 * ? *") ;; daily
+    :fn #'app.tasks.trim-file/handler}
+   ])
+
+
+(defstate executor
+  :start (impl/thread-pool {:idle-timeout 10000
+                            :min-threads 0
+                            :max-threads 256})
+  :stop (impl/stop! executor))
+
+(defstate worker
+  :start (impl/start-worker!
+          {:tasks tasks
+           :name "worker1"
+           :batch-size 1
+           :executor executor})
+  :stop (impl/stop! worker))
+
+(defstate scheduler-worker
+  :start (impl/start-scheduler-worker! {:schedule schedule
+                                        :executor executor})
+  :stop (impl/stop! scheduler-worker))

backend/src/app/worker_impl.clj

@@ -0,0 +1,357 @@
+;; 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.worker-impl
+  (:require
+   [cuerdas.core :as str]
+   [clojure.core.async :as a]
+   [clojure.spec.alpha :as s]
+   [clojure.tools.logging :as log]
+   [promesa.exec :as px]
+   [app.common.exceptions :as ex]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.config :as cfg]
+   [app.db :as db]
+   [app.util.async :as aa]
+   [app.util.blob :as blob]
+   [app.util.time :as dt])
+  (:import
+   org.eclipse.jetty.util.thread.QueuedThreadPool
+   java.util.concurrent.ExecutorService
+   java.util.concurrent.Executors
+   java.util.concurrent.Executor
+   java.time.Duration
+   java.time.Instant
+   java.util.Date))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Tasks
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^:private
+  sql:mark-as-retry
+  "update task
+      set scheduled_at = clock_timestamp() + '10 seconds'::interval,
+          modified_at = clock_timestamp(),
+          error = ?,
+          status = 'retry',
+          retry_num = retry_num + ?
+    where id = ?")
+
+(defn- mark-as-retry
+  [conn {:keys [task error inc-by]
+         :or {inc-by 1}}]
+  (let [explain (ex-message error)
+        sqlv [sql:mark-as-retry explain inc-by (:id task)]]
+    (db/exec-one! conn sqlv)
+    nil))
+
+(defn- mark-as-failed
+  [conn {:keys [task error]}]
+  (let [explain (ex-message error)]
+    (db/update! conn :task
+                {:error explain
+                 :modified-at (dt/now)
+                 :status "failed"}
+                {:id (:id task)})
+    nil))
+
+(defn- mark-as-completed
+  [conn {:keys [task] :as opts}]
+  (let [now (dt/now)]
+    (db/update! conn :task
+                {:completed-at now
+                 :modified-at now
+                 :status "completed"}
+                {:id (:id task)})
+    nil))
+
+(defn- decode-task-row
+  [{:keys [props] :as row}]
+  (when row
+    (cond-> row
+      (db/pgobject? props) (assoc :props (db/decode-transit-pgobject props)))))
+
+
+(defn- log-task-error
+  [item err]
+  (log/error (str/format "Unhandled exception on task '%s' (retry: %s)\n" (:name item) (:retry-num item))
+             (str/format "Props: %s\n" (pr-str (:props item)))
+             (with-out-str
+               (.printStackTrace ^Throwable err (java.io.PrintWriter. *out*)))))
+
+(defn- handle-task
+  [tasks {:keys [name] :as item}]
+  (let [task-fn (get tasks name)]
+    (if task-fn
+      (task-fn item)
+      (do
+        (log/warn "no task handler found for" (pr-str name))
+        nil))))
+
+(defn- run-task
+  [{:keys [tasks conn]} item]
+  (try
+    (log/debugf "Started task '%s/%s/%s'." (:name item) (:id item) (:retry-num item))
+    (handle-task tasks item)
+    {:status :completed :task item}
+    (catch Exception e
+      (let [data (ex-data e)]
+        (cond
+          (and (= ::retry (:type data))
+               (= ::noop (:strategy data)))
+          {:status :retry :task item :error e :inc-by 0}
+
+          (and (< (:retry-num item)
+                  (:max-retries item))
+               (= ::retry (:type data)))
+          {:status :retry :task item :error e}
+
+          :else
+          (do
+            (log/errorf e "Unhandled exception on task '%s' (retry: %s)\nProps: %s"
+                        (:name item) (:retry-num item) (pr-str (:props item)))
+            (if (>= (:retry-num item) (:max-retries item))
+              {:status :failed :task item :error e}
+              {:status :retry :task item :error e})))))
+    (finally
+      (log/debugf "Finished task '%s/%s/%s'." (:name item) (:id item) (:retry-num item)))))
+
+(def ^:private
+  sql:select-next-tasks
+  "select * from task as t
+    where t.scheduled_at <= now()
+      and t.queue = ?
+      and (t.status = 'new' or t.status = 'retry')
+    order by t.priority desc, t.scheduled_at
+    limit ?
+      for update skip locked")
+
+(defn- event-loop-fn*
+  [{:keys [tasks executor batch-size] :as opts}]
+  (db/with-atomic [conn db/pool]
+    (let [queue (:queue opts "default")
+          items (->> (db/exec! conn [sql:select-next-tasks queue batch-size])
+                     (map decode-task-row)
+                     (seq))
+          opts  (assoc opts :conn conn)]
+
+      (if (nil? items)
+        ::empty
+        (let [results (->> items
+                           (map #(partial run-task opts %))
+                           (map #(px/submit! executor %)))]
+          (doseq [res results]
+            (let [res (deref res)]
+              (case (:status res)
+                :retry (mark-as-retry conn res)
+                :failed (mark-as-failed conn res)
+                :completed (mark-as-completed conn res))))
+          ::handled)))))
+
+(defn- event-loop-fn
+  [{:keys [executor] :as opts}]
+  (aa/thread-call executor #(event-loop-fn* opts)))
+
+(s/def ::batch-size ::us/integer)
+(s/def ::poll-interval ::us/integer)
+(s/def ::fn (s/or :var var? :fn fn?))
+(s/def ::tasks (s/map-of string? ::fn))
+
+(s/def ::start-worker-params
+  (s/keys :req-un [::tasks ::aa/executor ::batch-size]
+          :opt-un [::poll-interval]))
+
+(defn start-worker!
+  [{:keys [poll-interval executor]
+    :or {poll-interval 5000}
+    :as opts}]
+  (us/assert ::start-worker-params opts)
+  (log/infof "Starting worker '%s' on queue '%s'."
+             (:name opts "anonymous")
+             (:queue opts "default"))
+  (let [cch (a/chan 1)]
+    (a/go-loop []
+      (let [[val port] (a/alts! [cch (event-loop-fn opts)] :priority true)]
+        (cond
+          ;; Terminate the loop if close channel is closed or
+          ;; event-loop-fn returns nil.
+          (or (= port cch) (nil? val))
+          (log/infof "Stop condition found. Shutdown worker: '%s'"
+                     (:name opts "anonymous"))
+
+          (db/pool-closed? db/pool)
+          (do
+            (log/info "Worker eventloop is aborted because pool is closed.")
+            (a/close! cch))
+
+          (and (instance? java.sql.SQLException val)
+               (contains? #{"08003" "08006" "08001" "08004"} (.getSQLState val)))
+          (do
+            (log/error "Connection error, trying resume in some instants.")
+            (a/<! (a/timeout poll-interval))
+            (recur))
+
+          (and (instance? java.sql.SQLException val)
+               (= "40001" (.getSQLState ^java.sql.SQLException val)))
+          (do
+            (log/debug "Serialization failure (retrying in some instants).")
+            (a/<! (a/timeout 1000))
+            (recur))
+
+          (instance? Exception val)
+          (do
+            (log/errorf val "Unexpected error ocurried on polling the database (will resume operations in some instants). ")
+            (a/<! (a/timeout poll-interval))
+            (recur))
+
+          (= ::handled val)
+          (recur)
+
+          (= ::empty val)
+          (do
+            (a/<! (a/timeout poll-interval))
+            (recur)))))
+
+    (reify
+      java.lang.AutoCloseable
+      (close [_]
+        (a/close! cch)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Scheduled Tasks
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^:private
+  sql:upsert-scheduled-task
+  "insert into scheduled_task (id, cron_expr)
+   values (?, ?)
+       on conflict (id)
+       do update set cron_expr=?")
+
+(defn- synchronize-schedule-item
+  [conn {:keys [id cron] :as item}]
+  (let [cron (str cron)]
+    (log/debug (str/format "Initialize scheduled task '%s' (cron: '%s')." id cron))
+    (db/exec-one! conn [sql:upsert-scheduled-task id cron cron])))
+
+(defn- synchronize-schedule!
+  [schedule]
+  (db/with-atomic [conn db/pool]
+    (run! (partial synchronize-schedule-item conn) schedule)))
+
+(def ^:private sql:lock-scheduled-task
+  "select id from scheduled_task where id=? for update skip locked")
+
+(declare schedule-task!)
+
+(defn exception->string
+  [error]
+  (with-out-str
+    (.printStackTrace ^Throwable error (java.io.PrintWriter. *out*))))
+
+(defn- execute-scheduled-task
+  [{:keys [scheduler executor] :as opts} {:keys [id cron] :as task}]
+  (letfn [(run-task [conn]
+            (try
+              (when (db/exec-one! conn [sql:lock-scheduled-task id])
+                (log/info "Executing scheduled task" id)
+                ((:fn task) task))
+              (catch Exception e
+                e)))
+
+          (handle-task* [conn]
+            (let [result (run-task conn)]
+              (if (instance? Throwable result)
+                (do
+                  (log/warnf result "Unhandled exception on scheduled task '%s'." id)
+                  (db/insert! conn :scheduled-task-history
+                              {:id (uuid/next)
+                               :task-id id
+                               :is-error true
+                               :reason (exception->string result)}))
+                (db/insert! conn :scheduled-task-history
+                            {:id (uuid/next)
+                             :task-id id}))))
+          (handle-task []
+            (db/with-atomic [conn db/pool]
+              (handle-task* conn)))]
+
+    (try
+      (px/run! executor handle-task)
+      (finally
+        (schedule-task! opts task)))))
+
+(defn ms-until-valid
+  [cron]
+  (s/assert dt/cron? cron)
+  (let [^Instant now  (dt/now)
+        ^Instant next (dt/next-valid-instant-from cron now)]
+    (inst-ms (dt/duration-between now next))))
+
+(defn- schedule-task!
+  [{:keys [scheduler] :as opts} {:keys [cron] :as task}]
+  (let [ms (ms-until-valid cron)]
+    (px/schedule! scheduler ms (partial execute-scheduled-task opts task))))
+
+(s/def ::fn (s/or :var var? :fn fn?))
+(s/def ::id string?)
+(s/def ::cron dt/cron?)
+(s/def ::props (s/nilable map?))
+(s/def ::scheduled-task
+  (s/keys :req-un [::id ::cron ::fn]
+          :opt-un [::props]))
+
+(s/def ::schedule (s/coll-of ::scheduled-task))
+(s/def ::start-scheduler-worker-params
+  (s/keys :req-un [::schedule]))
+
+(defn start-scheduler-worker!
+  [{:keys [schedule] :as opts}]
+  (us/assert ::start-scheduler-worker-params opts)
+  (let [scheduler (Executors/newScheduledThreadPool (int 1))
+        opts      (assoc opts :scheduler scheduler)]
+    (synchronize-schedule! schedule)
+    (run! (partial schedule-task! opts) schedule)
+    (reify
+      java.lang.AutoCloseable
+      (close [_]
+        (.shutdownNow ^ExecutorService scheduler)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Thread Pool
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn thread-pool
+  ([] (thread-pool {}))
+  ([{:keys [min-threads max-threads idle-timeout name]
+     :or {min-threads 0 max-threads 128 idle-timeout 60000}}]
+   (let [executor (QueuedThreadPool. max-threads min-threads)]
+     (.setName executor (or name "default-tp"))
+     (.start executor)
+     executor)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Helpers
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn stop!
+  [o]
+  (cond
+    (instance? java.lang.AutoCloseable o)
+    (.close ^java.lang.AutoCloseable o)
+
+    (instance? org.eclipse.jetty.util.component.ContainerLifeCycle o)
+    (.stop ^org.eclipse.jetty.util.component.ContainerLifeCycle o)
+
+    :else
+    (ex/raise :type :not-implemented)))
+
+