📎 Minor update on feedback module.

This allows on-premise users skip the email validation.

.clj-kondo/config.edn

@@ -17,12 +17,16 @@
  {:exclude-files
   ["data_readers.clj"
    "app/util/perf.cljs"
+   "app/common/logging.cljc"
    "app/common/exceptions.cljc"]}
 
  :linters
  {:unsorted-required-namespaces
   {:level :warning}
 
+  :potok/reify-type
+  {:level :error}
+
   :unresolved-namespace
   {:level :warning
    :exclude [data_readers]}

.clj-kondo/hooks/export.clj

@@ -10,15 +10,34 @@
                   sname])]
     {:node result}))
 
+(def registry (atom {}))
+
 (defn potok-reify
-  [{:keys [:node]}]
+  [{:keys [:node :filename] :as params}]
   (let [[rnode rtype & other] (:children node)
-        result  (api/list-node
-                 (into [(api/token-node (symbol "deftype"))
-                        (api/token-node (gensym (name (:k rtype))))
-                        (api/vector-node [])]
-                       other))]
-    {:node result}))
+        rsym (symbol (str "event-type-" (name (:k rtype))))
+        reg  (get @registry filename #{})]
+    (when-not (:namespaced? rtype)
+      (let [{:keys [:row :col]} (meta rtype)]
+        (api/reg-finding! {:message "ptk/reify type should be namespaced"
+                           :type :potok/reify-type
+                           :row row
+                           :col col})))
+
+    (if (contains? reg rsym)
+      (let [{:keys [:row :col]} (meta rtype)]
+        (api/reg-finding! {:message (str "duplicate type: " (name (:k rtype)))
+                           :type :potok/reify-type
+                           :row row
+                           :col col}))
+      (swap! registry update filename (fnil conj #{}) rsym))
+
+    (let [result  (api/list-node
+                   (into [(api/token-node (symbol "deftype"))
+                          (api/token-node rsym)
+                          (api/vector-node [])]
+                         other))]
+      {:node result})))
 
 (defn clojure-specify
   [{:keys [:node]}]

.gitignore

@@ -38,4 +38,8 @@ node_modules
 /deploy
 /web
 /_dump
-/vendor/svgclean/bundle*.js
+/vendor/svgclean/bundle*.js
+
+.calva
+.clj-kondo
+.lsp

CHANGES.md

@@ -1,17 +1,203 @@
-# CHANGELOG #
-
-
-
+# CHANGELOG
 
 ## :rocket: Next
 
+### :boom: Breaking changes
+### :sparkles: New features
+### :bug: Bugs fixed
+### :arrow_up: Deps updates
+### :heart: Community contributions by (Thank you!)
+
+
+## 1.10.0-beta
+
+### :boom: Breaking changes
+
+- The initial project / data mechanism (not documented) has been
+  disabled. Is the mechanism used for creating initial project on user
+  signup. With the new onboarding approach, this subsystem is no
+  longer needed and is disabled.
+
 ### :sparkles: New features
 
+- Enhance corner radius behavior [Taiga #2190](https://tree.taiga.io/project/penpot/issue/2190).
+- Allow preserve scroll position in interactions [Taiga #2250](https://tree.taiga.io/project/penpot/us/2250).
+- Add new onboarding modals.
+
 ### :bug: Bugs fixed
+
+- Fix problem with exporting before the document is saved [Taiga #2189](https://tree.taiga.io/project/penpot/issue/2189).
+- Fix undo stacking when changing color from color-picker [Taiga #2191](https://tree.taiga.io/project/penpot/issue/2191).
+- Fix pages dropdown in viewer [Taiga #2087](https://tree.taiga.io/project/penpot/issue/2087).
+- Fix problem when exporting texts with gradients or opacity [Taiga #2200](https://tree.taiga.io/project/penpot/issue/2200).
+- Fix problem with view mode comments [Taiga #2226](https://tree.taiga.io/project/penpot/issue/2226).
+- Disallow to create a component when already has one [Taiga #2237](https://tree.taiga.io/project/penpot/issue/2237).
+- Add ellipsis in long labels for input fields [Taiga #2224](https://tree.taiga.io/project/penpot/issue/2224)
+- Fix problem with text rendering on export [Taiga #2223](https://tree.taiga.io/project/penpot/issue/2223)
+- Fix problem when flattening booleans losing styles [Taiga #2217](https://tree.taiga.io/project/penpot/issue/2217)
+- Add shortcuts to boolean icons popups [Taiga #2220](https://tree.taiga.io/project/penpot/issue/2220)
+- Fix a worker error when transforming a rectangle into path
+- Fix max/min values for opacity fields [Taiga #2183](https://tree.taiga.io/project/penpot/issue/2183)
+- Fix viewer comment position when zoom applied [Taiga #2240](https://tree.taiga.io/project/penpot/issue/2240)
+- Remove change style on hover for options [Taiga #2172](https://tree.taiga.io/project/penpot/issue/2172)
+- Fix problem in viewer with dropdowns when comments active [#1303](https://github.com/penpot/penpot/issues/1303)
+- Add placeholder to create shareable link
+- Fix project files count not refreshing correctly after import [Taiga #2216](https://tree.taiga.io/project/penpot/issue/2216)
+- Remove button after import process finish [Taiga #2215](https://tree.taiga.io/project/penpot/issue/2215)
+
+### :heart: Community contributions by (Thank you!)
+
+- To the translation community for the hard work on making penpot
+  available on so many languages.
+
+## 1.9.0-alpha
+
+### :boom: Breaking changes
+
+- Some stroke-caps can change behaviour.
+- Text display bug fix could potentialy make some texts jump a line.
+
+### :sparkles: New features
+
+- Add boolean shapes: intersections, unions, difference and exclusions[Taiga #748](https://tree.taiga.io/project/penpot/us/748).
+- Add advanced prototyping [Taiga #244](https://tree.taiga.io/project/penpot/us/244).
+- Add multiple flows [Taiga #2091](https://tree.taiga.io/project/penpot/us/2091).
+- Change order of the teams menu so it's in the joined time order.
+
+### :bug: Bugs fixed
+
+- Enhance duplicating prototype connections behaviour [Taiga #2093](https://tree.taiga.io/project/penpot/us/2093).
+- Ignore constraints in horizontal or vertical flip [Taiga #2038](https://tree.taiga.io/project/penpot/issue/2038).
+- Fix color and typographies refs lost when duplicated file [Taiga #2165](https://tree.taiga.io/project/penpot/issue/2165).
+- Fix problem with overflow dropdown on stroke-cap [#1216](https://github.com/penpot/penpot/issues/1216).
+- Fix menu context for single element nested in components [#1186](https://github.com/penpot/penpot/issues/1186).
+- Fix error screen when operations over comments fail [#1219](https://github.com/penpot/penpot/issues/1219).
+- Fix undo problem when changing typography/color from library [#1230](https://github.com/penpot/penpot/issues/1230).
+- Fix problem with text margin while rendering [#1231](https://github.com/penpot/penpot/issues/1231).
+- Fix problem with masked texts on exporting [Taiga #2116](https://tree.taiga.io/project/penpot/issue/2116).
+- Fix text editor enter behaviour with centered texts [Taiga #2126](https://tree.taiga.io/project/penpot/issue/2126).
+- Fix residual stroke on imported svg [Taiga #2125](https://tree.taiga.io/project/penpot/issue/2125).
+- Add links for terms of service and privacy policy in register checkbox [Taiga #2020](https://tree.taiga.io/project/penpot/issue/2020).
+- Allow three character hex and web colors in color picker hex input [#1184](https://github.com/penpot/penpot/issues/1184).
+- Allow lowercase search for fonts [#1180](https://github.com/penpot/penpot/issues/1180).
+- Fix group renaming problem [Taiga #1969](https://tree.taiga.io/project/penpot/issue/1969).
+- Fix export group with shadows on children [Taiga #2036](https://tree.taiga.io/project/penpot/issue/2036).
+- Fix zoom context menu in viewer [Taiga #2041](https://tree.taiga.io/project/penpot/issue/2041).
+- Fix stroke caps adjustments in relation with stroke size [Taiga #2123](https://tree.taiga.io/project/penpot/issue/2123).
+- Fix problem duplicating paths [Taiga #2147](https://tree.taiga.io/project/penpot/issue/2147).
+- Fix problem inheriting attributes from SVG root when importing [Taiga #2124](https://tree.taiga.io/project/penpot/issue/2124).
+- Fix problem with lines and inside/outside stroke [Taiga #2146](https://tree.taiga.io/project/penpot/issue/2146).
+- Add stroke width in selection calculation [Taiga #2146](https://tree.taiga.io/project/penpot/issue/2146).
+- Fix shift+wheel to horizontal scrolling in MacOS [#1217](https://github.com/penpot/penpot/issues/1217).
+- Fix path stroke is not working properly with high thickness [Taiga #2154](https://tree.taiga.io/project/penpot/issue/2154).
+- Fix bug with transformation operations [Taiga #2155](https://tree.taiga.io/project/penpot/issue/2155).
+- Fix bug in firefox when a text box is inside a mask [Taiga #2152](https://tree.taiga.io/project/penpot/issue/2152).
+- Fix problem with stroke inside/outside [Taiga #2186](https://tree.taiga.io/project/penpot/issue/2186)
+- Fix masks export area [Taiga #2189](https://tree.taiga.io/project/penpot/issue/2189)
+- Fix paste in place in arboards [Taiga #2188](https://tree.taiga.io/project/penpot/issue/2188)
+- Fix font size input stuck on selection change [Taiga #2184](https://tree.taiga.io/project/penpot/issue/2184)
+- Fix stroke cut on shapes export [Taiga #2171](https://tree.taiga.io/project/penpot/issue/2171)
+- Fix no color when boolean with an SVG [Taiga #2193](https://tree.taiga.io/project/penpot/issue/2193)
+- Fix unlink color styles at strokes [Taiga #2206](https://tree.taiga.io/project/penpot/issue/2206).
+
+### :arrow_up: Deps updates
+
+### :heart: Community contributions by (Thank you!)
+
+- To the translation community for the hard work on making penpot
+  available on so many languages.
+
+
+
+## 1.8.4-alpha
+
+### :bug: Bugs fixed
+
+- Fix problem importing components [Taiga #2151](https://tree.taiga.io/project/penpot/issue/2151).
+
+## 1.8.3-alpha
+
+### :sparkles: New features
+
+- Adds progress report to importing process.
+
+## 1.8.2-alpha
+
+### :bug: Bugs fixed
+
+- Fix problem with masking images in viewer [#1238](https://github.com/penpot/penpot/issues/1238).
+
+## 1.8.1-alpha
+
+### :bug: Bugs fixed
+
+- Fix project renaming issue (and some other related to the same underlying bug).
+- Fix internal exception on audit log persistence layer.
+- Set proper environment variable on docker images for chrome executable.
+- Fix internal metrics on websocket connections.
+
+
+## 1.8.0-alpha
+
+### :boom: Breaking changes
+
+- This release includes a new approach for handling share links, and
+  this feature is incompatible with the previous one. This means that
+  all the public share links generated previously will stop working.
+
+### :sparkles: New features
+
+- Add tooltips to color picker tabs [Taiga #1814](https://tree.taiga.io/project/penpot/us/1814).
+- Add styling to the end point of any open paths [Taiga #1107](https://tree.taiga.io/project/penpot/us/1107).
+- Allow to zoom with ctrl + middle button [Taiga #1428](https://tree.taiga.io/project/penpot/us/1428).
+- Auto placement of duplicated objects [Taiga #1386](https://tree.taiga.io/project/penpot/us/1386).
+- Enable penpot SVG metadata only when exporting complete files [Taiga #1914](https://tree.taiga.io/project/penpot/us/1914?milestone=295883).
+- Export to PDF all artboards of one page [Taiga #1895](https://tree.taiga.io/project/penpot/us/1895).
+- Go to a undo step clicking on a history element of the list [Taiga #1374](https://tree.taiga.io/project/penpot/us/1374).
+- Increment font size by 10 with shift+arrows [1047](https://github.com/penpot/penpot/issues/1047).
+- New shortcut to detach components Ctrl+Shift+K [Taiga #1799](https://tree.taiga.io/project/penpot/us/1799).
+- Set email inputs to type "email", to aid keyboard entry [Taiga #1921](https://tree.taiga.io/project/penpot/issue/1921).
+- Use shift+move to move element orthogonally [#823](https://github.com/penpot/penpot/issues/823).
+- Use space + mouse drag to pan, instead of only space [Taiga #1800](https://tree.taiga.io/project/penpot/us/1800).
+- Allow navigate through pages on the viewer [Taiga #1550](https://tree.taiga.io/project/penpot/us/1550).
+- Allow create share links with specific pages [Taiga #1844](https://tree.taiga.io/project/penpot/us/1844).
+
+### :bug: Bugs fixed
+
+- Prevent adding numeric suffix to layer names when not needed [Taiga #1929](https://tree.taiga.io/project/penpot/us/1929).
+- Prevent deleting or moving the drafts project [Taiga #1935](https://tree.taiga.io/project/penpot/issue/1935).
+- Fix problem with zoom and selection [Taiga #1919](https://tree.taiga.io/project/penpot/issue/1919)
+- Fix problem with borders on shape export [#1092](https://github.com/penpot/penpot/issues/1092)
+- Fix thumbnail cropping issue [Taiga #1964](https://tree.taiga.io/project/penpot/issue/1964)
+- Fix repeated fetch on file selection [Taiga #1933](https://tree.taiga.io/project/penpot/issue/1933)
+- Fix rename typography on text options [Taiga #1963](https://tree.taiga.io/project/penpot/issue/1963)
+- Fix problems with order in groups [Taiga #1960](https://tree.taiga.io/project/penpot/issue/1960)
+- Fix SVG components preview [#1134](https://github.com/penpot/penpot/issues/1134)
+- Fix group renaming problem [Taiga #1969](https://tree.taiga.io/project/penpot/issue/1969)
+- Fix problem with import broken images links [#1197](https://github.com/penpot/penpot/issues/1197)
+- Fix problem while moving imported SVG's [#1199](https://github.com/penpot/penpot/issues/1199)
+
 ### :arrow_up: Deps updates
 ### :boom: Breaking changes
 ### :heart: Community contributions by (Thank you!)
 
+- eduayme [#1129](https://github.com/penpot/penpot/pull/1129).
+
+
+## 1.7.4-alpha
+
+### :bug: Bugs fixed
+
+- Fix demo user creation (self-hosted only)
+- Add better ldap response validation and reporting (self-hosted only)
+
+
+## 1.7.3-alpha
+
+### :bug: Bugs fixed
+
+- Fix font uploading issue on Windows.
+
 
 ## 1.7.2-alpha
 
@@ -32,7 +218,6 @@
 
 - Update frontend build tooling.
 
-### :boom: Breaking changes
 ### :heart: Community contributions by (Thank you!)
 
 - soultipsy [#1100](https://github.com/penpot/penpot/pull/1100)
@@ -83,10 +268,6 @@
 - Fix dynamic alignment enabled with hidden objects [#1063](https://github.com/penpot/penpot/issues/1063)
 
 
-### :arrow_up: Deps updates
-### :boom: Breaking changes
-### :heart: Community contributions by (Thank you!)
-
 ## 1.6.5-alpha
 
 ### :bug: Bugs fixed

backend/deps.edn

@@ -12,7 +12,7 @@
   org.zeromq/jeromq {:mvn/version "0.5.2"}
 
   com.taoensso/nippy {:mvn/version "3.1.1"}
-  com.github.luben/zstd-jni {:mvn/version "1.4.9-5"}
+  com.github.luben/zstd-jni {:mvn/version "1.5.0-4"}
 
   ;; NOTE: don't upgrade to latest version, breaking change is
   ;; introduced on 0.10.0 that suffixes counters with _total if they
@@ -24,14 +24,14 @@
                                                  org.eclipse.jetty/jetty-servlet]}
   io.prometheus/simpleclient_httpserver {:mvn/version "0.9.0"}
 
-  io.lettuce/lettuce-core {:mvn/version "6.1.2.RELEASE"}
-  java-http-clj/java-http-clj {:mvn/version "0.4.2"}
+  io.lettuce/lettuce-core {:mvn/version "6.1.5.RELEASE"}
+  java-http-clj/java-http-clj {:mvn/version "0.4.3"}
 
-  info.sunng/ring-jetty9-adapter {:mvn/version "0.15.1"}
-  com.github.seancorfield/next.jdbc {:mvn/version "1.2.659"}
-  metosin/reitit-ring {:mvn/version "0.5.13"}
-  org.postgresql/postgresql {:mvn/version "42.2.20"}
-  com.zaxxer/HikariCP {:mvn/version "4.0.3"}
+  info.sunng/ring-jetty9-adapter {:mvn/version "0.15.2"}
+  com.github.seancorfield/next.jdbc {:mvn/version "1.2.709"}
+  metosin/reitit-ring {:mvn/version "0.5.15"}
+  org.postgresql/postgresql {:mvn/version "42.2.23"}
+  com.zaxxer/HikariCP {:mvn/version "5.0.0"}
 
   funcool/datoteka {:mvn/version "2.0.0"}
 
@@ -39,14 +39,20 @@
   buddy/buddy-hashers {:mvn/version "1.8.1"}
   buddy/buddy-sign {:mvn/version "3.4.1"}
 
-  org.jsoup/jsoup {:mvn/version "1.13.1"}
+  org.jsoup/jsoup {:mvn/version "1.14.2"}
   org.im4java/im4java {:mvn/version "1.4.0"}
-  org.lz4/lz4-java {:mvn/version "1.7.1"}
+  org.lz4/lz4-java {:mvn/version "1.8.0"}
 
   org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
   integrant/integrant {:mvn/version "0.8.0"}
 
-  software.amazon.awssdk/s3 {:mvn/version "2.16.62"}}
+  io.sentry/sentry {:mvn/version "5.1.2"}
+
+  ;; Pretty Print specs
+  fipp/fipp {:mvn/version "0.6.24"}
+  pretty-spec/pretty-spec {:mvn/version "0.1.4"}
+
+  software.amazon.awssdk/s3 {:mvn/version "2.17.40"}}
 
  :paths ["src" "resources"]
  :aliases
@@ -55,24 +61,21 @@
    {com.bhauman/rebel-readline {:mvn/version "RELEASE"}
     org.clojure/tools.namespace {:mvn/version "RELEASE"}
     org.clojure/test.check {:mvn/version "RELEASE"}
-    com.clojure-goes-fast/clj-async-profiler {:mvn/version "0.5.0"}
+    org.clojure/data.csv {:mvn/version "1.0.0"}
+    com.clojure-goes-fast/clj-async-profiler {:mvn/version "0.5.1"}
 
     criterium/criterium {:mvn/version "RELEASE"}
     mockery/mockery {:mvn/version "RELEASE"}}
    :extra-paths ["test" "dev"]}
 
-  :fn-fixtures
-  {:exec-fn app.cli.fixtures/run
-   :args {}}
-
   :kaocha
-  {:extra-deps {lambdaisland/kaocha {:mvn/version "1.0.829"}}
+  {:extra-deps {lambdaisland/kaocha {:mvn/version "1.0.887"}}
    :main-opts ["-m" "kaocha.runner"]}
 
   :test
   {:extra-deps {io.github.cognitect-labs/test-runner
                 {:git/url "https://github.com/cognitect-labs/test-runner.git"
-                 :sha "705ad25bbf0228b1c38d0244a36001c2987d7337"}}
+                 :git/sha "dd6da11611eeb87f08780a30ac8ea6012d4c05ce"}}
    :exec-fn cognitect.test-runner.api/test}
 
   :outdated

backend/resources/api-doc.css

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

backend/resources/api-doc.js

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

backend/resources/api-doc.tmpl

@@ -0,0 +1,80 @@
+<!DOCTYPE html>
+<html>
+  <head>
+    <meta charset="utf-8" />
+    <meta name="robots" content="noindex,nofollow">
+    <meta http-equiv="x-ua-compatible" content="ie=edge" />
+    <title>Builtin API Documentation - Penpot</title>
+    <link rel="stylesheet" href="https://fonts.googleapis.com/css2?family=JetBrains+Mono">
+    <style>
+      {% include "api-doc.css" %}
+    </style>
+    <script>
+      {% include "api-doc.js" %}
+    </script>
+  </head>
+  <body>
+    <main>
+      <header>
+        <h1>Penpot API Documentation</h1>
+      </header>
+      <section class="rpc-doc-content">
+
+        <h2>RPC QUERY METHODS:</h2>
+        <ul class="rpc-items">
+          {% for item in query-methods %}
+            <li class="rpc-item">
+              <div class="rpc-row-info">
+                {# <div class="type">{{item.type}}</div> #}
+                <div class="name">{{item.name}}</div>
+                <div class="tags">
+                  <span class="tag">
+                    <span>Auth:</span>
+                    <span>{% if item.auth %}YES{% else %}NO{% endif %}</span>
+                  </span>
+                </div>
+              </div>
+              <div class="rpc-row-detail hidden">
+                {% if item.docs %}
+                  <h3>DOCSTRING:</h3>
+                  <p>{{item.docs}}</p>
+                {% endif %}
+
+                <h3>SPEC EXPLAIN:</h3>
+                <pre>{{item.spec}}</pre>
+              </div>
+            </li>
+          {% endfor %}
+        </ul>
+
+        <h2>RPC MUTATION METHODS:</h2>
+        <ul class="rpc-items">
+          {% for item in mutation-methods %}
+            <li class="rpc-item">
+              <div class="rpc-row-info">
+                {# <div class="type">{{item.type}}</div> #}
+                <div class="name">{{item.name}}</div>
+                <div class="tags">
+                  <span class="tag">
+                    <span>Auth:</span>
+                    <span>{% if item.auth %}YES{% else %}NO{% endif %}</span>
+                  </span>
+                </div>
+              </div>
+              <div class="rpc-row-detail hidden">
+                {% if item.docs %}
+                  <h3>DOCSTRING:</h3>
+                  <p>{{item.docs}}</p>
+                {% endif %}
+
+                <h3>SPEC EXPLAIN:</h3>
+                <pre>{{item.spec}}</pre>
+              </div>
+            </li>
+          {% endfor %}
+        </ul>
+      </section>
+    </main>
+  </body>
+</html>
+

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

@@ -22,7 +22,7 @@
         <mj-text font-size="24px" font-weight="600">Hello {{name}}!</mj-text>
         <mj-text>
           Thanks for signing up for your Penpot account! Please verify your
-          email using the link below adn get started building mockups and
+          email using the link below and get started building mockups and
           prototypes today!
         </mj-text>
         <mj-button href="{{ public-uri }}/#/auth/verify-token?token={{token}}">

backend/resources/emails/feedback/en.subj

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

backend/resources/emails/register/en.html

@@ -173,7 +173,7 @@
                   </tr>
                   <tr>
                     <td align="left" style="font-size:0px;padding:10px 25px;word-break:break-word;">
-                      <div style="font-family:Source Sans Pro, sans-serif;font-size:16px;line-height:150%;text-align:left;color:#000000;">Thanks for signing up for your Penpot account! Please verify your email using the link below adn get started building mockups and prototypes today!</div>
+                      <div style="font-family:Source Sans Pro, sans-serif;font-size:16px;line-height:150%;text-align:left;color:#000000;">Thanks for signing up for your Penpot account! Please verify your email using the link below and get started building mockups and prototypes today!</div>
                     </td>
                   </tr>
                   <tr>
@@ -465,4 +465,4 @@
   </div>
 </body>
 
-</html>
+</html>

backend/resources/emails/register/en.txt

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

backend/resources/error-report.tmpl

@@ -2,6 +2,7 @@
 <html>
   <head>
     <meta charset="utf-8" />
+    <meta name="robots" content="noindex,nofollow">
     <meta http-equiv="x-ua-compatible" content="ie=edge" />
     <title>penpot - error report {{id}}</title>
     <link rel="stylesheet" href="https://fonts.googleapis.com/css2?family=JetBrains+Mono">

backend/scripts/repl

@@ -1,6 +1,6 @@
 #!/usr/bin/env bash
 
-export PENPOT_ASSERTS_ENABLED=true
+export PENPOT_FLAGS="enable-asserts enable-audit-log $PENPOT_FLAGS"
 
 export OPTIONS="-A:jmx-remote:dev -J-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager -J-Dlog4j2.configurationFile=log4j2-devenv.xml -J-Djdk.attach.allowAttachSelf -J-XX:+UseZGC -J-XX:ConcGCThreads=1 -J-XX:-OmitStackTraceInFastThrow -J-Xms50m -J-Xmx512m";
 # export OPTIONS="$OPTIONS -J-XX:+UnlockDiagnosticVMOptions";

backend/scripts/start-dev

@@ -1,15 +1,23 @@
-#!/bin/sh
+#!/usr/bin/env bash
 
-export PENPOT_ASSERTS_ENABLED=true
+export PENPOT_FLAGS="$PENPOT_FLAGS enable-asserts"
 
 set -ex
 
-if [ ! -e ~/.fixtures-loaded ]; then
-    echo "Loading fixtures..."
-    clojure -Adev -X:fn-fixtures
-    touch ~/.fixtures-loaded
+if [ "$1" = "--watch" ]; then
+    echo "Start Watch..."
+
+    clojure -A:dev -M -m app.main &
+    PID=$!
+
+    npx nodemon \
+        --watch src \
+        --watch ../common \
+        --ext "clj" \
+        --signal SIGKILL \
+        --exec 'echo "(user/restart)" | nc -N localhost 6062'
+
+    kill -9 $PID
+else
+    clojure -A:dev -M -m app.main
 fi
-
-clojure -A:dev -M -m app.main
-
-

backend/src/app/cli/fixtures.clj

@@ -1,258 +0,0 @@
-;; This Source Code Form is subject to the terms of the Mozilla Public
-;; License, v. 2.0. If a copy of the MPL was not distributed with this
-;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
-;;
-;; Copyright (c) UXBOX Labs SL
-
-(ns app.cli.fixtures
-  "A initial fixtures."
-  (:require
-   [app.common.pages :as cp]
-   [app.common.uuid :as uuid]
-   [app.db :as db]
-   [app.main :as main]
-   [app.rpc.mutations.profile :as profile]
-   [app.util.blob :as blob]
-   [app.util.logging :as l]
-   [buddy.hashers :as hashers]
-   [integrant.core :as ig]))
-
-(defn- mk-uuid
-  [prefix & args]
-  (uuid/namespaced uuid/zero (apply str prefix (interpose "-" args))))
-
-;; --- Profiles creation
-
-(def password (hashers/derive "123123"))
-
-(def preset-small
-  {:num-teams 5
-   :num-profiles 5
-   :num-profiles-per-team 5
-   :num-projects-per-team 5
-   :num-files-per-project 5
-   :num-draft-files-per-profile 10})
-
-(defn- rng-ids
-  [rng n max]
-  (let [stream (->> (.longs rng 0 max)
-                    (.iterator)
-                    (iterator-seq))]
-    (reduce (fn [acc item]
-              (if (= (count acc) n)
-                (reduced acc)
-                (conj acc item)))
-            #{}
-            stream)))
-
-(defn- rng-vec
-  [rng vdata n]
-  (let [ids (rng-ids rng n (count vdata))]
-    (mapv #(nth vdata %) ids)))
-
-(defn- rng-nth
-  [rng vdata]
-  (let [stream (->> (.longs rng 0 (count vdata))
-                    (.iterator)
-                    (iterator-seq))]
-    (nth vdata (first stream))))
-
-(defn- collect
-  [f items]
-  (reduce #(conj %1 (f %2)) [] items))
-
-(defn- register-profile
-  [conn params]
-  (->> (#'profile/create-profile conn params)
-       (#'profile/create-profile-relations conn)))
-
-(defn impl-run
-  [pool opts]
-  (let [rng (java.util.Random. 1)]
-    (letfn [(create-profile [conn index]
-              (let [id   (mk-uuid "profile" index)
-                    _    (l/info :action "create profile"
-                                 :index index
-                                 :id id)
-
-                    prof (register-profile conn
-                                           {:id id
-                                            :fullname (str "Profile " index)
-                                            :password "123123"
-                                            :is-demo true
-                                            :email (str "profile" index "@example.com")})
-                    team-id  (:default-team-id prof)
-                    owner-id id]
-                (let [project-ids (collect (partial create-project conn team-id owner-id)
-                                           (range (:num-projects-per-team opts)))]
-                  (run! (partial create-files conn owner-id) project-ids))
-                prof))
-
-            (create-profiles [conn]
-              (l/info :action "create profiles")
-              (collect (partial create-profile conn)
-                       (range (:num-profiles opts))))
-
-            (create-team [conn index]
-              (let [id (mk-uuid "team" index)
-                    name (str "Team" index)]
-                (l/info :action "create team"
-                        :index index
-                        :id id)
-                (db/insert! conn :team {:id id
-                                        :name name})
-                id))
-
-            (create-teams [conn]
-              (l/info :action "create teams")
-              (collect (partial create-team conn)
-                       (range (:num-teams opts))))
-
-            (create-file [conn owner-id project-id index]
-              (let [id (mk-uuid "file" project-id index)
-                    name (str "file" index)
-                    data (cp/make-file-data id)]
-                (l/info :action "create file"
-                        :index index
-                        :id id)
-                (db/insert! conn :file
-                            {:id id
-                             :data (blob/encode data)
-                             :project-id project-id
-                             :name name})
-                (db/insert! conn :file-profile-rel
-                            {:file-id id
-                             :profile-id owner-id
-                             :is-owner true
-                             :is-admin true
-                             :can-edit true})
-                id))
-
-            (create-files [conn owner-id project-id]
-              (l/info :action "create files")
-              (run! (partial create-file conn owner-id project-id)
-                    (range (:num-files-per-project opts))))
-
-            (create-project [conn team-id owner-id index]
-              (let [id        (if index
-                                (mk-uuid "project" team-id index)
-                                (mk-uuid "project" team-id))
-                    name      (if index
-                                (str "project " index)
-                                "Drafts")
-                    is-default (nil? index)]
-                (l/info :action "create project"
-                        :index index
-                        :id id)
-                (db/insert! conn :project
-                            {:id id
-                             :team-id team-id
-                             :is-default is-default
-                             :name name})
-                (db/insert! conn :project-profile-rel
-                            {:project-id id
-                             :profile-id owner-id
-                             :is-owner true
-                             :is-admin true
-                             :can-edit true})
-                id))
-
-            (create-projects [conn team-id profile-ids]
-              (l/info :action "create projects")
-              (let [owner-id (rng-nth rng profile-ids)
-                    project-ids (conj
-                                  (collect (partial create-project conn team-id owner-id)
-                                         (range (:num-projects-per-team opts)))
-                                  (create-project conn team-id owner-id nil))]
-                (run! (partial create-files conn owner-id) project-ids)))
-
-            (assign-profile-to-team [conn team-id owner? profile-id]
-              (db/insert! conn :team-profile-rel
-                          {:team-id team-id
-                           :profile-id profile-id
-                           :is-owner owner?
-                           :is-admin true
-                           :can-edit true}))
-
-            (setup-team [conn team-id profile-ids]
-              (l/info :action "setup team"
-                      :team-id team-id
-                      :profile-ids (pr-str profile-ids))
-              (assign-profile-to-team conn team-id true (first profile-ids))
-              (run! (partial assign-profile-to-team conn team-id false)
-                    (rest profile-ids))
-              (create-projects conn team-id profile-ids))
-
-            (assign-teams-and-profiles [conn teams profiles]
-              (l/info :action "assign teams and profiles")
-              (loop [team-id (first teams)
-                     teams (rest teams)]
-                (when-not (nil? team-id)
-                  (let [n-profiles-team (:num-profiles-per-team opts)
-                        selected-profiles (rng-vec rng profiles n-profiles-team)]
-                    (setup-team conn team-id selected-profiles)
-                    (recur (first teams)
-                           (rest teams))))))
-
-            (create-draft-file [conn owner index]
-              (let [owner-id   (:id owner)
-                    id         (mk-uuid "file" "draft" owner-id index)
-                    name       (str "file" index)
-                    project-id (:default-project-id owner)
-                    data       (cp/make-file-data id)]
-
-                (l/info :action "create draft file"
-                        :index index
-                        :id id)
-                (db/insert! conn :file
-                            {:id id
-                             :data (blob/encode data)
-                             :project-id project-id
-                             :name name})
-                (db/insert! conn :file-profile-rel
-                            {:file-id id
-                             :profile-id owner-id
-                             :is-owner true
-                             :is-admin true
-                             :can-edit true})
-                id))
-
-            (create-draft-files [conn profile]
-              (run! (partial create-draft-file conn profile)
-                    (range (:num-draft-files-per-profile opts))))
-            ]
-      (db/with-atomic [conn 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-in-system
-  [system preset]
-  (let [pool   (:app.db/pool system)
-        preset (if (map? preset)
-                 preset
-                 (case preset
-                   (nil "small" :small) preset-small
-                   ;; "medium" preset-medium
-                   ;; "big" preset-big
-                   preset-small))]
-    (impl-run pool preset)))
-
-(defn run
-  [{:keys [preset] :or {preset :small}}]
-  (let [config (select-keys main/system-config
-                            [:app.db/pool
-                             :app.telemetry/migrations
-                             :app.migrations/migrations
-                             :app.migrations/all
-                             :app.metrics/metrics])
-        _      (ig/load-namespaces config)
-        system (-> (ig/prep config)
-                   (ig/init))]
-    (try
-      (run-in-system system preset)
-      (catch Exception e
-        (l/error :hint "unhandled exception" :cause e))
-      (finally
-        (ig/halt! system)))))

backend/src/app/cli/manage.clj

@@ -7,11 +7,11 @@
 (ns app.cli.manage
   "A manage cli api."
   (:require
+   [app.common.logging :as l]
    [app.db :as db]
    [app.main :as main]
    [app.rpc.mutations.profile :as profile]
    [app.rpc.queries.profile :refer [retrieve-profile-data-by-email]]
-   [app.util.logging :as l]
    [clojure.string :as str]
    [clojure.tools.cli :refer [parse-opts]]
    [integrant.core :as ig])

backend/src/app/cli/migrate_media.clj

@@ -6,12 +6,12 @@
 
 (ns app.cli.migrate-media
   (:require
+   [app.common.logging :as l]
    [app.common.media :as cm]
    [app.config :as cf]
    [app.db :as db]
    [app.main :as main]
    [app.storage :as sto]
-   [app.util.logging :as l]
    [cuerdas.core :as str]
    [datoteka.core :as fs]
    [integrant.core :as ig]))

backend/src/app/config.clj

@@ -10,6 +10,7 @@
   (:require
    [app.common.data :as d]
    [app.common.exceptions :as ex]
+   [app.common.flags :as flags]
    [app.common.spec :as us]
    [app.common.version :as v]
    [app.util.time :as dt]
@@ -50,8 +51,6 @@
    :default-blob-version 3
    :loggers-zmq-uri "tcp://localhost:45556"
 
-   :asserts-enabled false
-
    :public-uri "http://localhost:3449"
    :redis-uri "redis://redis/0"
 
@@ -61,15 +60,11 @@
    :assets-storage-backend :assets-fs
    :storage-assets-fs-directory "assets"
 
-   :feedback-destination "info@example.com"
-   :feedback-enabled false
-
    :assets-path "/internal/assets/"
 
    :rlimits-password 10
    :rlimits-image 2
 
-   :smtp-enabled false
    :smtp-default-reply-to "Penpot <no-reply@example.com>"
    :smtp-default-from "Penpot <no-reply@example.com>"
 
@@ -79,10 +74,6 @@
    :profile-bounce-max-age (dt/duration {:days 7})
    :profile-bounce-threshold 10
 
-   :allow-demo-users true
-   :registration-enabled true
-
-   :telemetry-enabled false
    :telemetry-uri "https://telemetry.penpot.app/"
 
    :ldap-user-query "(|(uid=:username)(mail=:username))"
@@ -92,27 +83,29 @@
    :ldap-attrs-photo "jpegPhoto"
 
    ;; a server prop key where initial project is stored.
-   :initial-project-skey "initial-project"
-   })
+   :initial-project-skey "initial-project"})
 
-(s/def ::audit-enabled ::us/boolean)
-(s/def ::audit-archive-enabled ::us/boolean)
-(s/def ::audit-archive-uri ::us/string)
-(s/def ::audit-archive-gc-enabled ::us/boolean)
-(s/def ::audit-archive-gc-max-age ::dt/duration)
+(s/def ::flags ::us/set-of-keywords)
+
+;; DEPRECATED PROPERTIES: should be removed in 1.10
+(s/def ::registration-enabled ::us/boolean)
+(s/def ::smtp-enabled ::us/boolean)
+(s/def ::telemetry-enabled ::us/boolean)
+(s/def ::asserts-enabled ::us/boolean)
+;; END DEPRECATED
+
+(s/def ::audit-log-archive-uri ::us/string)
+(s/def ::audit-log-gc-max-age ::dt/duration)
 
 (s/def ::secret-key ::us/string)
 (s/def ::allow-demo-users ::us/boolean)
-(s/def ::asserts-enabled ::us/boolean)
 (s/def ::assets-path ::us/string)
 (s/def ::database-password (s/nilable ::us/string))
 (s/def ::database-uri ::us/string)
 (s/def ::database-username (s/nilable ::us/string))
 (s/def ::default-blob-version ::us/integer)
 (s/def ::error-report-webhook ::us/string)
-(s/def ::feedback-destination ::us/string)
-(s/def ::feedback-enabled ::us/boolean)
-(s/def ::feedback-token ::us/string)
+(s/def ::user-feedback-destination ::us/string)
 (s/def ::github-client-id ::us/string)
 (s/def ::github-client-secret ::us/string)
 (s/def ::gitlab-base-uri ::us/string)
@@ -158,12 +151,10 @@
 (s/def ::public-uri ::us/string)
 (s/def ::redis-uri ::us/string)
 (s/def ::registration-domain-whitelist ::us/set-of-str)
-(s/def ::registration-enabled ::us/boolean)
 (s/def ::rlimits-image ::us/integer)
 (s/def ::rlimits-password ::us/integer)
 (s/def ::smtp-default-from ::us/string)
 (s/def ::smtp-default-reply-to ::us/string)
-(s/def ::smtp-enabled ::us/boolean)
 (s/def ::smtp-host ::us/string)
 (s/def ::smtp-password (s/nilable ::us/string))
 (s/def ::smtp-port ::us/integer)
@@ -180,28 +171,27 @@
 (s/def ::storage-fdata-s3-bucket ::us/string)
 (s/def ::storage-fdata-s3-region ::us/keyword)
 (s/def ::storage-fdata-s3-prefix ::us/string)
-(s/def ::telemetry-enabled ::us/boolean)
 (s/def ::telemetry-uri ::us/string)
 (s/def ::telemetry-with-taiga ::us/boolean)
 (s/def ::tenant ::us/string)
 
+(s/def ::sentry-trace-sample-rate ::us/number)
+(s/def ::sentry-attach-stack-trace ::us/boolean)
+(s/def ::sentry-debug ::us/boolean)
+(s/def ::sentry-dsn ::us/string)
+
 (s/def ::config
   (s/keys :opt-un [::secret-key
+                   ::flags
                    ::allow-demo-users
-                   ::audit-enabled
-                   ::audit-archive-enabled
-                   ::audit-archive-uri
-                   ::audit-archive-gc-enabled
-                   ::audit-archive-gc-max-age
-                   ::asserts-enabled
+                   ::audit-log-archive-uri
+                   ::audit-log-gc-max-age
                    ::database-password
                    ::database-uri
                    ::database-username
                    ::default-blob-version
                    ::error-report-webhook
-                   ::feedback-destination
-                   ::feedback-enabled
-                   ::feedback-token
+                   ::user-feedback-destination
                    ::github-client-id
                    ::github-client-secret
                    ::gitlab-base-uri
@@ -249,6 +239,10 @@
                    ::registration-enabled
                    ::rlimits-image
                    ::rlimits-password
+                   ::sentry-dsn
+                   ::sentry-debug
+                   ::sentry-attach-stack-trace
+                   ::sentry-trace-sample-rate
                    ::smtp-default-from
                    ::smtp-default-reply-to
                    ::smtp-enabled
@@ -258,26 +252,33 @@
                    ::smtp-ssl
                    ::smtp-tls
                    ::smtp-username
-
                    ::srepl-host
                    ::srepl-port
-
                    ::assets-storage-backend
                    ::storage-assets-fs-directory
                    ::storage-assets-s3-bucket
                    ::storage-assets-s3-region
-
                    ::fdata-storage-backend
                    ::storage-fdata-s3-bucket
                    ::storage-fdata-s3-region
                    ::storage-fdata-s3-prefix
-
                    ::telemetry-enabled
                    ::telemetry-uri
                    ::telemetry-referer
                    ::telemetry-with-taiga
                    ::tenant]))
 
+(def default-flags
+  [:enable-backend-asserts
+   :enable-backend-api-doc
+   :enable-secure-session-cookies])
+
+(defn- parse-flags
+  [config]
+  (flags/parse flags/default
+               default-flags
+               (:flags config)))
+
 (defn read-env
   [prefix]
   (let [prefix (str prefix "-")
@@ -304,11 +305,14 @@
         (println ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;")))
       (throw e))))
 
-(def version (v/parse (or (some-> (io/resource "version.txt")
-                                  (slurp)
-                                  (str/trim))
-                          "%version%")))
-(def config (atom (read-config)))
+(def version
+  (v/parse (or (some-> (io/resource "version.txt")
+                       (slurp)
+                       (str/trim))
+               "%version%")))
+
+(def ^:dynamic config (read-config))
+(def ^:dynamic flags  (parse-flags config))
 
 (def deletion-delay
   (dt/duration {:days 7}))
@@ -316,9 +320,9 @@
 (defn get
   "A configuration getter. Helps code be more testable."
   ([key]
-   (c/get @config key))
+   (c/get config key))
   ([key default]
-   (c/get @config key default)))
+   (c/get config key default)))
 
 ;; Set value for all new threads bindings.
-(alter-var-root #'*assert* (constantly (get :asserts-enabled)))
+(alter-var-root #'*assert* (constantly (contains? flags :backend-asserts)))

backend/src/app/db.clj

@@ -9,13 +9,13 @@
    [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.geom.point :as gpt]
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.common.transit :as t]
    [app.common.uuid :as uuid]
    [app.db.sql :as sql]
    [app.metrics :as mtx]
    [app.util.json :as json]
-   [app.util.logging :as l]
    [app.util.migrations :as mg]
    [app.util.time :as dt]
    [clojure.java.io :as io]
@@ -46,28 +46,26 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (declare instrument-jdbc!)
+(declare apply-migrations!)
 
 (s/def ::name keyword?)
 (s/def ::uri ::us/not-empty-string)
 (s/def ::min-pool-size ::us/integer)
 (s/def ::max-pool-size ::us/integer)
 (s/def ::migrations map?)
+(s/def ::read-only ::us/boolean)
 
 (defmethod ig/pre-init-spec ::pool [_]
-  (s/keys :req-un [::uri ::name ::min-pool-size ::max-pool-size ::migrations ::mtx/metrics]))
+  (s/keys :req-un [::uri ::name ::min-pool-size ::max-pool-size]
+          :opt-un [::migrations ::mtx/metrics ::read-only]))
 
 (defmethod ig/init-key ::pool
-  [_ {:keys [migrations metrics] :as cfg}]
-  (l/info :action "initialize connection pool"
-          :name (d/name (:name cfg))
-          :uri (:uri cfg))
-  (instrument-jdbc! (:registry metrics))
+  [_ {:keys [migrations metrics name] :as cfg}]
+  (l/info :action "initialize connection pool" :name (d/name name) :uri (:uri cfg))
+  (some-> metrics :registry instrument-jdbc!)
+
   (let [pool (create-pool cfg)]
-    (when (seq migrations)
-      (with-open [conn ^AutoCloseable (open pool)]
-        (mg/setup! conn)
-        (doseq [[name steps] migrations]
-          (mg/migrate! conn {:name (d/name name) :steps steps}))))
+    (some->> (seq migrations) (apply-migrations! pool))
     pool))
 
 (defmethod ig/halt-key! ::pool
@@ -84,37 +82,50 @@
     :name "database_query_total"
     :help "An absolute counter of database queries."}))
 
+(defn- apply-migrations!
+  [pool migrations]
+  (with-open [conn ^AutoCloseable (open pool)]
+    (mg/setup! conn)
+    (doseq [[name steps] migrations]
+      (mg/migrate! conn {:name (d/name name) :steps steps}))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; API & Impl
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (def initsql
-  (str "SET statement_timeout = 120000;\n"
-       "SET idle_in_transaction_session_timeout = 120000;"))
+  (str "SET statement_timeout = 200000;\n"
+       "SET idle_in_transaction_session_timeout = 200000;"))
 
 (defn- create-datasource-config
-  [{:keys [metrics] :as cfg}]
+  [{:keys [metrics read-only] :or {read-only false} :as cfg}]
   (let [dburi    (:uri cfg)
         username (:username cfg)
         password (:password cfg)
-        config   (HikariConfig.)
-        mtf      (PrometheusMetricsTrackerFactory. (:registry metrics))]
+        config   (HikariConfig.)]
     (doto config
       (.setJdbcUrl (str "jdbc:" dburi))
       (.setPoolName (d/name (:name cfg)))
       (.setAutoCommit true)
-      (.setReadOnly false)
-      (.setConnectionTimeout 8000)  ;; 8seg
-      (.setValidationTimeout 8000)  ;; 8seg
-      (.setIdleTimeout 120000)      ;; 2min
-      (.setMaxLifetime 1800000)     ;; 30min
+      (.setReadOnly read-only)
+      (.setConnectionTimeout 10000)  ;; 10seg
+      (.setValidationTimeout 10000)  ;; 10seg
+      (.setIdleTimeout 120000)       ;; 2min
+      (.setMaxLifetime 1800000)      ;; 30min
       (.setMinimumIdle (:min-pool-size cfg 0))
       (.setMaximumPoolSize (:max-pool-size cfg 30))
-      (.setMetricsTrackerFactory mtf)
       (.setConnectionInitSql initsql)
       (.setInitializationFailTimeout -1))
+
+    ;; When metrics namespace is provided
+    (when metrics
+      (->> (:registry metrics)
+           (PrometheusMetricsTrackerFactory.)
+           (.setMetricsTrackerFactory config)))
+
     (when username (.setUsername config username))
     (when password (.setPassword config password))
+
     config))
 
 (defn pool?
@@ -127,7 +138,7 @@
   [pool]
   (.isClosed ^HikariDataSource pool))
 
-(defn- create-pool
+(defn create-pool
   [cfg]
   (let [dsc (create-datasource-config cfg)]
     (jdbc-dt/read-as-instant)
@@ -231,9 +242,9 @@
 (defn get-by-params
   ([ds table params]
    (get-by-params ds table params nil))
-  ([ds table params {:keys [uncheked] :or {uncheked false} :as opts}]
+  ([ds table params {:keys [check-not-found] :or {check-not-found true} :as opts}]
    (let [res (exec-one! ds (sql/select table params opts))]
-     (when (and (not uncheked) (or (not res) (is-deleted? res)))
+     (when (and check-not-found (or (not res) (is-deleted? res)))
        (ex/raise :type :not-found
                  :table table
                  :hint "database object not found"))
@@ -267,13 +278,28 @@
   (instance? PGpoint v))
 
 (defn pgarray?
-  [v]
-  (instance? PgArray v))
+  ([v] (instance? PgArray v))
+  ([v type]
+   (and (instance? PgArray v)
+        (= type (.getBaseTypeName ^PgArray v)))))
 
 (defn pgarray-of-uuid?
   [v]
   (and (pgarray? v) (= "uuid" (.getBaseTypeName ^PgArray v))))
 
+(defn decode-pgarray
+  ([v] (into [] (.getArray ^PgArray v)))
+  ([v in] (into in (.getArray ^PgArray v)))
+  ([v in xf] (into in xf (.getArray ^PgArray v))))
+
+(defn pgarray->set
+  [v]
+  (set (.getArray ^PgArray v)))
+
+(defn pgarray->vector
+  [v]
+  (vec (.getArray ^PgArray v)))
+
 (defn pgpoint
   [p]
   (PGpoint. (:x p) (:y p)))
@@ -285,7 +311,6 @@
       (.createArrayOf conn ^String type (into-array Object objects))
       (.createArrayOf conn ^String type objects))))
 
-
 (defn decode-pgpoint
   [^PGpoint v]
   (gpt/point (.-x v) (.-y v)))
@@ -369,15 +394,6 @@
     (.setType "jsonb")
     (.setValue (json/encode-str data))))
 
-(defn pgarray->set
-  [v]
-  (set (.getArray ^PgArray v)))
-
-(defn pgarray->vector
-  [v]
-  (vec (.getArray ^PgArray v)))
-
-
 ;; --- Locks
 
 (defn- xact-check-param

backend/src/app/emails.clj

@@ -7,12 +7,12 @@
 (ns app.emails
   "Main api for send emails."
   (:require
+   [app.common.logging :as l]
    [app.common.spec :as us]
-   [app.config :as cfg]
+   [app.config :as cf]
    [app.db :as db]
    [app.db.sql :as sql]
    [app.util.emails :as emails]
-   [app.util.logging :as l]
    [app.worker :as wrk]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]))
@@ -54,10 +54,10 @@
 (defn allow-send-emails?
   [conn profile]
   (when-not (:is-muted profile false)
-    (let [complaint-threshold (cfg/get :profile-complaint-threshold)
-          complaint-max-age   (cfg/get :profile-complaint-max-age)
-          bounce-threshold    (cfg/get :profile-bounce-threshold)
-          bounce-max-age      (cfg/get :profile-bounce-max-age)
+    (let [complaint-threshold (cf/get :profile-complaint-threshold)
+          complaint-max-age   (cf/get :profile-complaint-max-age)
+          bounce-threshold    (cf/get :profile-bounce-threshold)
+          bounce-max-age      (cf/get :profile-bounce-max-age)
 
           {:keys [complaints bounces] :as result}
           (db/exec-one! conn [sql:profile-complaint-report
@@ -140,19 +140,17 @@
 
 (declare send-console!)
 
-(s/def ::username ::cfg/smtp-username)
-(s/def ::password ::cfg/smtp-password)
-(s/def ::tls ::cfg/smtp-tls)
-(s/def ::ssl ::cfg/smtp-ssl)
-(s/def ::host ::cfg/smtp-host)
-(s/def ::port ::cfg/smtp-port)
-(s/def ::default-reply-to ::cfg/smtp-default-reply-to)
-(s/def ::default-from ::cfg/smtp-default-from)
-(s/def ::enabled ::cfg/smtp-enabled)
+(s/def ::username ::cf/smtp-username)
+(s/def ::password ::cf/smtp-password)
+(s/def ::tls ::cf/smtp-tls)
+(s/def ::ssl ::cf/smtp-ssl)
+(s/def ::host ::cf/smtp-host)
+(s/def ::port ::cf/smtp-port)
+(s/def ::default-reply-to ::cf/smtp-default-reply-to)
+(s/def ::default-from ::cf/smtp-default-from)
 
 (defmethod ig/pre-init-spec ::sendmail-handler [_]
-  (s/keys :req-un [::enabled]
-          :opt-un [::username
+  (s/keys :opt-un [::username
                    ::password
                    ::tls
                    ::ssl
@@ -164,9 +162,12 @@
 (defmethod ig/init-key ::sendmail-handler
   [_ cfg]
   (fn [{:keys [props] :as task}]
-    (if (:enabled cfg)
-      (emails/send! cfg props)
-      (send-console! cfg props))))
+    (let [enabled? (or (contains? cf/flags :smtp)
+                       (cf/get :smtp-enabled)
+                       (:enabled task))]
+      (if enabled?
+        (emails/send! cfg props)
+        (send-console! cfg props)))))
 
 (defn- send-console!
   [cfg email]

backend/src/app/http.clj

@@ -8,11 +8,12 @@
   (:require
    [app.common.data :as d]
    [app.common.exceptions :as ex]
+   [app.common.logging :as l]
    [app.common.spec :as us]
+   [app.http.doc :as doc]
    [app.http.errors :as errors]
    [app.http.middleware :as middleware]
    [app.metrics :as mtx]
-   [app.util.logging :as l]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]
    [reitit.ring :as rr]
@@ -114,9 +115,14 @@
 (s/def ::storage map?)
 (s/def ::assets map?)
 (s/def ::feedback fn?)
+(s/def ::error-report-handler fn?)
+(s/def ::audit-http-handler fn?)
 
 (defmethod ig/pre-init-spec ::router [_]
-  (s/keys :req-un [::rpc ::session ::mtx/metrics ::oauth ::storage ::assets ::feedback]))
+  (s/keys :req-un [::rpc ::session ::mtx/metrics
+                   ::oauth ::storage ::assets ::feedback
+                   ::error-report-handler
+                   ::audit-http-handler]))
 
 (defmethod ig/init-key ::router
   [_ {:keys [session rpc oauth metrics assets feedback] :as cfg}]
@@ -136,9 +142,8 @@
     ["/webhooks"
      ["/sns" {:post (:sns-webhook cfg)}]]
 
-    ["/api" {:middleware [
-                          ;; Temporary disabled
-                          #_[middleware/etag]
+    ["/api" {:middleware [[middleware/cors]
+                          [middleware/etag]
                           [middleware/format-response-body]
                           [middleware/params]
                           [middleware/multipart-params]
@@ -147,12 +152,16 @@
                           [middleware/errors errors/handle]
                           [middleware/cookies]]}
 
+     ["/_doc" {:get (doc/handler rpc)}]
+
      ["/feedback" {:middleware [(:middleware session)]
                    :post feedback}]
-
      ["/auth/oauth/:provider" {:post (:handler oauth)}]
      ["/auth/oauth/:provider/callback" {:get (:callback-handler oauth)}]
 
+     ["/audit/events" {:middleware [(:middleware session)]
+                       :post (:audit-http-handler cfg)}]
+
      ["/rpc" {:middleware [(:middleware session)]}
       ["/query/:type" {:get (:query-handler rpc)
                        :post (:query-handler rpc)}]

backend/src/app/http/awsns.clj

@@ -8,10 +8,10 @@
   "AWS SNS webhook handler for bounces."
   (:require
    [app.common.exceptions :as ex]
+   [app.common.logging :as l]
    [app.db :as db]
    [app.db.sql :as sql]
    [app.util.http :as http]
-   [app.util.logging :as l]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [integrant.core :as ig]

backend/src/app/http/doc.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/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.http.doc
+  "API autogenerated documentation."
+  (:require
+   [app.common.data :as d]
+   [app.config :as cf]
+   [app.util.services :as sv]
+   [app.util.template :as tmpl]
+   [clojure.java.io :as io]
+   [clojure.spec.alpha :as s]
+   [pretty-spec.core :as ps]))
+
+(defn get-spec-str
+  [k]
+  (with-out-str
+    (ps/pprint (s/form k)
+               {:ns-aliases {"clojure.spec.alpha" "s"
+                             "clojure.core.specs.alpha" "score"
+                             "clojure.core" nil}})))
+
+(defn prepare-context
+  [rpc]
+  (letfn [(gen-doc [type [name f]]
+            (let [mdata (meta f)]
+              ;; (prn name mdata)
+              {:type (d/name type)
+               :name (d/name name)
+               :auth (:auth mdata true)
+               :docs (::sv/docs mdata)
+               :spec (get-spec-str (::sv/spec mdata))}))]
+    {:query-methods
+     (into []
+           (map (partial gen-doc :query))
+           (->> rpc :methods :query (sort-by first)))
+     :mutation-methods
+     (into []
+           (map (partial gen-doc :mutation))
+           (->> rpc :methods :mutation (sort-by first)))}))
+
+(defn handler
+  [rpc]
+  (let [context (prepare-context rpc)]
+    (if (contains? cf/flags :backend-api-doc)
+      (fn [_]
+        {:status 200
+         :body (-> (io/resource "api-doc.tmpl")
+                   (tmpl/render context))})
+      (constantly {:status 404 :body ""}))))

backend/src/app/http/errors.clj

@@ -7,31 +7,57 @@
 (ns app.http.errors
   "A errors handling for the http server."
   (:require
+   [app.common.data :as d]
    [app.common.exceptions :as ex]
+   [app.common.logging :as l]
    [app.common.uuid :as uuid]
-   [app.util.logging :as l]
-   [cuerdas.core :as str]
-   [expound.alpha :as expound]))
+   [clojure.pprint]
+   [cuerdas.core :as str]))
 
-(defn- explain-error
-  [error]
-  (with-out-str
-    (expound/printer (:data error))))
+(defn- parse-client-ip
+  [{:keys [headers] :as request}]
+  (or (some-> (get headers "x-forwarded-for") (str/split ",") first)
+      (get headers "x-real-ip")
+      (get request :remote-addr)))
+
+
+(defn- simple-prune
+  ([s] (simple-prune s (* 1024 1024)))
+  ([s max-length]
+   (if (> (count s) max-length)
+     (str (subs s 0 max-length) " [...]")
+     s)))
+
+(defn- stringify-data
+  [data]
+  (binding [clojure.pprint/*print-right-margin* 200]
+    (let [result (with-out-str (clojure.pprint/pprint data))]
+      (simple-prune result (* 1024 1024)))))
 
 (defn get-error-context
   [request error]
-  (let [edata (ex-data error)]
-    (merge
-     {:id      (uuid/next)
-      :path    (:uri request)
-      :method  (:request-method request)
-      :params  (:params request)
-      :data    edata}
+  (let [data (ex-data error)]
+    (d/without-nils
+     (merge
+      {:id      (str (uuid/next))
+       :path    (str (:uri request))
+       :method  (name (:request-method request))
+       :hint    (or (:hint data) (ex-message error))
+       :params  (stringify-data (:params request))
+       :data    (stringify-data (dissoc data :explain))
+       :ip-addr (parse-client-ip request)
+       :explain (str/prune (:explain data) (* 1024 1024) "[...]")}
+
+     (when-let [id (:profile-id request)]
+       {:profile-id id})
+
      (let [headers (:headers request)]
        {:user-agent (get headers "user-agent")
         :frontend-version (get headers "x-frontend-version" "unknown")})
-     (when (and (map? edata) (:data edata))
-       {:explain (explain-error edata)}))))
+
+     (when (map? data)
+       {:error-type (:type data)
+        :error-code (:code data)})))))
 
 (defmulti handle-exception
   (fn [err & _rest]
@@ -43,7 +69,6 @@
   [err _]
   {:status 401 :body (ex-data err)})
 
-
 (defmethod handle-exception :restriction
   [err _]
   {:status 400 :body (ex-data err)})
@@ -57,13 +82,10 @@
       {:status 400
        :headers {"content-type" "text/html"}
        :body (str "<pre style='font-size:16px'>"
-                  (explain-error edata)
+                  (:explain edata)
                   "</pre>\n")}
       {:status 400
-       :body   (cond-> edata
-                 (map? (:data edata))
-                 (-> (assoc :explain (explain-error edata))
-                     (dissoc :data)))})))
+       :body   (dissoc edata :data)})))
 
 (defmethod handle-exception :assertion
   [error request]
@@ -77,9 +99,7 @@
     {:status 500
      :body {:type :server-error
             :code :assertion
-            :data (-> edata
-                      (assoc :explain (explain-error edata))
-                      (dissoc :data))}}))
+            :data (dissoc edata :data)}}))
 
 (defmethod handle-exception :not-found
   [err _]

backend/src/app/http/feedback.clj

@@ -10,7 +10,7 @@
    [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
-   [app.config :as cfg]
+   [app.config :as cf]
    [app.db :as db]
    [app.emails :as eml]
    [app.rpc.queries.profile :as profile]
@@ -24,8 +24,8 @@
 
 (defmethod ig/init-key ::handler
   [_ {:keys [pool] :as scfg}]
-  (let [ftoken   (cfg/get :feedback-token ::no-token)
-        enabled  (cfg/get :feedback-enabled)]
+  (let [ftoken   (cf/get :feedback-token ::no-token)
+        enabled  (contains? cf/flags :user-feedback)]
     (fn [{:keys [profile-id] :as request}]
       (let [token  (get-in request [:headers "x-feedback-token"])
             params (d/merge (:params request)
@@ -58,9 +58,10 @@
 (defn send-feedback
   [pool profile params]
   (let [params      (us/conform ::feedback params)
-        destination (cfg/get :feedback-destination)]
+        destination (cf/get :feedback-destination)]
     (eml/send! {::eml/conn pool
                 ::eml/factory eml/feedback
+                :from     destination
                 :to       destination
                 :profile  profile
                 :reply-to (:from params)

backend/src/app/http/middleware.clj

@@ -6,14 +6,14 @@
 
 (ns app.http.middleware
   (:require
+   [app.common.logging :as l]
    [app.common.transit :as t]
+   [app.config :as cf]
    [app.metrics :as mtx]
    [app.util.json :as json]
-   [app.util.logging :as l]
    [buddy.core.codecs :as bc]
    [buddy.core.hash :as bh]
    [clojure.java.io :as io]
-   [ring.core.protocols :as rp]
    [ring.middleware.cookies :refer [wrap-cookies]]
    [ring.middleware.keyword-params :refer [wrap-keyword-params]]
    [ring.middleware.multipart-params :refer [wrap-multipart-params]]
@@ -74,33 +74,15 @@
   {:name ::parse-request-body
    :compile (constantly wrap-parse-request-body)})
 
-(defn- transit-streamable-body
-  [data opts]
-  (reify rp/StreamableResponseBody
-    (write-body-to-stream [_ response output-stream]
-      (try
-        (let [tw (t/writer output-stream opts)]
-          (t/write! tw data))
-        (finally
-          (.close ^java.io.OutputStream output-stream))))))
-
 (defn- impl-format-response-body
   [response _request]
   (let [body (:body response)
-        opts {:type :json-verbose}]
+        opts {:type :json}]
     (cond
       (coll? body)
       (-> response
           (update :headers assoc "content-type" "application/transit+json")
-          (assoc :body (transit-streamable-body body opts)))
-
-      ;; ;; Temporary disabled
-      ;; (-> response
-      ;;     (update :headers assoc "content-type" "application/transit+json")
-      ;;     (assoc :body
-      ;;            (if (= :post (:request-method request))
-      ;;              (transit-streamable-body body opts)
-      ;;              (t/encode body opts))))
+          (assoc :body (t/encode body opts)))
 
       (nil? body)
       (assoc response :status 204 :body "")
@@ -195,3 +177,29 @@
                 :uri (str (:uri request) (when qstring (str "?" qstring)))
                 :method (name (:request-method request)))
         (handler request)))))
+
+(defn- wrap-cors
+  [handler]
+  (if-not (contains? cf/flags :cors)
+    handler
+    (letfn [(add-cors-headers [response request]
+              (-> response
+                  (update
+                   :headers
+                   (fn [headers]
+                     (-> headers
+                         (assoc "access-control-allow-origin" (get-in request [:headers "origin"]))
+                         (assoc "access-control-allow-methods" "GET,POST,DELETE,OPTIONS,PUT,HEAD,PATCH")
+                         (assoc "access-control-allow-credentials" "true")
+                         (assoc "access-control-expose-headers" "x-requested-with, content-type, cookie")
+                         (assoc "access-control-allow-headers" "x-frontend-version, content-type, accept, x-requested-width"))))))]
+      (fn [request]
+        (if (= (:request-method request) :options)
+          (-> {:status 200 :body ""}
+              (add-cors-headers request))
+          (let [response (handler request)]
+            (add-cors-headers response request)))))))
+
+(def cors
+  {:name ::cors
+   :compile (constantly wrap-cors)})

backend/src/app/http/oauth.clj

@@ -8,6 +8,7 @@
   (:require
    [app.common.data :as d]
    [app.common.exceptions :as ex]
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.common.uri :as u]
    [app.config :as cf]
@@ -15,7 +16,6 @@
    [app.loggers.audit :as audit]
    [app.rpc.queries.profile :as profile]
    [app.util.http :as http]
-   [app.util.logging :as l]
    [app.util.time :as dt]
    [clojure.data.json :as json]
    [clojure.set :as set]
@@ -58,10 +58,16 @@
           {:token (get data "access_token")
            :type  (get data "token_type")})))
     (catch Exception e
-      (l/error :hint "unexpected error on retrieve-access-token"
-               :cause e)
+      (l/warn :hint "unexpected error on retrieve-access-token" :cause e)
       nil)))
 
+(defn- qualify-props
+  [provider props]
+  (reduce-kv (fn [result k v]
+               (assoc result (keyword (:name provider) (name k)) v))
+             {}
+             props))
+
 (defn- retrieve-user-info
   [{:keys [provider] :as cfg} tdata]
   (try
@@ -76,11 +82,10 @@
           {:backend (:name provider)
            :email (:email info)
            :fullname (:name info)
-           :props (dissoc info :name :email)})))
-
+           :props (->> (dissoc info :name :email)
+                       (qualify-props provider))})))
     (catch Exception e
-      (l/error :hint "unexpected exception on retrieve-user-info"
-               :cause e)
+      (l/warn :hint "unexpected exception on retrieve-user-info" :cause e)
       nil)))
 
 (s/def ::backend ::us/not-empty-string)
@@ -138,15 +143,14 @@
 
 ;; --- HTTP HANDLERS
 
-(defn extract-props
+(defn extract-utm-props
+  "Extracts additional data from user params."
   [params]
   (reduce-kv (fn [params k v]
                (let [sk (name k)]
                  (cond-> params
-                   (or (str/starts-with? sk "pm_")
-                       (str/starts-with? sk "pm-")
-                       (str/starts-with? sk "utm_"))
-                   (assoc (-> sk str/kebab keyword) v))))
+                   (str/starts-with? sk "utm_")
+                   (assoc (->> sk str/kebab (keyword "penpot")) v))))
              {}
              params))
 
@@ -197,6 +201,7 @@
            (sxf request)))
     (let [info   (assoc info
                         :iss :prepared-register
+                        :is-active true
                         :exp (dt/in-future {:hours 48}))
           token  (tokens :generate info)
           params (d/without-nils
@@ -210,7 +215,7 @@
 (defn- auth-handler
   [{:keys [tokens] :as cfg} {:keys [params] :as request}]
   (let [invitation (:invitation-token params)
-        props      (extract-props params)
+        props      (extract-utm-props params)
         state      (tokens :generate
                            {:iss :oauth
                             :invitation-token invitation

backend/src/app/http/session.clj

@@ -8,11 +8,11 @@
   (:require
    [app.common.data :as d]
    [app.common.exceptions :as ex]
+   [app.common.logging :as l]
    [app.config :as cfg]
    [app.db :as db]
    [app.metrics :as mtx]
    [app.util.async :as aa]
-   [app.util.logging :as l]
    [app.util.time :as dt]
    [app.worker :as wrk]
    [clojure.core.async :as a]
@@ -53,7 +53,13 @@
 
 (defn- add-cookies
   [response {:keys [id] :as session}]
-  (assoc response :cookies {cookie-name {:path "/" :http-only true :value id}}))
+  (let [cors?   (contains? cfg/flags :cors)
+        secure? (contains? cfg/flags :secure-session-cookies)]
+    (assoc response :cookies {cookie-name {:path "/"
+                                           :http-only true
+                                           :value id
+                                           :same-site (if cors? :none :strict)
+                                           :secure secure?}})))
 
 (defn- clear-cookies
   [response]

backend/src/app/loggers/audit.clj

@@ -9,6 +9,7 @@
   (:require
    [app.common.data :as d]
    [app.common.exceptions :as ex]
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.common.transit :as t]
    [app.common.uuid :as uuid]
@@ -16,14 +17,14 @@
    [app.db :as db]
    [app.util.async :as aa]
    [app.util.http :as http]
-   [app.util.logging :as l]
    [app.util.time :as dt]
    [app.worker :as wrk]
    [clojure.core.async :as a]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
    [integrant.core :as ig]
-   [lambdaisland.uri :as u]))
+   [lambdaisland.uri :as u]
+   [promesa.exec :as px]))
 
 (defn parse-client-ip
   [{:keys [headers] :as request}]
@@ -35,6 +36,7 @@
   [profile]
   (-> profile
       (select-keys [:is-active :is-muted :auth-backend :email :default-team-id :default-project-id :fullname :lang])
+      (merge (:props profile))
       (d/without-nils)))
 
 (defn clean-props
@@ -67,6 +69,66 @@
 
     (update event :props #(-> % clean-common clean-profile-id clean-complex-data))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HTTP Handler
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare persist-http-events)
+
+(s/def ::profile-id ::us/uuid)
+(s/def ::name ::us/string)
+(s/def ::type ::us/string)
+(s/def ::props (s/map-of ::us/keyword any?))
+(s/def ::timestamp dt/instant?)
+(s/def ::context (s/map-of ::us/keyword any?))
+
+(s/def ::event
+  (s/keys :req-un [::type ::name ::props ::timestamp ::profile-id]
+          :opt-un [::context]))
+
+(s/def ::events (s/every ::event))
+
+(defmethod ig/init-key ::http-handler
+  [_  {:keys [executor] :as cfg}]
+  (fn [{:keys [params profile-id] :as request}]
+    (when (contains? cf/flags :audit-log)
+      (let [events  (->> (:events params)
+                         (remove #(not= profile-id (:profile-id %)))
+                         (us/conform ::events))
+            ip-addr (parse-client-ip request)
+            cfg     (-> cfg
+                        (assoc :source "frontend")
+                        (assoc :events events)
+                        (assoc :ip-addr ip-addr))]
+        (px/run! executor #(persist-http-events cfg))))
+    {:status 204 :body ""}))
+
+(defn- persist-http-events
+  [{:keys [pool events ip-addr source] :as cfg}]
+  (try
+    (let [columns    [:id :name :source :type :tracked-at :profile-id :ip-addr :props :context]
+          prepare-xf (map (fn [event]
+                            [(uuid/next)
+                             (:name event)
+                             source
+                             (:type event)
+                             (:timestamp event)
+                             (:profile-id event)
+                             (db/inet ip-addr)
+                             (db/tjson (:props event))
+                             (db/tjson (d/without-nils (:context event)))]))
+          events     (us/conform ::events events)]
+      (when (seq events)
+        (->> (into [] prepare-xf events)
+             (db/insert-multi! pool :audit-log columns))))
+    (catch Throwable e
+      (let [xdata (ex-data e)]
+        (if (= :spec-validation (:code xdata))
+          (l/error ::l/raw (str "spec validation on persist-events:\n"
+                                (:explain xdata)))
+          (l/error :hint "error on persist-events"
+                   :cause e))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Collector
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -76,10 +138,9 @@
 ;; an external storage and data cleared.
 
 (declare persist-events)
-(s/def ::enabled ::us/boolean)
 
 (defmethod ig/pre-init-spec ::collector [_]
-  (s/keys :req-un [::db/pool ::wrk/executor ::enabled]))
+  (s/keys :req-un [::db/pool ::wrk/executor]))
 
 (def event-xform
   (comp
@@ -87,9 +148,9 @@
    (map clean-props)))
 
 (defmethod ig/init-key ::collector
-  [_ {:keys [enabled] :as cfg}]
-  (when enabled
-    (l/info :msg "intializing audit collector")
+  [_ cfg]
+  (when (contains? cf/flags :audit-log)
+    (l/info :msg "intializing audit log collector")
     (let [input  (a/chan 512 event-xform)
           buffer (aa/batch input {:max-batch-size 100
                                   :max-batch-age (* 10 1000) ; 10s
@@ -103,7 +164,9 @@
           (recur)))
 
       (fn [& {:keys [cmd] :as params}]
-        (let [params (dissoc params :cmd)]
+        (let [params (-> params
+                         (dissoc :cmd)
+                         (assoc :tracked-at (dt/now)))]
           (case cmd
             :stop   (a/close! input)
             :submit (when-not (a/offer! input params)
@@ -117,14 +180,16 @@
              (:name event)
              (:type event)
              (:profile-id event)
+             (:tracked-at event)
              (some-> (:ip-addr event) db/inet)
-             (db/tjson (:props event))])]
-
+             (db/tjson (:props event))
+             "backend"])]
     (aa/with-thread executor
-      (db/with-atomic [conn pool]
-        (db/insert-multi! conn :audit-log
-                          [:id :name :type :profile-id :ip-addr :props]
-                          (sequence (map event->row) events))))))
+      (when (seq events)
+        (db/with-atomic [conn pool]
+          (db/insert-multi! conn :audit-log
+                            [:id :name :type :profile-id :tracked-at :ip-addr :props :source]
+                            (sequence (map event->row) events)))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Archive Task
@@ -139,47 +204,59 @@
 (s/def ::tokens fn?)
 
 (defmethod ig/pre-init-spec ::archive-task [_]
-  (s/keys :req-un [::db/pool ::tokens ::enabled]
+  (s/keys :req-un [::db/pool ::tokens]
           :opt-un [::uri]))
 
 (defmethod ig/init-key ::archive-task
-  [_ {:keys [uri enabled] :as cfg}]
-  (fn [_]
-    (when (and enabled (not uri))
-      (ex/raise :type :internal
-                :code :task-not-configured
-                :hint "archive task not configured, missing uri"))
-    (loop []
-      (let [res (archive-events cfg)]
-        (when (= res :continue)
-          (aa/thread-sleep 200)
-          (recur))))))
+  [_ {:keys [uri] :as cfg}]
+  (fn [props]
+    ;; NOTE: this let allows overwrite default configured values from
+    ;; the repl, when manually invoking the task.
+    (let [enabled (or (contains? cf/flags :audit-log-archive)
+                      (:enabled props false))
+          uri     (or uri (:uri props))
+          cfg     (assoc cfg :uri uri)]
+      (when (and enabled (not uri))
+        (ex/raise :type :internal
+                  :code :task-not-configured
+                  :hint "archive task not configured, missing uri"))
+      (when enabled
+        (loop []
+          (let [res (archive-events cfg)]
+            (when (= res :continue)
+              (aa/thread-sleep 200)
+              (recur))))))))
 
 (def sql:retrieve-batch-of-audit-log
   "select * from audit_log
     where archived_at is null
     order by created_at asc
-    limit 100
+    limit 1000
       for update skip locked;")
 
 (defn archive-events
   [{:keys [pool uri tokens] :as cfg}]
-  (letfn [(decode-row [{:keys [props ip-addr] :as row}]
+  (letfn [(decode-row [{:keys [props ip-addr context] :as row}]
             (cond-> row
               (db/pgobject? props)
               (assoc :props (db/decode-transit-pgobject props))
 
+              (db/pgobject? context)
+              (assoc :context (db/decode-transit-pgobject context))
+
               (db/pgobject? ip-addr "inet")
               (assoc :ip-addr (db/decode-inet ip-addr))))
 
-          (row->event [{:keys [name type created-at profile-id props ip-addr]}]
-            (cond-> {:type type
-                     :name name
-                     :timestamp created-at
-                     :profile-id profile-id
-                     :props props}
-              (some? ip-addr)
-              (update :context assoc :source-ip ip-addr)))
+          (row->event [row]
+            (select-keys row [:type
+                              :name
+                              :source
+                              :created-at
+                              :tracked-at
+                              :profile-id
+                              :ip-addr
+                              :props
+                              :context]))
 
           (send [events]
             (let [token   (tokens :generate {:iss "authentication"
@@ -195,11 +272,12 @@
                            :headers headers
                            :body body}
                   resp    (http/send! params)]
-              (when (not= (:status resp) 204)
-                (ex/raise :type :internal
-                          :code :unable-to-send-events
-                          :hint "unable to send events"
-                          :context resp))))
+              (if (= (:status resp) 204)
+                true
+                (do
+                  (l/warn :hint "unable to archive events"
+                          :resp-status (:status resp))
+                  false))))
 
           (mark-as-archived [conn rows]
             (db/exec-one! conn ["update audit_log set archived_at=now() where id = ANY(?)"
@@ -212,11 +290,9 @@
             xform  (comp (map decode-row)
                          (map row->event))
             events (into [] xform rows)]
-        (l/debug :action "archive-events" :uri uri :events (count events))
-        (if (empty? events)
-          :empty
-          (do
-            (send events)
+        (when-not (empty? events)
+          (l/debug :action "archive-events" :uri uri :events (count events))
+          (when (send events)
             (mark-as-archived conn rows)
             :continue))))))
 
@@ -224,18 +300,6 @@
 ;; GC Task
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(declare clean-archived)
-
-(s/def ::max-age ::cf/audit-archive-gc-max-age)
-
-(defmethod ig/pre-init-spec ::archive-gc-task [_]
-  (s/keys :req-un [::db/pool ::enabled ::max-age]))
-
-(defmethod ig/init-key ::archive-gc-task
-  [_ cfg]
-  (fn [_]
-    (clean-archived cfg)))
-
 (def sql:clean-archived
   "delete from audit_log
     where archived_at is not null
@@ -248,3 +312,13 @@
         result   (:next.jdbc/update-count result)]
     (l/debug :action "clean archived audit log" :removed result)
     result))
+
+(s/def ::max-age ::cf/audit-log-gc-max-age)
+
+(defmethod ig/pre-init-spec ::gc-task [_]
+  (s/keys :req-un [::db/pool ::max-age]))
+
+(defmethod ig/init-key ::gc-task
+  [_ cfg]
+  (fn [_]
+    (clean-archived cfg)))

backend/src/app/loggers/database.clj

@@ -0,0 +1,126 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.loggers.database
+  "A specific logger impl that persists errors on the database."
+  (:require
+   [app.common.exceptions :as ex]
+   [app.common.logging :as l]
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.config :as cf]
+   [app.db :as db]
+   [app.util.async :as aa]
+   [app.util.template :as tmpl]
+   [app.worker :as wrk]
+   [clojure.core.async :as a]
+   [clojure.java.io :as io]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [integrant.core :as ig]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Error Listener
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare handle-event)
+
+(defonce enabled (atom true))
+
+(defn- persist-on-database!
+  [{:keys [pool] :as cfg} {:keys [id] :as event}]
+  (db/with-atomic [conn pool]
+    (db/insert! conn :server-error-report
+                {:id id :content (db/tjson event)})))
+
+(defn- parse-context
+  [event]
+  (reduce-kv
+   (fn [acc k v]
+     (cond
+       (= k :id)         (assoc acc k (uuid/uuid v))
+       (= k :profile-id) (assoc acc k (uuid/uuid v))
+       (str/blank? v)    acc
+       :else             (assoc acc k v)))
+   {}
+   (:context event)))
+
+(defn parse-event
+  [event]
+  (-> (parse-context event)
+      (merge (dissoc event :context))
+      (assoc :tenant (cf/get :tenant))
+      (assoc :host (cf/get :host))
+      (assoc :public-uri (cf/get :public-uri))
+      (assoc :version (:full cf/version))))
+
+(defn handle-event
+  [{:keys [executor] :as cfg} event]
+  (aa/with-thread executor
+    (try
+      (let [event (parse-event event)]
+        (persist-on-database! cfg event))
+      (catch Exception e
+        (l/warn :hint "unexpected exception on database error logger"
+                :cause e)))))
+
+(defmethod ig/pre-init-spec ::reporter [_]
+  (s/keys :req-un [::wrk/executor ::db/pool ::receiver]))
+
+(defmethod ig/init-key ::reporter
+  [_ {:keys [receiver] :as cfg}]
+  (l/info :msg "initializing database error persistence")
+  (let [output (a/chan (a/sliding-buffer 128)
+                       (filter #(= (:level %) "error")))]
+    (receiver :sub output)
+    (a/go-loop []
+      (let [msg (a/<! output)]
+        (if (nil? msg)
+          (l/info :msg "stoping error reporting loop")
+          (do
+            (a/<! (handle-event cfg msg))
+            (recur)))))
+    output))
+
+(defmethod ig/halt-key! ::reporter
+  [_ output]
+  (a/close! output))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Http Handler
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod ig/pre-init-spec ::handler [_]
+  (s/keys :req-un [::db/pool]))
+
+(defmethod ig/init-key ::handler
+  [_ {:keys [pool] :as cfg}]
+  (letfn [(parse-id [request]
+            (let [id (get-in request [:path-params :id])
+                  id (us/uuid-conformer id)]
+              (when (uuid? id)
+                id)))
+          (retrieve-report [id]
+            (ex/ignoring
+             (when-let [{:keys [content] :as row} (db/get-by-id pool :server-error-report id)]
+               (assoc row :content (db/decode-transit-pgobject content)))))
+
+          (render-template [{:keys [content] :as report}]
+            (some-> (io/resource "error-report.tmpl")
+                    (tmpl/render content)))]
+
+
+    (fn [request]
+      (let [result (some-> (parse-id request)
+                           (retrieve-report)
+                           (render-template))]
+        (if result
+          {:status 200
+           :headers {"content-type" "text/html; charset=utf-8"
+                     "x-robots-tag" "noindex"}
+           :body result}
+          {:status 404
+           :body "not found"})))))

backend/src/app/loggers/loki.clj

@@ -7,12 +7,12 @@
 (ns app.loggers.loki
   "A Loki integration."
   (:require
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.config :as cfg]
    [app.util.async :as aa]
    [app.util.http :as http]
    [app.util.json :as json]
-   [app.util.logging :as l]
    [app.worker :as wrk]
    [clojure.core.async :as a]
    [clojure.spec.alpha :as s]

backend/src/app/loggers/mattermost.clj

@@ -7,32 +7,51 @@
 (ns app.loggers.mattermost
   "A mattermost integration for error reporting."
   (:require
-   [app.common.exceptions :as ex]
-   [app.common.spec :as us]
-   [app.common.uuid :as uuid]
-   [app.config :as cfg]
+   [app.common.logging :as l]
+   [app.config :as cf]
    [app.db :as db]
+   [app.loggers.database :as ldb]
    [app.util.async :as aa]
    [app.util.http :as http]
    [app.util.json :as json]
-   [app.util.logging :as l]
-   [app.util.template :as tmpl]
    [app.worker :as wrk]
    [clojure.core.async :as a]
-   [clojure.java.io :as io]
    [clojure.spec.alpha :as s]
-   [cuerdas.core :as str]
    [integrant.core :as ig]))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Error Listener
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defonce enabled (atom true))
 
-(declare handle-event)
+(defn- send-mattermost-notification!
+  [cfg {:keys [host id public-uri] :as event}]
+  (try
+    (let [uri  (:uri cfg)
+          text (str "Exception on (host: " host ", url: " public-uri "/dbg/error-by-id/" id ")\n"
+                    (when-let [pid (:profile-id event)]
+                      (str "- profile-id: #uuid-" pid "\n")))
+          rsp  (http/send! {:uri uri
+                            :method :post
+                            :headers {"content-type" "application/json"}
+                            :body (json/encode-str {:text text})})]
+      (when (not= (:status rsp) 200)
+        (l/error :hint "error on sending data to mattermost"
+                 :response (pr-str rsp))))
 
-(defonce enabled-mattermost (atom true))
+    (catch Exception e
+      (l/error :hint "unexpected exception on error reporter"
+               :cause e))))
 
-(s/def ::uri ::us/string)
+(defn handle-event
+  [{:keys [executor] :as cfg} event]
+  (aa/with-thread executor
+    (try
+      (let [event (ldb/parse-event event)]
+        (when @enabled
+          (send-mattermost-notification! cfg event)))
+      (catch Exception e
+        (l/warn :hint "unexpected exception on error reporter" :cause e)))))
+
+
+(s/def ::uri ::cf/error-report-webhook)
 
 (defmethod ig/pre-init-spec ::reporter [_]
   (s/keys :req-un [::wrk/executor ::db/pool ::receiver]
@@ -58,95 +77,3 @@
   [_ output]
   (when output
     (a/close! output)))
-
-(defn- send-mattermost-notification!
-  [cfg {:keys [host id] :as cdata}]
-  (try
-    (let [uri  (:uri cfg)
-          text (str "Unhandled exception (host: " host ", url: " (cfg/get :public-uri) "/dbg/error-by-id/" id "\n"
-                    "- profile-id: #" (:profile-id cdata) "\n")
-          rsp  (http/send! {:uri uri
-                            :method :post
-                            :headers {"content-type" "application/json"}
-                            :body (json/encode-str {:text text})})]
-      (when (not= (:status rsp) 200)
-        (l/error :hint "error on sending data to mattermost"
-                 :response (pr-str rsp))))
-
-    (catch Exception e
-      (l/error :hint "unexpected exception on error reporter"
-               :cause e))))
-
-(defn- persist-on-database!
-  [{:keys [pool] :as cfg} {:keys [id] :as cdata}]
-  (db/with-atomic [conn pool]
-    (db/insert! conn :server-error-report
-                {:id id :content (db/tjson cdata)})))
-
-(defn- parse-context
-  [event]
-  (reduce-kv
-   (fn [acc k v]
-     (cond
-       (= k :id)         (assoc acc k (uuid/uuid v))
-       (= k :profile-id) (assoc acc k (uuid/uuid v))
-       (str/blank? v)    acc
-       :else             (assoc acc k v)))
-   {:id (uuid/next)}
-   (:context event)))
-
-(defn- parse-event
-  [event]
-  (-> (parse-context event)
-      (merge (dissoc event :context))
-      (assoc :tenant (cfg/get :tenant))
-      (assoc :host (cfg/get :host))
-      (assoc :public-uri (cfg/get :public-uri))
-      (assoc :version (:full cfg/version))))
-
-(defn handle-event
-  [{:keys [executor] :as cfg} event]
-  (aa/with-thread executor
-    (try
-      (let [cdata (parse-event event)]
-        (when @enabled-mattermost
-          (send-mattermost-notification! cfg cdata))
-        (persist-on-database! cfg cdata))
-      (catch Exception e
-        (l/error :hint "unexpected exception on error reporter"
-                 :cause e)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Http Handler
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::db/pool]))
-
-(defmethod ig/init-key ::handler
-  [_ {:keys [pool] :as cfg}]
-  (letfn [(parse-id [request]
-            (let [id (get-in request [:path-params :id])
-                  id (us/uuid-conformer id)]
-              (when (uuid? id)
-                id)))
-          (retrieve-report [id]
-            (ex/ignoring
-             (when-let [{:keys [content] :as row} (db/get-by-id pool :server-error-report id)]
-               (assoc row :content (db/decode-transit-pgobject content)))))
-
-          (render-template [{:keys [content] :as report}]
-            (some-> (io/resource "error-report.tmpl")
-                    (tmpl/render content)))]
-
-
-    (fn [request]
-      (let [result (some-> (parse-id request)
-                           (retrieve-report)
-                           (render-template))]
-        (if result
-          {:status 200
-           :headers {"content-type" "text/html; charset=utf-8"}
-           :body result}
-          {:status 404
-           :body "not found"})))))

backend/src/app/loggers/sentry.clj

@@ -0,0 +1,172 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.loggers.sentry
+  "A mattermost integration for error reporting."
+  (:require
+   [app.common.logging :as l]
+   [app.common.uuid :as uuid]
+   [app.config :as cf]
+   [app.db :as db]
+   [app.util.async :as aa]
+   [app.worker :as wrk]
+   [clojure.core.async :as a]
+   [clojure.spec.alpha :as s]
+   [cuerdas.core :as str]
+   [integrant.core :as ig])
+  (:import
+   io.sentry.Scope
+   io.sentry.IHub
+   io.sentry.Hub
+   io.sentry.NoOpHub
+   io.sentry.protocol.User
+   io.sentry.SentryOptions
+   io.sentry.SentryLevel
+   io.sentry.ScopeCallback))
+
+(defonce enabled (atom true))
+
+(defn- parse-context
+  [event]
+  (reduce-kv
+   (fn [acc k v]
+     (cond
+       (= k :id)         (assoc acc k (uuid/uuid v))
+       (= k :profile-id) (assoc acc k (uuid/uuid v))
+       (str/blank? v)    acc
+       :else             (assoc acc k v)))
+   {}
+   (:context event)))
+
+(defn- parse-event
+  [event]
+  (assoc event :context (parse-context event)))
+
+(defn- build-sentry-options
+  [cfg]
+  (let [version (:base cf/version)]
+    (doto (SentryOptions.)
+      (.setDebug (:debug cfg false))
+      (.setTracesSampleRate (:traces-sample-rate cfg 1.0))
+      (.setDsn (:dsn cfg))
+      (.setServerName (cf/get :host))
+      (.setEnvironment (cf/get :tenant))
+      (.setAttachServerName true)
+      (.setAttachStacktrace (:attach-stack-trace cfg false))
+      (.setRelease (str "backend@" (if (= version "0.0.0") "develop" version))))))
+
+(defn handle-event
+  [^IHub shub event]
+  (letfn [(set-user! [^Scope scope {:keys [context] :as event}]
+            (let [user (User.)]
+              (.setIpAddress ^User user ^String (:ip-addr context))
+              (when-let [pid (:profile-id context)]
+                (.setId ^User user ^String (str pid)))
+              (.setUser scope ^User user)))
+
+          (set-level! [^Scope scope]
+            (.setLevel scope SentryLevel/ERROR))
+
+          (set-context! [^Scope scope {:keys [context] :as event}]
+            (let [uri (str (cf/get :public-uri) "/dbg/error-by-id/" (:id context))]
+              (.setContexts scope "detailed_error_uri" ^String uri))
+            (when-let [vers (:frontend-version event)]
+              (.setContexts scope "frontend_version" ^String vers))
+            (when-let [puri (:public-uri event)]
+              (.setContexts scope "public_uri" ^String (str puri)))
+            (when-let [uagent (:user-agent context)]
+              (.setContexts scope "user_agent" ^String uagent))
+            (when-let [tenant (:tenant event)]
+              (.setTag scope "tenant" ^String tenant))
+            (when-let [type (:error-type context)]
+              (.setTag scope "error_type" ^String  (str type)))
+            (when-let [code (:error-code context)]
+              (.setTag scope "error_code" ^String (str code)))
+            )
+
+          (capture [^Scope scope {:keys [context error] :as event}]
+            (let [msg   (str (:message error) "\n\n"
+
+                             "======================================================\n"
+                             "=================== Params ===========================\n"
+                             "======================================================\n"
+
+                             (:params context) "\n"
+
+                             (when (:explain context)
+                               (str "======================================================\n"
+                                    "=================== Explain ==========================\n"
+                                    "======================================================\n"
+                                    (:explain context) "\n"))
+
+                             (when (:data context)
+                               (str "======================================================\n"
+                                    "=================== Error Data =======================\n"
+                                    "======================================================\n"
+                                    (:data context) "\n"))
+
+                             (str "======================================================\n"
+                                  "=================== Stack Trace ======================\n"
+                                  "======================================================\n"
+                                  (:trace error))
+
+                             "\n")]
+              (set-user! scope event)
+              (set-level! scope)
+              (set-context! scope event)
+              (.captureMessage ^IHub shub msg)
+              ))
+          ]
+    ;; (clojure.pprint/pprint event)
+
+    (when @enabled
+      (.withScope ^IHub shub (reify ScopeCallback
+                               (run [_ scope]
+                                 (->> event
+                                      (parse-event)
+                                      (capture scope))))))
+
+    ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Error Listener
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(s/def ::receiver any?)
+(s/def ::dsn ::cf/sentry-dsn)
+(s/def ::trace-sample-rate ::cf/sentry-trace-sample-rate)
+(s/def ::attach-stack-trace ::cf/sentry-attach-stack-trace)
+(s/def ::debug ::cf/sentry-debug)
+
+(defmethod ig/pre-init-spec ::reporter [_]
+  (s/keys :req-un [::wrk/executor ::db/pool ::receiver]
+          :opt-un [::dsn ::trace-sample-rate ::attach-stack-trace]))
+
+(defmethod ig/init-key ::reporter
+  [_ {:keys [receiver dsn executor] :as cfg}]
+  (l/info :msg "initializing sentry reporter" :dsn dsn)
+  (let [opts   (build-sentry-options cfg)
+        shub   (if dsn
+                 (Hub. ^SentryOptions opts)
+                 (NoOpHub/getInstance))
+        output (a/chan (a/sliding-buffer 128)
+                       (filter #(= (:level %) "error")))]
+    (receiver :sub output)
+    (a/go-loop []
+      (let [event (a/<! output)]
+        (if (nil? event)
+          (do
+            (l/info :msg "stoping error reporting loop")
+            (.close ^IHub shub))
+          (do
+            (a/<! (aa/with-thread executor (handle-event shub event)))
+            (recur)))))
+    output))
+
+(defmethod ig/halt-key! ::reporter
+  [_ output]
+  (when output
+    (a/close! output)))

backend/src/app/loggers/zmq.clj

@@ -7,10 +7,9 @@
 (ns app.loggers.zmq
   "A generic ZMQ listener."
   (:require
-   [app.common.data :as d]
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.util.json :as json]
-   [app.util.logging :as l]
    [app.util.time :as dt]
    [clojure.core.async :as a]
    [clojure.spec.alpha :as s]
@@ -74,7 +73,7 @@
 
 (defn- prepare
   [event]
-  (d/merge
+  (merge
    {:logger     (:loggerName event)
     :level      (str/lower (:level event))
     :thread     (:thread event)

backend/src/app/main.clj

@@ -6,8 +6,8 @@
 
 (ns app.main
   (:require
+   [app.common.logging :as l]
    [app.config :as cf]
-   [app.util.logging :as l]
    [app.util.time :as dt]
    [integrant.core :as ig]))
 
@@ -20,7 +20,7 @@
     :migrations (ig/ref :app.migrations/all)
     :name :main
     :min-pool-size 0
-    :max-pool-size 20}
+    :max-pool-size 30}
 
    :app.metrics/metrics
    {:definitions
@@ -28,9 +28,20 @@
      {:name "actions_profile_register_count"
       :help "A global counter of user registrations."
       :type :counter}
+
      :profile-activation
      {:name "actions_profile_activation_count"
       :help "A global counter of profile activations"
+      :type :counter}
+
+     :update-file-changes
+     {:name "rpc_update_file_changes_total"
+      :help "A total number of changes submitted to update-file."
+      :type :counter}
+
+     :update-file-bytes-processed
+     {:name "rpc_update_file_bytes_processed_total"
+      :help "A total number of bytes processed by update-file."
       :type :counter}}}
 
    :app.migrations/all
@@ -95,7 +106,8 @@
     :storage     (ig/ref :app.storage/storage)
     :sns-webhook (ig/ref :app.http.awsns/handler)
     :feedback    (ig/ref :app.http.feedback/handler)
-    :error-report-handler (ig/ref :app.loggers.mattermost/handler)}
+    :audit-http-handler   (ig/ref :app.loggers.audit/http-handler)
+    :error-report-handler (ig/ref :app.loggers.database/handler)}
 
    :app.http.assets/handlers
    {:metrics           (ig/ref :app.metrics/metrics)
@@ -196,15 +208,16 @@
        {:cron #app/cron "0 0 * * * ?"  ;; hourly
         :task :file-offload})
 
-     (when (cf/get :audit-archive-enabled)
-       {:cron #app/cron "0 0 * * * ?" ;; every 1h
-        :task :audit-archive})
+     (when (contains? cf/flags :audit-log-archive)
+       {:cron #app/cron "0 */3 * * * ?" ;; every 3m
+        :task :audit-log-archive})
 
-     (when (cf/get :audit-archive-gc-enabled)
-       {:cron #app/cron "0 0 * * * ?" ;; every 1h
-        :task :audit-archive-gc})
+     (when (contains? cf/flags :audit-log-gc)
+       {:cron #app/cron "0 0 0 * * ?" ;; daily
+        :task :audit-log-gc})
 
-     (when (cf/get :telemetry-enabled)
+     (when (or (contains? cf/flags :telemetry)
+               (cf/get :telemetry-enabled))
        {:cron #app/cron "0 0 */6 * * ?" ;; every 6h
         :task :telemetry})]}
 
@@ -213,8 +226,6 @@
     :tasks
     {:sendmail           (ig/ref :app.emails/sendmail-handler)
      :objects-gc         (ig/ref :app.tasks.objects-gc/handler)
-     :delete-object      (ig/ref :app.tasks.delete-object/handler)
-     :delete-profile     (ig/ref :app.tasks.delete-profile/handler)
      :file-media-gc      (ig/ref :app.tasks.file-media-gc/handler)
      :file-xlog-gc       (ig/ref :app.tasks.file-xlog-gc/handler)
      :storage-deleted-gc (ig/ref :app.storage/gc-deleted-task)
@@ -224,15 +235,14 @@
      :telemetry          (ig/ref :app.tasks.telemetry/handler)
      :session-gc         (ig/ref :app.http.session/gc-task)
      :file-offload       (ig/ref :app.tasks.file-offload/handler)
-     :audit-archive      (ig/ref :app.loggers.audit/archive-task)
-     :audit-archive-gc   (ig/ref :app.loggers.audit/archive-gc-task)}}
+     :audit-log-archive  (ig/ref :app.loggers.audit/archive-task)
+     :audit-log-gc       (ig/ref :app.loggers.audit/gc-task)}}
 
    :app.emails/sendmail-handler
    {:host             (cf/get :smtp-host)
     :port             (cf/get :smtp-port)
     :ssl              (cf/get :smtp-ssl)
     :tls              (cf/get :smtp-tls)
-    :enabled          (cf/get :smtp-enabled)
     :username         (cf/get :smtp-username)
     :password         (cf/get :smtp-password)
     :metrics          (ig/ref :app.metrics/metrics)
@@ -243,18 +253,11 @@
    {:pool    (ig/ref :app.db/pool)
     :max-age cf/deletion-delay}
 
-   :app.tasks.delete-object/handler
-   {:pool    (ig/ref :app.db/pool)
-    :storage (ig/ref :app.storage/storage)}
-
    :app.tasks.objects-gc/handler
    {:pool    (ig/ref :app.db/pool)
     :storage (ig/ref :app.storage/storage)
     :max-age cf/deletion-delay}
 
-   :app.tasks.delete-profile/handler
-   {:pool    (ig/ref :app.db/pool)}
-
    :app.tasks.file-media-gc/handler
    {:pool    (ig/ref :app.db/pool)
     :max-age cf/deletion-delay}
@@ -289,20 +292,21 @@
    :app.loggers.zmq/receiver
    {:endpoint (cf/get :loggers-zmq-uri)}
 
+   :app.loggers.audit/http-handler
+   {:pool     (ig/ref :app.db/pool)
+    :executor (ig/ref :app.worker/executor)}
+
    :app.loggers.audit/collector
-   {:enabled  (cf/get :audit-enabled false)
-    :pool     (ig/ref :app.db/pool)
+   {:pool     (ig/ref :app.db/pool)
     :executor (ig/ref :app.worker/executor)}
 
    :app.loggers.audit/archive-task
-   {:uri      (cf/get :audit-archive-uri)
-    :enabled  (cf/get :audit-archive-enabled false)
+   {:uri      (cf/get :audit-log-archive-uri)
     :tokens   (ig/ref :app.tokens/tokens)
     :pool     (ig/ref :app.db/pool)}
 
-   :app.loggers.audit/archive-gc-task
-   {:enabled  (cf/get :audit-archive-gc-enabled false)
-    :max-age  (cf/get :audit-archive-gc-max-age cf/deletion-delay)
+   :app.loggers.audit/gc-task
+   {:max-age  (cf/get :audit-log-gc-max-age cf/deletion-delay)
     :pool     (ig/ref :app.db/pool)}
 
    :app.loggers.loki/reporter
@@ -316,9 +320,23 @@
     :pool     (ig/ref :app.db/pool)
     :executor (ig/ref :app.worker/executor)}
 
-   :app.loggers.mattermost/handler
+   :app.loggers.database/reporter
+   {:receiver (ig/ref :app.loggers.zmq/receiver)
+    :pool     (ig/ref :app.db/pool)
+    :executor (ig/ref :app.worker/executor)}
+
+   :app.loggers.database/handler
    {:pool (ig/ref :app.db/pool)}
 
+   :app.loggers.sentry/reporter
+   {:dsn                (cf/get :sentry-dsn)
+    :trace-sample-rate  (cf/get :sentry-trace-sample-rate 1.0)
+    :attach-stack-trace (cf/get :sentry-attach-stack-trace false)
+    :debug              (cf/get :sentry-debug false)
+    :receiver (ig/ref :app.loggers.zmq/receiver)
+    :pool     (ig/ref :app.db/pool)
+    :executor (ig/ref :app.worker/executor)}
+
    :app.storage/storage
    {:pool     (ig/ref :app.db/pool)
     :executor (ig/ref :app.worker/executor)

backend/src/app/media.clj

@@ -13,7 +13,7 @@
    [app.common.spec :as us]
    [app.config :as cf]
    [app.rlimits :as rlm]
-   [app.rpc.queries.svg :as svg]
+   [app.util.svg :as svg]
    [buddy.core.bytes :as bb]
    [buddy.core.codecs :as bc]
    [clojure.java.io :as io]
@@ -180,7 +180,7 @@
   (us/assert ::input input)
   (let [{:keys [path mtype]} input]
     (if (= mtype "image/svg+xml")
-      (let [info (some-> path slurp svg/parse get-basic-info-from-svg)]
+      (let [info (some-> path slurp svg/pre-process svg/parse get-basic-info-from-svg)]
         (when-not info
           (ex/raise :type :validation
                     :code :invalid-svg-file

backend/src/app/metrics.clj

@@ -7,7 +7,7 @@
 (ns app.metrics
   (:require
    [app.common.exceptions :as ex]
-   [app.util.logging :as l]
+   [app.common.logging :as l]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig])
   (:import
@@ -92,18 +92,14 @@
         _        (when (seq labels)
                    (.labelNames instance (into-array String labels)))
         instance (.register instance registry)]
-    (reify
-      clojure.lang.IDeref
-      (deref [_] instance)
 
-      clojure.lang.IFn
-      (invoke [_ cmd]
-        (.inc ^Counter instance))
-
-      (invoke [_ cmd labels]
-        (.. ^Counter instance
-            (labels (into-array String labels))
-            (inc))))))
+    {::instance instance
+     ::fn (fn [{:keys [by labels] :or {by 1}}]
+            (if labels
+              (.. ^Counter instance
+                  (labels (into-array String labels))
+                  (inc by))
+              (.inc ^Counter instance by)))}))
 
 (defn make-gauge
   [{:keys [name help registry reg labels] :as props}]
@@ -115,21 +111,16 @@
                    (.labelNames instance (into-array String labels)))
         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)))
-
-      (invoke [_ cmd labels]
-        (let [labels (into-array String [labels])]
-          (case cmd
-            :inc (.. ^Gauge instance (labels labels) (inc))
-            :dec (.. ^Gauge instance (labels labels) (dec))))))))
+    {::instance instance
+     ::fn (fn [{:keys [cmd by labels] :or {by 1}}]
+            (if labels
+              (let [labels (into-array String [labels])]
+                (case cmd
+                  :inc (.. ^Gauge instance (labels labels) (inc by))
+                  :dec (.. ^Gauge instance (labels labels) (dec by))))
+              (case cmd
+                :inc (.inc ^Gauge instance by)
+                :dec (.dec ^Gauge instance by))))}))
 
 (def default-quantiles
   [[0.75 0.02]
@@ -150,18 +141,14 @@
         _        (when (seq labels)
                    (.labelNames instance (into-array String labels)))
         instance (.register instance registry)]
-    (reify
-      clojure.lang.IDeref
-      (deref [_] instance)
 
-      clojure.lang.IFn
-      (invoke [_ cmd val]
-        (.observe ^Summary instance val))
-
-      (invoke [_ cmd val labels]
-        (.. ^Summary instance
-            (labels (into-array String labels))
-            (observe val))))))
+    {::instance instance
+     ::fn (fn [{:keys [val labels]}]
+            (if labels
+              (.. ^Summary instance
+                  (labels (into-array String labels))
+                  (observe val))
+              (.observe ^Summary instance val)))}))
 
 (def default-histogram-buckets
   [1 5 10 25 50 75 100 250 500 750 1000 2500 5000 7500])
@@ -177,18 +164,14 @@
         _        (when (seq labels)
                    (.labelNames instance (into-array String labels)))
         instance (.register instance registry)]
-    (reify
-      clojure.lang.IDeref
-      (deref [_] instance)
 
-      clojure.lang.IFn
-      (invoke [_ cmd val]
-        (.observe ^Histogram instance val))
-
-      (invoke [_ cmd val labels]
-        (.. ^Histogram instance
-            (labels (into-array String labels))
-            (observe val))))))
+    {::instance instance
+     ::fn (fn [{:keys [val labels]}]
+            (if labels
+              (.. ^Histogram instance
+                  (labels (into-array String labels))
+                  (observe val))
+              (.observe ^Histogram instance val)))}))
 
 (defn create
   [{:keys [type] :as props}]
@@ -205,19 +188,19 @@
      (with-meta
        (fn
          ([a]
-          (mobj :inc)
+          ((::fn mobj) nil)
           (origf a))
          ([a b]
-          (mobj :inc)
+          ((::fn mobj) nil)
           (origf a b))
          ([a b c]
-          (mobj :inc)
+          ((::fn mobj) nil)
           (origf a b c))
          ([a b c d]
-          (mobj :inc)
+          ((::fn mobj) nil)
           (origf a b c d))
          ([a b c d & more]
-          (mobj :inc)
+          ((::fn mobj) nil)
           (apply origf a b c d more)))
        (assoc mdata ::original origf))))
   ([rootf mobj labels]
@@ -226,13 +209,13 @@
      (with-meta
        (fn
          ([a]
-          (mobj :inc labels)
+          ((::fn mobj) {:labels labels})
           (origf a))
          ([a b]
-          (mobj :inc labels)
+          ((::fn mobj) {:labels labels})
           (origf a b))
          ([a b & more]
-          (mobj :inc labels)
+          ((::fn mobj) {:labels labels})
           (apply origf a b more)))
        (assoc mdata ::original origf)))))
 
@@ -245,15 +228,15 @@
          ([a]
          (with-measure
            :expr (origf a)
-           :cb   #(mobj :observe %)))
+           :cb   #((::fn mobj) {:val %})))
          ([a b]
           (with-measure
             :expr (origf a b)
-            :cb   #(mobj :observe %)))
+            :cb   #((::fn mobj) {:val %})))
          ([a b & more]
           (with-measure
             :expr (apply origf a b more)
-            :cb   #(mobj :observe %))))
+            :cb   #((::fn mobj) {:val %}))))
        (assoc mdata ::original origf))))
 
   ([rootf mobj labels]
@@ -264,26 +247,26 @@
          ([a]
          (with-measure
            :expr (origf a)
-           :cb   #(mobj :observe % labels)))
+           :cb   #((::fn mobj) {:val % :labels labels})))
          ([a b]
           (with-measure
             :expr (origf a b)
-            :cb   #(mobj :observe % labels)))
+            :cb   #((::fn mobj) {:val % :labels labels})))
          ([a b & more]
           (with-measure
             :expr (apply origf a b more)
-            :cb   #(mobj :observe % labels))))
+            :cb   #((::fn mobj) {:val % :labels labels}))))
        (assoc mdata ::original origf)))))
 
 (defn instrument-vars!
   [vars {:keys [wrap] :as props}]
   (let [obj (create props)]
     (cond
-      (instance? Counter @obj)
+      (instance? Counter (::instance obj))
       (doseq [var vars]
         (alter-var-root var (or wrap wrap-counter) obj))
 
-      (instance? Summary @obj)
+      (instance? Summary (::instance obj))
       (doseq [var vars]
         (alter-var-root var (or wrap wrap-summary) obj))
 
@@ -294,13 +277,13 @@
   [f {:keys [wrap] :as props}]
   (let [obj (create props)]
     (cond
-      (instance? Counter @obj)
+      (instance? Counter (::instance obj))
       ((or wrap wrap-counter) f obj)
 
-      (instance? Summary @obj)
+      (instance? Summary (::instance obj))
       ((or wrap wrap-summary) f obj)
 
-      (instance? Histogram @obj)
+      (instance? Histogram (::instance obj))
       ((or wrap wrap-summary) f obj)
 
       :else

backend/src/app/migrations.clj

@@ -193,6 +193,15 @@
 
    {:name "0061-mod-file-table"
     :fn (mg/resource "app/migrations/sql/0061-mod-file-table.sql")}
+
+   {:name "0062-fix-metadata-media"
+    :fn (mg/resource "app/migrations/sql/0062-fix-metadata-media.sql")}
+
+   {:name "0063-add-share-link-table"
+    :fn (mg/resource "app/migrations/sql/0063-add-share-link-table.sql")}
+
+   {:name "0064-mod-audit-log-table"
+    :fn (mg/resource "app/migrations/sql/0064-mod-audit-log-table.sql")}
    ])
 
 

backend/src/app/migrations/sql/0063-add-share-link-table.sql

@@ -0,0 +1,12 @@
+CREATE TABLE share_link (
+  id uuid PRIMARY KEY DEFAULT uuid_generate_v4(),
+  file_id uuid NOT NULL REFERENCES file(id) ON DELETE CASCADE DEFERRABLE,
+  owner_id uuid NULL REFERENCES profile(id) ON DELETE SET NULL DEFERRABLE,
+  created_at timestamptz NOT NULL DEFAULT clock_timestamp(),
+
+  pages uuid[],
+  flags text[]
+);
+
+CREATE INDEX share_link_file_id_idx ON share_link(file_id);
+CREATE INDEX share_link_owner_id_idx ON share_link(owner_id);

backend/src/app/migrations/sql/0064-mod-audit-log-table.sql

@@ -0,0 +1,13 @@
+ALTER TABLE audit_log
+  ADD COLUMN tracked_at timestamptz NULL DEFAULT clock_timestamp(),
+  ADD COLUMN source text NULL,
+  ADD COLUMN context jsonb NULL;
+
+ALTER TABLE audit_log
+  ALTER COLUMN source SET STORAGE external,
+  ALTER COLUMN context SET STORAGE external;
+
+UPDATE audit_log SET source = 'backend', tracked_at=created_at;
+
+-- ALTER TABLE audit_log ALTER COLUMN source SET NOT NULL;
+-- ALTER TABLE audit_log ALTER COLUMN tracked_at SET NOT NULL;

backend/src/app/msgbus.clj

@@ -8,10 +8,10 @@
   "The msgbus abstraction implemented using redis as underlying backend."
   (:require
    [app.common.exceptions :as ex]
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.config :as cfg]
    [app.util.blob :as blob]
-   [app.util.logging :as l]
    [app.util.time :as dt]
    [clojure.core.async :as a]
    [clojure.spec.alpha :as s]

backend/src/app/notifications.clj

@@ -7,12 +7,12 @@
 (ns app.notifications
   "A websocket based notifications mechanism."
   (:require
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.common.transit :as t]
    [app.db :as db]
    [app.metrics :as mtx]
    [app.util.async :as aa]
-   [app.util.logging :as l]
    [app.util.time :as dt]
    [app.worker :as wrk]
    [clojure.core.async :as a]
@@ -69,6 +69,7 @@
                    :mtx-messages mtx-messages
                    :mtx-sessions mtx-sessions
                    )]
+
     (-> #(handler cfg %)
         (wrap-session)
         (wrap-keyword-params)
@@ -135,7 +136,7 @@
         ws-send      (mtx/wrap-counter ws-send mtx-messages ["send"])]
 
     (letfn [(on-connect [conn]
-              (mtx-aconn :inc)
+              ((::mtx/fn mtx-aconn) {:cmd :inc :by 1})
               ;; A subscription channel should use a lossy buffer
               ;; because we can't penalize normal clients when one
               ;; slow client is connected to the room.
@@ -162,8 +163,8 @@
                   (a/<! (handle-connect cfg))
 
                   ;; when connection is closed
-                  (mtx-aconn :dec)
-                  (mtx-sessions :observe (/ (inst-ms (dt/diff created-at (dt/now))) 1000.0))
+                  ((::mtx/fn mtx-aconn) {:cmd :dec :by 1})
+                  ((::mtx/fn mtx-sessions) {:val (/ (inst-ms (dt/diff created-at (dt/now))) 1000.0)})
 
                   ;; close subscription
                   (a/close! sub-ch))))

backend/src/app/rpc.clj

@@ -8,12 +8,13 @@
   (:require
    [app.common.data :as d]
    [app.common.exceptions :as ex]
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.db :as db]
    [app.loggers.audit :as audit]
    [app.metrics :as mtx]
    [app.rlimits :as rlm]
-   [app.util.logging :as l]
+   [app.util.retry :as retry]
    [app.util.services :as sv]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
@@ -92,41 +93,44 @@
 (defn- wrap-impl
   [{:keys [audit] :as cfg} f mdata]
   (let [f      (wrap-with-rlimits cfg f mdata)
+        f      (retry/wrap-retry cfg f mdata)
         f      (wrap-with-metrics cfg f mdata)
         spec   (or (::sv/spec mdata) (s/spec any?))
         auth?  (:auth mdata true)]
 
     (l/trace :action "register" :name (::sv/name mdata))
-    (fn [params]
+    (with-meta
+      (fn [params]
+        ;; Raise authentication error when rpc method requires auth but
+        ;; no profile-id is found in the request.
+        (when (and auth? (not (uuid? (:profile-id params))))
+          (ex/raise :type :authentication
+                    :code :authentication-required
+                    :hint "authentication required for this endpoint"))
 
-      ;; Raise authentication error when rpc method requires auth but
-      ;; no profile-id is found in the request.
-      (when (and auth? (not (uuid? (:profile-id params))))
-        (ex/raise :type :authentication
-                  :code :authentication-required
-                  :hint "authentication required for this endpoint"))
+        (let [params' (dissoc params ::request)
+              params' (us/conform spec params')
+              result  (f cfg params')]
 
-      (let [params' (dissoc params ::request)
-            params' (us/conform spec params')
-            result  (f cfg params')]
+          ;; When audit log is enabled (default false).
+          (when (fn? audit)
+            (let [resultm    (meta result)
+                  request    (::request params)
+                  profile-id (or (:profile-id params')
+                                 (:profile-id result)
+                                 (::audit/profile-id resultm))
+                  props      (d/merge params' (::audit/props resultm))]
+              (audit :cmd :submit
+                     :type (or (::audit/type resultm)
+                               (::type cfg))
+                     :name (or (::audit/name resultm)
+                               (::sv/name mdata))
+                     :profile-id profile-id
+                     :ip-addr (audit/parse-client-ip request)
+                     :props props)))
 
-        ;; When audit log is enabled (default false).
-        (when (fn? audit)
-          (let [resultm    (meta result)
-                request    (::request params)
-                profile-id (or (:profile-id params')
-                               (:profile-id result)
-                               (::audit/profile-id resultm))
-                props      (d/merge params (::audit/props resultm))]
-            (audit :cmd :submit
-                   :type (::type cfg)
-                   :name (or (::audit/name resultm)
-                             (::sv/name mdata))
-                   :profile-id profile-id
-                   :ip-addr (audit/parse-client-ip request)
-                   :props (audit/profile->props props))))
-
-        result))))
+          result))
+      mdata)))
 
 (defn- process-method
   [cfg vfn]
@@ -148,10 +152,8 @@
                      'app.rpc.queries.teams
                      'app.rpc.queries.comments
                      'app.rpc.queries.profile
-                     'app.rpc.queries.recent-files
                      'app.rpc.queries.viewer
-                     'app.rpc.queries.fonts
-                     'app.rpc.queries.svg)
+                     'app.rpc.queries.fonts)
          (map (partial process-method cfg))
          (into {}))))
 
@@ -170,11 +172,11 @@
                      'app.rpc.mutations.files
                      'app.rpc.mutations.comments
                      'app.rpc.mutations.projects
-                     'app.rpc.mutations.viewer
                      'app.rpc.mutations.teams
                      'app.rpc.mutations.management
                      'app.rpc.mutations.ldap
                      'app.rpc.mutations.fonts
+                     'app.rpc.mutations.share-link
                      'app.rpc.mutations.verify-token)
          (map (partial process-method cfg))
          (into {}))))

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

@@ -12,6 +12,9 @@
    [app.rpc.queries.comments :as comments]
    [app.rpc.queries.files :as files]
    [app.util.blob :as blob]
+   #_:clj-kondo/ignore
+   [app.util.retry :as retry]
+
    [app.util.services :as sv]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]))
@@ -32,6 +35,9 @@
   (s/keys :req-un [::profile-id ::file-id ::position ::content ::page-id]))
 
 (sv/defmethod ::create-comment-thread
+  {::retry/enabled true
+   ::retry/max-retries 3
+   ::retry/matches retry/conflict-db-insert?}
   [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
   (db/with-atomic [conn pool]
     (files/check-read-permissions! conn profile-id file-id)
@@ -43,7 +49,7 @@
         res (db/exec-one! conn [sql file-id])]
     (:next-seqn res)))
 
-(defn- create-comment-thread*
+(defn- create-comment-thread
   [conn {:keys [profile-id file-id page-id position content] :as params}]
   (let [seqn    (retrieve-next-seqn conn file-id)
         now     (dt/now)
@@ -78,24 +84,6 @@
 
     (select-keys thread [:id :file-id :page-id])))
 
-(defn- create-comment-thread
-  [conn params]
-  (loop [sp (db/savepoint conn)
-         rc 0]
-    (let [res (ex/try (create-comment-thread* conn params))]
-      (cond
-        (and (instance? Throwable res)
-             (< rc 3))
-        (do
-          (db/rollback! conn sp)
-          (recur (db/savepoint conn)
-                 (inc rc)))
-
-        (instance? Throwable res)
-        (throw res)
-
-        :else res))))
-
 (defn- retrieve-page-name
   [conn {:keys [file-id page-id]}]
   (let [{:keys [data]} (db/get-by-id conn :file file-id)

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

@@ -9,11 +9,10 @@
   (:require
    [app.common.exceptions :as ex]
    [app.common.uuid :as uuid]
-   [app.config :as cfg]
+   [app.config :as cf]
    [app.db :as db]
    [app.loggers.audit :as audit]
    [app.rpc.mutations.profile :as profile]
-   [app.setup.initial-data :as sid]
    [app.util.services :as sv]
    [app.util.time :as dt]
    [buddy.core.codecs :as bc]
@@ -34,20 +33,19 @@
         params   {:id id
                   :email email
                   :fullname fullname
-                  :is-demo true
-                  :deleted-at (dt/in-future cfg/deletion-delay)
+                  :is-active true
+                  :deleted-at (dt/in-future cf/deletion-delay)
                   :password password
                   :props {:onboarding-viewed true}}]
 
-    (when-not (cfg/get :allow-demo-users)
+    (when-not (contains? cf/flags :demo-users)
       (ex/raise :type :validation
                 :code :demo-users-not-allowed
                 :hint "Demo users are disabled by config."))
 
     (db/with-atomic [conn pool]
       (->> (#'profile/create-profile conn params)
-           (#'profile/create-profile-relations conn)
-           (sid/load-initial-project! conn))
+           (#'profile/create-profile-relations conn))
 
       (with-meta {:email email
                   :password password}

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

@@ -12,6 +12,7 @@
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
    [app.db :as db]
+   [app.metrics :as mtx]
    [app.rpc.permissions :as perms]
    [app.rpc.queries.files :as files]
    [app.rpc.queries.projects :as proj]
@@ -291,7 +292,7 @@
     (simpl/del-object backend file)))
 
 (defn- update-file
-  [{:keys [conn] :as cfg} {:keys [file changes changes-with-metadata session-id profile-id] :as params}]
+  [{:keys [conn metrics] :as cfg} {:keys [file changes changes-with-metadata session-id profile-id] :as params}]
   (when (> (:revn params)
            (:revn file))
 
@@ -301,14 +302,22 @@
               :context {:incoming-revn (:revn params)
                         :stored-revn (:revn file)}))
 
-  (let [changes (if changes-with-metadata
+  (let [mtx1    (get-in metrics [:definitions :update-file-changes])
+        mtx2    (get-in metrics [:definitions :update-file-bytes-processed])
+
+        changes (if changes-with-metadata
                   (mapcat :changes changes-with-metadata)
                   changes)
 
+        ;; Trace the number of changes processed
+        _       ((::mtx/fn mtx1) {:by (count changes)})
+
         ts      (dt/now)
         file    (-> (files/retrieve-data cfg file)
                     (update :revn inc)
                     (update :data (fn [data]
+                                    ;; Trace the length of bytes of processed data
+                                    ((::mtx/fn mtx2) {:by (alength data)})
                                     (-> data
                                         (blob/decode)
                                         (assoc :id (:id file))

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

@@ -6,16 +6,15 @@
 
 (ns app.rpc.mutations.fonts
   (:require
+   [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
-   [app.config :as cf]
    [app.db :as db]
    [app.media :as media]
    [app.rpc.queries.teams :as teams]
    [app.storage :as sto]
    [app.util.services :as sv]
    [app.util.time :as dt]
-   [app.worker :as wrk]
    [clojure.spec.alpha :as s]))
 
 (declare create-font-variant)
@@ -49,6 +48,7 @@
   (let [data    (media/run cfg {:cmd :generate-fonts :input data :rlimit :font})
         storage (media/configure-assets-storage storage conn)
 
+
         otf     (when-let [fdata (get data "font/otf")]
                   (sto/put-object storage {:content (sto/content fdata)
                                            :content-type "font/otf"}))
@@ -65,6 +65,13 @@
                   (sto/put-object storage {:content (sto/content fdata)
                                            :content-type "font/woff2"}))]
 
+    (when (and (nil? otf)
+               (nil? ttf)
+               (nil? woff1)
+               (nil? woff2))
+      (ex/raise :type :validation
+                :code :invalid-font-upload))
+
     (db/insert! conn :team-font-variant
                 {:id (uuid/next)
                  :team-id (:team-id params)
@@ -120,13 +127,6 @@
   (db/with-atomic [conn pool]
     (teams/check-edition-permissions! conn profile-id team-id)
 
-    ;; Schedule object deletion
-    (wrk/submit! {::wrk/task :delete-object
-                  ::wrk/delay cf/deletion-delay
-                  ::wrk/conn conn
-                  :id id
-                  :type :team-font-variant})
-
     (db/update! conn :team-font-variant
                 {:deleted-at (dt/now)}
                 {:id id :team-id team-id})

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

@@ -7,6 +7,7 @@
 (ns app.rpc.mutations.ldap
   (:require
    [app.common.exceptions :as ex]
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.config :as cfg]
    [app.db :as db]
@@ -18,6 +19,14 @@
    [clojure.spec.alpha :as s]
    [clojure.string]))
 
+
+(s/def ::fullname ::us/not-empty-string)
+(s/def ::email ::us/email)
+(s/def ::backend ::us/not-empty-string)
+
+(s/def ::info-data
+  (s/keys :req-un [::fullname ::email ::backend]))
+
 (defn ^java.lang.AutoCloseable connect
   []
   (let [params {:ssl?      (cfg/get :ldap-ssl)
@@ -57,6 +66,13 @@
         (ex/raise :type :validation
                   :code :wrong-credentials))
 
+      (when-not (s/valid? ::info-data info)
+        (let [explain (s/explain-str ::info-data info)]
+          (l/warn ::l/raw (str "invalid response from ldap, looks like ldap is not configured correctly\n" explain))
+          (ex/raise :type :restriction
+                    :code :wrong-ldap-response
+                    :reason explain)))
+
       (let [profile (login-or-register cfg {:email (:email info)
                                             :backend (:backend info)
                                             :fullname (:fullname info)})]
@@ -94,7 +110,9 @@
                  (cfg/get :ldap-attrs-fullname)]
 
         base-dn (cfg/get :ldap-base-dn)
-        params  {:filter query :sizelimit 1 :attributes attrs}]
+        params  {:filter query
+                 :sizelimit 1
+                 :attributes attrs}]
     (first (ldap/search cpool base-dn params))))
 
 (defn- authenticate

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

@@ -39,11 +39,23 @@
   [file index]
   (letfn [(process-form [form]
             (cond-> form
-              ;; Relink Components
+              ;; Relink library items
               (and (map? form)
                    (uuid? (:component-file form)))
               (update :component-file #(get index % %))
 
+              (and (map? form)
+                   (uuid? (:fill-color-ref-file form)))
+              (update :fill-color-ref-file #(get index % %))
+
+              (and (map? form)
+                   (uuid? (:stroke-color-ref-file form)))
+              (update :stroke-color-ref-file #(get index % %))
+
+              (and (map? form)
+                   (uuid? (:typography-ref-file form)))
+              (update :typography-ref-file #(get index % %))
+
               ;; Relink Image Shapes
               (and (map? form)
                    (map? (:metadata form))

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

@@ -12,13 +12,12 @@
    [app.config :as cf]
    [app.db :as db]
    [app.emails :as eml]
-   [app.http.oauth :refer [extract-props]]
+   [app.http.oauth :refer [extract-utm-props]]
    [app.loggers.audit :as audit]
    [app.media :as media]
-   [app.rpc.mutations.projects :as projects]
+   [app.metrics :as mtx]
    [app.rpc.mutations.teams :as teams]
    [app.rpc.queries.profile :as profile]
-   [app.setup.initial-data :as sid]
    [app.storage :as sto]
    [app.util.services :as sv]
    [app.util.time :as dt]
@@ -99,10 +98,9 @@
 
 (sv/defmethod ::prepare-register-profile {:auth false}
   [{:keys [pool tokens] :as cfg} params]
-  (when-not (cf/get :registration-enabled)
+  (when-not (contains? cf/flags :registration)
     (ex/raise :type :restriction
               :code :registration-disabled))
-
   (when-let [domains (cf/get :registration-domain-whitelist)]
     (when-not (email-domain-in-whitelist? domains (:email params))
       (ex/raise :type :validation
@@ -126,43 +124,37 @@
 
 ;; --- MUTATION: Register Profile
 
-(s/def ::accept-terms-and-privacy ::us/boolean)
-(s/def ::accept-newsletter-subscription ::us/boolean)
 (s/def ::token ::us/not-empty-string)
-
 (s/def ::register-profile
-  (s/keys :req-un [::token ::fullname
-                   ::accept-terms-and-privacy]
-          :opt-un [::accept-newsletter-subscription]))
+  (s/keys :req-un [::token ::fullname]))
 
 (sv/defmethod ::register-profile {:auth false :rlimit :password}
   [{:keys [pool] :as cfg} params]
-  (when-not (:accept-terms-and-privacy params)
-    (ex/raise :type :validation
-              :code :invalid-terms-and-privacy))
-
   (db/with-atomic [conn pool]
-    (let [cfg     (assoc cfg :conn conn)]
-      (register-profile cfg params))))
+    (-> (assoc cfg :conn conn)
+        (register-profile params))))
 
 (defn- annotate-profile-register
   "A helper for properly increase the profile-register metric once the
   transaction is completed."
   [metrics]
   (fn []
-    ((get-in metrics [:definitions :profile-register]) :inc)))
+    (let [mobj (get-in metrics [:definitions :profile-register])]
+      ((::mtx/fn mobj) {:by 1}))))
 
 (defn register-profile
   [{:keys [conn tokens session metrics] :as cfg} {:keys [token] :as params}]
-  (let [claims (tokens :verify {:token token :iss :prepared-register})
-        params (merge params claims)]
-    (check-profile-existence! conn params)
-    (let [profile (->> params
-                       (create-profile conn)
-                       (create-profile-relations conn)
-                       (decode-profile-row))]
-      (sid/load-initial-project! conn profile)
+  (let [claims    (tokens :verify {:token token :iss :prepared-register})
+        params    (merge params claims)]
 
+    (check-profile-existence! conn params)
+
+    (let [is-active (or (:is-active params)
+                        (contains? cf/flags :insecure-register))
+          profile   (->> (assoc params :is-active is-active)
+                         (create-profile conn)
+                         (create-profile-relations conn)
+                         (decode-profile-row))]
       (cond
         ;; If invitation token comes in params, this is because the
         ;; user comes from team-invitation process; in this case,
@@ -192,6 +184,15 @@
            ::audit/props (audit/profile->props profile)
            ::audit/profile-id (:id profile)})
 
+        ;; If the `:enable-insecure-register` flag is set, we proceed
+        ;; to sign in the user directly, without email verification.
+        (true? is-active)
+        (with-meta (profile/strip-private-attrs profile)
+          {:transform-response ((:create session) (:id profile))
+           :before-complete (annotate-profile-register metrics)
+           ::audit/props (audit/profile->props profile)
+           ::audit/profile-id (:id profile)})
+
         ;; In all other cases, send a verification email.
         :else
         (let [vtoken (tokens :generate
@@ -202,7 +203,6 @@
               ptoken (tokens :generate-predefined
                              {:iss :profile-identity
                               :profile-id (:id profile)})]
-
           (eml/send! {::eml/conn conn
                       ::eml/factory eml/register
                       :public-uri (:public-uri cfg)
@@ -222,23 +222,22 @@
   [conn params]
   (let [id        (or (:id params) (uuid/next))
 
-        props     (-> (extract-props params)
+        props     (-> (extract-utm-props params)
                       (merge (:props params))
-                      (assoc :accept-terms-and-privacy (:accept-terms-and-privacy params true))
-                      (assoc :accept-newsletter-subscription (:accept-newsletter-subscription params false))
                       (db/tjson))
 
         password  (if-let [password (:password params)]
                     (derive-password password)
                     "!")
 
-        locale    (as-> (:locale params) locale
-                    (and (string? locale) (not (str/blank? locale)) locale))
+        locale    (:locale params)
+        locale    (when (and (string? locale) (not (str/blank? locale)))
+                    locale)
 
         backend   (:backend params "penpot")
         is-demo   (:is-demo params false)
         is-muted  (:is-muted params false)
-        is-active (:is-active params (or (not= "penpot" backend) is-demo))
+        is-active (:is-active params false)
         email     (str/lower (:email params))
 
         params    {:id id
@@ -263,28 +262,15 @@
                       :code :email-already-exists
                       :cause e)))))))
 
-
 (defn create-profile-relations
   [conn profile]
-  (let [team    (teams/create-team conn {:profile-id (:id profile)
-                                         :name "Default"
-                                         :is-default true})
-        project (projects/create-project conn {:profile-id (:id profile)
-                                               :team-id (:id team)
-                                               :name "Drafts"
-                                               :is-default true})
-        params  {:team-id (:id team)
-                 :profile-id (:id profile)
-                 :project-id (:id project)
-                 :role :owner}]
-
-    (teams/create-team-role conn params)
-    (projects/create-project-role conn params)
-
+  (let [team (teams/create-team conn {:profile-id (:id profile)
+                                      :name "Default"
+                                      :is-default true})]
     (-> profile
         (profile/strip-private-attrs)
         (assoc :default-team-id (:id team))
-        (assoc :default-project-id (:id project)))))
+        (assoc :default-project-id (:default-project-id team)))))
 
 ;; --- MUTATION: Login
 
@@ -357,11 +343,14 @@
 
 (defn- update-profile
   [conn {:keys [id fullname lang theme] :as params}]
-  (db/update! conn :profile
-              {:fullname fullname
-               :lang lang
-               :theme theme}
-              {:id id}))
+  (let [profile (db/update! conn :profile
+                            {:fullname fullname
+                             :lang lang
+                             :theme theme}
+                            {:id id})]
+    (-> profile
+        (profile/decode-profile-row)
+        (profile/strip-private-attrs))))
 
 (s/def ::update-profile
   (s/keys :req-un [::id ::fullname]
@@ -370,8 +359,9 @@
 (sv/defmethod ::update-profile
   [{:keys [pool] :as cfg} params]
   (db/with-atomic [conn pool]
-    (update-profile conn params)
-    nil))
+    (let [profile (update-profile conn params)]
+      (with-meta profile
+        {::audit/props (audit/profile->props profile)}))))
 
 ;; --- MUTATION: Update Password
 
@@ -456,7 +446,8 @@
           params  (assoc params
                          :profile profile
                          :email (str/lower email))]
-      (if (cf/get :smtp-enabled)
+      (if (or (cf/get :smtp-enabled)
+              (contains? cf/flags :smtp))
         (request-email-change cfg params)
         (change-email-inmediatelly cfg params)))))
 
@@ -589,11 +580,15 @@
   (db/with-atomic [conn pool]
     (let [profile (profile/retrieve-profile-data conn profile-id)
           props   (reduce-kv (fn [props k v]
-                               (if (nil? v)
-                                 (dissoc props k)
-                                 (assoc props k v)))
+                               ;; We don't accept namespaced keys
+                               (if (simple-ident? k)
+                                 (if (nil? v)
+                                   (dissoc props k)
+                                   (assoc props k v))
+                                 props))
                              (:props profile)
                              props)]
+
       (db/update! conn :profile
                   {:props (db/tjson props)}
                   {:id profile-id})

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

@@ -117,11 +117,15 @@
 (s/def ::delete-project
   (s/keys :req-un [::id ::profile-id]))
 
+;; TODO: right now, we just don't allow delete default projects, in a
+;; future we need to ensure raise a correct exception signaling that
+;; this is not allowed.
+
 (sv/defmethod ::delete-project
   [{:keys [pool] :as cfg} {:keys [id profile-id] :as params}]
   (db/with-atomic [conn pool]
     (proj/check-edition-permissions! conn profile-id id)
     (db/update! conn :project
                 {:deleted-at (dt/now)}
-                {:id id})
+                {:id id :is-default false})
     nil))

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

@@ -0,0 +1,72 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.rpc.mutations.share-link
+  "Share link related rpc mutation methods."
+  (:require
+   [app.common.spec :as us]
+   [app.common.uuid :as uuid]
+   [app.db :as db]
+   [app.rpc.queries.files :as files]
+   [app.util.services :as sv]
+   [clojure.spec.alpha :as s]))
+
+;; --- Helpers & Specs
+
+(s/def ::id ::us/uuid)
+(s/def ::profile-id ::us/uuid)
+(s/def ::file-id ::us/uuid)
+(s/def ::flags (s/every ::us/string :kind set?))
+(s/def ::pages (s/every ::us/uuid :kind set?))
+
+;; --- Mutation: Create Share Link
+
+(declare create-share-link)
+
+(s/def ::create-share-link
+  (s/keys :req-un [::profile-id ::file-id ::flags]
+          :opt-un [::pages]))
+
+(sv/defmethod ::create-share-link
+  "Creates a share-link object.
+
+  Share links are resources that allows external users access to
+  specific files with specific permissions (flags)."
+
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
+  (db/with-atomic [conn pool]
+    (files/check-edition-permissions! conn profile-id file-id)
+    (create-share-link conn params)))
+
+(defn create-share-link
+  [conn {:keys [profile-id file-id pages flags]}]
+  (let [pages (db/create-array conn "uuid" pages)
+        flags (->> (map name flags)
+                   (db/create-array conn "text"))
+        slink (db/insert! conn :share-link
+                          {:id (uuid/next)
+                           :file-id file-id
+                           :flags flags
+                           :pages pages
+                           :owner-id profile-id})]
+    (-> slink
+        (update :pages db/decode-pgarray #{})
+        (update :flags db/decode-pgarray #{}))))
+
+;; --- Mutation: Delete Share Link
+
+(declare delete-share-link)
+
+(s/def ::delete-share-link
+  (s/keys :req-un [::profile-id ::id]))
+
+(sv/defmethod ::delete-share-link
+  [{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
+  (db/with-atomic [conn pool]
+    (let [slink (db/get-by-id conn :share-link id)]
+      (files/check-edition-permissions! conn profile-id (:file-id slink))
+      (db/delete! conn :share-link {:id id})
+      nil)))

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

@@ -32,6 +32,7 @@
 ;; --- Mutation: Create Team
 
 (declare create-team)
+(declare create-team-entry)
 (declare create-team-role)
 (declare create-team-default-project)
 
@@ -42,15 +43,21 @@
 (sv/defmethod ::create-team
   [{:keys [pool] :as cfg} params]
   (db/with-atomic [conn pool]
-    (let [team   (create-team conn params)
-          params (assoc params
-                        :team-id (:id team)
-                        :role :owner)]
-      (create-team-role conn params)
-      (create-team-default-project conn params)
-      team)))
+    (create-team conn params)))
 
 (defn create-team
+  "This is a complete team creation process, it creates the team
+  object and all related objects (default role and default project)."
+  [conn params]
+  (let [team    (create-team-entry conn params)
+        params  (assoc params
+                       :team-id (:id team)
+                       :role :owner)
+        project (create-team-default-project conn params)]
+    (create-team-role conn params)
+    (assoc team :default-project-id (:id project))))
+
+(defn- create-team-entry
   [conn {:keys [id name is-default] :as params}]
   (let [id         (or id (uuid/next))
         is-default (if (boolean? is-default) is-default false)]
@@ -59,23 +66,24 @@
                  :name name
                  :is-default is-default})))
 
-(defn create-team-role
+(defn- create-team-role
   [conn {:keys [team-id profile-id role] :as params}]
   (let [params {:team-id team-id
                 :profile-id profile-id}]
     (->> (perms/assign-role-flags params role)
          (db/insert! conn :team-profile-rel))))
 
-(defn create-team-default-project
+(defn- create-team-default-project
   [conn {:keys [team-id profile-id] :as params}]
   (let [project {:id (uuid/next)
                  :team-id team-id
                  :name "Drafts"
-                 :is-default true}]
-    (projects/create-project conn project)
+                 :is-default true}
+        project (projects/create-project conn project)]
     (projects/create-project-role conn {:project-id (:id project)
                                         :profile-id profile-id
-                                        :role :owner})))
+                                        :role :owner})
+    project))
 
 ;; --- Mutation: Update Team
 
@@ -125,17 +133,21 @@
 (s/def ::delete-team
   (s/keys :req-un [::profile-id ::id]))
 
+;; TODO: right now just don't allow delete default team, in future it
+;; should raise a speific exception for signal that this acction is
+;; not allowed.
+
 (sv/defmethod ::delete-team
   [{:keys [pool] :as cfg} {:keys [id profile-id] :as params}]
   (db/with-atomic [conn pool]
-    (let [perms (teams/check-edition-permissions! conn profile-id id)]
-      (when-not (some :is-owner perms)
+    (let [perms (teams/get-permissions conn profile-id id)]
+      (when-not (:is-owner perms)
         (ex/raise :type :validation
                   :code :only-owner-can-delete-team))
 
       (db/update! conn :team
                   {:deleted-at (dt/now)}
-                  {:id id})
+                  {:id id :is-default false})
       nil)))
 
 
@@ -289,30 +301,20 @@
 
 ;; --- Mutation: Invite Member
 
+(declare create-team-invitation)
+
 (s/def ::email ::us/email)
 (s/def ::invite-team-member
   (s/keys :req-un [::profile-id ::team-id ::email ::role]))
 
 (sv/defmethod ::invite-team-member
-  [{:keys [pool tokens] :as cfg} {:keys [profile-id team-id email role] :as params}]
+  [{:keys [pool] :as cfg} {:keys [profile-id team-id email role] :as params}]
   (db/with-atomic [conn pool]
-    (let [perms    (teams/check-edition-permissions! conn profile-id team-id)
+    (let [perms    (teams/get-permissions conn profile-id team-id)
           profile  (db/get-by-id conn :profile profile-id)
-          member   (profile/retrieve-profile-data-by-email conn email)
-          team     (db/get-by-id conn :team team-id)
-          itoken   (tokens :generate
-                           {:iss :team-invitation
-                            :exp (dt/in-future "48h")
-                            :profile-id (:id profile)
-                            :role role
-                            :team-id team-id
-                            :member-email (:email member email)
-                            :member-id (:id member)})
-          ptoken   (tokens :generate-predefined
-                           {:iss :profile-identity
-                            :profile-id (:id profile)})]
+          team     (db/get-by-id conn :team team-id)]
 
-      (when-not (some :is-admin perms)
+      (when-not (:is-admin perms)
         (ex/raise :type :validation
                   :code :insufficient-permissions))
 
@@ -322,24 +324,71 @@
                   :code :profile-is-muted
                   :hint "looks like the profile has reported repeatedly as spam or has permanent bounces"))
 
-      (when (and member (not (eml/allow-send-emails? conn member)))
-        (ex/raise :type :validation
-                  :code :member-is-muted
-                  :hint "looks like the profile has reported repeatedly as spam or has permanent bounces"))
-
-      ;; Secondly check if the invited member email is part of the
-      ;; global spam/bounce report.
-      (when (eml/has-bounce-reports? conn email)
-        (ex/raise :type :validation
-                  :code :email-has-permanent-bounces
-                  :hint "looks like the email you invite has been repeatedly reported as spam or permanent bounce"))
-
-      (eml/send! {::eml/conn conn
-                  ::eml/factory eml/invite-to-team
-                  :public-uri (:public-uri cfg)
-                  :to email
-                  :invited-by (:fullname profile)
-                  :team (:name team)
-                  :token itoken
-                  :extra-data ptoken})
+      (create-team-invitation
+       (assoc cfg
+              :email email
+              :conn conn
+              :team team
+              :profile profile
+              :role role))
       nil)))
+
+(defn- create-team-invitation
+  [{:keys [conn tokens team profile role email] :as cfg}]
+  (let [member   (profile/retrieve-profile-data-by-email conn email)
+        itoken   (tokens :generate
+                         {:iss :team-invitation
+                          :exp (dt/in-future "48h")
+                          :profile-id (:id profile)
+                          :role role
+                          :team-id (:id team)
+                          :member-email (:email member email)
+                          :member-id (:id member)})
+        ptoken   (tokens :generate-predefined
+                         {:iss :profile-identity
+                          :profile-id (:id profile)})]
+
+    (when (and member (not (eml/allow-send-emails? conn member)))
+      (ex/raise :type :validation
+                :code :member-is-muted
+                :hint "looks like the profile has reported repeatedly as spam or has permanent bounces"))
+
+    ;; Secondly check if the invited member email is part of the
+    ;; global spam/bounce report.
+    (when (eml/has-bounce-reports? conn email)
+      (ex/raise :type :validation
+                :code :email-has-permanent-bounces
+                :hint "looks like the email you invite has been repeatedly reported as spam or permanent bounce"))
+
+    (eml/send! {::eml/conn conn
+                ::eml/factory eml/invite-to-team
+                :public-uri (:public-uri cfg)
+                :to email
+                :invited-by (:fullname profile)
+                :team (:name team)
+                :token itoken
+                :extra-data ptoken})))
+
+
+;; --- Mutation: Create Team & Invite Members
+
+(s/def ::emails ::us/set-of-emails)
+(s/def ::create-team-and-invite-members
+  (s/and ::create-team (s/keys :req-un [::emails ::role])))
+
+(sv/defmethod ::create-team-and-invite-members
+  [{:keys [pool] :as cfg} {:keys [profile-id emails role] :as params}]
+  (db/with-atomic [conn pool]
+    (let [team    (create-team conn params)
+          profile (db/get-by-id conn :profile profile-id)]
+
+      ;; Create invitations for all provided emails.
+      (doseq [email emails]
+        (create-team-invitation
+         (assoc cfg
+                :conn conn
+                :team team
+                :profile profile
+                :email email
+                :role role)))
+      team)))

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

@@ -9,6 +9,8 @@
    [app.common.exceptions :as ex]
    [app.common.spec :as us]
    [app.db :as db]
+   [app.loggers.audit :as audit]
+   [app.metrics :as mtx]
    [app.rpc.mutations.teams :as teams]
    [app.rpc.queries.profile :as profile]
    [app.util.services :as sv]
@@ -32,17 +34,23 @@
   (when (profile/retrieve-profile-data-by-email conn email)
     (ex/raise :type :validation
               :code :email-already-exists))
+
   (db/update! conn :profile
               {:email email}
               {:id profile-id})
-  claims)
+
+  (with-meta claims
+    {::audit/name "update-profile-email"
+     ::audit/props {:email email}
+     ::audit/profile-id profile-id}))
 
 (defn- annotate-profile-activation
   "A helper for properly increase the profile-activation metric once the
   transaction is completed."
   [metrics]
   (fn []
-    ((get-in metrics [:definitions :profile-activation]) :inc)))
+    (let [mobj (get-in metrics [:definitions :profile-activation])]
+      ((::mtx/fn mobj) {:by 1}))))
 
 (defmethod process-token :verify-email
   [{:keys [conn session metrics] :as cfg} _ {:keys [profile-id] :as claims}]
@@ -61,7 +69,10 @@
 
     (with-meta claims
       {:transform-response ((:create session) profile-id)
-       :before-complete (annotate-profile-activation metrics)})))
+       :before-complete (annotate-profile-activation metrics)
+       ::audit/name "verify-profile-email"
+       ::audit/props (audit/profile->props profile)
+       ::audit/profile-id (:id profile)})))
 
 (defmethod process-token :auth
   [{:keys [conn] :as cfg} _params {:keys [profile-id] :as claims}]
@@ -114,8 +125,7 @@
     ;; user is already logged in with some account.
     (and (uuid? profile-id)
          (uuid? member-id))
-    (do
-      (accept-invitation cfg claims)
+    (let [profile (accept-invitation cfg claims)]
       (if (= member-id profile-id)
         ;; If the current session is already matches the invited
         ;; member, then just return the token and leave the frontend
@@ -129,27 +139,44 @@
         ;; account.
         (with-meta
           (assoc claims :state :created)
-          {:transform-response ((:create session) member-id)})))
+          {:transform-response ((:create session) member-id)
+           ::audit/name "accept-team-invitation"
+           ::audit/props (merge
+                          (audit/profile->props profile)
+                          {:team-id (:team-id claims)
+                           :role (:role claims)})
+           ::audit/profile-id profile-id})))
 
     ;; This happens when member-id is not filled in the invitation but
     ;; the user already has an account (probably with other mail) and
     ;; is already logged-in.
     (and (uuid? profile-id)
          (nil? member-id))
-    (do
-      (accept-invitation cfg (assoc claims :member-id profile-id))
-      (assoc claims :state :created))
+    (let [profile (accept-invitation cfg (assoc claims :member-id profile-id))]
+      (with-meta
+        (assoc claims :state :created)
+        {::audit/name "accept-team-invitation"
+         ::audit/props (merge
+                        (audit/profile->props profile)
+                        {:team-id (:team-id claims)
+                         :role (:role claims)})
+         ::audit/profile-id profile-id}))
 
     ;; This happens when member-id is filled but the accessing user is
     ;; not logged-in. In this case we proceed to accept invitation and
     ;; leave the user logged-in.
     (and (nil? profile-id)
          (uuid? member-id))
-    (do
-      (accept-invitation cfg claims)
+    (let [profile (accept-invitation cfg claims)]
       (with-meta
         (assoc claims :state :created)
-        {:transform-response ((:create session) member-id)}))
+        {:transform-response ((:create session) member-id)
+         ::audit/name "accept-team-invitation"
+         ::audit/props (merge
+                        (audit/profile->props profile)
+                        {:team-id (:team-id claims)
+                         :role (:role claims)})
+         ::audit/profile-id member-id}))
 
     ;; In this case, we wait until frontend app redirect user to
     ;; registeration page, the user is correctly registered and the

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

@@ -1,49 +0,0 @@
-;; This Source Code Form is subject to the terms of the Mozilla Public
-;; License, v. 2.0. If a copy of the MPL was not distributed with this
-;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
-;;
-;; Copyright (c) UXBOX Labs SL
-
-(ns app.rpc.mutations.viewer
-  (:require
-   [app.common.spec :as us]
-   [app.db :as db]
-   [app.rpc.queries.files :as files]
-   [app.util.services :as sv]
-   [buddy.core.codecs :as bc]
-   [buddy.core.nonce :as bn]
-   [clojure.spec.alpha :as s]))
-
-(s/def ::profile-id ::us/uuid)
-(s/def ::file-id ::us/uuid)
-(s/def ::page-id ::us/uuid)
-
-(s/def ::create-file-share-token
-  (s/keys :req-un [::profile-id ::file-id ::page-id]))
-
-(sv/defmethod ::create-file-share-token
-  [{:keys [pool] :as cfg} {:keys [profile-id file-id page-id] :as params}]
-  (db/with-atomic [conn pool]
-    (files/check-edition-permissions! conn profile-id file-id)
-    (let [token (-> (bn/random-bytes 16)
-                    (bc/bytes->b64u)
-                    (bc/bytes->str))]
-      (db/insert! conn :file-share-token
-                  {:file-id file-id
-                   :page-id page-id
-                   :token token})
-      {:token token})))
-
-
-(s/def ::token ::us/not-empty-string)
-(s/def ::delete-file-share-token
-  (s/keys :req-un [::profile-id ::file-id ::token]))
-
-(sv/defmethod ::delete-file-share-token
-  [{:keys [pool] :as cfg} {:keys [profile-id file-id token]}]
-  (db/with-atomic [conn pool]
-    (files/check-edition-permissions! conn profile-id file-id)
-    (db/delete! conn :file-share-token
-                {:file-id file-id
-                 :token token})
-    nil))

backend/src/app/rpc/permissions.clj

@@ -37,28 +37,28 @@
            :is-admin false
            :can-edit false)))
 
-(defn make-edition-check-fn
-  "A simple factory for edition permission check functions."
+(defn make-edition-predicate-fn
+  "A simple factory for edition permission predicate functions."
   [qfn]
   (us/assert fn? qfn)
-  (fn [& args]
-    (let [rows (apply qfn args)]
-      (if (or (empty? rows)
-              (not (or (some :can-edit rows)
-                       (some :is-admin rows)
-                       (some :is-owner rows))))
-        (ex/raise :type :not-found
-                  :code :object-not-found
-                  :hint "not found")
-        rows))))
+  (fn check
+    ([perms] (:can-edit perms))
+    ([conn & args] (check (apply qfn conn args)))))
 
-(defn make-read-check-fn
-  "A simple factory for read permission check functions."
+(defn make-read-predicate-fn
+  "A simple factory for read permission predicate functions."
   [qfn]
   (us/assert fn? qfn)
+  (fn check
+    ([perms] (:can-read perms))
+    ([conn & args] (check (apply qfn conn args)))))
+
+(defn make-check-fn
+  "Helper that converts a predicate permission function to a check
+  function (function that raises an exception)."
+  [pred]
   (fn [& args]
-    (let [rows (apply qfn args)]
-      (if-not (seq rows)
-        (ex/raise :type :not-found
-                  :code :object-not-found)
-        rows))))
+    (when-not (apply pred args)
+      (ex/raise :type :not-found
+                :code :object-not-found
+                :hint "not found"))))

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

@@ -12,6 +12,7 @@
    [app.db :as db]
    [app.rpc.permissions :as perms]
    [app.rpc.queries.projects :as projects]
+   [app.rpc.queries.share-link :refer [retrieve-share-link]]
    [app.rpc.queries.teams :as teams]
    [app.storage.impl :as simpl]
    [app.util.blob :as blob]
@@ -59,19 +60,51 @@
     where f.id = ?
       and ppr.profile_id = ?")
 
-(defn- retrieve-file-permissions
+(defn retrieve-file-permissions
   [conn profile-id file-id]
-  (db/exec! conn [sql:file-permissions
-                  file-id profile-id
-                  file-id profile-id
-                  file-id profile-id]))
+  (when (and profile-id file-id)
+    (db/exec! conn [sql:file-permissions
+                    file-id profile-id
+                    file-id profile-id
+                    file-id profile-id])))
+
+(defn get-permissions
+  ([conn profile-id file-id]
+   (let [rows     (retrieve-file-permissions conn profile-id file-id)
+         is-owner (boolean (some :is-owner rows))
+         is-admin (boolean (some :is-admin rows))
+         can-edit (boolean (some :can-edit rows))]
+     (when (seq rows)
+       {:type :membership
+        :is-owner is-owner
+        :is-admin (or is-owner is-admin)
+        :can-edit (or is-owner is-admin can-edit)
+        :can-read true})))
+  ([conn profile-id file-id share-id]
+   (let [perms  (get-permissions conn profile-id file-id)
+         ldata  (retrieve-share-link conn file-id share-id)]
+
+     ;; NOTE: in a future when share-link becomes more powerfull and
+     ;; will allow us specify which parts of the app is availabel, we
+     ;; will probably need to tweak this function in order to expose
+     ;; this flags to the frontend.
+     (cond
+       (some? perms) perms
+       (some? ldata) {:type :share-link
+                      :can-read true
+                      :flags (:flags ldata)}))))
+
+(def has-edit-permissions?
+  (perms/make-edition-predicate-fn get-permissions))
+
+(def has-read-permissions?
+  (perms/make-read-predicate-fn get-permissions))
 
 (def check-edition-permissions!
-  (perms/make-edition-check-fn retrieve-file-permissions))
+  (perms/make-check-fn has-edit-permissions?))
 
 (def check-read-permissions!
-  (perms/make-read-check-fn retrieve-file-permissions))
-
+  (perms/make-check-fn has-read-permissions?))
 
 ;; --- Query: Files search
 
@@ -124,29 +157,6 @@
                     profile-id team-id
                     search-term])))
 
-
-;; --- Query: Files
-
-;; DEPRECATED: should be removed probably on 1.6.x
-
-(def ^:private sql:files
-  "select f.*
-     from file as f
-    where f.project_id = ?
-      and f.deleted_at is null
-    order by f.modified_at desc")
-
-(s/def ::project-id ::us/uuid)
-(s/def ::files
-  (s/keys :req-un [::profile-id ::project-id]))
-
-(sv/defmethod ::files
-  [{:keys [pool] :as cfg} {:keys [profile-id project-id] :as params}]
-  (with-open [conn (db/open pool)]
-    (projects/check-read-permissions! conn profile-id project-id)
-    (into [] decode-row-xf (db/exec! conn [sql:files project-id]))))
-
-
 ;; --- Query: Project Files
 
 (def ^:private sql:project-files
@@ -194,11 +204,15 @@
   (s/keys :req-un [::profile-id ::id]))
 
 (sv/defmethod ::file
+  "Retrieve a file by its ID. Only authenticated users."
   [{:keys [pool] :as cfg} {:keys [profile-id id] :as params}]
   (db/with-atomic [conn pool]
-    (let [cfg (assoc cfg :conn conn)]
-      (check-edition-permissions! conn profile-id id)
-      (retrieve-file cfg id))))
+    (let [cfg   (assoc cfg :conn conn)
+          perms (get-permissions conn profile-id id)]
+
+      (check-read-permissions! perms)
+      (some-> (retrieve-file cfg id)
+              (assoc :permissions perms)))))
 
 (s/def ::page
   (s/keys :req-un [::profile-id ::file-id]))
@@ -233,7 +247,8 @@
 (sv/defmethod ::page
   [{:keys [pool] :as cfg} {:keys [profile-id file-id strip-thumbnails]}]
   (db/with-atomic [conn pool]
-    (check-edition-permissions! conn profile-id file-id)
+    (check-read-permissions! conn profile-id file-id)
+
     (let [cfg     (assoc cfg :conn conn)
           file    (retrieve-file cfg file-id)
           page-id (get-in file [:data :pages 0])]
@@ -243,28 +258,6 @@
 
 ;; --- Query: Shared Library Files
 
-;; DEPRECATED: and will be removed on 1.6.x
-
-(def ^:private sql:shared-files
-  "select f.*
-     from file as f
-    inner join project as p on (p.id = f.project_id)
-    where f.is_shared = true
-      and f.deleted_at is null
-      and p.deleted_at is null
-      and p.team_id = ?
-    order by f.modified_at desc")
-
-(s/def ::shared-files
-  (s/keys :req-un [::profile-id ::team-id]))
-
-(sv/defmethod ::shared-files
-  [{:keys [pool] :as cfg} {:keys [team-id] :as params}]
-  (into [] decode-row-xf (db/exec! pool [sql:shared-files team-id])))
-
-
-;; --- Query: Shared Library Files
-
 (def ^:private sql:team-shared-files
   "select f.id,
           f.project_id,
@@ -329,7 +322,7 @@
   [{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
   (db/with-atomic [conn pool]
     (let [cfg (assoc cfg :conn conn)]
-      (check-edition-permissions! conn profile-id file-id)
+      (check-read-permissions! conn profile-id file-id)
       (retrieve-file-libraries cfg false file-id))))
 
 ;; --- QUERY: team-recent-files

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

@@ -70,6 +70,10 @@
   [conn profile]
   (merge profile (retrieve-additional-data conn (:id profile))))
 
+(defn- filter-profile-props
+  [props]
+  (into {} (filter (fn [[k _]] (simple-ident? k))) props))
+
 (defn decode-profile-row
   [{:keys [props] :as row}]
   (cond-> row
@@ -83,20 +87,21 @@
 
 (defn retrieve-profile
   [conn id]
-  (let [profile (some->> (retrieve-profile-data conn id)
-                         (strip-private-attrs)
-                         (populate-additional-data conn))]
-    (when (nil? profile)
-      (ex/raise :type :not-found
-                :hint "Object doest not exists."))
+  (let [profile (->> (retrieve-profile-data conn id)
+                     (strip-private-attrs)
+                     (populate-additional-data conn))]
+    (update profile :props filter-profile-props)))
 
-    profile))
+(def ^:private sql:profile-by-email
+  "select p.* from profile as p
+    where p.email = ?
+      and (p.deleted_at is null or
+           p.deleted_at > now())")
 
 (defn retrieve-profile-data-by-email
   [conn email]
-  (try
-    (db/get-by-params conn :profile {:email (str/lower email)})
-    (catch Exception _e)))
+  (ex/ignoring
+   (db/exec-one! conn [sql:profile-by-email (str/lower email)])))
 
 ;; --- Attrs Helpers
 

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

@@ -31,18 +31,31 @@
     where ppr.project_id = ?
       and ppr.profile_id = ?")
 
-(defn- retrieve-project-permissions
+(defn- get-permissions
   [conn profile-id project-id]
-  (db/exec! conn [sql:project-permissions
-                  project-id profile-id
-                  project-id profile-id]))
+  (let [rows     (db/exec! conn [sql:project-permissions
+                                 project-id profile-id
+                                 project-id profile-id])
+        is-owner (boolean (some :is-owner rows))
+        is-admin (boolean (some :is-admin rows))
+        can-edit (boolean (some :can-edit rows))]
+     (when (seq rows)
+       {:is-owner is-owner
+        :is-admin (or is-owner is-admin)
+        :can-edit (or is-owner is-admin can-edit)
+        :can-read true})))
+
+(def has-edit-permissions?
+  (perms/make-edition-predicate-fn get-permissions))
+
+(def has-read-permissions?
+  (perms/make-read-predicate-fn get-permissions))
 
 (def check-edition-permissions!
-  (perms/make-edition-check-fn retrieve-project-permissions))
+  (perms/make-check-fn has-edit-permissions?))
 
 (def check-read-permissions!
-  (perms/make-read-check-fn retrieve-project-permissions))
-
+  (perms/make-check-fn has-read-permissions?))
 
 ;; --- Query: Projects
 
@@ -66,12 +79,14 @@
             where f.project_id = p.id
               and deleted_at is null) as count
      from project as p
+    inner join team as t on (t.id = p.team_id)
      left join team_project_profile_rel as tpp
             on (tpp.project_id = p.id and
                 tpp.team_id = p.team_id and
                 tpp.profile_id = ?)
     where p.team_id = ?
       and p.deleted_at is null
+      and t.deleted_at is null
     order by p.modified_at desc")
 
 (defn retrieve-projects
@@ -95,26 +110,26 @@
 (def sql:all-projects
   "select p1.*, t.name as team_name, t.is_default as is_default_team
      from project as p1
-    inner join team as t
-            on t.id = p1.team_id
+    inner join team as t on (t.id = p1.team_id)
     where t.id in (select team_id
                      from team_profile_rel as tpr
                     where tpr.profile_id = ?
                       and (tpr.can_edit = true or
                            tpr.is_owner = true or
                            tpr.is_admin = true))
+      and t.deleted_at is null
       and p1.deleted_at is null
    union
    select p2.*, t.name as team_name, t.is_default as is_default_team
      from project as p2
-    inner join team as t
-              on t.id = p2.team_id
+    inner join team as t on (t.id = p2.team_id)
     where p2.id in (select project_id
                      from project_profile_rel as ppr
                     where ppr.profile_id = ?
                       and (ppr.can_edit = true or
                            ppr.is_owner = true or
                            ppr.is_admin = true))
+      and t.deleted_at is null
       and p2.deleted_at is null
     order by team_name, name;")
 

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

@@ -1,42 +0,0 @@
-;; This Source Code Form is subject to the terms of the Mozilla Public
-;; License, v. 2.0. If a copy of the MPL was not distributed with this
-;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
-;;
-;; Copyright (c) UXBOX Labs SL
-
-(ns app.rpc.queries.recent-files
-  (:require
-   [app.common.spec :as us]
-   [app.db :as db]
-   [app.rpc.queries.files :refer [decode-row-xf]]
-   [app.rpc.queries.teams :as teams]
-   [app.util.services :as sv]
-   [clojure.spec.alpha :as s]))
-
-;; DEPRECATED: should be removed on 1.6.x
-
-(def sql:recent-files
-  "with recent_files as (
-     select f.*, row_number() over w as row_num
-       from file as f
-       join project as p on (p.id = f.project_id)
-      where p.team_id = ?
-        and p.deleted_at is null
-        and f.deleted_at is null
-     window w as (partition by f.project_id order by f.modified_at desc)
-      order by f.modified_at desc
-   )
-   select * from recent_files where row_num <= 10;")
-
-(s/def ::team-id ::us/uuid)
-(s/def ::profile-id ::us/uuid)
-
-(s/def ::recent-files
-  (s/keys :req-un [::profile-id ::team-id]))
-
-(sv/defmethod ::recent-files
-  [{:keys [pool] :as cfg} {:keys [profile-id team-id]}]
-  (with-open [conn (db/open pool)]
-    (teams/check-read-permissions! conn profile-id team-id)
-    (let [files (db/exec! conn [sql:recent-files team-id])]
-      (into [] decode-row-xf files))))

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

@@ -0,0 +1,23 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.rpc.queries.share-link
+  (:require
+   [app.db :as db]))
+
+(defn decode-share-link-row
+  [row]
+  (-> row
+      (update :flags db/decode-pgarray #{})
+      (update :pages db/decode-pgarray #{})))
+
+(defn retrieve-share-link
+  [conn file-id share-id]
+  (some-> (db/get-by-params conn :share-link
+                            {:id share-id :file-id file-id}
+                            {:check-not-found false})
+          (decode-share-link-row)))
+

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

@@ -24,16 +24,29 @@
     where tpr.profile_id = ?
       and tpr.team_id = ?")
 
-(defn- retrieve-team-permissions
+(defn get-permissions
   [conn profile-id team-id]
-  (db/exec! conn [sql:team-permissions profile-id team-id]))
+  (let [rows     (db/exec! conn [sql:team-permissions profile-id team-id])
+        is-owner (boolean (some :is-owner rows))
+        is-admin (boolean (some :is-admin rows))
+        can-edit (boolean (some :can-edit rows))]
+     (when (seq rows)
+       {:is-owner is-owner
+        :is-admin (or is-owner is-admin)
+        :can-edit (or is-owner is-admin can-edit)
+        :can-read true})))
+
+(def has-edit-permissions?
+  (perms/make-edition-predicate-fn get-permissions))
+
+(def has-read-permissions?
+  (perms/make-read-predicate-fn get-permissions))
 
 (def check-edition-permissions!
-  (perms/make-edition-check-fn retrieve-team-permissions))
+  (perms/make-check-fn has-edit-permissions?))
 
 (def check-read-permissions!
-  (perms/make-read-check-fn retrieve-team-permissions))
-
+  (perms/make-check-fn has-read-permissions?))
 
 ;; --- Query: Teams
 
@@ -58,12 +71,26 @@
      join team as t on (t.id = tp.team_id)
     where t.deleted_at is null
       and tp.profile_id = ?
-    order by t.created_at asc")
+    order by tp.created_at asc")
+
+(defn process-permissions
+  [team]
+  (let [is-owner    (:is-owner team)
+        is-admin    (:is-admin team)
+        can-edit    (:can-edit team)
+        permissions {:type :membership
+                     :is-owner is-owner
+                     :is-admin (or is-owner is-admin)
+                     :can-edit (or is-owner is-admin can-edit)}]
+    (-> team
+        (dissoc :is-owner :is-admin :can-edit)
+        (assoc :permissions permissions))))
 
 (defn retrieve-teams
   [conn profile-id]
   (let [defaults (profile/retrieve-additional-data conn profile-id)]
-    (db/exec! conn [sql:teams (:default-team-id defaults) profile-id])))
+    (->> (db/exec! conn [sql:teams (:default-team-id defaults) profile-id])
+         (mapv process-permissions))))
 
 ;; --- Query: Team (by ID)
 
@@ -86,7 +113,7 @@
     (when-not result
       (ex/raise :type :not-found
                 :code :team-does-not-exist))
-    result))
+    (process-permissions result)))
 
 
 ;; --- Query: Team Members

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

@@ -10,77 +10,74 @@
    [app.common.spec :as us]
    [app.db :as db]
    [app.rpc.queries.files :as files]
+   [app.rpc.queries.share-link :as slnk]
    [app.rpc.queries.teams :as teams]
    [app.util.services :as sv]
    [clojure.spec.alpha :as s]))
 
-;; --- Query: Viewer Bundle (by Page ID)
-
-(declare check-shared-token!)
-(declare retrieve-shared-token)
-
-(def ^:private
-  sql:project
-  "select p.id, p.name, p.team_id
-     from project as p
-    where p.id = ?
-      and p.deleted_at is null")
+;; --- Query: View Only Bundle
 
 (defn- retrieve-project
   [conn id]
-  (db/exec-one! conn [sql:project id]))
+  (db/get-by-id conn :project id {:columns [:id :name :team-id]}))
+
+(defn- retrieve-bundle
+  [{:keys [conn] :as cfg} file-id]
+  (let [file    (files/retrieve-file cfg file-id)
+        project (retrieve-project conn (:project-id file))
+        libs    (files/retrieve-file-libraries cfg false file-id)
+        users   (teams/retrieve-users conn (:team-id project))
+
+        links   (->> (db/query conn :share-link {:file-id file-id})
+                     (mapv slnk/decode-share-link-row))
+
+        fonts   (db/query conn :team-font-variant
+                          {:team-id (:team-id project)
+                           :deleted-at nil})]
+    {:file file
+     :users users
+     :fonts fonts
+     :project project
+     :share-links links
+     :libraries libs}))
 
-(s/def ::id ::us/uuid)
 (s/def ::file-id ::us/uuid)
-(s/def ::page-id ::us/uuid)
-(s/def ::token ::us/string)
+(s/def ::profile-id ::us/uuid)
+(s/def ::share-id ::us/uuid)
 
-(s/def ::viewer-bundle
-  (s/keys :req-un [::file-id ::page-id]
-          :opt-un [::profile-id ::token]))
+(s/def ::view-only-bundle
+  (s/keys :req-un [::file-id] :opt-un [::profile-id ::share-id]))
 
-(sv/defmethod ::viewer-bundle {:auth false}
-  [{:keys [pool] :as cfg} {:keys [profile-id file-id page-id token] :as params}]
+(sv/defmethod ::view-only-bundle {:auth false}
+  [{:keys [pool] :as cfg} {:keys [profile-id file-id share-id] :as params}]
   (db/with-atomic [conn pool]
-    (let [cfg     (assoc cfg :conn conn)
-          file    (files/retrieve-file cfg file-id)
-          project (retrieve-project conn (:project-id file))
-          page    (get-in file [:data :pages-index page-id])
-          file    (merge (dissoc file :data)
-                         (select-keys (:data file) [:colors :media :typographies]))
-          libs    (files/retrieve-file-libraries cfg false file-id)
-          users   (teams/retrieve-users conn (:team-id project))
+    (let [cfg    (assoc cfg :conn conn)
+          slink  (slnk/retrieve-share-link conn file-id share-id)
+          perms  (files/get-permissions conn profile-id file-id share-id)
 
-          fonts   (db/query conn :team-font-variant
-                            {:team-id (:team-id project)
-                             :deleted-at nil})
+          bundle (some-> (retrieve-bundle cfg file-id)
+                         (assoc :permissions perms))]
 
-          bundle  {:file file
-                   :page page
-                   :users users
-                   :fonts fonts
-                   :project project
-                   :libraries libs}]
-
-      (if (string? token)
-        (do
-          (check-shared-token! conn file-id page-id token)
-          (assoc bundle :token token))
-        (let [stoken (retrieve-shared-token conn file-id page-id)]
-          (files/check-read-permissions! conn profile-id file-id)
-          (assoc bundle :token (:token stoken)))))))
-
-(defn check-shared-token!
-  [conn file-id page-id token]
-  (let [sql "select exists(select 1 from file_share_token where file_id=? and page_id=? and token=?) as exists"]
-    (when-not (:exists (db/exec-one! conn [sql file-id page-id token]))
-      (ex/raise :type :not-found
-                :code :object-not-found))))
-
-(defn retrieve-shared-token
-  [conn file-id page-id]
-  (let [sql "select * from file_share_token where file_id=? and page_id=?"]
-    (db/exec-one! conn [sql file-id page-id])))
+      ;; When we have neither profile nor share, we just return a not
+      ;; found response to the user.
+      (when (and (not profile-id)
+                 (not slink))
+        (ex/raise :type :not-found
+                  :code :object-not-found))
 
+      ;; When we have only profile, we need to check read permissiones
+      ;; on file.
+      (when (and profile-id (not slink))
+        (files/check-read-permissions! conn profile-id file-id))
 
+      (cond-> bundle
+        (some? slink)
+        (assoc :share slink)
 
+        (and (some? slink)
+             (not (contains? (:flags slink) "view-all-pages")))
+        (update-in [:file :data] (fn [data]
+                                   (let [allowed-pages (:pages slink)]
+                                     (-> data
+                                         (update :pages (fn [pages] (filterv #(contains? allowed-pages %) pages)))
+                                         (update :pages-index (fn [index] (select-keys index allowed-pages)))))))))))

backend/src/app/srepl.clj

@@ -7,9 +7,9 @@
 (ns app.srepl
   "Server Repl."
   (:require
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.srepl.main]
-   [app.util.logging :as l]
    [clojure.core.server :as ccs]
    [clojure.main :as cm]
    [clojure.spec.alpha :as s]

backend/src/app/storage.clj

@@ -9,6 +9,7 @@
   (:require
    [app.common.data :as d]
    [app.common.exceptions :as ex]
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
    [app.db :as db]
@@ -16,7 +17,6 @@
    [app.storage.fs :as sfs]
    [app.storage.impl :as impl]
    [app.storage.s3 :as ss3]
-   [app.util.logging :as l]
    [app.util.time :as dt]
    [app.worker :as wrk]
    [clojure.spec.alpha :as s]

backend/src/app/tasks/delete_object.clj

@@ -1,70 +0,0 @@
-;; This Source Code Form is subject to the terms of the Mozilla Public
-;; License, v. 2.0. If a copy of the MPL was not distributed with this
-;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
-;;
-;; Copyright (c) UXBOX Labs SL
-
-;; TODO: DEPRECATED
-;; Should be removed in the 1.8.x
-
-(ns app.tasks.delete-object
-  "Generic task for permanent deletion of objects."
-  (:require
-   [app.common.data :as d]
-   [app.common.spec :as us]
-   [app.db :as db]
-   [app.storage :as sto]
-   [app.util.logging :as l]
-   [clojure.spec.alpha :as s]
-   [integrant.core :as ig]))
-
-(declare handle-deletion)
-
-(defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::db/pool ::sto/storage]))
-
-(defmethod ig/init-key ::handler
-  [_ {:keys [pool] :as cfg}]
-  (fn [{:keys [props] :as task}]
-    (us/verify ::props props)
-    (db/with-atomic [conn pool]
-      (let [cfg (assoc cfg :conn conn)]
-        (handle-deletion cfg props)))))
-
-(s/def ::type ::us/keyword)
-(s/def ::id ::us/uuid)
-(s/def ::props (s/keys :req-un [::id ::type]))
-
-(defmulti handle-deletion
-  (fn [_ props] (:type props)))
-
-(defmethod handle-deletion :default
-  [_cfg {:keys [type]}]
-  (l/warn :hint "no handler found"
-          :type (d/name type)))
-
-(defmethod handle-deletion :file
-  [{:keys [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
-  [{:keys [conn]} {:keys [id] :as props}]
-  (let [sql "delete from project where id=? and deleted_at is not null"]
-    (db/exec-one! conn [sql id])))
-
-(defmethod handle-deletion :team
-  [{:keys [conn]} {:keys [id] :as props}]
-  (let [sql "delete from team where id=? and deleted_at is not null"]
-    (db/exec-one! conn [sql id])))
-
-(defmethod handle-deletion :team-font-variant
-  [{:keys [conn storage]} {:keys [id] :as props}]
-  (let [font    (db/get-by-id conn :team-font-variant id {:uncheked true})
-        storage (assoc storage :conn conn)]
-    (when (:deleted-at font)
-      (db/delete! conn :team-font-variant {:id id})
-      (some->> (:woff1-file-id font) (sto/del-object storage))
-      (some->> (:woff2-file-id font) (sto/del-object storage))
-      (some->> (:otf-file-id font)   (sto/del-object storage))
-      (some->> (:ttf-file-id font)   (sto/del-object storage)))))

backend/src/app/tasks/delete_profile.clj

@@ -1,79 +0,0 @@
-;; This Source Code Form is subject to the terms of the Mozilla Public
-;; License, v. 2.0. If a copy of the MPL was not distributed with this
-;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
-;;
-;; Copyright (c) UXBOX Labs SL
-
-(ns app.tasks.delete-profile
-  "Task for permanent deletion of profiles."
-  (:require
-   [app.common.spec :as us]
-   [app.db :as db]
-   [app.db.sql :as sql]
-   [app.util.logging :as l]
-   [clojure.spec.alpha :as s]
-   [integrant.core :as ig]))
-
-;; TODO: DEPRECATED
-;; Should be removed in the 1.8.x
-
-(declare delete-profile-data)
-
-;; --- INIT
-
-(defmethod ig/pre-init-spec ::handler [_]
-  (s/keys :req-un [::db/pool]))
-
-;; This task is responsible to permanently delete a profile with all
-;; the dependent data. As step (1) we delete all owned teams of the
-;; profile (that will cause to delete all underlying projects, files,
-;; file_media and mark to be deleted storage_object's used by team,
-;; profile and files previously deleted. Then, finally as step (2) we
-;; proceed to delete the profile row.
-;;
-;; The storage_objects marked as deleted will be deleted by the
-;; corresponding garbage collector task.
-
-(s/def ::profile-id ::us/uuid)
-(s/def ::props (s/keys :req-un [::profile-id]))
-
-(defmethod ig/init-key ::handler
-  [_ {:keys [pool] :as cfg}]
-  (fn [{:keys [props] :as task}]
-    (us/verify ::props props)
-    (db/with-atomic [conn pool]
-      (let [id      (:profile-id props)
-            profile (db/exec-one! conn (sql/select :profile {:id id} {:for-update true}))]
-        (if (or (:is-demo profile)
-                (:deleted-at profile))
-          (delete-profile-data conn id)
-          (l/warn :hint "profile does not match constraints for deletion"
-                  :profile-id id))))))
-
-;; --- IMPL
-
-(def ^:private sql:remove-owned-teams
-  "delete from team
-    where id in (
-      select tpr.team_id
-        from team_profile_rel as tpr
-       where tpr.is_owner is true
-         and tpr.profile_id = ?
-    )")
-
-(defn- delete-teams
-  [conn profile-id]
-  (db/exec-one! conn [sql:remove-owned-teams profile-id]))
-
-(defn delete-profile
-  [conn profile-id]
-  (db/delete! conn :profile {:id profile-id}))
-
-(defn- delete-profile-data
-  [conn profile-id]
-  (l/debug :action "delete profile"
-           :profile-id profile-id)
-  (delete-teams conn profile-id)
-  (delete-profile conn profile-id)
-  true)
-

backend/src/app/tasks/file_media_gc.clj

@@ -9,10 +9,10 @@
   objects from files. A file is ellegible to be garbage collected
   after some period of inactivity (the default threshold is 72h)."
   (:require
+   [app.common.logging :as l]
    [app.common.pages.migrations :as pmg]
    [app.db :as db]
    [app.util.blob :as blob]
-   [app.util.logging :as l]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]))

backend/src/app/tasks/file_offload.clj

@@ -7,11 +7,11 @@
 (ns app.tasks.file-offload
   "A maintenance task that offloads file data to an external storage (S3)."
   (:require
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.db :as db]
    [app.storage :as sto]
    [app.storage.impl :as simpl]
-   [app.util.logging :as l]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]))

backend/src/app/tasks/file_xlog_gc.clj

@@ -8,8 +8,8 @@
   "A maintenance task that performs a garbage collection of the file
   change (transaction) log."
   (:require
+   [app.common.logging :as l]
    [app.db :as db]
-   [app.util.logging :as l]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]))

backend/src/app/tasks/objects_gc.clj

@@ -8,11 +8,11 @@
   "A maintenance task that performs a general purpose garbage collection
   of deleted objects."
   (:require
+   [app.common.logging :as l]
    [app.config :as cf]
    [app.db :as db]
    [app.storage :as sto]
    [app.storage.impl :as simpl]
-   [app.util.logging :as l]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]

backend/src/app/tasks/tasks_gc.clj

@@ -8,8 +8,8 @@
   "A maintenance task that performs a cleanup of already executed tasks
   from the database table."
   (:require
+   [app.common.logging :as l]
    [app.db :as db]
-   [app.util.logging :as l]
    [app.util.time :as dt]
    [clojure.spec.alpha :as s]
    [integrant.core :as ig]))

backend/src/app/util/logging.clj

@@ -1,110 +0,0 @@
-;; This Source Code Form is subject to the terms of the Mozilla Public
-;; License, v. 2.0. If a copy of the MPL was not distributed with this
-;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
-;;
-;; Copyright (c) UXBOX Labs SL
-
-(ns app.util.logging
-  (:require
-   [clojure.pprint :refer [pprint]])
-  (:import
-   org.apache.logging.log4j.Level
-   org.apache.logging.log4j.LogManager
-   org.apache.logging.log4j.Logger
-   org.apache.logging.log4j.ThreadContext
-   org.apache.logging.log4j.message.MapMessage
-   org.apache.logging.log4j.spi.LoggerContext))
-
-(defn build-map-message
-  [m]
-  (let [message (MapMessage. (count m))]
-    (reduce-kv #(.with ^MapMessage %1 (name %2) %3) message m)))
-
-(defprotocol ILogger
-  (-enabled? [logger level])
-  (-write! [logger level throwable message]))
-
-(def logger-context
-  (LogManager/getContext false))
-
-(def logging-agent
-  (agent nil :error-mode :continue))
-
-(defn get-logger
-  [lname]
-  (.getLogger ^LoggerContext logger-context ^String lname))
-
-(defn get-level
-  [level]
-  (case level
-    :trace Level/TRACE
-    :debug Level/DEBUG
-    :info  Level/INFO
-    :warn  Level/WARN
-    :error Level/ERROR
-    :fatal Level/FATAL))
-
-(defn enabled?
-  [logger level]
-  (.isEnabled ^Logger logger ^Level level))
-
-(defn write-log!
-  [logger level e msg]
-  (if e
-    (.log ^Logger    logger
-          ^Level     level
-          ^Object    msg
-          ^Throwable e)
-    (.log ^Logger logger
-          ^Level  level
-          ^Object msg)))
-
-(defmacro log
-  [& {:keys [level cause ::logger ::async ::raw] :as props}]
-  (let [props      (dissoc props :level :cause ::logger ::async ::raw)
-        logger     (or logger (str *ns*))
-        logger-sym (gensym "log")
-        level-sym  (gensym "log")]
-    `(let [~logger-sym (get-logger ~logger)
-           ~level-sym  (get-level ~level)]
-       (if (enabled? ~logger-sym ~level-sym)
-         ~(if async
-            `(send-off logging-agent
-                       (fn [_#]
-                         (let [message# (or ~raw (build-map-message ~props))]
-                           (write-log! ~logger-sym ~level-sym ~cause message#))))
-            `(let [message# (or ~raw (build-map-message ~props))]
-               (write-log! ~logger-sym ~level-sym ~cause message#)))))))
-
-(defmacro info
-  [& params]
-  `(log :level :info ~@params))
-
-(defmacro error
-  [& params]
-  `(log :level :error ~@params))
-
-(defmacro warn
-  [& params]
-  `(log :level :warn ~@params))
-
-(defmacro debug
-  [& params]
-  `(log :level :debug ~@params))
-
-(defmacro trace
-  [& params]
-  `(log :level :trace ~@params))
-
-(defn update-thread-context!
-  [data]
-  (run! (fn [[key val]]
-          (ThreadContext/put
-           (name key)
-           (cond
-             (coll? val)
-             (binding [clojure.pprint/*print-right-margin* 120]
-               (with-out-str (pprint val)))
-             (instance? clojure.lang.Named val) (name val)
-             :else (str val))))
-        data))

backend/src/app/util/migrations.clj

@@ -6,7 +6,7 @@
 
 (ns app.util.migrations
   (:require
-   [app.util.logging :as l]
+   [app.common.logging :as l]
    [clojure.java.io :as io]
    [clojure.spec.alpha :as s]
    [next.jdbc :as jdbc]))

backend/src/app/util/retry.clj

@@ -0,0 +1,43 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.util.retry
+  "A fault tolerance helpers. Allow retry some operations that we know
+  we can retry."
+  (:require
+   [app.common.exceptions :as ex]
+   [app.common.logging :as l]
+   [app.util.async :as aa]
+   [app.util.services :as sv]))
+
+(defn conflict-db-insert?
+  "Check if exception matches a insertion conflict on postgresql."
+  [e]
+  (and (instance? org.postgresql.util.PSQLException e)
+       (= "23505" (.getSQLState e))))
+
+(defn wrap-retry
+  [_ f {:keys [::max-retries ::matches ::sv/name]
+        :or {max-retries 3
+             matches (constantly false)}
+        :as mdata}]
+  (when (::enabled mdata)
+    (l/debug :hint "wrapping retry" :name name))
+  (if (::enabled mdata)
+    (fn [cfg params]
+      (loop [retry 1]
+        (when (> retry 1)
+          (l/debug :hint "retrying controlled function" :retry retry :name name))
+        (let [res (ex/try (f cfg params))]
+          (if (ex/exception? res)
+            (if (and (matches res) (< retry max-retries))
+              (do
+                (aa/thread-sleep (* 100 retry))
+                (recur (inc retry)))
+              (throw res))
+            res))))
+    f))
+

backend/src/app/util/services.clj

@@ -7,21 +7,34 @@
 (ns app.util.services
   "A helpers and macros for define rpc like registry based services."
   (:refer-clojure :exclude [defmethod])
-  (:require [app.common.data :as d]))
+  (:require
+   [app.common.data :as d]
+   [cuerdas.core :as str]))
 
 (defmacro defmethod
   [sname & body]
-  (let [[mdata args body] (if (map? (first body))
-                            [(first body) (first (rest body)) (drop 2 body)]
-                            [nil (first body) (rest body)])
-        mdata (assoc mdata
-                     ::spec sname
-                     ::name (name sname))
+  (let [[docs body]  (if (string? (first body))
+                       [(first body) (rest body)]
+                       [nil body])
+        [mdata body] (if (map? (first body))
+                       [(first body) (rest body)]
+                       [nil body])
 
-        sym   (symbol (str "sm$" (name sname)))]
-    `(do
-       (def ~sym (fn ~args ~@body))
-       (reset-meta! (var ~sym) ~mdata))))
+        [args body]  (if (vector? (first body))
+                       [(first body) (rest body)]
+                       [nil body])]
+    (when-not args
+      (throw (IllegalArgumentException. "Missing arguments on `defmethod` macro.")))
+
+    (let [mdata (assoc mdata
+                       ::docs (some-> docs str/<<-)
+                       ::spec sname
+                       ::name (name sname))
+
+          sym   (symbol (str "sm$" (name sname)))]
+      `(do
+         (def ~sym (fn ~args ~@body))
+         (reset-meta! (var ~sym) ~mdata)))))
 
 (def nsym-xf
   (comp

backend/src/app/util/svg.clj

@@ -4,13 +4,10 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.rpc.queries.svg
+(ns app.util.svg
   (:require
    [app.common.exceptions :as ex]
-   [app.common.spec :as us]
-   [app.util.logging :as l]
-   [app.util.services :as sv]
-   [clojure.spec.alpha :as s]
+   [app.common.logging :as l]
    [clojure.xml :as xml]
    [cuerdas.core :as str])
   (:import
@@ -39,14 +36,6 @@
                 :hint "invalid svg file"
                 :cause e))))
 
-(declare pre-process)
-
-(s/def ::data ::us/string)
-(s/def ::parsed-svg (s/keys :req-un [::data]))
-
-(sv/defmethod ::parsed-svg
-  [_ {:keys [data] :as params}]
-  (->> data pre-process parse))
 
 ;; --- PROCESSORS
 

backend/src/app/worker.clj

@@ -9,12 +9,12 @@
   (:require
    [app.common.data :as d]
    [app.common.exceptions :as ex]
+   [app.common.logging :as l]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
    [app.db :as db]
    [app.metrics :as mtx]
    [app.util.async :as aa]
-   [app.util.logging :as l]
    [app.util.time :as dt]
    [clojure.core.async :as a]
    [clojure.spec.alpha :as s]

backend/test/app/services_files_test.clj

@@ -53,21 +53,6 @@
           (t/is (= (:id data) (:id result)))
           (t/is (= (:name data) (:name result))))))
 
-    (t/testing "query files (deprecated)"
-      (let [data {::th/type :files
-                  :project-id proj-id
-                  :profile-id (:id prof)}
-            out  (th/query! data)]
-
-        ;; (th/print-result! out)
-        (t/is (nil? (:error out)))
-
-        (let [result (:result out)]
-          (t/is (= 1 (count result)))
-          (t/is (= file-id (get-in result [0 :id])))
-          (t/is (= "new name" (get-in result [0 :name])))
-          (t/is (= 1 (count (get-in result [0 :data :pages])))))))
-
     (t/testing "query files"
       (let [data {::th/type :project-files
                   :project-id proj-id
@@ -120,7 +105,7 @@
           (t/is (= (:type error-data) :not-found)))))
 
     (t/testing "query list files after delete"
-      (let [data {::th/type :files
+      (let [data {::th/type :project-files
                   :project-id proj-id
                   :profile-id (:id prof)}
             out  (th/query! data)]

backend/test/app/services_profile_test.clj

@@ -89,7 +89,7 @@
 
         ;; (th/print-result! out)
         (t/is (nil? (:error out)))
-        (t/is (nil? (:result out)))))
+        (t/is (map? (:result out)))))
 
     (t/testing "query profile after update"
       (let [data {::th/type :profile
@@ -136,7 +136,7 @@
       (t/is (nil? (:error out))))
 
     ;; query files after profile soft deletion
-    (let [params {::th/type :files
+    (let [params {::th/type :project-files
                   :project-id (:default-project-id prof)
                   :profile-id (:id prof)}
           out    (th/query! params)]
@@ -177,17 +177,6 @@
     (t/is (string? token))
 
 
-    ;; try register without accepting terms
-    (let [data  {::th/type :register-profile
-                 :token token
-                 :fullname "foobar"
-                 :accept-terms-and-privacy false}
-          out   (th/mutation! data)]
-      (let [error (:error out)]
-        (t/is (th/ex-info? error))
-        (t/is (th/ex-of-type? error :validation))
-        (t/is (th/ex-of-code? error :invalid-terms-and-privacy))))
-
     ;; try register without token
     (let [data  {::th/type :register-profile
                  :fullname "foobar"
@@ -205,16 +194,11 @@
                  :accept-terms-and-privacy true
                  :accept-newsletter-subscription true}]
       (let [{:keys [result error]} (th/mutation! data)]
-        (t/is (nil? error))
-        (t/is (true? (get-in result [:props :accept-newsletter-subscription])))
-        (t/is (true? (get-in result [:props :accept-terms-and-privacy])))))
+        (t/is (nil? error))))
     ))
 
 (t/deftest prepare-register-with-registration-disabled
-  (with-mocks [mock {:target 'app.config/get
-                     :return (th/mock-config-get-with
-                              {:registration-enabled false})}]
-
+  (th/with-mocks {#'app.config/flags nil}
     (let [data  {::th/type :prepare-register-profile
                  :email "user@example.com"
                  :password "foobar"}]

backend/test/app/services_projects_test.clj

@@ -43,7 +43,7 @@
 
       (t/is (nil? (:error out)))
       (let [result (:result out)]
-        (t/is (= 1 (count result)))
+        (t/is (= 2 (count result)))
         (t/is project-id (get-in result [0 :id]))
         (t/is (= "test project" (get-in result [0 :name])))))
 
@@ -55,15 +55,15 @@
 
       (t/is (nil? (:error out)))
       (let [result (:result out)]
-        (t/is (= 2 (count result)))
+        (t/is (= 3 (count result)))
         (t/is (not= project-id (get-in result [0 :id])))
         (t/is (= "Drafts" (get-in result [0 :name])))
         (t/is (= "Default" (get-in result [0 :team-name])))
         (t/is (= true (get-in result [0 :is-default-team])))
-        (t/is project-id (get-in result [1 :id]))
-        (t/is (= "test project" (get-in result [1 :name])))
-        (t/is (= "team1" (get-in result [1 :team-name])))
-        (t/is (= false (get-in result [1 :is-default-team])))))
+        (t/is project-id (get-in result [2 :id]))
+        (t/is (= "test project" (get-in result [2 :name])))
+        (t/is (= "team1" (get-in result [2 :team-name])))
+        (t/is (= false (get-in result [2 :is-default-team])))))
 
     ;; rename project
     (let [data {::th/type :rename-project
@@ -95,7 +95,7 @@
       (t/is (nil? (:error out)))
       (t/is (nil? (:result out))))
 
-    ;; query a list of projects after delete"
+    ;; query a list of projects after delete
     (let [data {::th/type :projects
                 :team-id (:id team)
                 :profile-id (:id profile)}
@@ -103,7 +103,7 @@
       ;; (th/print-result! out)
       (t/is (nil? (:error out)))
       (let [result (:result out)]
-        (t/is (= 0 (count result)))))
+        (t/is (= 1 (count result)))))
   ))
 
 (t/deftest permissions-checks-create-project

backend/test/app/services_teams_test.clj

@@ -33,11 +33,13 @@
                     :role :editor
                     :profile-id (:id profile1)}]
 
-      ;; (th/print-result! out)
 
       ;; invite external user without complaints
       (let [data (assoc data :email "foo@bar.com")
             out  (th/mutation! data)]
+
+        ;; (th/print-result! out)
+
         (t/is (nil? (:result out)))
         (t/is (= 1 (:call-count (deref mock)))))
 
@@ -111,6 +113,7 @@
                   :id (:id team)
                   :profile-id (:id profile1)}
           out    (th/mutation! params)]
+      ;; (th/print-result! out)
       (t/is (nil? (:error out))))
 
     ;; query the list of teams after soft deletion
@@ -127,13 +130,12 @@
     (let [result (task {:max-age (dt/duration {:minutes 1})})]
       (t/is (nil? result)))
 
-    ;; query the list of projects of a after hard deletion
+    ;; query the list of projects after hard deletion
     (let [data {::th/type :projects
                 :team-id (:id team)
                 :profile-id (:id profile1)}
           out  (th/query! data)]
       ;; (th/print-result! out)
-
       (t/is (nil? (:error out)))
       (let [result (:result out)]
         (t/is (= 0 (count result)))))

backend/test/app/services_viewer_test.clj

@@ -16,18 +16,18 @@
 (t/use-fixtures :each th/database-reset)
 
 (t/deftest retrieve-bundle
-  (let [prof    (th/create-profile* 1 {:is-active true})
-        prof2   (th/create-profile* 2 {:is-active true})
-        team-id (:default-team-id prof)
-        proj-id (:default-project-id prof)
+  (let [prof     (th/create-profile* 1 {:is-active true})
+        prof2    (th/create-profile* 2 {:is-active true})
+        team-id  (:default-team-id prof)
+        proj-id  (:default-project-id prof)
 
-        file    (th/create-file* 1 {:profile-id (:id prof)
-                                    :project-id proj-id
-                                    :is-shared false})
-        token   (atom nil)]
+        file     (th/create-file* 1 {:profile-id (:id prof)
+                                     :project-id proj-id
+                                     :is-shared false})
+        share-id (atom nil)]
 
     (t/testing "authenticated with page-id"
-      (let [data {::th/type :viewer-bundle
+      (let [data {::th/type :view-only-bundle
                   :profile-id (:id prof)
                   :file-id (:id file)
                   :page-id (get-in file [:data :pages 0])}
@@ -38,64 +38,67 @@
         (t/is (nil? (:error out)))
 
         (let [result (:result out)]
-          (t/is (contains? result :token))
-          (t/is (contains? result :page))
+          (t/is (contains? result :share-links))
+          (t/is (contains? result :permissions))
+          (t/is (contains? result :libraries))
           (t/is (contains? result :file))
           (t/is (contains? result :project)))))
 
     (t/testing "generate share token"
-      (let [data {::th/type :create-file-share-token
+      (let [data {::th/type :create-share-link
                   :profile-id (:id prof)
                   :file-id (:id file)
-                  :page-id (get-in file [:data :pages 0])}
+                  :pages #{(get-in file [:data :pages 0])}
+                  :flags #{}}
             out  (th/mutation! data)]
 
         ;; (th/print-result! out)
         (t/is (nil? (:error out)))
         (let [result (:result out)]
-          (t/is (string? (:token result)))
-          (reset! token (:token result)))))
+          (t/is (uuid? (:id result)))
+          (reset! share-id (:id result)))))
 
     (t/testing "not authenticated with page-id"
-      (let [data {::th/type :viewer-bundle
+      (let [data {::th/type :view-only-bundle
                   :profile-id (:id prof2)
                   :file-id (:id file)
                   :page-id (get-in file [:data :pages 0])}
             out  (th/query! data)]
 
         ;; (th/print-result! out)
-        (let [error (:error out)
+        (let [error      (:error out)
               error-data (ex-data error)]
           (t/is (th/ex-info? error))
           (t/is (= (:type error-data) :not-found))
           (t/is (= (:code error-data) :object-not-found)))))
 
-    ;; (t/testing "authenticated with token & profile"
-    ;;   (let [data {::sq/type :viewer-bundle
-    ;;               :profile-id (:id prof2)
-    ;;               :token @token
-    ;;               :file-id (:id file)
-    ;;               :page-id (get-in file [:data :pages 0])}
-    ;;         out  (th/try-on! (sq/handle data))]
+    (t/testing "authenticated with token & profile"
+      (let [data {::th/type :view-only-bundle
+                  :profile-id (:id prof2)
+                  :share-id @share-id
+                  :file-id (:id file)
+                  :page-id (get-in file [:data :pages 0])}
+            out  (th/query! data)]
 
-    ;;     ;; (th/print-result! out)
+        ;; (th/print-result! out)
+        (t/is (nil? (:error out)))
 
-    ;;     (let [result (:result out)]
-    ;;       (t/is (contains? result :page))
-    ;;       (t/is (contains? result :file))
-    ;;       (t/is (contains? result :project)))))
+        (let [result (:result out)]
+          (t/is (contains? result :share))
+          (t/is (contains? result :file))
+          (t/is (contains? result :project)))))
 
-    ;; (t/testing "authenticated with token"
-    ;;   (let [data {::sq/type :viewer-bundle
-    ;;               :token @token
-    ;;               :file-id (:id file)
-    ;;               :page-id (get-in file [:data :pages 0])}
-    ;;         out  (th/try-on! (sq/handle data))]
+    (t/testing "authenticated with token"
+      (let [data {::th/type :view-only-bundle
+                  :share-id @share-id
+                  :file-id (:id file)
+                  :page-id (get-in file [:data :pages 0])}
+            out  (th/query! data)]
 
-    ;;     ;; (th/print-result! out)
+        ;; (th/print-result! out)
+        (let [result (:result out)]
+          (t/is (contains? result :file))
+          (t/is (contains? result :share))
+          (t/is (contains? result :project)))))
 
-    ;;     (let [result (:result out)]
-    ;;       (t/is (contains? result :page))
-    ;;       (t/is (contains? result :file))
-    ;;       (t/is (contains? result :project)))))
     ))

backend/test/app/test_helpers.clj

@@ -7,6 +7,7 @@
 (ns app.test-helpers
   (:require
    [app.common.data :as d]
+   [app.common.flags :as flags]
    [app.common.pages :as cp]
    [app.common.spec :as us]
    [app.common.uuid :as uuid]
@@ -125,7 +126,8 @@
                         :password "123123"
                         :is-demo false}
                        params)]
-     (->> (#'profile/create-profile conn params)
+     (->> params
+          (#'profile/create-profile conn)
           (#'profile/create-profile-relations conn)))))
 
 (defn create-project*
@@ -158,15 +160,10 @@
   ([i params] (create-team* *pool* i params))
   ([conn i {:keys [profile-id] :as params}]
    (us/assert uuid? profile-id)
-   (let [id   (mk-uuid "team" i)
-         team (#'teams/create-team conn {:id id
-                                         :profile-id profile-id
-                                         :name (str "team" i)})]
-     (#'teams/create-team-role conn
-                               {:team-id id
-                                :profile-id profile-id
-                                :role :owner})
-     team)))
+   (let [id   (mk-uuid "team" i)]
+     (teams/create-team conn {:id id
+                              :profile-id profile-id
+                              :name (str "team" i)}))))
 
 (defn create-file-media-object*
   ([params] (create-file-media-object* *pool* params))
@@ -228,9 +225,12 @@
   ([params] (update-file* *pool* params))
   ([conn {:keys [file-id changes session-id profile-id revn]
           :or {session-id (uuid/next) revn 0}}]
-   (let [file   (db/get-by-id conn :file file-id)
-         msgbus (:app.msgbus/msgbus *system*)]
-     (#'files/update-file {:conn conn :msgbus msgbus}
+   (let [file    (db/get-by-id conn :file file-id)
+         msgbus  (:app.msgbus/msgbus *system*)
+         metrics (:app.metrics/metrics *system*)]
+     (#'files/update-file {:conn conn
+                           :msgbus msgbus
+                           :metrics metrics}
                           {:file file
                            :revn revn
                            :changes changes
@@ -333,10 +333,24 @@
   [data]
   (fn
     ([key]
-     (get data key (get @cf/config key)))
+     (get data key (get cf/config key)))
     ([key default]
-     (get data key (get @cf/config key default)))))
+     (get data key (get cf/config key default)))))
+
+
+(defmacro with-mocks
+  [rebinds & body]
+  `(with-redefs-fn ~rebinds
+     (fn [] ~@body)))
 
 (defn reset-mock!
   [m]
   (reset! m @(mk/make-mock {})))
+
+(defn pause
+  []
+  (let [^java.io.Console cnsl (System/console)]
+    (println "[waiting RETURN]")
+    (.readLine cnsl)
+    nil))
+

common/src/app/common/data.cljc

@@ -69,6 +69,11 @@
              (next colls))
       (persistent! result))))
 
+(defn preconj
+  [coll elem]
+  (assert (vector? coll))
+  (concat [elem] coll))
+
 (defn enumerate
   ([items] (enumerate items 0))
   ([items start]
@@ -154,6 +159,11 @@
   ([mfn coll]
    (into {} (mapm mfn) coll)))
 
+(defn removev
+  "Returns a vector of the items in coll for which (fn item) returns logical false"
+  [fn coll]
+  (filterv (comp not fn) coll))
+
 (defn filterm
   "Filter values of a map that satisfy a predicate"
   [pred coll]

common/src/app/common/exceptions.cljc

@@ -27,7 +27,10 @@
   [& {:keys [message hint cause] :as params}]
   (s/assert ::error-params params)
   (let [message (or message hint "")
-        payload (dissoc params :cause)]
+        payload (-> params
+                    (dissoc :cause)
+                    (dissoc :message)
+                    (assoc :hint message))]
     (ex-info message payload cause)))
 
 (defmacro raise

common/src/app/common/file_builder.cljc

@@ -278,6 +278,48 @@
     (-> file
         (update :parent-stack pop))))
 
+(defn add-bool [file data]
+  (let [frame-id (:current-frame-id file)
+        name (:name data)
+        obj (-> {:id (uuid/next)
+                 :type :bool
+                 :name name
+                 :shapes []
+                 :frame-id frame-id}
+                (merge data)
+                (check-name file :bool)
+                (d/without-nils))]
+    (-> file
+        (commit-shape obj)
+        (assoc :last-id (:id obj))
+        (add-name (:name obj))
+        (update :parent-stack conjv (:id obj)))))
+
+(defn close-bool [file]
+  (let [bool-id (-> file :parent-stack peek)
+        bool    (lookup-shape file bool-id)
+        children (->> bool :shapes (mapv #(lookup-shape file %)))
+
+        file
+        (let [objects (lookup-objects file)
+              bool' (gsh/update-bool-selrect bool children objects)]
+          (commit-change
+           file
+           {:type :mod-obj
+            :id bool-id
+            :operations
+            [{:type :set :attr :selrect :val (:selrect bool')}
+             {:type :set :attr :points  :val (:points bool')}
+             {:type :set :attr :x       :val (-> bool' :selrect :x)}
+             {:type :set :attr :y       :val (-> bool' :selrect :y)}
+             {:type :set :attr :width   :val (-> bool' :selrect :width)}
+             {:type :set :attr :height  :val (-> bool' :selrect :height)}]}
+
+           {:add-container? true}))]
+
+    (-> file
+        (update :parent-stack pop))))
+
 (defn create-shape [file type data]
   (let [frame-id (:current-frame-id file)
         frame (when-not (= frame-id root-frame)
@@ -332,21 +374,79 @@
   (-> file
       (update :parent-stack pop)))
 
+(defn- read-classifier
+  [interaction-src]
+  (select-keys interaction-src [:event-type :action-type]))
+
+(defmulti read-event-opts :event-type)
+
+(defmethod read-event-opts :after-delay
+  [interaction-src]
+  (select-keys interaction-src [:delay]))
+
+(defmethod read-event-opts :default
+  [_]
+  {})
+
+(defmulti read-action-opts :action-type)
+
+(defmethod read-action-opts :navigate
+  [interaction-src]
+  (select-keys interaction-src [:destination
+                                :preserve-scroll]))
+
+(defmethod read-action-opts :open-overlay
+  [interaction-src]
+  (select-keys interaction-src [:destination
+                                :overlay-position
+                                :overlay-pos-type
+                                :close-click-outside
+                                :background-overlay]))
+
+(defmethod read-action-opts :toggle-overlay
+  [interaction-src]
+  (select-keys interaction-src [:destination
+                                :overlay-position
+                                :overlay-pos-type
+                                :close-click-outside
+                                :background-overlay]))
+
+(defmethod read-action-opts :close-overlay
+  [interaction-src]
+  (select-keys interaction-src [:destination]))
+
+(defmethod read-action-opts :prev-screen
+  [_]
+  {})
+
+(defmethod read-action-opts :open-url
+  [interaction-src]
+  (select-keys interaction-src [:url]))
+
 (defn add-interaction
-  [file from-id {:keys [action-type event-type destination]}]
+  [file from-id interaction-src]
 
   (assert (some? (lookup-shape file from-id)) (str "Cannot locate shape with id " from-id))
-  (assert (some? (lookup-shape file destination)) (str "Cannot locate shape with id " destination))
 
-  (let [interactions (->> (lookup-shape file from-id)
-                          :interactions
-                          (filterv #(or (not= (:action-type %) action-type)
-                                        (not= (:event-type %) event-type))))
-        interactions (-> interactions
+  (let [{:keys [event-type action-type]} (read-classifier interaction-src)
+        {:keys [delay]} (read-event-opts interaction-src)
+        {:keys [destination overlay-pos-type overlay-position url
+                close-click-outside background-overlay preserve-scroll]}
+        (read-action-opts interaction-src)
+
+        interactions (-> (lookup-shape file from-id)
+                         :interactions
                          (conjv
-                          {:action-type action-type
-                           :event-type event-type
-                           :destination destination}))]
+                          (d/without-nils {:event-type event-type
+                                           :action-type action-type
+                                           :delay delay
+                                           :destination destination
+                                           :overlay-pos-type overlay-pos-type
+                                           :overlay-position overlay-position
+                                           :url url
+                                           :close-click-outside close-click-outside
+                                           :background-overlay background-overlay
+                                           :preserve-scroll preserve-scroll})))]
     (commit-change
      file
      {:type :mod-obj

common/src/app/common/flags.cljc

@@ -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) UXBOX Labs SL
+
+(ns app.common.flags
+  "Flags parsing algorithm."
+  (:require
+   [cuerdas.core :as str]))
+
+(def default
+  "A common flags that affects both: backend and frontend."
+  [:enable-registration
+   :enable-demo-users])
+
+(defn parse
+  [& flags]
+  (loop [flags  (apply concat flags)
+         result #{}]
+    (let [item (first flags)]
+      (if (nil? item)
+        result
+        (let [sname (name item)]
+          (cond
+            (str/starts-with? sname "enable-")
+            (recur (rest flags)
+                   (conj result (keyword (subs sname 7))))
+
+            (str/starts-with? sname "disable-")
+            (recur (rest flags)
+                   (disj result (keyword (subs sname 8))))
+
+            :else
+            (recur (rest flags) result)))))))
+
+

common/src/app/common/geom/point.cljc

@@ -22,7 +22,8 @@
 (defn ^boolean point?
   "Return true if `v` is Point instance."
   [v]
-  (instance? Point v))
+  (or (instance? Point v)
+      (and (map? v) (contains? v :x) (contains? v :y))))
 
 (defn ^boolean point-like?
   [{:keys [x y] :as v}]
@@ -257,15 +258,12 @@
   (and (mth/almost-zero? x)
        (mth/almost-zero? y)))
 
-(defn line-val
-  "Given a line with two points p1-p2 and a 'percent'. Returns the point in the vector
-  generated by these two points. For example: for p1=(0,0) p2=(1,1) and v=0.25 will return
-  the point (0.25, 0.25)"
-  [p1 p2 v]
-  (let [v (-> (to-vec p1 p2)
-              (scale v))]
-    (add p1 v)))
-
+(defn lerp
+  "Calculates a linear interpolation between two points given a tvalue"
+  [p1 p2 t]
+  (let [x (mth/lerp (:x p1) (:x p2) t)
+        y (mth/lerp (:y p1) (:y p2) t)]
+    (point x y)))
 
 (defn rotate
   "Rotates the point around center with an angle"

common/src/app/common/geom/shapes.cljc

@@ -8,11 +8,13 @@
   (:require
    [app.common.data :as d]
    [app.common.geom.point :as gpt]
+   [app.common.geom.shapes.bool :as gsb]
    [app.common.geom.shapes.common :as gco]
    [app.common.geom.shapes.intersect :as gin]
    [app.common.geom.shapes.path :as gsp]
    [app.common.geom.shapes.rect :as gpr]
-   [app.common.geom.shapes.transforms :as gtr]))
+   [app.common.geom.shapes.transforms :as gtr]
+   [app.common.math :as mth]))
 
 ;; --- Setup (Initialize)
 ;; FIXME: Is this the correct place for these functions?
@@ -126,6 +128,13 @@
         (assoc :selrect selrect
                :points points))))
 
+(defn shape-stroke-margin
+  [shape stroke-width]
+  (if (= (:type shape) :path)
+    ;; TODO: Calculate with the stroke offset (not implemented yet
+    (mth/sqrt (* 2 stroke-width stroke-width))
+    (- (mth/sqrt (* 2 stroke-width stroke-width)) stroke-width)))
+
 
 ;; EXPORTS
 (d/export gco/center-shape)
@@ -133,19 +142,20 @@
 (d/export gco/center-rect)
 (d/export gco/center-points)
 (d/export gco/make-centered-rect)
+(d/export gco/transform-points)
 
 (d/export gpr/rect->selrect)
 (d/export gpr/rect->points)
 (d/export gpr/points->selrect)
 (d/export gpr/points->rect)
 (d/export gpr/center->rect)
+(d/export gpr/join-rects)
 
 (d/export gtr/move)
 (d/export gtr/absolute-move)
 (d/export gtr/transform-matrix)
 (d/export gtr/inverse-transform-matrix)
 (d/export gtr/transform-point-center)
-(d/export gtr/transform-points)
 (d/export gtr/transform-rect)
 (d/export gtr/calculate-adjust-matrix)
 (d/export gtr/update-group-selrect)
@@ -156,12 +166,15 @@
 (d/export gtr/calc-child-modifiers)
 
 ;; PATHS
-(d/export gsp/content->points)
 (d/export gsp/content->selrect)
 (d/export gsp/transform-content)
+(d/export gsp/open-path?)
 
 ;; Intersection
 (d/export gin/overlaps?)
 (d/export gin/has-point?)
 (d/export gin/has-point-rect?)
 (d/export gin/rect-contains-shape?)
+
+;; Bool
+(d/export gsb/update-bool-selrect)

common/src/app/common/geom/shapes/bool.cljc

@@ -0,0 +1,32 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.common.geom.shapes.bool
+  (:require
+   [app.common.geom.shapes.path :as gsp]
+   [app.common.geom.shapes.rect :as gpr]
+   [app.common.geom.shapes.transforms :as gtr]
+   [app.common.path.bool :as pb]
+   [app.common.path.shapes-to-path :as stp]))
+
+(defn update-bool-selrect
+  "Calculates the selrect+points for the boolean shape"
+  [shape children objects]
+
+  (let [content (->> children
+                     (map #(stp/convert-to-path % objects))
+                     (mapv :content)
+                     (pb/content-bool (:bool-type shape)))
+
+        [points selrect]
+        (if (empty? content)
+          (let [selrect (gtr/selection-rect children)
+                points (gpr/rect->points selrect)]
+            [points selrect])
+          (gsp/content->points+selrect shape content))]
+    (-> shape
+        (assoc :selrect selrect)
+        (assoc :points points))))

common/src/app/common/geom/shapes/common.cljc

@@ -6,6 +6,7 @@
 
 (ns app.common.geom.shapes.common
   (:require
+   [app.common.geom.matrix :as gmt]
    [app.common.geom.point :as gpt]
    [app.common.math :as mth]))
 
@@ -48,3 +49,14 @@
    :y (- (:y center) (/ height 2.0))
    :width width
    :height height})
+
+(defn transform-points
+  ([points matrix]
+   (transform-points points nil matrix))
+  ([points center matrix]
+   (let [prev (if center (gmt/translate-matrix center) (gmt/matrix))
+         post (if center (gmt/translate-matrix (gpt/negate center)) (gmt/matrix))
+
+         tr-point (fn [point]
+                    (gpt/transform point (gmt/multiply prev matrix post)))]
+     (mapv tr-point points))))

common/src/app/common/geom/shapes/intersect.cljc

@@ -6,6 +6,7 @@
 
 (ns app.common.geom.shapes.intersect
   (:require
+   [app.common.data :as d]
    [app.common.geom.matrix :as gmt]
    [app.common.geom.point :as gpt]
    [app.common.geom.shapes.path :as gpp]
@@ -172,22 +173,23 @@
   "Checks if the given rect overlaps with the path in any point"
   [shape rect]
 
-  (let [;; If paths are too complex the intersection is too expensive
-        ;; we fallback to check its bounding box otherwise the performance penalty
-        ;; is too big
-        ;; TODO: Look for ways to optimize this operation
-        simple? (> (count (:content shape)) 100)
+  (when (d/not-empty? (:content shape))
+    (let [ ;; If paths are too complex the intersection is too expensive
+          ;; we fallback to check its bounding box otherwise the performance penalty
+          ;; is too big
+          ;; TODO: Look for ways to optimize this operation
+          simple? (> (count (:content shape)) 100)
 
-        rect-points  (gpr/rect->points rect)
-        rect-lines   (points->lines rect-points)
-        path-lines   (if simple?
-                       (points->lines (:points shape))
-                       (gpp/path->lines shape))
-        start-point (-> shape :content (first) :params (gpt/point))]
+          rect-points  (gpr/rect->points rect)
+          rect-lines   (points->lines rect-points)
+          path-lines   (if simple?
+                         (points->lines (:points shape))
+                         (gpp/path->lines shape))
+          start-point (-> shape :content (first) :params (gpt/point))]
 
-    (or (is-point-inside-nonzero? (first rect-points) path-lines)
-        (is-point-inside-nonzero? start-point rect-lines)
-        (intersects-lines? rect-lines path-lines))))
+      (or (is-point-inside-nonzero? (first rect-points) path-lines)
+          (is-point-inside-nonzero? start-point rect-lines)
+          (intersects-lines? rect-lines path-lines)))))
 
 (defn is-point-inside-ellipse?
   "checks if a point is inside an ellipse"
@@ -284,12 +286,19 @@
 (defn overlaps?
   "General case to check for overlaping between shapes and a rectangle"
   [shape rect]
-  (or (not shape)
-      (let [path? (= :path (:type shape))
-            circle? (= :circle (:type shape))]
-        (and (overlaps-rect-points? rect (:points shape))
-             (or (not path?)   (overlaps-path? shape rect))
-             (or (not circle?) (overlaps-ellipse? shape rect))))))
+  (let [stroke-width (/ (or (:stroke-width shape) 0) 2)
+        rect (-> rect
+                 (update :x - stroke-width)
+                 (update :y - stroke-width)
+                 (update :width + (* 2 stroke-width))
+                 (update :height + (* 2 stroke-width))
+                 )]
+    (or (not shape)
+        (let [path? (= :path (:type shape))
+              circle? (= :circle (:type shape))]
+          (and (overlaps-rect-points? rect (:points shape))
+               (or (not path?)   (overlaps-path? shape rect))
+               (or (not circle?) (overlaps-ellipse? shape rect)))))))
 
 (defn has-point-rect?
   [rect point]
@@ -308,3 +317,4 @@
   (->> shape
        :points
        (every? (partial has-point-rect? rect))))
+

common/src/app/common/geom/shapes/path.cljc

@@ -7,97 +7,276 @@
 (ns app.common.geom.shapes.path
   (:require
    [app.common.data :as d]
+   [app.common.geom.matrix :as gmt]
    [app.common.geom.point :as gpt]
+   [app.common.geom.shapes.common :as gsc]
    [app.common.geom.shapes.rect :as gpr]
-   [app.common.math :as mth]))
+   [app.common.math :as mth]
+   [app.common.path.commands :as upc]
+   [app.common.path.subpaths :as sp]))
 
-(defn content->points [content]
+(def ^:const curve-curve-precision 0.1)
+(def ^:const curve-range-precision 2)
+
+(defn s= [a b]
+  (mth/almost-zero? (- a b)))
+
+(defn calculate-opposite-handler
+  "Given a point and its handler, gives the symetric handler"
+  [point handler]
+  (let [handler-vector (gpt/to-vec point handler)]
+    (gpt/add point (gpt/negate handler-vector))))
+
+(defn opposite-handler
+  "Calculates the coordinates of the opposite handler"
+  [point handler]
+  (let [phv (gpt/to-vec point handler)]
+    (gpt/add point (gpt/negate phv))))
+
+(defn opposite-handler-keep-distance
+  "Calculates the coordinates of the opposite handler but keeping the old distance"
+  [point handler old-opposite]
+  (let [old-distance (gpt/distance point old-opposite)
+        phv (gpt/to-vec point handler)
+        phv2 (gpt/multiply
+              (gpt/unit (gpt/negate phv))
+              (gpt/point old-distance))]
+    (gpt/add point phv2)))
+
+(defn content->points
+  "Returns the points in the given content"
+  [content]
   (->> content
-       (map #(when (-> % :params :x) (gpt/point (-> % :params :x) (-> % :params :y))))
+       (map #(when (-> % :params :x)
+               (gpt/point (-> % :params :x) (-> % :params :y))))
        (remove nil?)
        (into [])))
 
+(defn line-values
+  [[from-p to-p] t]
+  (let [move-v (-> (gpt/to-vec from-p to-p)
+                   (gpt/scale t))]
+    (gpt/add from-p move-v)))
+
+(defn line-windup
+  [[from-p to-p :as l] t]
+  (let [p (line-values l t)
+        cy (:y p)
+        ay (:y to-p)
+        by (:y from-p)]
+    (cond
+      (and (> (- cy ay) 0) (not (s= cy ay)))  1
+      (and (< (- cy ay) 0) (not (s= cy ay))) -1
+      (< (- cy by) 0)  1
+      (> (- cy by) 0) -1
+      :else            0)))
+
 ;; https://medium.com/@Acegikmo/the-ever-so-lovely-b%C3%A9zier-curve-eb27514da3bf
 ;; https://en.wikipedia.org/wiki/Bernstein_polynomial
 (defn curve-values
   "Parametric equation for cubic beziers. Given a start and end and
   two intermediate points returns points for values of t.
   If you draw t on a plane you got the bezier cube"
-  [start end h1 h2 t]
+  ([[start end h1 h2] t]
+   (curve-values start end h1 h2 t))
 
-  (let [t2 (* t t)  ;; t square
-        t3 (* t2 t) ;; t cube
+  ([start end h1 h2 t]
+   (let [t2 (* t t) ;; t square
+         t3 (* t2 t) ;; t cube
 
-        start-v (+ (- t3) (* 3 t2) (* -3 t) 1)
-        h1-v    (+ (* 3 t3) (* -6 t2) (* 3 t))
-        h2-v    (+ (* -3 t3) (* 3 t2))
-        end-v   t3
+         start-v (+ (- t3) (* 3 t2) (* -3 t) 1)
+         h1-v    (+ (* 3 t3) (* -6 t2) (* 3 t))
+         h2-v    (+ (* -3 t3) (* 3 t2))
+         end-v   t3
 
-        coord-v (fn [coord]
-                  (+ (* (coord start) start-v)
-                     (* (coord h1)    h1-v)
-                     (* (coord h2)    h2-v)
-                     (* (coord end)   end-v)))]
+         coord-v (fn [coord]
+                   (+ (* (coord start) start-v)
+                      (* (coord h1)    h1-v)
+                      (* (coord h2)    h2-v)
+                      (* (coord end)   end-v)))]
 
-    (gpt/point (coord-v :x) (coord-v :y))))
+     (gpt/point (coord-v :x) (coord-v :y)))))
+
+(defn curve-tangent
+  "Retrieve the tangent vector to the curve in the point `t`"
+  [[start end h1 h2] t]
+  
+  (let [coords [[(:x start) (:x h1) (:x h2) (:x end)]
+                [(:y start) (:y h1) (:y h2) (:y end)]]
+
+        solve-derivative
+        (fn [[c0 c1 c2 c3]]
+          ;; Solve B'(t) given t to retrieve the value for the
+          ;; first derivative
+          (let [t2 (* t t)]
+            (+ (* c0 (+ (* -3 t2) (*   6 t) -3))
+               (* c1 (+ (*  9 t2) (* -12 t)  3))
+               (* c2 (+ (* -9 t2) (*   6 t)))
+               (* c3 (* 3 t2)))))
+
+        [x y] (->> coords (mapv solve-derivative))
+
+        ;; normalize value
+        d (mth/sqrt (+ (* x x) (* y y)))]
+
+    (gpt/point (/ x d) (/ y d))))
+
+(defn curve-windup
+  [curve t]
+
+  (let [tangent (curve-tangent curve t)]
+    (cond
+      (> (:y tangent) 0) -1
+      (< (:y tangent) 0)  1
+      :else               0)))
 
 (defn curve-split
   "Splits a curve into two at the given parametric value `t`.
   Calculates the Casteljau's algorithm intermediate points"
-  [start end h1 h2 t]
+  ([[start end h1 h2] t]
+   (curve-split start end h1 h2 t))
 
-  (let [p1 (gpt/line-val start h1 t)
-        p2 (gpt/line-val h1 h2 t)
-        p3 (gpt/line-val h2 end t)
-        p4 (gpt/line-val p1 p2 t)
-        p5 (gpt/line-val p2 p3 t)
-        sp (gpt/line-val p4 p5 t)]
-    [[start sp  p1 p4]
-     [sp    end p5 p3]]))
+  ([start end h1 h2 t]
+   (let [p1 (gpt/lerp start h1 t)
+         p2 (gpt/lerp h1 h2 t)
+         p3 (gpt/lerp h2 end t)
+         p4 (gpt/lerp p1 p2 t)
+         p5 (gpt/lerp p2 p3 t)
+         sp (gpt/lerp p4 p5 t)]
+     [[start sp  p1 p4]
+      [sp    end p5 p3]])))
+
+(defn subcurve-range
+  "Given a curve returns a new curve between the values t1-t2"
+  ([[start end h1 h2] [t1 t2]]
+   (subcurve-range start end h1 h2 t1 t2))
+
+  ([[start end h1 h2] t1 t2]
+   (subcurve-range start end h1 h2 t1 t2))
+
+  ([start end h1 h2 t1 t2]
+   ;; Make sure that t2 is greater than t1
+   (let [[t1 t2] (if (< t1 t2) [t1 t2] [t2 t1])
+         t2' (/ (- t2 t1) (- 1 t1))
+         [_ curve'] (curve-split start end h1 h2 t1)]
+     (first (curve-split curve' t2')))))
+
+
+;; https://trans4mind.com/personal_development/mathematics/polynomials/cubicAlgebra.htm
+(defn- solve-roots
+  "Solvers a quadratic or cubic equation given by the parameters a b c d"
+  ([a b c]
+   (solve-roots a b c 0))
+
+  ([a b c d]
+   (let [sqrt-b2-4ac (mth/sqrt (- (* b b) (* 4 a c)))]
+     (cond
+       ;; No solutions
+       (and (mth/almost-zero? d) (mth/almost-zero? a) (mth/almost-zero? b))
+       []
+
+       ;; Linear solution
+       (and (mth/almost-zero? d) (mth/almost-zero? a))
+       [(/ (- c) b)]
+
+       ;; Cuadratic
+       (mth/almost-zero? d)
+       [(/ (+ (- b) sqrt-b2-4ac)
+           (* 2 a))
+        (/ (- (- b) sqrt-b2-4ac)
+           (* 2 a))]
+
+       ;; Cubic
+       :else
+       (let [a (/ a d)
+             b (/ b d)
+             c (/ c d)
+
+             p  (/ (- (* 3 b) (* a a)) 3)
+             q (/ (+ (* 2 a a a) (* -9 a b) (* 27 c)) 27)
+
+             p3 (/ p 3)
+             q2 (/ q 2)
+             discriminant (+ (* q2 q2) (* p3 p3 p3))]
+
+         (cond
+           (< discriminant 0)
+           (let [mp3 (/ (- p) 3)
+                 mp33 (* mp3 mp3 mp3)
+                 r (mth/sqrt mp33)
+                 t (/ (- q) (* 2 r))
+                 cosphi (cond (< t -1) -1
+                              (> t 1) 1
+                              :else t)
+                 phi (mth/acos cosphi)
+                 crtr (mth/cubicroot r)
+                 t1 (* 2 crtr)
+                 root1 (- (* t1 (mth/cos (/ phi 3))) (/ a 3))
+                 root2 (- (* t1 (mth/cos (/ (+ phi (* 2 mth/PI)) 3))) (/ a 3))
+                 root3 (- (* t1 (mth/cos (/ (+ phi (* 4 mth/PI)) 3))) (/ a 3))]
+
+             [root1 root2 root3])
+
+           (mth/almost-zero? discriminant)
+           (let [u1 (if (< q2 0) (mth/cubicroot (- q2)) (- (mth/cubicroot q2)))
+                 root1 (- (* 2 u1) (/ a 3))
+                 root2 (- (- u1) (/ a 3))]
+             [root1 root2])
+
+           :else
+           (let [sd (mth/sqrt discriminant)
+                 u1 (mth/cubicroot (- sd q2))
+                 v1 (mth/cubicroot (+ sd q2))
+                 root (- u1 v1 (/ a 3))]
+             [root])))))))
 
 ;; https://pomax.github.io/bezierinfo/#extremities
 (defn curve-extremities
-  "Given a cubic bezier cube finds its roots in t. This are the extremities
-  if we calculate its values for x, y we can find a bounding box for the curve."
-  [start end h1 h2]
+  "Calculates the extremities by solving the first derivative for a cubic
+  bezier and then solving the quadratic formula"
+  ([[start end h1 h2]]
+   (curve-extremities start end h1 h2))
 
-  (let [coords [[(:x start) (:x h1) (:x h2) (:x end)]
-                [(:y start) (:y h1) (:y h2) (:y end)]]
+  ([start end h1 h2]
 
-        coord->tvalue
-        (fn [[c0 c1 c2 c3]]
+   (let [coords [[(:x start) (:x h1) (:x h2) (:x end)]
+                 [(:y start) (:y h1) (:y h2) (:y end)]]
 
-          (let [a (+ (* -3 c0) (*   9 c1) (* -9 c2) (* 3 c3))
-                b (+ (*  6 c0) (* -12 c1) (* 6 c2))
-                c (+ (*  3 c1) (*  -3 c0))
+         coord->tvalue
+         (fn [[c0 c1 c2 c3]]
+           (let [a (+ (* -3 c0) (*   9 c1) (* -9 c2) (* 3 c3))
+                 b (+ (*  6 c0) (* -12 c1) (* 6 c2))
+                 c (+ (*  3 c1) (*  -3 c0))]
 
-                sqrt-b2-4ac (mth/sqrt (- (* b b) (* 4 a c)))]
+             (solve-roots a b c)))]
+     (->> coords
+          (mapcat coord->tvalue)
 
-            (cond
-              (and (mth/almost-zero? a)
-                   (not (mth/almost-zero? b)))
-              ;; When the term a is close to zero we have a linear equation
-              [(/ (- c) b)]
+          ;; Only values in the range [0, 1] are valid
+          (filterv #(and (> % 0.01) (< % 0.99)))))))
 
-              ;; If a is not close to zero return the two roots for a cuadratic
-              (not (mth/almost-zero? a))
-              [(/ (+ (- b) sqrt-b2-4ac)
-                  (* 2 a))
-               (/ (- (- b) sqrt-b2-4ac)
-                  (* 2 a))]
+(defn curve-roots
+  "Uses cardano algorithm to find the roots for a cubic bezier"
+  ([[start end h1 h2] coord]
+   (curve-roots start end h1 h2 coord))
 
-              ;; If a and b close to zero we can't find a root for a constant term
-              :else
-              [])))]
-    (->> coords
-         (mapcat coord->tvalue)
+  ([start end h1 h2 coord]
 
-         ;; Only values in the range [0, 1] are valid
-         (filter #(and (>= % 0) (<= % 1)))
+   (let [coords [[(get start coord) (get h1 coord) (get h2 coord) (get end coord)]]
 
-         ;; Pass t-values to actual points
-         (map #(curve-values start end h1 h2 %)))
-    ))
+         coord->tvalue
+         (fn [[pa pb pc pd]]
+
+           (let [a (+ (* 3 pa) (* -6 pb) (* 3 pc))
+                 b (+ (* -3 pa) (* 3 pb))
+                 c pa
+                 d (+ (- pa) (* 3 pb) (* -3 pc) pd)]
+
+             (solve-roots a b c d)))]
+     (->> coords
+          (mapcat coord->tvalue)
+          ;; Only values in the range [0, 1] are valid
+          (filterv #(and (>= % 0) (<= % 1)))))))
 
 (defn command->point
   ([command] (command->point command nil))
@@ -107,7 +286,50 @@
          ykey (keyword (str prefix "y"))
          x (get params xkey)
          y (get params ykey)]
-     (gpt/point x y))))
+     (when (and (some? x) (some? y))
+       (gpt/point x y)))))
+
+(defn command->line
+  ([cmd]
+   (command->line cmd (:prev cmd)))
+  ([cmd prev]
+   [prev (command->point cmd)]))
+
+(defn command->bezier
+  ([cmd]
+   (command->bezier cmd (:prev cmd)))
+  ([cmd prev]
+   [prev
+    (command->point cmd)
+    (gpt/point (-> cmd :params :c1x) (-> cmd :params :c1y))
+    (gpt/point (-> cmd :params :c2x) (-> cmd :params :c2y))]))
+
+(defn command->selrect
+  ([command]
+   (command->selrect command (:prev command)))
+
+  ([command prev-point]
+   (let [points (case (:command command)
+                  :move-to [(command->point command)]
+
+                  ;; If it's a line we add the beginning point and endpoint
+                  :line-to [prev-point (command->point command)]
+
+                  ;; We return the bezier extremities
+                  :curve-to (d/concat
+                             [prev-point
+                              (command->point command)]
+                             (let [curve [prev-point
+                                          (command->point command)
+                                          (command->point command :c1)
+                                          (command->point command :c2)]]
+                               (->> (curve-extremities curve)
+                                    (mapv #(curve-values curve %)))))
+                  [])
+         selrect (gpr/points->selrect points)]
+     (-> selrect
+         (update :width #(if (mth/almost-zero? %) 1 %))
+         (update :height #(if (mth/almost-zero? %) 1 %))))))
 
 (defn content->selrect [content]
   (let [calc-extremities
@@ -123,10 +345,12 @@
             :curve-to (d/concat
                        [(command->point prev)
                         (command->point command)]
-                       (curve-extremities (command->point prev)
-                                          (command->point command)
-                                          (command->point command :c1)
-                                          (command->point command :c2)))
+                       (let [curve [(command->point prev)
+                                    (command->point command)
+                                    (command->point command :c1)
+                                    (command->point command :c2)]]
+                         (->> (curve-extremities curve)
+                              (mapv #(curve-values curve %)))))
             []))
 
         extremities (mapcat calc-extremities
@@ -154,7 +378,11 @@
             (not (nil? c1x)) (set-tr :c1x :c1y)
             (not (nil? c2x)) (set-tr :c2x :c2y)))]
 
-    (mapv #(update % :params transform-params) content)))
+    (->> content
+         (mapv (fn [cmd]
+                 (cond-> cmd
+                   (map? cmd)
+                   (update :params transform-params)))))))
 
 (defn transform-content
   [content transform]
@@ -302,24 +530,25 @@
   "Given a path and a position"
   [shape position]
 
-  (let [point+distance (fn [[cur-cmd prev-cmd]]
-                         (let [from-p (command->point prev-cmd)
-                               to-p   (command->point cur-cmd)
-                               h1 (gpt/point (get-in cur-cmd [:params :c1x])
-                                             (get-in cur-cmd [:params :c1y]))
-                               h2 (gpt/point (get-in cur-cmd [:params :c2x])
-                                             (get-in cur-cmd [:params :c2y]))
-                               point
-                               (case (:command cur-cmd)
-                                 :line-to
-                                 (line-closest-point position from-p to-p)
+  (let [point+distance
+        (fn [[cur-cmd prev-cmd]]
+          (let [from-p (command->point prev-cmd)
+                to-p   (command->point cur-cmd)
+                h1 (gpt/point (get-in cur-cmd [:params :c1x])
+                              (get-in cur-cmd [:params :c1y]))
+                h2 (gpt/point (get-in cur-cmd [:params :c2x])
+                              (get-in cur-cmd [:params :c2y]))
+                point
+                (case (:command cur-cmd)
+                  :line-to
+                  (line-closest-point position from-p to-p)
 
-                                 :curve-to
-                                 (curve-closest-point position from-p to-p h1 h2)
+                  :curve-to
+                  (curve-closest-point position from-p to-p h1 h2)
 
-                                 nil)]
-                           (when point
-                             [point (gpt/distance point position)])))
+                  nil)]
+            (when point
+              [point (gpt/distance point position)])))
 
         find-min-point (fn [[min-p min-dist :as acc] [cur-p cur-dist :as cur]]
                          (if (and (some? acc) (or (not cur) (<= min-dist cur-dist)))
@@ -331,3 +560,399 @@
          (map point+distance)
          (reduce find-min-point)
          (first))))
+
+(defn- get-line-tval
+  [[{x1 :x y1 :y} {x2 :x y2 :y}] {:keys [x y]}]
+  (cond
+    (and (s= x1 x2) (s= y1 y2))
+    ##Inf
+
+    (s= x1 x2)
+    (/ (- y y1) (- y2 y1))
+
+    :else
+    (/ (- x x1) (- x2 x1))))
+
+(defn- curve-range->rect
+  [curve from-t to-t]
+
+  (let [[from-p to-p :as curve] (subcurve-range curve from-t to-t)
+        extremes (->> (curve-extremities curve)
+                      (mapv #(curve-values curve %)))]
+    (gpr/points->rect (into [from-p to-p] extremes))))
+
+(defn line-has-point?
+  "Using the line equation we put the x value and check if matches with
+  the given Y. If it does the point is inside the line"
+  [point [from-p to-p]]
+  (let [{x1 :x y1 :y} from-p
+        {x2 :x y2 :y} to-p
+        {px :x py :y} point
+
+        m  (when-not (s= x1 x2) (/ (- y2 y1) (- x2 x1)))
+        vy (when (some? m) (+ (* m px) (* (- m) x1) y1))]
+
+    ;; If x1 = x2 there is no slope, to see if the point is in the line
+    ;; only needs to check the x is the same
+    (or (and (s= x1 x2) (s= px x1))
+        (and (some? vy) (s= py vy)))))
+
+(defn segment-has-point?
+  "Using the line equation we put the x value and check if matches with
+  the given Y. If it does the point is inside the line"
+  [point line]
+
+  (and (line-has-point? point line)
+       (let [t (get-line-tval line point)]
+         (and (or (> t 0) (s= t 0))
+              (or (< t 1) (s= t 1))))))
+
+(defn curve-has-point?
+  [point curve]
+  (letfn [(check-range [from-t to-t]
+            (let [r (curve-range->rect curve from-t to-t)]
+              (when (gpr/contains-point? r point)
+                (if (s= from-t to-t)
+                  (< (gpt/distance (curve-values curve from-t) point) 0.1)
+
+                  (let [half-t (+ from-t (/ (- to-t from-t) 2.0))]
+                    (or (check-range from-t half-t)
+                        (check-range half-t to-t)))))))]
+
+    (check-range 0 1)))
+
+(defn line-line-crossing
+  [[from-p1 to-p1 :as l1] [from-p2 to-p2 :as l2]]
+
+  (let [{x1 :x y1 :y} from-p1
+        {x2 :x y2 :y} to-p1
+
+        {x3 :x y3 :y} from-p2
+        {x4 :x y4 :y} to-p2
+
+        nx (- (* (- x3 x4) (- (* x1 y2) (* y1 x2)))
+              (* (- x1 x2) (- (* x3 y4) (* y3 x4))))
+
+        ny (- (* (- y3 y4) (- (* x1 y2) (* y1 x2)))
+              (* (- y1 y2) (- (* x3 y4) (* y3 x4))))
+
+        d  (- (* (- x1 x2) (- y3 y4))
+              (* (- y1 y2) (- x3 x4)))]
+
+    (cond
+      (not (mth/almost-zero? d))
+      ;; Coordinates in the line. We calculate the tvalue that will
+      ;; return 0-1 as a percentage in the segment
+      (let [cross-p (gpt/point (/ nx d) (/ ny d))
+            t1 (get-line-tval l1 cross-p)
+            t2 (get-line-tval l2 cross-p)]
+        [t1 t2])
+
+      ;; If they are parallels they could define the same line
+      (line-has-point? from-p2 l1) [(get-line-tval l1 from-p2) 0]
+      (line-has-point? to-p2   l1) [(get-line-tval l1 to-p2)   1]
+      (line-has-point? to-p1   l2) [1 (get-line-tval l2 to-p1)]
+      (line-has-point? from-p1 l2) [0 (get-line-tval l2 from-p1)]
+
+      :else
+      nil)))
+
+(defn line-curve-crossing
+  [[from-p1 to-p1]
+   [from-p2 to-p2 h1-p2 h2-p2]]
+
+  (let [theta (-> (mth/atan2 (- (:y to-p1) (:y from-p1))
+                             (- (:x to-p1) (:x from-p1)))
+                  (mth/degrees))
+
+        transform (-> (gmt/matrix)
+                      (gmt/rotate (- theta))
+                      (gmt/translate (gpt/negate from-p1)))
+
+        c2' [(gpt/transform from-p2 transform)
+             (gpt/transform to-p2 transform)
+             (gpt/transform h1-p2 transform)
+             (gpt/transform h2-p2 transform)]]
+
+    (curve-roots c2' :y)))
+
+
+
+(defn ray-line-intersect
+  [point [a b :as line]]
+
+  ;; If the ray is paralell to the line there will be no crossings
+  (let [ray-line [point (gpt/point (inc (:x point)) (:y point))]
+        ;; Rays fail when fall just in a vertex so we move a bit upward
+        ;; because only want to use this for insideness
+        a (if (and (some? a) (s= (:y a) (:y point))) (update a :y + 10) a)
+        b (if (and (some? b) (s= (:y b) (:y point))) (update b :y + 10) b)
+        [ray-t line-t] (line-line-crossing ray-line [a b])]
+
+    (when (and (some? line-t) (some? ray-t)
+               (> ray-t 0)
+               (or (> line-t 0) (s= line-t 0))
+               (or (< line-t 1) (s= line-t 1)))
+      [[(line-values line line-t)
+        (line-windup line line-t)]])))
+
+(defn line-line-intersect
+  [l1 l2]
+
+  (let [[l1-t l2-t] (line-line-crossing l1 l2)]
+    (when (and (some? l1-t) (some? l2-t)
+               (or (> l1-t 0) (s= l1-t 0))
+               (or (< l1-t 1) (s= l1-t 1))
+               (or (> l2-t 0) (s= l2-t 0))
+               (or (< l2-t 1) (s= l2-t 1)))
+      [[l1-t] [l2-t]])))
+
+(defn ray-curve-intersect
+  [ray-line c2]
+
+  (let [;; ray-line [point (gpt/point (inc (:x point)) (:y point))]
+        curve-ts (->> (line-curve-crossing ray-line c2)
+                      (filterv #(let [curve-v (curve-values c2 %)
+                                      curve-tg (curve-tangent c2 %)
+                                      curve-tg-angle (gpt/angle curve-tg)
+                                      ray-t (get-line-tval ray-line curve-v)]
+                                  (and (> ray-t 0)
+                                       (> (mth/abs (- curve-tg-angle 180)) 0.01)
+                                       (> (mth/abs (- curve-tg-angle 0)) 0.01)) )))]
+    (->> curve-ts
+         (mapv #(vector (curve-values c2 %)
+                        (curve-windup c2 %))))))
+
+(defn line-curve-intersect
+  [l1 c2]
+
+  (let [curve-ts (->> (line-curve-crossing l1 c2)
+                      (filterv
+                       (fn [curve-t]
+                         (let [curve-t (if (mth/almost-zero? curve-t) 0 curve-t)
+                               curve-v (curve-values c2 curve-t)
+                               line-t (get-line-tval l1 curve-v)]
+                           (and (>= curve-t 0) (<= curve-t 1)
+                                (>= line-t 0) (<= line-t 1))))))
+
+        ;; Intersection line-curve points
+        intersect-ps (->> curve-ts
+                          (mapv #(curve-values c2 %)))
+
+        line-ts (->> intersect-ps
+                     (mapv #(get-line-tval l1 %)))]
+
+    [line-ts curve-ts]))
+
+(defn curve-curve-intersect
+  [c1 c2]
+
+  (letfn [(check-range [c1-from c1-to c2-from c2-to]
+            (let [r1 (curve-range->rect c1 c1-from c1-to)
+                  r2 (curve-range->rect c2 c2-from c2-to)]
+
+              (when (gpr/overlaps-rects? r1 r2)
+                (let [p1 (curve-values c1 c1-from)
+                      p2 (curve-values c2 c2-from)]
+
+                  (if (< (gpt/distance p1 p2) curve-curve-precision)
+                    [{:p1 p1
+                      :p2 p2
+                      :d  (gpt/distance p1 p2)
+                      :t1 (mth/precision c1-from 4)
+                      :t2 (mth/precision c2-from 4)}]
+
+                    (let [c1-half (+ c1-from (/ (- c1-to c1-from) 2))
+                          c2-half (+ c2-from (/ (- c2-to c2-from) 2))
+
+                          ts-1 (check-range c1-from c1-half c2-from c2-half)
+                          ts-2 (check-range c1-from c1-half c2-half c2-to)
+                          ts-3 (check-range c1-half c1-to c2-from c2-half)
+                          ts-4 (check-range c1-half c1-to c2-half c2-to)]
+
+                      (d/concat [] ts-1 ts-2 ts-3 ts-4)))))))
+
+          (remove-close-ts [{cp1 :p1 cp2 :p2}]
+            (fn [{:keys [p1 p2]}]
+              (and (>= (gpt/distance p1 cp1) curve-range-precision)
+                   (>= (gpt/distance p2 cp2) curve-range-precision))))
+
+          (process-ts [ts]
+            (loop [current (first ts)
+                   pending (rest ts)
+                   c1-ts   []
+                   c2-ts   []]
+
+              (if (nil? current)
+                [c1-ts c2-ts]
+
+                (let [pending (->> pending (filter (remove-close-ts current)))
+                      c1-ts (conj c1-ts (:t1 current))
+                      c2-ts (conj c2-ts (:t2 current))]
+                  (recur (first pending)
+                         (rest pending)
+                         c1-ts
+                         c2-ts)))))]
+
+    (->> (check-range 0 1 0 1)
+         (sort-by :d)
+         (process-ts))))
+
+(defn curve->rect
+  [[from-p to-p :as curve]]
+  (let [extremes (->> (curve-extremities curve)
+                      (mapv #(curve-values curve %)))]
+    (gpr/points->rect (into [from-p to-p] extremes))))
+
+
+(defn is-point-in-border?
+  [point content]
+
+  (letfn [(inside-border? [cmd]
+            (case (:command cmd)
+              :line-to  (segment-has-point?  point (command->line cmd))
+              :curve-to (curve-has-point? point (command->bezier cmd))
+              #_:else   false))]
+
+    (->> content
+         (some inside-border?))))
+
+(defn is-point-in-content?
+  [point content]
+  (let [selrect (content->selrect content)
+        ray-line [point (gpt/point (inc (:x point)) (:y point))]
+
+        closed-content
+        (into []
+              (comp  (filter sp/is-closed?)
+                     (mapcat :data))
+              (->> content
+                   (sp/close-subpaths)
+                   (sp/get-subpaths)))
+
+        cast-ray
+        (fn [cmd]
+          (case (:command cmd)
+            :line-to  (ray-line-intersect  point (command->line cmd))
+            :curve-to (ray-curve-intersect ray-line (command->bezier cmd))
+            #_:else   []))]
+
+    (and (gpr/contains-point? selrect point)
+         (->> closed-content
+              (mapcat cast-ray)
+              (map second)
+              (reduce +)
+              (not= 0)))))
+
+(defn split-line-to
+  "Given a point and a line-to command will create a two new line-to commands
+  that will split the original line into two given a value between 0-1"
+  [from-p cmd t-val]
+  (let [to-p (upc/command->point cmd)
+        sp (gpt/lerp from-p to-p t-val)]
+    [(upc/make-line-to sp) cmd]))
+
+(defn split-curve-to
+  "Given the point and a curve-to command will split the curve into two new
+  curve-to commands given a value between 0-1"
+  [from-p cmd t-val]
+  (let [params (:params cmd)
+        end (gpt/point (:x params) (:y params))
+        h1 (gpt/point (:c1x params) (:c1y params))
+        h2 (gpt/point (:c2x params) (:c2y params))
+        [[_ to1 h11 h21]
+         [_ to2 h12 h22]] (curve-split from-p end h1 h2 t-val)]
+    [(upc/make-curve-to to1 h11 h21)
+     (upc/make-curve-to to2 h12 h22)]))
+
+(defn split-line-to-ranges
+  "Splits a line into several lines given the points in `values`
+  for example (split-line-to-ranges p c [0 0.25 0.5 0.75 1] will split
+  the line into 4 lines"
+  [from-p cmd values]
+  (let [values (->> values (filter #(and (> % 0) (< % 1))))]
+    (if (empty? values)
+      [cmd]
+      (let [to-p (upc/command->point cmd)
+            values-set (->> (conj values 1) (into (sorted-set)))]
+        (->> values-set
+             (mapv (fn [val]
+                     (-> (gpt/lerp from-p to-p val)
+                         #_(gpt/round 2)
+                         (upc/make-line-to)))))))))
+
+(defn split-curve-to-ranges
+  "Splits a curve into several curves given the points in `values`
+  for example (split-curve-to-ranges p c [0 0.25 0.5 0.75 1] will split
+  the curve into 4 curves that draw the same curve"
+  [from-p cmd values]
+
+  (let [values (->> values (filter #(and (> % 0) (< % 1))))]
+    (if (empty? values)
+      [cmd]
+      (let [to-p (upc/command->point cmd)
+            params (:params cmd)
+            h1 (gpt/point (:c1x params) (:c1y params))
+            h2 (gpt/point (:c2x params) (:c2y params))
+
+            values-set (->> (conj values 0 1) (into (sorted-set)))]
+
+        (->> (d/with-prev values-set)
+             (rest)
+             (mapv
+              (fn [[t1 t0]]
+                (let [[_ to-p h1' h2'] (subcurve-range from-p to-p h1 h2 t0 t1)]
+                  (upc/make-curve-to (-> to-p #_(gpt/round 2)) h1' h2')))))))))
+
+(defn content-center
+  [content]
+  (-> content
+      content->selrect
+      gsc/center-selrect))
+
+(defn content->points+selrect
+  "Given the content of a shape, calculate its points and selrect"
+  [shape content]
+  (let [{:keys [flip-x flip-y]} shape
+        transform
+        (cond-> (:transform shape (gmt/matrix))
+          flip-x (gmt/scale (gpt/point -1 1))
+          flip-y (gmt/scale (gpt/point 1 -1)))
+
+        transform-inverse
+        (cond-> (gmt/matrix)
+          flip-x (gmt/scale (gpt/point -1 1))
+          flip-y (gmt/scale (gpt/point 1 -1))
+          :always (gmt/multiply (:transform-inverse shape (gmt/matrix))))
+
+        center (or (gsc/center-shape shape)
+                   (content-center content))
+
+        base-content (transform-content
+                      content
+                      (gmt/transform-in center transform-inverse))
+
+        ;; Calculates the new selrect with points given the old center
+        points (-> (content->selrect base-content)
+                   (gpr/rect->points)
+                   (gsc/transform-points center transform))
+
+        points-center (gsc/center-points points)
+
+        ;; Points is now the selrect but the center is different so we can create the selrect
+        ;; through points
+        selrect (-> points
+                    (gsc/transform-points points-center transform-inverse)
+                    (gpr/points->selrect))]
+    [points selrect]))
+
+
+(defn open-path?
+  [shape]
+
+  (and (= :path (:type shape))
+       (not (->> shape
+                 :content
+                 (sp/close-subpaths)
+                 (sp/get-subpaths)
+                 (every? sp/is-closed?)))))

common/src/app/common/geom/shapes/rect.cljc

@@ -7,7 +7,8 @@
 (ns app.common.geom.shapes.rect
   (:require
    [app.common.geom.point :as gpt]
-   [app.common.geom.shapes.common :as gco]))
+   [app.common.geom.shapes.common :as gco]
+   [app.common.math :as mth]))
 
 (defn rect->points [{:keys [x y width height]}]
   ;; (assert (number? x))
@@ -47,6 +48,16 @@
 (defn rect->selrect [rect]
   (-> rect rect->points points->selrect))
 
+(defn join-rects [rects]
+  (let [minx (transduce (comp (map :x) (remove nil?)) min ##Inf rects)
+        miny (transduce (comp (map :y) (remove nil?)) min ##Inf rects)
+        maxx (transduce (comp (map #(+ (:x %) (:width %))) (remove nil?)) max ##-Inf rects)
+        maxy (transduce (comp (map #(+ (:y %) (:height %))) (remove nil?)) max ##-Inf rects)]
+    {:x minx
+     :y miny
+     :width (- maxx minx)
+     :height (- maxy miny)}))
+
 (defn join-selrects [selrects]
   (let [minx (transduce (comp (map :x1) (remove nil?)) min ##Inf selrects)
         miny (transduce (comp (map :y1) (remove nil?)) min ##Inf selrects)
@@ -70,3 +81,43 @@
    :y (- (:y center) (/ height 2))
    :width width
    :height height})
+
+(defn s=
+  [a b]
+  (mth/almost-zero? (- a b)))
+
+(defn overlaps-rects?
+  "Check for two rects to overlap. Rects won't overlap only if
+   one of them is fully to the left or the top"
+  [rect-a rect-b]
+
+  (let [x1a (:x rect-a)
+        y1a (:y rect-a)
+        x2a (+ (:x rect-a) (:width rect-a))
+        y2a (+ (:y rect-a) (:height rect-a))
+
+        x1b (:x rect-b)
+        y1b (:y rect-b)
+        x2b (+ (:x rect-b) (:width rect-b))
+        y2b (+ (:y rect-b) (:height rect-b))]
+
+    (and (or (> x2a x1b)  (s= x2a x1b))
+         (or (>= x2b x1a) (s= x2b x1a))
+         (or (<= y1b y2a) (s= y1b y2a))
+         (or (<= y1a y2b) (s= y1a y2b)))))
+
+(defn contains-point?
+  [rect point]
+  (assert (gpt/point? point))
+  (let [x1 (:x rect)
+        y1 (:y rect)
+        x2 (+ (:x rect) (:width rect))
+        y2 (+ (:y rect) (:height rect))
+
+        px (:x point)
+        py (:y point)]
+
+    (and (or (> px x1) (s= px x1))
+         (or (< px x2) (s= px x2))
+         (or (> py y1) (s= py y1))
+         (or (< py y2) (s= py y2)))))

common/src/app/common/geom/shapes/transforms.cljc

@@ -18,7 +18,6 @@
    [app.common.spec :as us]
    [app.common.text :as txt]))
 
-
 ;; --- Relative Movement
 
 (defn- move-selrect [selrect {dx :x dy :y}]
@@ -161,23 +160,12 @@
                  matrix
                  (gmt/translate-matrix (gpt/negate center)))))
 
-(defn transform-points
-  ([points matrix]
-   (transform-points points nil matrix))
-  ([points center matrix]
-   (let [prev (if center (gmt/translate-matrix center) (gmt/matrix))
-         post (if center (gmt/translate-matrix (gpt/negate center)) (gmt/matrix))
-
-         tr-point (fn [point]
-                    (gpt/transform point (gmt/multiply prev matrix post)))]
-     (mapv tr-point points))))
-
 (defn transform-rect
   "Transform a rectangles and changes its attributes"
   [rect matrix]
 
   (let [points (-> (gpr/rect->points rect)
-                   (transform-points matrix))]
+                   (gco/transform-points matrix))]
     (gpr/points->rect points)))
 
 (defn calculate-adjust-matrix
@@ -201,12 +189,12 @@
          stretch-matrix (gmt/multiply stretch-matrix (gmt/skew-matrix skew-angle 0))
 
          h1 (max 1 (calculate-height points-temp))
-         h2 (max 1 (calculate-height (transform-points points-rec center stretch-matrix)))
+         h2 (max 1 (calculate-height (gco/transform-points points-rec center stretch-matrix)))
          h3 (if-not (mth/almost-zero? h2) (/ h1 h2) 1)
          h3 (if (mth/nan? h3) 1 h3)
 
          w1 (max 1 (calculate-width points-temp))
-         w2 (max 1 (calculate-width (transform-points points-rec center stretch-matrix)))
+         w2 (max 1 (calculate-width (gco/transform-points points-rec center stretch-matrix)))
          w3 (if-not (mth/almost-zero? w2) (/ w1 w2) 1)
          w3 (if (mth/nan? w3) 1 w3)
 
@@ -214,7 +202,7 @@
 
          rotation-angle (calculate-rotation
                          center
-                         (transform-points points-rec (gco/center-points points-rec) stretch-matrix)
+                         (gco/transform-points points-rec (gco/center-points points-rec) stretch-matrix)
                          points-temp
                          flip-x
                          flip-y)
@@ -232,14 +220,13 @@
   "Given a new set of points transformed, set up the rectangle so it keeps
   its properties. We adjust de x,y,width,height and create a custom transform"
   [shape transform round-coords?]
-  ;;
-  (let [points (-> shape :points (transform-points transform))
+  (let [points (-> shape :points (gco/transform-points transform))
         center (gco/center-points points)
 
         ;; Reverse the current transformation stack to get the base rectangle
         tr-inverse      (:transform-inverse shape (gmt/matrix))
 
-        points-temp     (transform-points points center tr-inverse)
+        points-temp     (gco/transform-points points center tr-inverse)
         points-temp-dim (calculate-dimensions points-temp)
 
         ;; This rectangle is the new data for the current rectangle. We want to change our rectangle
@@ -305,12 +292,12 @@
         points (->> children (mapcat :points))
 
         ;; Invert to get the points minus the transforms applied to the group
-        base-points (transform-points points shape-center (:transform-inverse group (gmt/matrix)))
+        base-points (gco/transform-points points shape-center (:transform-inverse group (gmt/matrix)))
 
         ;; Defines the new selection rect with its transformations
         new-points (-> (gpr/points->selrect base-points)
                        (gpr/rect->points)
-                       (transform-points shape-center (:transform group (gmt/matrix))))
+                       (gco/transform-points shape-center (:transform group (gmt/matrix))))
 
         ;; Calculte the new selrect
         new-selrect (gpr/points->selrect base-points)]
@@ -457,8 +444,10 @@
     transform))
 
 (defn- set-flip [shape modifiers]
-  (let [rx (get-in modifiers [:resize-vector :x])
-        ry (get-in modifiers [:resize-vector :y])]
+  (let [rx (or (get-in modifiers [:resize-vector :x])
+               (get-in modifiers [:resize-vector-2 :x]))
+        ry (or (get-in modifiers [:resize-vector :y])
+               (get-in modifiers [:resize-vector-2 :y]))]
     (cond-> shape
       (and rx (< rx 0)) (-> (update :flip-x not)
                             (update :rotation -))
@@ -487,6 +476,7 @@
                                             (d/parse-double)
                                             (* (get-in modifiers [:resize-vector :x] 1))
                                             (* (get-in modifiers [:resize-vector-2 :x] 1))
+                                            (mth/precision 2)
                                             (str))]
                           (attrs/merge attrs {:font-size font-size})))]
       (update shape :content #(txt/transform-nodes
@@ -516,7 +506,7 @@
 (defn calc-child-modifiers
   "Given the modifiers to apply to the parent, calculate the corresponding
   modifiers for the child, depending on the child constraints."
-  [parent child parent-modifiers]
+  [parent child parent-modifiers ignore-constraints]
   (let [parent-rect             (:selrect parent)
         child-rect              (:selrect child)
 
@@ -543,15 +533,19 @@
 
         transformed-parent-rect (-> parent-rect
                                     (gpr/rect->points)
-                                    (transform-points parent-displacement)
-                                    (transform-points parent-origin (gmt/scale-matrix parent-vector))
-                                    (transform-points parent-origin-2 (gmt/scale-matrix parent-vector-2))
+                                    (gco/transform-points parent-displacement)
+                                    (gco/transform-points parent-origin (gmt/scale-matrix parent-vector))
+                                    (gco/transform-points parent-origin-2 (gmt/scale-matrix parent-vector-2))
                                     (gpr/points->selrect))
 
         ;; Calculate the modifiers in the horizontal and vertical directions
         ;; depending on the child constraints.
-        constraints-h (get child :constraints-h (spec/default-constraints-h child))
-        constraints-v (get child :constraints-v (spec/default-constraints-v child))
+        constraints-h (if-not ignore-constraints
+                        (get child :constraints-h (spec/default-constraints-h child))
+                        :scale)
+        constraints-v (if-not ignore-constraints
+                        (get child :constraints-v (spec/default-constraints-v child))
+                        :scale)
 
         modifiers-h (case constraints-h
                       :left
@@ -691,3 +685,12 @@
       (assoc :resize-transform (:resize-transform parent-modifiers)
              :resize-transform-inverse (:resize-transform-inverse parent-modifiers)))))
 
+
+(defn selection-rect
+  "Returns a rect that contains all the shapes and is aware of the
+  rotation of each shape. Mainly used for multiple selection."
+  [shapes]
+  (->> shapes
+       (transform-shape)
+       (map (comp gpr/points->selrect :points))
+       (gpr/join-selrects)))

common/src/app/common/logging.cljc

@@ -0,0 +1,297 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.common.logging
+  (:require
+   [app.common.exceptions :as ex]
+   [clojure.pprint :refer [pprint]]
+   [cuerdas.core :as str]
+   #?(:cljs [goog.log :as glog]))
+  #?(:cljs (:require-macros [app.common.logging]))
+  #?(:clj
+     (:import
+      org.apache.logging.log4j.Level
+      org.apache.logging.log4j.LogManager
+      org.apache.logging.log4j.Logger
+      org.apache.logging.log4j.ThreadContext
+      org.apache.logging.log4j.message.MapMessage
+      org.apache.logging.log4j.spi.LoggerContext)))
+
+#?(:clj
+   (defn build-map-message
+     [m]
+     (let [message (MapMessage. (count m))]
+       (reduce-kv #(.with ^MapMessage %1 (name %2) %3) message m))))
+
+#?(:clj
+  (def logger-context
+    (LogManager/getContext false)))
+
+#?(:clj
+  (def logging-agent
+    (agent nil :error-mode :continue)))
+
+(defn get-logger
+  [lname]
+  #?(:clj  (.getLogger ^LoggerContext logger-context ^String lname)
+     :cljs
+      (glog/getLogger
+       (cond
+         (string? lname) lname
+         (= lname :root) ""
+         (simple-ident? lname) (name lname)
+         (qualified-ident? lname) (str (namespace lname) "." (name lname))
+         :else (str lname)))))
+
+(defn get-level
+  [level]
+  #?(:clj
+     (case level
+       :trace Level/TRACE
+       :debug Level/DEBUG
+       :info  Level/INFO
+       :warn  Level/WARN
+       :error Level/ERROR
+       :fatal Level/FATAL)
+     :cljs
+     (case level
+       :off     (.-OFF ^js glog/Level)
+       :shout   (.-SHOUT ^js glog/Level)
+       :error   (.-SEVERE ^js  glog/Level)
+       :severe  (.-SEVERE ^js glog/Level)
+       :warning (.-WARNING ^js glog/Level)
+       :warn    (.-WARNING ^js glog/Level)
+       :info    (.-INFO ^js glog/Level)
+       :config  (.-CONFIG ^js glog/Level)
+       :debug   (.-FINE ^js glog/Level)
+       :fine    (.-FINE ^js glog/Level)
+       :finer   (.-FINER ^js glog/Level)
+       :trace   (.-FINER ^js glog/Level)
+       :finest  (.-FINEST ^js glog/Level)
+       :all     (.-ALL ^js glog/Level))))
+
+(defn write-log!
+  [logger level exception message]
+  #?(:clj
+     (if exception
+       (.log ^Logger    logger
+             ^Level     level
+             ^Object    message
+             ^Throwable exception)
+       (.log ^Logger logger
+             ^Level  level
+             ^Object message))
+     :cljs
+     (when glog/ENABLED
+       (when-let [l (get-logger logger)]
+         (let [level  (get-level level)
+               record (glog/LogRecord. level message (.getName ^js l))]
+           (when exception (.setException record exception))
+           (glog/publishLogRecord l record))))))
+
+#?(:clj
+   (defn enabled?
+     [logger level]
+     (.isEnabled ^Logger logger ^Level level)))
+
+(defmacro log
+  [& {:keys [level cause ::logger ::async ::raw] :as props}]
+  (if (:ns &env) ; CLJS
+    `(write-log! ~(or logger (str *ns*))
+                 ~level
+                 ~cause
+                 ~(dissoc props :level :cause ::logger ::raw))
+    (let [props      (dissoc props :level :cause ::logger ::async ::raw)
+          logger     (or logger (str *ns*))
+          logger-sym (gensym "log")
+          level-sym  (gensym "log")]
+      `(let [~logger-sym (get-logger ~logger)
+             ~level-sym  (get-level ~level)]
+         (if (enabled? ~logger-sym ~level-sym)
+           ~(if async
+              `(send-off logging-agent
+                         (fn [_#]
+                           (let [message# (or ~raw (build-map-message ~props))]
+                             (write-log! ~logger-sym ~level-sym ~cause message#))))
+              `(let [message# (or ~raw (build-map-message ~props))]
+                 (write-log! ~logger-sym ~level-sym ~cause message#))))))))
+
+(defmacro info
+  [& params]
+  `(log :level :info ~@params))
+
+(defmacro error
+  [& params]
+  `(log :level :error ~@params))
+
+(defmacro warn
+  [& params]
+  `(log :level :warn ~@params))
+
+(defmacro debug
+  [& params]
+  `(log :level :debug ~@params))
+
+(defmacro trace
+  [& params]
+  `(log :level :trace ~@params))
+
+(defmacro set-level!
+  ([level]
+   (when (:ns &env)
+     `(set-level* ~(str *ns*) ~level)))
+  ([n level]
+   (when (:ns &env)
+     `(set-level* ~n ~level))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; CLJ Specific
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+#?(:clj
+   (defn update-thread-context!
+     [data]
+     (run! (fn [[key val]]
+             (ThreadContext/put
+              (name key)
+              (cond
+                (coll? val)
+                (binding [clojure.pprint/*print-right-margin* 120]
+                  (with-out-str (pprint val)))
+                (instance? clojure.lang.Named val) (name val)
+                :else (str val))))
+           data)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; CLJS Specific
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+#?(:cljs
+   (def ^:private colors
+     {:gray3  "#8e908c"
+      :gray4  "#969896"
+      :gray5  "#4d4d4c"
+      :gray6  "#282a2e"
+      :black  "#1d1f21"
+      :red    "#c82829"
+      :blue   "#4271ae"
+      :orange "#f5871f"}))
+
+#?(:cljs
+   (defn- level->color
+     [level]
+     (letfn [(get-level-value [l] (.-value ^js (get-level l)))]
+       (condp <= (get-level-value level)
+         (get-level-value :error) (get colors :red)
+         (get-level-value :warn)  (get colors :orange)
+         (get-level-value :info)  (get colors :blue)
+         (get-level-value :debug) (get colors :gray4)
+         (get-level-value :trace) (get colors :gray3)
+         (get colors :gray2)))))
+
+#?(:cljs
+   (defn- level->short-name
+     [l]
+     (case l
+       :fine "DBG"
+       :debug "DBG"
+       :finer "TRC"
+       :trace "TRC"
+       :info "INF"
+       :warn "WRN"
+       :warning "WRN"
+       :error "ERR"
+       (subs (.-name ^js (get-level l)) 0 3))))
+
+#?(:cljs
+   (defn set-level*
+     "Set the level (a keyword) of the given logger, identified by name."
+     [name lvl]
+     (some-> (get-logger name)
+             (glog/setLevel (get-level lvl)))))
+
+
+#?(:cljs
+   (defn set-levels!
+     [lvls]
+     (doseq [[logger level] lvls
+             :let [level (if (string? level) (keyword level) level)]]
+       (set-level* logger level))))
+
+#?(:cljs
+   (defn- prepare-message
+     [message]
+     (loop [kvpairs (seq message)
+            message (array-map)
+            specials []]
+       (if (nil? kvpairs)
+         [message specials]
+         (let [[k v] (first kvpairs)]
+           (cond
+             (= k :err)
+             (recur (next kvpairs)
+                    message
+                    (conj specials [:error nil v]))
+
+             (and (qualified-ident? k)
+                  (= "js" (namespace k)))
+             (recur (next kvpairs)
+                    message
+                    (conj specials [:js (name k) (if (object? v) v (clj->js v))]))
+
+             :else
+             (recur (next kvpairs)
+                    (assoc message k v)
+                    specials)))))))
+
+#?(:cljs
+   (defn default-handler
+     [{:keys [message level logger-name]}]
+     (let [header-styles (str "font-weight: 600; color: " (level->color level))
+           normal-styles (str "font-weight: 300; color: " (get colors :gray6))
+           level-name    (level->short-name level)
+           header        (str "%c" level-name " [" logger-name "] ")]
+
+       (if (string? message)
+         (let [message (str header "%c" message)]
+           (js/console.log message header-styles normal-styles))
+         (let [[message specials] (prepare-message message)]
+           (if (seq specials)
+             (let [message (str header "%c" (pr-str message))]
+               (js/console.group message header-styles normal-styles)
+               (doseq [[type n v] specials]
+                 (case type
+                   :js (js/console.log n v)
+                   :error (if (ex/ex-info? v)
+                            (js/console.error (pr-str v))
+                            (js/console.error v))))
+               (js/console.groupEnd message))
+             (let [message (str header "%c" (pr-str message))]
+               (js/console.log message header-styles normal-styles))))))))
+
+#?(:cljs
+   (defn record->map
+     [^js record]
+     {:seqn (.-sequenceNumber_ record)
+      :time (.-time_ record)
+      :level (keyword (str/lower (.-name (.-level_ record))))
+      :message (.-msg_ record)
+      :logger-name (.-loggerName_ record)
+      :exception (.-exception_ record)}))
+
+#?(:cljs
+   (defonce default-console-handler
+     (comp default-handler record->map)))
+
+#?(:cljs
+   (defn initialize!
+     []
+     (let [l (get-logger :root)]
+       (glog/removeHandler l default-console-handler)
+       (glog/addHandler l default-console-handler)
+       nil)))
+
+

common/src/app/common/math.cljc

@@ -72,17 +72,24 @@
   [v]
   (* v v))
 
+(defn pow
+  "Returns the base to the exponent power."
+  [b e]
+  #?(:cljs (js/Math.pow b e)
+     :clj (Math/pow b e)))
+
 (defn sqrt
   "Returns the square root of a number."
   [v]
   #?(:cljs (js/Math.sqrt v)
      :clj (Math/sqrt v)))
 
-(defn pow
-  "Returns the base to the exponent power."
-  [b e]
-  #?(:cljs (js/Math.pow b e)
-     :clj (Math/pow b e)))
+(defn cubicroot
+  "Returns the cubic root of a number"
+  [v]
+  (if (pos? v)
+    (pow v (/ 1 3))
+    (- (pow (- v) (/ 1 3)))))
 
 (defn floor
   "Returns the largest integer less than or
@@ -143,7 +150,7 @@
     (if (> num to) to num)))
 
 (defn almost-zero? [num]
-  (< (abs num) 1e-8))
+  (< (abs (double num)) 1e-5))
 
 (defonce float-equal-precision 0.001)
 
@@ -151,3 +158,9 @@
   "Equality for float numbers. Check if the difference is within a range"
   [num1 num2]
   (<= (abs (- num1 num2)) float-equal-precision))
+
+(defn lerp
+  "Calculates a the linear interpolation between two values and a given percent"
+  [v0 v1 t]
+  (+ (* (- 1 t) v0)
+     (* t       v1)))

common/src/app/common/pages.cljc

@@ -40,9 +40,11 @@
 (d/export helpers/get-children)
 (d/export helpers/get-children-objects)
 (d/export helpers/get-object-with-children)
+(d/export helpers/select-children)
 (d/export helpers/is-shape-grouped)
 (d/export helpers/get-parent)
 (d/export helpers/get-parents)
+(d/export helpers/get-frame)
 (d/export helpers/clean-loops)
 (d/export helpers/calculate-invalid-targets)
 (d/export helpers/valid-frame-target)
@@ -66,13 +68,14 @@
 (d/export helpers/merge-path-item)
 (d/export helpers/compact-path)
 (d/export helpers/compact-name)
+(d/export helpers/unframed-shape?)
 
 ;; Indices
 (d/export indices/calculate-z-index)
 (d/export indices/update-z-index)
 (d/export indices/generate-child-all-parents-index)
 (d/export indices/generate-child-parent-index)
-(d/export indices/create-mask-index)
+(d/export indices/create-clip-index)
 
 ;; Process changes
 (d/export changes/process-changes)