Merge branch 'staging'

.clj-kondo/config.edn

@@ -17,6 +17,7 @@
  {:exclude-files
   ["data_readers.clj"
    "app/util/perf.cljs"
+   "app/common/logging.cljc"
    "app/common/exceptions.cljc"]}
 
  :linters

.gitignore

@@ -39,3 +39,7 @@ node_modules
 /web
 /_dump
 /vendor/svgclean/bundle*.js
+
+.calva
+.clj-kondo
+.lsp

CHANGES.md

@@ -1,31 +1,91 @@
 # CHANGELOG
 
+
 ## :rocket: Next
 
 ### :boom: Breaking changes
 ### :sparkles: New features
 ### :bug: Bugs fixed
 ### :arrow_up: Deps updates
-### :boom: Breaking changes
 ### :heart: Community contributions by (Thank you!)
 
+
+## 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)
+- 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
+- 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)
+- Fix problem with masking images in viewer [#1238](https://github.com/penpot/penpot/issues/1238).
 
 ## 1.8.1-alpha
 

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"}
+  io.lettuce/lettuce-core {:mvn/version "6.1.5.RELEASE"}
-  java-http-clj/java-http-clj {:mvn/version "0.4.2"}
+  java-http-clj/java-http-clj {:mvn/version "0.4.3"}
 
-  info.sunng/ring-jetty9-adapter {:mvn/version "0.15.1"}
+  info.sunng/ring-jetty9-adapter {:mvn/version "0.15.2"}
-  com.github.seancorfield/next.jdbc {:mvn/version "1.2.659"}
+  com.github.seancorfield/next.jdbc {:mvn/version "1.2.709"}
-  metosin/reitit-ring {:mvn/version "0.5.13"}
+  metosin/reitit-ring {:mvn/version "0.5.15"}
-  org.postgresql/postgresql {:mvn/version "42.2.20"}
+  org.postgresql/postgresql {:mvn/version "42.2.23"}
-  com.zaxxer/HikariCP {:mvn/version "4.0.3"}
+  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,7 +61,8 @@
    {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"}}
@@ -66,13 +73,13 @@
    :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/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

@@ -10,6 +10,23 @@ if [ ! -e ~/.fixtures-loaded ]; then
     touch ~/.fixtures-loaded
 fi
 
+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
+
 
 

backend/src/app/cli/fixtures.clj

@@ -7,13 +7,13 @@
 (ns app.cli.fixtures
   "A initial fixtures."
   (:require
+   [app.common.logging :as l]
    [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]))
 

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 ::flags ::us/words)
-(s/def ::audit-archive-enabled ::us/boolean)
+
-(s/def ::audit-archive-uri ::us/string)
+;; DEPRECATED PROPERTIES: should be removed in 1.10
-(s/def ::audit-archive-gc-enabled ::us/boolean)
+(s/def ::registration-enabled ::us/boolean)
-(s/def ::audit-archive-gc-max-age ::dt/duration)
+(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 ::user-feedback-destination ::us/string)
-(s/def ::feedback-enabled ::us/boolean)
-(s/def ::feedback-token ::us/string)
 (s/def ::github-client-id ::us/string)
 (s/def ::github-client-secret ::us/string)
 (s/def ::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-log-archive-uri
-                   ::audit-archive-enabled
+                   ::audit-log-gc-max-age
-                   ::audit-archive-uri
-                   ::audit-archive-gc-enabled
-                   ::audit-archive-gc-max-age
-                   ::asserts-enabled
                    ::database-password
                    ::database-uri
                    ::database-username
                    ::default-blob-version
                    ::error-report-webhook
-                   ::feedback-destination
+                   ::user-feedback-destination
-                   ::feedback-enabled
-                   ::feedback-token
                    ::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,27 @@
                    ::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]))
 
+(defn- parse-flags
+  [config]
+  (-> (:flags config)
+      (flags/parse flags/default)))
+
 (defn read-env
   [prefix]
   (let [prefix (str prefix "-")
@@ -304,11 +299,14 @@
         (println ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;")))
       (throw e))))
 
-(def version (v/parse (or (some-> (io/resource "version.txt")
+(def version
+  (v/parse (or (some-> (io/resource "version.txt")
                        (slurp)
                        (str/trim))
                "%version%")))
-(def config (atom (read-config)))
+
+(def ^:dynamic config (read-config))
+(def ^:dynamic flags  (parse-flags config))
 
 (def deletion-delay
   (dt/duration {:days 7}))
@@ -316,9 +314,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}]
+  [_ {:keys [migrations metrics name] :as cfg}]
-  (l/info :action "initialize connection pool"
+  (l/info :action "initialize connection pool" :name (d/name name) :uri (:uri cfg))
-          :name (d/name (:name cfg))
+  (some-> metrics :registry instrument-jdbc!)
-          :uri (:uri cfg))
+
-  (instrument-jdbc! (:registry metrics))
   (let [pool (create-pool cfg)]
-    (when (seq migrations)
+    (some->> (seq migrations) (apply-migrations! pool))
-      (with-open [conn ^AutoCloseable (open pool)]
-        (mg/setup! conn)
-        (doseq [[name steps] migrations]
-          (mg/migrate! conn {:name (d/name name) :steps steps}))))
     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"
+  (str "SET statement_timeout = 200000;\n"
-       "SET idle_in_transaction_session_timeout = 120000;"))
+       "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.)
+        config   (HikariConfig.)]
-        mtf      (PrometheusMetricsTrackerFactory. (:registry metrics))]
     (doto config
       (.setJdbcUrl (str "jdbc:" dburi))
       (.setPoolName (d/name (:name cfg)))
       (.setAutoCommit true)
-      (.setReadOnly false)
+      (.setReadOnly read-only)
-      (.setConnectionTimeout 8000)  ;; 8seg
+      (.setConnectionTimeout 10000)  ;; 10seg
-      (.setValidationTimeout 8000)  ;; 8seg
+      (.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)

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)
+    (let [complaint-threshold (cf/get :profile-complaint-threshold)
-          complaint-max-age   (cfg/get :profile-complaint-max-age)
+          complaint-max-age   (cf/get :profile-complaint-max-age)
-          bounce-threshold    (cfg/get :profile-bounce-threshold)
+          bounce-threshold    (cf/get :profile-bounce-threshold)
-          bounce-max-age      (cfg/get :profile-bounce-max-age)
+          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 ::username ::cf/smtp-username)
-(s/def ::password ::cfg/smtp-password)
+(s/def ::password ::cf/smtp-password)
-(s/def ::tls ::cfg/smtp-tls)
+(s/def ::tls ::cf/smtp-tls)
-(s/def ::ssl ::cfg/smtp-ssl)
+(s/def ::ssl ::cf/smtp-ssl)
-(s/def ::host ::cfg/smtp-host)
+(s/def ::host ::cf/smtp-host)
-(s/def ::port ::cfg/smtp-port)
+(s/def ::port ::cf/smtp-port)
-(s/def ::default-reply-to ::cfg/smtp-default-reply-to)
+(s/def ::default-reply-to ::cf/smtp-default-reply-to)
-(s/def ::default-from ::cfg/smtp-default-from)
+(s/def ::default-from ::cf/smtp-default-from)
-(s/def ::enabled ::cfg/smtp-enabled)
 
 (defmethod ig/pre-init-spec ::sendmail-handler [_]
-  (s/keys :req-un [::enabled]
+  (s/keys :opt-un [::username
-          :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)
+    (let [enabled? (or (contains? cf/flags :smtp)
+                       (cf/get :smtp-enabled)
+                       (:enabled task))]
+      (if enabled?
         (emails/send! cfg props)
-      (send-console! 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]
@@ -141,7 +142,8 @@
     ["/webhooks"
      ["/sns" {:post (:sns-webhook cfg)}]]
 
-    ["/api" {:middleware [[middleware/etag]
+    ["/api" {:middleware [[middleware/cors]
+                          [middleware/etag]
                           [middleware/format-response-body]
                           [middleware/params]
                           [middleware/multipart-params]
@@ -150,6 +152,8 @@
                           [middleware/errors errors/handle]
                           [middleware/cookies]]}
 
+     ["/_doc" {:get (doc/handler rpc)}]
+
      ["/feedback" {:middleware [(:middleware session)]
                    :post feedback}]
      ["/auth/oauth/:provider" {:post (:handler oauth)}]

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 :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,49 @@
 (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]
+   [clojure.pprint]
-   [cuerdas.core :as str]
+   [cuerdas.core :as str]))
-   [expound.alpha :as expound]))
 
-(defn- explain-error
+(defn- parse-client-ip
-  [error]
+  [{:keys [headers] :as request}]
-  (with-out-str
+  (or (some-> (get headers "x-forwarded-for") (str/split ",") first)
-    (expound/printer (:data error))))
+      (get headers "x-real-ip")
+      (get request :remote-addr)))
+
+(defn- stringify-data
+  [data]
+  (binding [clojure.pprint/*print-right-margin* 200]
+    (let [result (with-out-str (clojure.pprint/pprint data))]
+      (str/prune result (* 1024 1024) "[...]"))))
 
 (defn get-error-context
   [request error]
-  (let [edata (ex-data error)]
+  (let [data (ex-data error)]
+    (d/without-nils
      (merge
-     {:id      (uuid/next)
+      {:id      (str (uuid/next))
-      :path    (:uri request)
+       :path    (str (:uri request))
-      :method  (:request-method request)
+       :method  (name (:request-method request))
-      :params  (:params request)
+       :hint    (or (:hint data) (ex-message error))
-      :data    edata}
+       :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 +61,6 @@
   [err _]
   {:status 401 :body (ex-data err)})
 
-
 (defmethod handle-exception :restriction
   [err _]
   {:status 400 :body (ex-data err)})
@@ -57,13 +74,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
+       :body   (dissoc edata :data)})))
-                 (map? (:data edata))
-                 (-> (assoc :explain (explain-error edata))
-                     (dissoc :data)))})))
 
 (defmethod handle-exception :assertion
   [error request]
@@ -77,9 +91,7 @@
     {:status 500
      :body {:type :server-error
             :code :assertion
-            :data (-> edata
+            :data (dissoc edata :data)}}))
-                      (assoc :explain (explain-error edata))
-                      (dissoc :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)
+  (let [ftoken   (cf/get :feedback-token ::no-token)
-        enabled  (cfg/get :feedback-enabled)]
+        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,7 +58,7 @@
 (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
                 :to       destination

backend/src/app/http/middleware.clj

@@ -6,10 +6,11 @@
 
 (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]
@@ -176,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]
@@ -62,6 +62,13 @@
                :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,8 +83,8 @@
           {: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)
@@ -138,15 +145,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 "utm_")
-                       (str/starts-with? sk "pm-")
+                   (assoc (->> sk str/kebab (keyword "penpot")) v))))
-                       (str/starts-with? sk "utm_"))
-                   (assoc (-> sk str/kebab keyword) v))))
              {}
              params))
 
@@ -210,7 +216,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,12 @@
 
 (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)]
+    (assoc response :cookies {cookie-name {:path "/"
+                                           :http-only true
+                                           :value id
+                                           :same-site (if cors? :none :strict)
+                                           :secure true}})))
 
 (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,7 +17,6 @@
    [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]
@@ -36,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
@@ -88,9 +89,9 @@
 (s/def ::events (s/every ::event))
 
 (defmethod ig/init-key ::http-handler
-  [_  {:keys [executor enabled] :as cfg}]
+  [_  {:keys [executor] :as cfg}]
-  (fn [{:keys [params _headers _cookies profile-id] :as request}]
+  (fn [{:keys [params profile-id] :as request}]
-    (when enabled
+    (when (contains? cf/flags :audit-log)
       (let [events  (->> (:events params)
                          (remove #(not= profile-id (:profile-id %)))
                          (us/conform ::events))
@@ -137,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
@@ -148,9 +148,9 @@
    (map clean-props)))
 
 (defmethod ig/init-key ::collector
-  [_ {:keys [enabled] :as cfg}]
+  [_ cfg]
-  (when enabled
+  (when (contains? cf/flags :audit-log)
-    (l/info :msg "intializing audit collector")
+    (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
@@ -204,15 +204,16 @@
 (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}]
+  [_ {: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 enabled (:enabled props false))
+    (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))
@@ -271,11 +272,12 @@
                            :headers headers
                            :body body}
                   resp    (http/send! params)]
-              (when (not= (:status resp) 204)
+              (if (= (:status resp) 204)
-                (ex/raise :type :internal
+                true
-                          :code :unable-to-send-events
+                (do
-                          :hint "unable to send events"
+                  (l/warn :hint "unable to archive events"
-                          :context resp))))
+                          :resp-status (:status resp))
+                  false))))
 
           (mark-as-archived [conn rows]
             (db/exec-one! conn ["update audit_log set archived_at=now() where id = ANY(?)"
@@ -290,26 +292,14 @@
             events (into [] xform rows)]
         (when-not (empty? events)
           (l/debug :action "archive-events" :uri uri :events (count events))
-          (send events)
+          (when (send events)
             (mark-as-archived conn rows)
-          :continue)))))
+            :continue))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; 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
@@ -322,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.logging :as l]
-   [app.common.spec :as us]
+   [app.config :as cf]
-   [app.common.uuid :as uuid]
-   [app.config :as cfg]
    [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]))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defonce enabled (atom true))
-;; Error Listener
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(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
@@ -44,8 +44,6 @@
       :help "A total number of bytes processed by update-file."
       :type :counter}}}
 
-
-
    :app.migrations/all
    {:main (ig/ref :app.migrations/migrations)}
 
@@ -109,7 +107,7 @@
     :sns-webhook (ig/ref :app.http.awsns/handler)
     :feedback    (ig/ref :app.http.feedback/handler)
     :audit-http-handler   (ig/ref :app.loggers.audit/http-handler)
-    :error-report-handler (ig/ref :app.loggers.mattermost/handler)}
+    :error-report-handler (ig/ref :app.loggers.database/handler)}
 
    :app.http.assets/handlers
    {:metrics           (ig/ref :app.metrics/metrics)
@@ -210,15 +208,16 @@
        {:cron #app/cron "0 0 * * * ?"  ;; hourly
         :task :file-offload})
 
-     (when (cf/get :audit-archive-enabled)
+     (when (contains? cf/flags :audit-log-archive)
        {:cron #app/cron "0 */3 * * * ?" ;; every 3m
-        :task :audit-archive})
+        :task :audit-log-archive})
 
-     (when (cf/get :audit-archive-gc-enabled)
+     (when (contains? cf/flags :audit-log-gc)
        {:cron #app/cron "0 0 0 * * ?" ;; daily
-        :task :audit-archive-gc})
+        :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})]}
 
@@ -227,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)
@@ -238,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-log-archive  (ig/ref :app.loggers.audit/archive-task)
-     :audit-archive-gc   (ig/ref :app.loggers.audit/archive-gc-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)
@@ -257,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}
@@ -304,24 +293,20 @@
    {:endpoint (cf/get :loggers-zmq-uri)}
 
    :app.loggers.audit/http-handler
-   {: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/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)
+   {:uri      (cf/get :audit-log-archive-uri)
-    :enabled  (cf/get :audit-archive-enabled false)
     :tokens   (ig/ref :app.tokens/tokens)
     :pool     (ig/ref :app.db/pool)}
 
-   :app.loggers.audit/archive-gc-task
+   :app.loggers.audit/gc-task
-   {:enabled  (cf/get :audit-archive-gc-enabled false)
+   {:max-age  (cf/get :audit-log-gc-max-age cf/deletion-delay)
-    :max-age  (cf/get :audit-archive-gc-max-age cf/deletion-delay)
     :pool     (ig/ref :app.db/pool)}
 
    :app.loggers.loki/reporter
@@ -335,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

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)

backend/src/app/rpc.clj

@@ -8,12 +8,12 @@
   (: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.services :as sv]
    [clojure.spec.alpha :as s]
    [cuerdas.core :as str]
@@ -97,6 +97,7 @@
         auth?  (:auth mdata true)]
 
     (l/trace :action "register" :name (::sv/name mdata))
+    (with-meta
       (fn [params]
 
         ;; Raise authentication error when rpc method requires auth but
@@ -119,14 +120,16 @@
                                  (::audit/profile-id resultm))
                   props      (d/merge params' (::audit/props resultm))]
               (audit :cmd :submit
-                   :type (::type cfg)
+                     :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)))
 
-        result))))
+          result))
+      mdata)))
 
 (defn- process-method
   [cfg vfn]
@@ -148,10 +151,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.fonts)
-                     'app.rpc.queries.svg)
          (map (partial process-method cfg))
          (into {}))))
 
@@ -170,7 +171,6 @@
                      '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

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

@@ -9,7 +9,7 @@
   (: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]
@@ -35,11 +35,11 @@
                   :email email
                   :fullname fullname
                   :is-demo true
-                  :deleted-at (dt/in-future cfg/deletion-delay)
+                  :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."))

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

@@ -9,14 +9,12 @@
    [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)
@@ -129,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,13 +7,13 @@
 (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]
    [app.loggers.audit :as audit]
    [app.rpc.mutations.profile :as profile-m]
    [app.rpc.queries.profile :as profile-q]
-   [app.util.logging :as l]
    [app.util.services :as sv]
    [clj-ldap.client :as ldap]
    [clojure.spec.alpha :as s]

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,7 +12,7 @@
    [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.metrics :as mtx]
@@ -100,10 +100,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
@@ -128,23 +127,16 @@
 ;; --- 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
+  (s/keys :req-un [::token ::fullname]))
-                   ::accept-terms-and-privacy]
-          :opt-un [::accept-newsletter-subscription]))
 
 (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)]
+    (-> (assoc cfg :conn conn)
-      (register-profile cfg params))))
+        (register-profile params))))
 
 (defn- annotate-profile-register
   "A helper for properly increase the profile-register metric once the
@@ -163,6 +155,7 @@
                        (create-profile conn)
                        (create-profile-relations conn)
                        (decode-profile-row))]
+
       (sid/load-initial-project! conn profile)
 
       (cond
@@ -204,7 +197,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)
@@ -224,18 +216,17 @@
   [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
+        locale    (:locale params)
-                    (and (string? locale) (not (str/blank? locale)) locale))
+        locale    (when (and (string? locale) (not (str/blank? locale)))
+                    locale)
 
         backend   (:backend params "penpot")
         is-demo   (:is-demo params false)
@@ -359,11 +350,14 @@
 
 (defn- update-profile
   [conn {:keys [id fullname lang theme] :as params}]
-  (db/update! conn :profile
+  (let [profile (db/update! conn :profile
                             {:fullname fullname
                              :lang lang
                              :theme theme}
-              {:id id}))
+                            {:id id})]
+    (-> profile
+        (profile/decode-profile-row)
+        (profile/strip-private-attrs))))
 
 (s/def ::update-profile
   (s/keys :req-un [::id ::fullname]
@@ -372,8 +366,9 @@
 (sv/defmethod ::update-profile
   [{:keys [pool] :as cfg} params]
   (db/with-atomic [conn pool]
-    (update-profile conn params)
+    (let [profile (update-profile conn params)]
-    nil))
+      (with-meta profile
+        {::audit/props (audit/profile->props profile)}))))
 
 ;; --- MUTATION: Update Password
 
@@ -458,7 +453,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)))))
 
@@ -591,11 +587,15 @@
   (db/with-atomic [conn pool]
     (let [profile (profile/retrieve-profile-data conn profile-id)
           props   (reduce-kv (fn [props k v]
+                               ;; We don't accept namespaced keys
+                               (if (simple-ident? k)
                                  (if (nil? v)
                                    (dissoc props k)
-                                 (assoc props k v)))
+                                   (assoc props k v))
+                                 props))
                              (:props profile)
                              props)]
+
       (db/update! conn :profile
                   {:props (db/tjson props)}
                   {:id profile-id})

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

@@ -31,6 +31,11 @@
           :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)

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

@@ -132,8 +132,8 @@
 (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)]
+    (let [perms (teams/get-permissions conn profile-id id)]
-      (when-not (some :is-owner perms)
+      (when-not (:is-owner perms)
         (ex/raise :type :validation
                   :code :only-owner-can-delete-team))
 
@@ -300,7 +300,7 @@
 (sv/defmethod ::invite-team-member
   [{:keys [pool tokens] :as cfg} {:keys [profile-id team-id email role] :as params}]
   (db/with-atomic [conn pool]
-    (let [perms    (teams/check-edition-permissions! conn profile-id team-id)
+    (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)
@@ -316,7 +316,7 @@
                            {:iss :profile-identity
                             :profile-id (:id profile)})]
 
-      (when-not (some :is-admin perms)
+      (when-not (:is-admin perms)
         (ex/raise :type :validation
                   :code :insufficient-permissions))
 

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

@@ -9,6 +9,7 @@
    [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]
@@ -63,7 +64,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}]
@@ -116,8 +120,7 @@
     ;; user is already logged in with some account.
     (and (uuid? profile-id)
          (uuid? member-id))
-    (do
+    (let [profile (accept-invitation cfg claims)]
-      (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
@@ -131,27 +134,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
+    (let [profile (accept-invitation cfg (assoc claims :member-id profile-id))]
-      (accept-invitation cfg (assoc claims :member-id profile-id))
+      (with-meta
-      (assoc claims :state :created))
+        (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
+    (let [profile (accept-invitation cfg claims)]
-      (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

@@ -41,59 +41,24 @@
   "A simple factory for edition permission predicate functions."
   [qfn]
   (us/assert fn? qfn)
-  (fn [& args]
+  (fn check
-    (let [rows (apply qfn args)]
+    ([perms] (:can-edit perms))
-      (when-not (or (empty? rows)
+    ([conn & args] (check (apply qfn conn args)))))
-                    (not (or (some :can-edit rows)
-                             (some :is-admin rows)
-                             (some :is-owner rows))))
-        rows))))
 
 (defn make-read-predicate-fn
   "A simple factory for read permission predicate functions."
   [qfn]
   (us/assert fn? qfn)
-  (fn [& args]
+  (fn check
-    (let [rows (apply qfn args)]
+    ([perms] (:can-read perms))
-      (when (seq rows)
+    ([conn & args] (check (apply qfn conn args)))))
-        rows))))
 
 (defn make-check-fn
   "Helper that converts a predicate permission function to a check
   function (function that raises an exception)."
   [pred]
   (fn [& args]
-    (when-not (seq (apply pred args))
+    (when-not (apply pred args)
       (ex/raise :type :not-found
                 :code :object-not-found
                 :hint "not found"))))
-
-
-;; TODO: the following functions are deprecated and replaced with the
-;; new ones. Should not be used.
-
-(defn make-edition-check-fn
-  "A simple factory for edition permission check 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))))
-
-(defn make-read-check-fn
-  "A simple factory for read permission check functions."
-  [qfn]
-  (us/assert fn? qfn)
-  (fn [& args]
-    (let [rows (apply qfn args)]
-      (if-not (seq rows)
-        (ex/raise :type :not-found
-                  :code :object-not-found)
-        rows))))

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,7 +60,7 @@
     where f.id = ?
       and ppr.profile_id = ?")
 
-(defn- retrieve-file-permissions
+(defn retrieve-file-permissions
   [conn profile-id file-id]
   (when (and profile-id file-id)
     (db/exec! conn [sql:file-permissions
@@ -67,11 +68,37 @@
                     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 retrieve-file-permissions))
+  (perms/make-edition-predicate-fn get-permissions))
 
 (def has-read-permissions?
-  (perms/make-read-predicate-fn retrieve-file-permissions))
+  (perms/make-read-predicate-fn get-permissions))
 
 (def check-edition-permissions!
   (perms/make-check-fn has-edit-permissions?))
@@ -79,7 +106,6 @@
 (def check-read-permissions!
   (perms/make-check-fn has-read-permissions?))
 
-
 ;; --- Query: Files search
 
 ;; TODO: this query need to a good refactor
@@ -131,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
@@ -201,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)]
+    (let [cfg   (assoc cfg :conn conn)
-      (check-edition-permissions! conn profile-id id)
+          perms (get-permissions conn profile-id id)]
-      (retrieve-file cfg id))))
+
+      (check-read-permissions! perms)
+      (some-> (retrieve-file cfg id)
+              (assoc :permissions perms)))))
 
 (s/def ::page
   (s/keys :req-un [::profile-id ::file-id]))
@@ -240,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])]
@@ -250,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,
@@ -336,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
@@ -90,7 +94,7 @@
       (ex/raise :type :not-found
                 :hint "Object doest not exists."))
 
-    profile))
+    (update profile :props filter-profile-props)))
 
 (def ^:private sql:profile-by-email
   "select p.* from profile as p

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
+  (let [rows     (db/exec! conn [sql:project-permissions
                                  project-id profile-id
-                  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
 

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,29 +10,17 @@
    [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: View Only Bundle
 
-(defn- decode-share-link-row
-  [row]
-  (-> row
-      (update :flags db/decode-pgarray #{})
-      (update :pages db/decode-pgarray #{})))
-
 (defn- retrieve-project
   [conn id]
   (db/get-by-id conn :project id {:columns [:id :name :team-id]}))
 
-(defn- retrieve-share-link
-  [{:keys [conn]} file-id id]
-  (some-> (db/get-by-params conn :share-link
-                            {:id id :file-id file-id}
-                            {:check-not-found false})
-          (decode-share-link-row)))
-
 (defn- retrieve-bundle
   [{:keys [conn] :as cfg} file-id]
   (let [file    (files/retrieve-file cfg file-id)
@@ -41,7 +29,7 @@
         users   (teams/retrieve-users conn (:team-id project))
 
         links   (->> (db/query conn :share-link {:file-id file-id})
-                     (mapv decode-share-link-row))
+                     (mapv slnk/decode-share-link-row))
 
         fonts   (db/query conn :team-font-variant
                           {:team-id (:team-id project)
@@ -64,8 +52,11 @@
   [{:keys [pool] :as cfg} {:keys [profile-id file-id share-id] :as params}]
   (db/with-atomic [conn pool]
     (let [cfg    (assoc cfg :conn conn)
-          bundle (retrieve-bundle cfg file-id)
+          slink  (slnk/retrieve-share-link conn file-id share-id)
-          slink  (retrieve-share-link cfg file-id share-id)]
+          perms  (files/get-permissions conn profile-id file-id share-id)
+
+          bundle (some-> (retrieve-bundle cfg file-id)
+                         (assoc :permissions perms))]
 
       ;; When we have neither profile nor share, we just return a not
       ;; found response to the user.
@@ -80,13 +71,6 @@
         (files/check-read-permissions! conn profile-id file-id))
 
       (cond-> bundle
-        ;; If we have current profile, put
-        (some? profile-id)
-        (as-> $ (let [edit? (boolean (files/has-edit-permissions? conn profile-id file-id))
-                      read? (boolean (files/has-read-permissions? conn profile-id file-id))]
-                  (-> (assoc $ :permissions {:read read? :edit edit?})
-                      (cond-> (not edit?) (dissoc :share-links)))))
-
         (some? slink)
         (assoc :share slink)
 
@@ -97,61 +81,3 @@
                                      (-> data
                                          (update :pages (fn [pages] (filterv #(contains? allowed-pages %) pages)))
                                          (update :pages-index (fn [index] (select-keys index allowed-pages)))))))))))
-
-;; --- Query: Viewer Bundle (by Page ID)
-
-;; DEPRECATED: should be removed in 1.9.x
-
-(declare check-shared-token!)
-(declare retrieve-shared-token)
-
-(s/def ::id ::us/uuid)
-(s/def ::page-id ::us/uuid)
-(s/def ::token ::us/string)
-
-(s/def ::viewer-bundle
-  (s/keys :req-un [::file-id ::page-id]
-          :opt-un [::profile-id ::token]))
-
-(sv/defmethod ::viewer-bundle {:auth false}
-  [{:keys [pool] :as cfg} {:keys [profile-id file-id page-id token] :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))
-
-          fonts   (db/query conn :team-font-variant
-                            {:team-id (:team-id project)
-                             :deleted-at nil})
-
-          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])))

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 {:check-not-found false})
-        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/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))
+  (let [[docs body]  (if (string? (first body))
-                            [(first body) (first (rest body)) (drop 2 body)]
+                       [(first body) (rest body)]
-                            [nil (first body) (rest body)])
+                       [nil body])
-        mdata (assoc mdata
+        [mdata body] (if (map? (first body))
+                       [(first body) (rest body)]
+                       [nil body])
+
+        [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))))
+         (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.common.logging :as l]
-   [app.util.logging :as l]
-   [app.util.services :as sv]
-   [clojure.spec.alpha :as s]
    [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 (nil? error))))
-        (t/is (true? (get-in result [:props :accept-newsletter-subscription])))
-        (t/is (true? (get-in result [:props :accept-terms-and-privacy])))))
     ))
 
 (t/deftest prepare-register-with-registration-disabled
-  (with-mocks [mock {:target 'app.config/get
+  (th/with-mocks {#'app.config/flags nil}
-                     :return (th/mock-config-get-with
-                              {:registration-enabled false})}]
-
     (let [data  {::th/type :prepare-register-profile
                  :email "user@example.com"
                  :password "foobar"}]

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
@@ -133,7 +136,6 @@
                 :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/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]
@@ -336,9 +337,15 @@
   [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]

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,76 @@
   (-> 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]))
+
+(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)
+  (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]} (read-action-opts interaction-src)
+
+        interactions (-> (lookup-shape file from-id)
                          :interactions
-                          (filterv #(or (not= (:action-type %) action-type)
-                                        (not= (:event-type %) event-type))))
-        interactions (-> interactions
                          (conjv
-                          {:action-type action-type
+                          (d/without-nils {:event-type event-type
-                           :event-type event-type
+                                           :action-type action-type
-                           :destination destination}))]
+                                           :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})))]
     (commit-change
      file
      {:type :mod-obj

common/src/app/common/flags.cljc

@@ -9,8 +9,15 @@
   (:require
    [cuerdas.core :as str]))
 
+(def default
+  #{:backend-asserts
+    :api-doc
+    :registration
+    :demo-users})
+
 (defn parse
-  [default flags]
+  ([flags] (parse flags #{}))
+  ([flags default]
    (loop [flags  (seq flags)
           result default]
      (let [item (first flags)]
@@ -27,6 +34,6 @@
                     (disj result (keyword (subs sname 8))))
 
              :else
-            (recur (rest flags) result)))))))
+             (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
+(defn lerp
-  "Given a line with two points p1-p2 and a 'percent'. Returns the point in the vector
+  "Calculates a linear interpolation between two points given a tvalue"
-  generated by these two points. For example: for p1=(0,0) p2=(1,1) and v=0.25 will return
+  [p1 p2 t]
-  the point (0.25, 0.25)"
+  (let [x (mth/lerp (:x p1) (:x p2) t)
-  [p1 p2 v]
+        y (mth/lerp (:y p1) (:y p2) t)]
-  (let [v (-> (to-vec p1 p2)
+    (point x y)))
-              (scale v))]
-    (add p1 v)))
-
 
 (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

@@ -284,12 +284,19 @@
 (defn overlaps?
   "General case to check for overlaping between shapes and a rectangle"
   [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))))))
+               (or (not circle?) (overlaps-ellipse? shape rect)))))))
 
 (defn has-point-rect?
   [rect point]
@@ -308,3 +315,4 @@
   (->> shape
        :points
        (every? (partial has-point-rect? rect))))
+

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

@@ -7,24 +7,80 @@
 (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))
 
+  ([start end h1 h2 t]
    (let [t2 (* t t) ;; t square
          t3 (* t2 t) ;; t cube
 
@@ -39,65 +95,188 @@
                       (* (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)
+  ([start end h1 h2 t]
-        p2 (gpt/line-val h1 h2 t)
+   (let [p1 (gpt/lerp start h1 t)
-        p3 (gpt/line-val h2 end t)
+         p2 (gpt/lerp h1 h2 t)
-        p4 (gpt/line-val p1 p2 t)
+         p3 (gpt/lerp h2 end t)
-        p5 (gpt/line-val p2 p3 t)
+         p4 (gpt/lerp p1 p2 t)
-        sp (gpt/line-val p4 p5 t)]
+         p5 (gpt/lerp p2 p3 t)
+         sp (gpt/lerp p4 p5 t)]
      [[start sp  p1 p4]
-     [sp    end p5 p3]]))
+      [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
+  "Calculates the extremities by solving the first derivative for a cubic
-  if we calculate its values for x, y we can find a bounding box for the curve."
+  bezier and then solving the quadratic formula"
-  [start end h1 h2]
+  ([[start end h1 h2]]
+   (curve-extremities start end h1 h2))
+
+  ([start end h1 h2]
 
    (let [coords [[(:x start) (:x h1) (:x h2) (:x end)]
                  [(:y start) (:y h1) (:y h2) (:y end)]]
 
          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))
+                 c (+ (*  3 c1) (*  -3 c0))]
 
-                sqrt-b2-4ac (mth/sqrt (- (* b b) (* 4 a c)))]
+             (solve-roots a b c)))]
-
-            (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)]
-
-              ;; 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))]
-
-              ;; If a and b close to zero we can't find a root for a constant term
-              :else
-              [])))]
      (->> coords
           (mapcat coord->tvalue)
 
           ;; Only values in the range [0, 1] are valid
-         (filter #(and (>= % 0) (<= % 1)))
+          (filterv #(and (> % 0.01) (< % 0.99)))))))
 
-         ;; Pass t-values to actual points
+(defn curve-roots
-         (map #(curve-values start end h1 h2 %)))
+  "Uses cardano algorithm to find the roots for a cubic bezier"
-    ))
+  ([[start end h1 h2] coord]
+   (curve-roots start end h1 h2 coord))
+
+  ([start end h1 h2 coord]
+
+   (let [coords [[(get start coord) (get h1 coord) (get h2 coord) (get end coord)]]
+
+         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)
+                       (let [curve [(command->point prev)
                                     (command->point command)
                                     (command->point command :c1)
-                                          (command->point command :c2)))
+                                    (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,7 +530,8 @@
   "Given a path and a position"
   [shape position]
 
-  (let [point+distance (fn [[cur-cmd prev-cmd]]
+  (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])
@@ -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 (gco/transform-points transform))
-  (let [points (-> shape :points (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])
+  (let [rx (or (get-in modifiers [:resize-vector :x])
-        ry (get-in modifiers [:resize-vector :y])]
+               (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 -))
@@ -517,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)
 
@@ -544,15 +533,19 @@
 
         transformed-parent-rect (-> parent-rect
                                     (gpr/rect->points)
-                                    (transform-points parent-displacement)
+                                    (gco/transform-points parent-displacement)
-                                    (transform-points parent-origin (gmt/scale-matrix parent-vector))
+                                    (gco/transform-points parent-origin (gmt/scale-matrix parent-vector))
-                                    (transform-points parent-origin-2 (gmt/scale-matrix parent-vector-2))
+                                    (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-h (if-not ignore-constraints
-        constraints-v (get child :constraints-v (spec/default-constraints-v child))
+                        (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
@@ -692,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
+(defn cubicroot
-  "Returns the base to the exponent power."
+  "Returns the cubic root of a number"
-  [b e]
+  [v]
-  #?(:cljs (js/Math.pow b e)
+  (if (pos? v)
-     :clj (Math/pow b e)))
+    (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)

common/src/app/common/pages/changes.cljc

@@ -9,6 +9,7 @@
    [app.common.data :as d]
    [app.common.exceptions :as ex]
    [app.common.geom.shapes :as gsh]
+   [app.common.geom.shapes.bool :as gshb]
    [app.common.pages.common :refer [component-sync-attrs]]
    [app.common.pages.helpers :as cph]
    [app.common.pages.init :as init]
@@ -156,7 +157,7 @@
                     (sequence (comp
                                (mapcat #(cons % (cph/get-parents % objects)))
                                (map #(get objects %))
-                               (filter #(= (:type %) :group))
+                               (filter #(contains? #{:group :bool} (:type %)))
                                (map :id)
                                (distinct))
                               shapes)))
@@ -177,6 +178,9 @@
                 (empty? children)
                 group
 
+                (= :bool (:type group))
+                (gshb/update-bool-selrect group children objects)
+
                 (:masked-group? group)
                 (set-mask-selrect group children)
 

common/src/app/common/pages/changes_builder.cljc

@@ -0,0 +1,167 @@
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; License, v. 2.0. If a copy of the MPL was not distributed with this
+;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.common.pages.changes-builder
+  (:require
+   [app.common.data :as d]
+   [app.common.pages :as cp]
+   [app.common.pages.helpers :as h]))
+
+;; Auxiliary functions to help create a set of changes (undo + redo)
+
+(defn empty-changes [origin page-id]
+  (let [changes {:redo-changes []
+                 :undo-changes []
+                 :origin origin}]
+    (with-meta changes
+      {::page-id page-id})))
+
+(defn with-objects [changes objects]
+  (vary-meta changes assoc ::objects objects))
+
+(defn add-obj
+  ([changes obj index]
+   (add-obj changes (assoc obj ::index index)))
+
+  ([changes obj]
+   (let [add-change
+         {:type      :add-obj
+          :id        (:id obj)
+          :page-id   (::page-id (meta changes))
+          :parent-id (:parent-id obj)
+          :frame-id  (:frame-id obj)
+          :index     (::index obj)
+          :obj       (dissoc obj ::index :parent-id)}
+
+         del-change
+         {:type :del-obj
+          :id (:id obj)
+          :page-id (::page-id (meta changes))}]
+
+     (-> changes
+         (update :redo-changes conj add-change)
+         (update :undo-changes d/preconj del-change)))))
+
+(defn change-parent
+  [changes parent-id shapes]
+  (assert (contains? (meta changes) ::objects) "Call (with-objects) first to use this function")
+
+  (let [objects (::objects (meta changes))
+        set-parent-change
+        {:type :mov-objects
+         :parent-id parent-id
+         :page-id (::page-id (meta changes))
+         :shapes (->> shapes (mapv :id))}
+
+        mk-undo-change
+        (fn [change-set shape]
+          (d/preconj
+           change-set
+           {:type :mov-objects
+            :page-id (::page-id (meta changes))
+            :parent-id (:parent-id shape)
+            :shapes [(:id shape)]
+            :index (cp/position-on-parent (:id shape) objects)}))]
+
+    (-> changes
+        (update :redo-changes conj set-parent-change)
+        (update :undo-changes #(reduce mk-undo-change % shapes)))))
+
+(defn- generate-operation
+  "Given an object old and new versions and an attribute will append into changes
+  the set and undo operations"
+  [changes attr old new ignore-geometry?]
+  (let [old-val (get old attr)
+        new-val (get new attr)]
+    (if (= old-val new-val)
+      changes
+      (-> changes
+          (update :rops conj {:type :set :attr attr :val new-val :ignore-geometry ignore-geometry?})
+          (update :uops conj {:type :set :attr attr :val old-val :ignore-touched true})))))
+
+(defn update-shapes
+  "Calculate the changes and undos to be done when a function is applied to a
+  single object"
+  ([changes ids update-fn]
+   (update-shapes changes ids update-fn nil))
+
+  ([changes ids update-fn {:keys [attrs ignore-geometry?] :or {attrs nil ignore-geometry? false}}]
+   (assert (contains? (meta changes) ::objects) "Call (with-objects) first to use this function")
+   (let [objects (::objects (meta changes))
+
+         update-shape
+         (fn [changes id]
+           (let [old-obj (get objects id)
+                 new-obj (update-fn old-obj)
+
+                 attrs (or attrs (d/concat #{} (keys old-obj) (keys new-obj)))
+
+                 {rops :rops uops :uops}
+                 (reduce #(generate-operation %1 %2 old-obj new-obj ignore-geometry?)
+                         {:rops [] :uops []}
+                         attrs)
+
+                 uops (cond-> uops
+                        (seq uops)
+                        (conj {:type :set-touched :touched (:touched old-obj)}))
+
+                 change {:type :mod-obj
+                         :page-id (::page-id (meta changes))
+                         :id id}]
+
+             (cond-> changes
+               (seq rops)
+               (update :redo-changes conj (assoc change :operations rops))
+
+               (seq uops)
+               (update :undo-changes d/preconj (assoc change :operations uops)))))]
+
+     (reduce update-shape changes ids))))
+
+(defn remove-objects
+  [changes ids]
+  (assert (contains? (meta changes) ::objects) "Call (with-objects) first to use this function")
+  (let [page-id (::page-id (meta changes))
+        objects (::objects (meta changes))
+
+        add-redo-change
+        (fn [change-set id]
+          (conj change-set
+                {:type :del-obj
+                 :page-id page-id
+                 :id id}))
+
+        add-undo-change-shape
+        (fn [change-set id]
+          (let [shape (get objects id)]
+            (d/preconj
+             change-set
+             {:type :add-obj
+              :page-id page-id
+              :parent-id (:frame-id shape)
+              :frame-id (:frame-id shape)
+              :id id
+              :obj (cond-> shape
+                     (contains? shape :shapes)
+                     (assoc :shapes []))})))
+
+        add-undo-change-parent
+        (fn [change-set id]
+          (let [shape (get objects id)]
+            (d/preconj
+             change-set
+             {:type :mov-objects
+              :page-id page-id
+              :parent-id (:parent-id shape)
+              :shapes [id]
+              :index (h/position-on-parent id objects)
+              :ignore-touched true})))]
+
+    (-> changes
+        (update :redo-changes #(reduce add-redo-change % ids))
+        (update :undo-changes #(as-> % $
+                                 (reduce add-undo-change-parent $ ids)
+                                 (reduce add-undo-change-shape $ ids))))))

common/src/app/common/pages/helpers.cljc

@@ -9,6 +9,7 @@
    [app.common.data :as d]
    [app.common.geom.shapes :as gsh]
    [app.common.spec :as us]
+   [app.common.types.interactions :as cti]
    [app.common.uuid :as uuid]
    [cuerdas.core :as str]))
 
@@ -138,6 +139,10 @@
   [id objects]
   (mapv #(get objects %) (cons id (get-children id objects))))
 
+(defn select-children [id objects]
+  (->> (get-children id objects)
+       (select-keys objects)))
+
 (defn is-shape-grouped
   "Checks if a shape is inside a group"
   [shape-id objects]
@@ -161,6 +166,12 @@
     (when parent-id
       (lazy-seq (cons parent-id (get-parents parent-id objects))))))
 
+(defn get-frame
+  "Get the frame that contains the shape. If the shape is already a frame, get itself."
+  [shape objects]
+  (if (= (:type shape) :frame)
+    shape
+    (get objects (:frame-id shape))))
 
 (defn clean-loops
   "Clean a list of ids from circular references."
@@ -466,3 +477,17 @@
   (let [path-split (split-path path)]
     (merge-path-item (first path-split) name)))
 
+(defn connected-frame?
+  "Check if some frame is origin or destination of any navigate interaction
+  in the page"
+  [frame-id objects]
+  (let [children (get-object-with-children frame-id objects)]
+    (or (some cti/flow-origin? (map :interactions children))
+        (some #(cti/flow-to? % frame-id) (map :interactions (vals objects))))))
+
+(defn unframed-shape?
+  "Checks if it's a non-frame shape in the top level."
+  [shape]
+  (and (not= (:type shape) :frame)
+       (= (:frame-id shape) uuid/zero)))
+

common/src/app/common/pages/indices.cljc

@@ -95,16 +95,24 @@
           (map #(vector (:id %) (shape->parents %)))
           (into {})))))
 
-(defn create-mask-index
+(defn create-clip-index
   "Retrieves the mask information for an object"
   [objects parents-index]
-  (let [retrieve-masks
+  (let [retrieve-clips
         (fn [_ parents]
-          ;; TODO: use transducers?
+          (let [lookup-object (fn [id] (get objects id))
-          (->> parents
+                get-clip-parents
-               (map #(get objects %))
+                (fn [shape]
-               (filter #(:masked-group? %))
+                  (cond-> []
-               ;; Retrieve the masking element
+                    (:masked-group? shape)
-               (mapv #(get objects (->> % :shapes first)))))]
+                    (conj (get objects (->> shape :shapes first)))
+
+                    (= :bool (:type shape))
+                    (conj shape)))]
+
+            (into []
+                  (comp (map lookup-object)
+                        (mapcat get-clip-parents))
+                  parents)))]
     (->> parents-index
-         (d/mapm retrieve-masks))))
+         (d/mapm retrieve-clips))))

common/src/app/common/pages/spec.cljc

@@ -9,6 +9,8 @@
    [app.common.geom.matrix :as gmt]
    [app.common.geom.point :as gpt]
    [app.common.spec :as us]
+   [app.common.types.interactions :as cti]
+   [app.common.types.page-options :as cto]
    [app.common.uuid :as uuid]
    [clojure.set :as set]
    [clojure.spec.alpha :as s]))
@@ -30,9 +32,6 @@
 (s/def ::component-root? boolean?)
 (s/def ::shape-ref uuid?)
 
-(s/def ::safe-integer ::us/safe-integer)
-(s/def ::safe-number ::us/safe-number)
-
 (s/def :internal.matrix/a ::us/safe-number)
 (s/def :internal.matrix/b ::us/safe-number)
 (s/def :internal.matrix/c ::us/safe-number)
@@ -61,15 +60,15 @@
 ;; GRADIENTS
 
 (s/def :internal.gradient.stop/color ::string)
-(s/def :internal.gradient.stop/opacity ::safe-number)
+(s/def :internal.gradient.stop/opacity ::us/safe-number)
-(s/def :internal.gradient.stop/offset ::safe-number)
+(s/def :internal.gradient.stop/offset ::us/safe-number)
 
 (s/def :internal.gradient/type #{:linear :radial})
-(s/def :internal.gradient/start-x ::safe-number)
+(s/def :internal.gradient/start-x ::us/safe-number)
-(s/def :internal.gradient/start-y ::safe-number)
+(s/def :internal.gradient/start-y ::us/safe-number)
-(s/def :internal.gradient/end-x ::safe-number)
+(s/def :internal.gradient/end-x ::us/safe-number)
-(s/def :internal.gradient/end-y ::safe-number)
+(s/def :internal.gradient/end-y ::us/safe-number)
-(s/def :internal.gradient/width ::safe-number)
+(s/def :internal.gradient/width ::us/safe-number)
 
 (s/def :internal.gradient/stop
   (s/keys :req-un [:internal.gradient.stop/color
@@ -95,7 +94,7 @@
 (s/def :internal.color/path (s/nilable ::string))
 (s/def :internal.color/value (s/nilable ::string))
 (s/def :internal.color/color (s/nilable ::string))
-(s/def :internal.color/opacity (s/nilable ::safe-number))
+(s/def :internal.color/opacity (s/nilable ::us/safe-number))
 (s/def :internal.color/gradient (s/nilable ::gradient))
 
 (s/def ::color
@@ -113,10 +112,10 @@
 (s/def :internal.shadow/id uuid?)
 (s/def :internal.shadow/style #{:drop-shadow :inner-shadow})
 (s/def :internal.shadow/color ::color)
-(s/def :internal.shadow/offset-x ::safe-number)
+(s/def :internal.shadow/offset-x ::us/safe-number)
-(s/def :internal.shadow/offset-y ::safe-number)
+(s/def :internal.shadow/offset-y ::us/safe-number)
-(s/def :internal.shadow/blur ::safe-number)
+(s/def :internal.shadow/blur ::us/safe-number)
-(s/def :internal.shadow/spread ::safe-number)
+(s/def :internal.shadow/spread ::us/safe-number)
 (s/def :internal.shadow/hidden boolean?)
 
 (s/def :internal.shadow/shadow
@@ -137,7 +136,7 @@
 
 (s/def :internal.blur/id uuid?)
 (s/def :internal.blur/type #{:layer-blur})
-(s/def :internal.blur/value ::safe-number)
+(s/def :internal.blur/value ::us/safe-number)
 (s/def :internal.blur/hidden boolean?)
 
 (s/def ::blur
@@ -146,57 +145,6 @@
                    :internal.blur/value
                    :internal.blur/hidden]))
 
-;; Page Options
-(s/def :internal.page.grid.color/value string?)
-(s/def :internal.page.grid.color/opacity ::safe-number)
-
-(s/def :internal.page.grid/size ::safe-integer)
-(s/def :internal.page.grid/color
-  (s/keys :req-un [:internal.page.grid.color/value
-                   :internal.page.grid.color/opacity]))
-
-(s/def :internal.page.grid/type #{:stretch :left :center :right})
-(s/def :internal.page.grid/item-length (s/nilable ::safe-integer))
-(s/def :internal.page.grid/gutter (s/nilable ::safe-integer))
-(s/def :internal.page.grid/margin (s/nilable ::safe-integer))
-
-(s/def :internal.page.grid/square
-  (s/keys :req-un [:internal.page.grid/size
-                   :internal.page.grid/color]))
-
-(s/def :internal.page.grid/column
-  (s/keys :req-un [:internal.page.grid/size
-                   :internal.page.grid/color
-                   :internal.page.grid/type
-                   :internal.page.grid/item-length
-                   :internal.page.grid/gutter
-                   :internal.page.grid/margin]))
-
-(s/def :internal.page.grid/row :internal.page.grid/column)
-
-(s/def :internal.page.options/background string?)
-(s/def :internal.page.options/saved-grids
-  (s/keys :req-un [:internal.page.grid/square
-                   :internal.page.grid/row
-                   :internal.page.grid/column]))
-
-(s/def :internal.page/options
-  (s/keys :opt-un [:internal.page.options/background]))
-
-;; Interactions
-
-(s/def :internal.shape.interaction/event-type #{:click}) ; In the future we will have more options
-(s/def :internal.shape.interaction/action-type #{:navigate})
-(s/def :internal.shape.interaction/destination ::uuid)
-
-(s/def :internal.shape/interaction
-  (s/keys :req-un [:internal.shape.interaction/event-type
-                   :internal.shape.interaction/action-type
-                   :internal.shape.interaction/destination]))
-
-(s/def :internal.shape/interactions
-  (s/coll-of :internal.shape/interaction :kind vector?))
-
 ;; Size constraints
 
 (s/def :internal.shape/constraints-h #{:left :right :leftright :center :scale})
@@ -227,33 +175,33 @@
 (s/def :internal.shape/content any?)
 
 (s/def :internal.shape/fill-color string?)
-(s/def :internal.shape/fill-opacity ::safe-number)
+(s/def :internal.shape/fill-opacity ::us/safe-number)
 (s/def :internal.shape/fill-color-gradient (s/nilable ::gradient))
 (s/def :internal.shape/fill-color-ref-file (s/nilable uuid?))
 (s/def :internal.shape/fill-color-ref-id (s/nilable uuid?))
 
 (s/def :internal.shape/font-family string?)
-(s/def :internal.shape/font-size ::safe-integer)
+(s/def :internal.shape/font-size ::us/safe-integer)
 (s/def :internal.shape/font-style string?)
 (s/def :internal.shape/font-weight string?)
 (s/def :internal.shape/hidden boolean?)
-(s/def :internal.shape/letter-spacing ::safe-number)
+(s/def :internal.shape/letter-spacing ::us/safe-number)
-(s/def :internal.shape/line-height ::safe-number)
+(s/def :internal.shape/line-height ::us/safe-number)
 (s/def :internal.shape/locked boolean?)
 (s/def :internal.shape/page-id uuid?)
-(s/def :internal.shape/proportion ::safe-number)
+(s/def :internal.shape/proportion ::us/safe-number)
 (s/def :internal.shape/proportion-lock boolean?)
-(s/def :internal.shape/rx ::safe-number)
+(s/def :internal.shape/rx ::us/safe-number)
-(s/def :internal.shape/ry ::safe-number)
+(s/def :internal.shape/ry ::us/safe-number)
-(s/def :internal.shape/r1 ::safe-number)
+(s/def :internal.shape/r1 ::us/safe-number)
-(s/def :internal.shape/r2 ::safe-number)
+(s/def :internal.shape/r2 ::us/safe-number)
-(s/def :internal.shape/r3 ::safe-number)
+(s/def :internal.shape/r3 ::us/safe-number)
-(s/def :internal.shape/r4 ::safe-number)
+(s/def :internal.shape/r4 ::us/safe-number)
 (s/def :internal.shape/stroke-color string?)
 (s/def :internal.shape/stroke-color-gradient (s/nilable ::gradient))
 (s/def :internal.shape/stroke-color-ref-file (s/nilable uuid?))
 (s/def :internal.shape/stroke-color-ref-id (s/nilable uuid?))
-(s/def :internal.shape/stroke-opacity ::safe-number)
+(s/def :internal.shape/stroke-opacity ::us/safe-number)
 (s/def :internal.shape/stroke-style #{:solid :dotted :dashed :mixed :none :svg})
 
 (def stroke-caps-line #{:round :square})
@@ -266,26 +214,26 @@
   [shape]
   (= (:type shape) :path))
 
-(s/def :internal.shape/stroke-width ::safe-number)
+(s/def :internal.shape/stroke-width ::us/safe-number)
 (s/def :internal.shape/stroke-alignment #{:center :inner :outer})
 (s/def :internal.shape/text-align #{"left" "right" "center" "justify"})
-(s/def :internal.shape/x ::safe-number)
+(s/def :internal.shape/x ::us/safe-number)
-(s/def :internal.shape/y ::safe-number)
+(s/def :internal.shape/y ::us/safe-number)
-(s/def :internal.shape/cx ::safe-number)
+(s/def :internal.shape/cx ::us/safe-number)
-(s/def :internal.shape/cy ::safe-number)
+(s/def :internal.shape/cy ::us/safe-number)
-(s/def :internal.shape/width ::safe-number)
+(s/def :internal.shape/width ::us/safe-number)
-(s/def :internal.shape/height ::safe-number)
+(s/def :internal.shape/height ::us/safe-number)
 (s/def :internal.shape/index integer?)
 (s/def :internal.shape/shadow ::shadow)
 (s/def :internal.shape/blur ::blur)
 
-(s/def :internal.shape/x1 ::safe-number)
+(s/def :internal.shape/x1 ::us/safe-number)
-(s/def :internal.shape/y1 ::safe-number)
+(s/def :internal.shape/y1 ::us/safe-number)
-(s/def :internal.shape/x2 ::safe-number)
+(s/def :internal.shape/x2 ::us/safe-number)
-(s/def :internal.shape/y2 ::safe-number)
+(s/def :internal.shape/y2 ::us/safe-number)
 
 (s/def :internal.shape.export/suffix string?)
-(s/def :internal.shape.export/scale ::safe-number)
+(s/def :internal.shape.export/scale ::us/safe-number)
 (s/def :internal.shape/export
   (s/keys :req-un [::type
                    :internal.shape.export/suffix
@@ -361,7 +309,7 @@
                    :internal.shape/transform-inverse
                    :internal.shape/width
                    :internal.shape/height
-                   :internal.shape/interactions
+                   ::cti/interactions
                    :internal.shape/masked-group?
                    :internal.shape/shadow
                    :internal.shape/blur]))
@@ -386,7 +334,7 @@
 (s/def ::page
   (s/keys :req-un [::id
                    ::name
-                   :internal.page/options
+                   ::cto/options
                    :internal.page/objects]))
 
 
@@ -397,8 +345,8 @@
                    :internal.color/gradient]))
 
 (s/def :internal.media-object/name ::string)
-(s/def :internal.media-object/width ::safe-integer)
+(s/def :internal.media-object/width ::us/safe-integer)
-(s/def :internal.media-object/height ::safe-integer)
+(s/def :internal.media-object/height ::us/safe-integer)
 (s/def :internal.media-object/mtype ::string)
 
 (s/def ::media-object

common/src/app/common/path/bool.cljc

@@ -0,0 +1,309 @@
+;; 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.path.bool
+  (:require
+   [app.common.data :as d]
+   [app.common.geom.point :as gpt]
+   [app.common.geom.shapes.path :as gsp]
+   [app.common.geom.shapes.rect :as gpr]
+   [app.common.path.commands :as upc]
+   [app.common.path.subpaths :as ups]))
+
+(defn add-previous
+  ([content]
+   (add-previous content nil))
+  ([content first]
+   (->> (d/with-prev content)
+        (mapv (fn [[cmd prev]]
+                (cond-> cmd
+                  (and (nil? prev) (some? first))
+                  (assoc :prev first)
+
+                  (some? prev)
+                  (assoc :prev (gsp/command->point prev))))))))
+
+(defn close-paths
+  "Removes the :close-path commands and replace them for line-to so we can calculate
+  the intersections"
+  [content]
+
+  (loop [head (first content)
+         content (rest content)
+         result []
+         last-move nil
+         last-p nil]
+
+    (if (nil? head)
+      result
+      (let [head-p (gsp/command->point head)
+            head (cond
+                   (and (= :close-path (:command head))
+                        (< (gpt/distance last-p last-move) 0.01))
+                   nil
+
+                   (= :close-path (:command head))
+                   (upc/make-line-to last-move)
+
+                   :else
+                   head)]
+
+        (recur (first content)
+               (rest content)
+               (cond-> result (some? head) (conj head))
+               (if (= :move-to (:command head))
+                 head-p
+                 last-move)
+               head-p)))))
+
+(defn- split-command
+  [cmd values]
+  (case (:command cmd)
+    :line-to  (gsp/split-line-to-ranges (:prev cmd) cmd values)
+    :curve-to (gsp/split-curve-to-ranges (:prev cmd) cmd values)
+    [cmd]))
+
+(defn split-ts [seg-1 seg-2]
+  (cond
+    (and (= :line-to (:command seg-1))
+         (= :line-to (:command seg-2)))
+    (gsp/line-line-intersect (gsp/command->line seg-1) (gsp/command->line seg-2))
+
+    (and (= :line-to (:command seg-1))
+         (= :curve-to (:command seg-2)))
+    (gsp/line-curve-intersect (gsp/command->line seg-1) (gsp/command->bezier seg-2))
+
+    (and (= :curve-to (:command seg-1))
+         (= :line-to (:command seg-2)))
+    (let [[seg-2' seg-1']
+          (gsp/line-curve-intersect (gsp/command->line seg-2) (gsp/command->bezier seg-1))]
+      ;; Need to reverse because we send the arguments reversed
+      [seg-1' seg-2'])
+
+    (and (= :curve-to (:command seg-1))
+         (= :curve-to (:command seg-2)))
+    (gsp/curve-curve-intersect (gsp/command->bezier seg-1) (gsp/command->bezier seg-2))
+
+    :else
+    [[] []]))
+
+(defn split
+  [seg-1 seg-2]
+  (let [r1 (gsp/command->selrect seg-1)
+        r2 (gsp/command->selrect seg-2)]
+    (if (not (gpr/overlaps-rects? r1 r2))
+      [[seg-1] [seg-2]]
+      (let [[ts-seg-1 ts-seg-2] (split-ts seg-1 seg-2)]
+        [(-> (split-command seg-1 ts-seg-1) (add-previous (:prev seg-1)))
+         (-> (split-command seg-2 ts-seg-2) (add-previous (:prev seg-2)))]))))
+
+(defn content-intersect-split
+  [content-a content-b]
+
+  (let [cache (atom {})]
+    (letfn [(split-cache [seg-1 seg-2]
+              (cond
+                (contains? @cache [seg-1 seg-2])
+                (first (get @cache [seg-1 seg-2]))
+
+                (contains? @cache [seg-2 seg-1])
+                (second (get @cache [seg-2 seg-1]))
+
+                :else
+                (let [value (split seg-1 seg-2)]
+                  (swap! cache assoc [seg-1 seg-2] value)
+                  (first value))))
+
+            (split-segment-on-content
+              [segment content]
+
+              (loop [current (first content)
+                     content (rest content)
+                     result [segment]]
+
+                (if (nil? current)
+                  result
+                  (let [result (->> result (into [] (mapcat #(split-cache % current))))]
+                    (recur (first content)
+                           (rest content)
+                           result)))))
+
+            (split-content
+              [content-a content-b]
+              (into []
+                    (mapcat #(split-segment-on-content % content-b))
+                    content-a))]
+
+      [(split-content content-a content-b)
+       (split-content content-b content-a)])))
+
+(defn is-segment?
+  [cmd]
+  (and (contains? cmd :prev)
+       (contains? #{:line-to :curve-to} (:command cmd))))
+
+(defn contains-segment?
+  [segment content]
+
+  (let [point (case (:command segment)
+                :line-to  (-> (gsp/command->line segment)
+                              (gsp/line-values 0.5))
+
+                :curve-to (-> (gsp/command->bezier segment)
+                              (gsp/curve-values 0.5)))]
+
+    (or (gsp/is-point-in-content? point content)
+        (gsp/is-point-in-border? point content))))
+
+(defn inside-segment?
+  [segment content]
+  (let [point (case (:command segment)
+                :line-to  (-> (gsp/command->line segment)
+                              (gsp/line-values 0.5))
+
+                :curve-to (-> (gsp/command->bezier segment)
+                              (gsp/curve-values 0.5)))]
+
+    (gsp/is-point-in-content? point content)))
+
+(defn overlap-segment?
+  "Finds if the current segment is overlapping against other
+  segment meaning they have the same coordinates"
+  [segment content]
+
+  (let [overlap-single?
+        (fn [other]
+          (when (and (= (:command segment) (:command other))
+                     (contains? #{:line-to :curve-to} (:command segment)))
+
+            (case (:command segment)
+              :line-to (let [[p1 q1] (gsp/command->line segment)
+                             [p2 q2] (gsp/command->line other)]
+
+                         (when (or (and (< (gpt/distance p1 p2) 0.1)
+                                        (< (gpt/distance q1 q2) 0.1))
+                                   (and (< (gpt/distance p1 q2) 0.1)
+                                        (< (gpt/distance q1 p2) 0.1)))
+                           [segment other]))
+
+              :curve-to (let [[p1 q1 h11 h21] (gsp/command->bezier segment)
+                              [p2 q2 h12 h22] (gsp/command->bezier other)]
+
+                          (when (or (and (< (gpt/distance p1 p2) 0.1)
+                                         (< (gpt/distance q1 q2) 0.1)
+                                         (< (gpt/distance h11 h12) 0.1)
+                                         (< (gpt/distance h21 h22) 0.1))
+
+                                    (and (< (gpt/distance p1 q2) 0.1)
+                                         (< (gpt/distance q1 p2) 0.1)
+                                         (< (gpt/distance h11 h22) 0.1)
+                                         (< (gpt/distance h21 h12) 0.1)))
+
+                            [segment other])))))]
+
+    (->> content
+         (d/seek overlap-single?)
+         (some?))))
+
+(defn create-union [content-a content-a-split content-b content-b-split]
+  ;; Pick all segments in content-a that are not inside content-b
+  ;; Pick all segments in content-b that are not inside content-a
+  (let [content
+        (d/concat
+         []
+         (->> content-a-split (filter #(not (contains-segment? % content-b))))
+         (->> content-b-split (filter #(not (contains-segment? % content-a)))))
+
+        ;; Overlapping segments should be added when they are part of the border
+        border-content
+        (->> content-b-split
+             (filterv #(and (contains-segment? % content-a)
+                            (overlap-segment? % content-a-split)
+                            (not (inside-segment? % content)))))]
+
+    (d/concat content border-content)))
+
+(defn create-difference [content-a content-a-split content-b content-b-split]
+  ;; Pick all segments in content-a that are not inside content-b
+  ;; Pick all segments in content b that are inside content-a
+  ;;  removing overlapping
+  (d/concat
+   []
+   (->> content-a-split (filter #(not (contains-segment? % content-b))))
+
+   ;; Reverse second content so we can have holes inside other shapes
+   (->> content-b-split
+        (filter #(and (contains-segment? % content-a)
+                      (not (overlap-segment? % content-a-split)))))))
+
+(defn create-intersection [content-a content-a-split content-b content-b-split]
+  ;; Pick all segments in content-a that are inside content-b
+  ;; Pick all segments in content-b that are inside content-a
+  (d/concat
+   []
+   (->> content-a-split (filter #(contains-segment? % content-b)))
+   (->> content-b-split (filter #(contains-segment? % content-a)))))
+
+
+(defn create-exclusion [content-a content-b]
+  ;; Pick all segments
+  (d/concat [] content-a content-b))
+
+
+(defn fix-move-to
+  [content]
+  ;; Remove the field `:prev` and makes the necesaries `move-to`
+  ;; then clean the subpaths
+
+  (loop [current (first content)
+         content (rest content)
+         prev nil
+         result []]
+
+    (if (nil? current)
+      result
+
+      (let [result (if (not= (:prev current) prev)
+                     (conj result (upc/make-move-to (:prev current)))
+                     result)]
+        (recur (first content)
+               (rest content)
+               (gsp/command->point current)
+               (conj result (dissoc current :prev)))))))
+
+(defn content-bool-pair
+  [bool-type content-a content-b]
+
+  (let [content-a (-> content-a (close-paths) (add-previous))
+
+        content-b (-> content-b
+                      (close-paths)
+                      (cond-> (ups/clockwise? content-b)
+                        (ups/reverse-content))
+                      (add-previous))
+
+        ;; Split content in new segments in the intersection with the other path
+        [content-a-split content-b-split] (content-intersect-split content-a content-b)
+        content-a-split (->> content-a-split add-previous (filter is-segment?))
+        content-b-split (->> content-b-split add-previous (filter is-segment?))
+
+        bool-content
+        (case bool-type
+          :union        (create-union        content-a content-a-split content-b content-b-split)
+          :difference   (create-difference   content-a content-a-split content-b content-b-split)
+          :intersection (create-intersection content-a content-a-split content-b content-b-split)
+          :exclude      (create-exclusion    content-a-split content-b-split))]
+
+    (->> (fix-move-to bool-content)
+         (ups/close-subpaths))))
+
+(defn content-bool
+  [bool-type contents]
+  ;; We apply the boolean operation in to each pair and the result to the next
+  ;; element
+  (->> contents
+       (reduce (partial content-bool-pair bool-type))
+       (into [])))

common/src/app/common/path/commands.cljc

@@ -4,7 +4,7 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.util.path.commands
+(ns app.common.path.commands
   (:require
    [app.common.data :as d]
    [app.common.geom.point :as gpt]))
@@ -199,3 +199,4 @@
   (if (= prefix :c1)
     (command->point (get content (dec index)))
     (command->point (get content index))))
+

common/src/app/common/path/shapes_to_path.cljc

@@ -0,0 +1,227 @@
+;; 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.path.shapes-to-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.path :as gsp]
+   [app.common.path.bool :as pb]
+   [app.common.path.commands :as pc]))
+
+(def ^:const bezier-circle-c 0.551915024494)
+
+(def dissoc-attrs
+  [:x :y :width :height
+   :rx :ry :r1 :r2 :r3 :r4
+   :metadata :shapes])
+
+(def allowed-transform-types
+  #{:rect
+    :circle
+    :image})
+
+(def style-group-properties
+  [:shadow
+   :blur])
+
+(def style-properties
+  (d/concat
+   style-group-properties
+   [:fill-color
+    :fill-opacity
+    :fill-color-gradient
+    :fill-color-ref-file
+    :fill-color-ref-id
+    :fill-image
+    :stroke-color
+    :stroke-color-ref-file
+    :stroke-color-ref-id
+    :stroke-opacity
+    :stroke-style
+    :stroke-width
+    :stroke-alignment
+    :stroke-cap-start
+    :stroke-cap-end]))
+
+(defn make-corner-arc
+  "Creates a curvle corner for border radius"
+  [from to corner radius]
+  (let [x (case corner
+            :top-left (:x from)
+            :top-right (- (:x from) radius)
+            :bottom-right (- (:x to) radius)
+            :bottom-left (:x to))
+
+        y (case corner
+            :top-left (- (:y from) radius)
+            :top-right (:y from)
+            :bottom-right (- (:y to) (* 2 radius))
+            :bottom-left (- (:y to) radius))
+
+        width  (* radius 2)
+        height (* radius 2)
+
+        c   bezier-circle-c
+        c1x (+ x (* (/ width 2)  (- 1 c)))
+        c2x (+ x (* (/ width 2)  (+ 1 c)))
+        c1y (+ y (* (/ height 2) (- 1 c)))
+        c2y (+ y (* (/ height 2) (+ 1 c)))
+
+        h1 (case corner
+             :top-left     (assoc from :y c1y)
+             :top-right    (assoc from :x c2x)
+             :bottom-right (assoc from :y c2y)
+             :bottom-left  (assoc from :x c1x))
+
+        h2 (case corner
+             :top-left     (assoc to :x c1x)
+             :top-right    (assoc to :y c1y)
+             :bottom-right (assoc to :x c2x)
+             :bottom-left  (assoc to :y c2y))]
+
+    (pc/make-curve-to to h1 h2)))
+
+(defn circle->path
+  "Creates the bezier curves to approximate a circle shape"
+  [x y width height]
+  (let [mx (+ x (/ width 2))
+        my (+ y (/ height 2))
+        ex (+ x width)
+        ey (+ y height)
+
+        p1  (gpt/point mx y)
+        p2  (gpt/point ex my)
+        p3  (gpt/point mx ey)
+        p4  (gpt/point x my)
+
+        c   bezier-circle-c
+        c1x (+ x (* (/ width 2)  (- 1 c)))
+        c2x (+ x (* (/ width 2)  (+ 1 c)))
+        c1y (+ y (* (/ height 2) (- 1 c)))
+        c2y (+ y (* (/ height 2) (+ 1 c)))]
+
+    [(pc/make-move-to p1)
+     (pc/make-curve-to p2 (assoc p1 :x c2x) (assoc p2 :y c1y))
+     (pc/make-curve-to p3 (assoc p2 :y c2y) (assoc p3 :x c2x))
+     (pc/make-curve-to p4 (assoc p3 :x c1x) (assoc p4 :y c2y))
+     (pc/make-curve-to p1 (assoc p4 :y c1y) (assoc p1 :x c1x))]))
+
+(defn rect->path
+  "Creates a bezier curve that approximates a rounded corner rectangle"
+  [x y width height r1 r2 r3 r4 rx]
+  (let [[r1 r2 r3 r4] (->> [r1 r2 r3 r4] (mapv #(or % rx 0)))
+        p1 (gpt/point x (+ y r1))
+        p2 (gpt/point (+ x r1) y)
+
+        p3 (gpt/point (+ width x (- r2)) y)
+        p4 (gpt/point (+ width x) (+ y r2))
+
+        p5 (gpt/point (+ width x) (+ height y (- r3)))
+        p6 (gpt/point (+ width x (- r3)) (+ height y))
+
+        p7 (gpt/point (+ x r4) (+ height y))
+        p8 (gpt/point x (+ height y (- r4)))]
+    (-> []
+        (conj (pc/make-move-to p1))
+        (cond-> (not= p1 p2)
+          (conj (make-corner-arc p1 p2 :top-left r1)))
+        (conj (pc/make-line-to p3))
+        (cond-> (not= p3 p4)
+          (conj (make-corner-arc p3 p4 :top-right r2)))
+        (conj (pc/make-line-to p5))
+        (cond-> (not= p5 p6)
+          (conj (make-corner-arc p5 p6 :bottom-right r3)))
+        (conj (pc/make-line-to p7))
+        (cond-> (not= p7 p8)
+          (conj (make-corner-arc p7 p8 :bottom-left r4)))
+        (conj (pc/make-line-to p1)))))
+
+(declare convert-to-path)
+
+(defn fix-first-relative
+  "Fix an issue with the simplify commands not changing the first relative"
+  [content]
+  (let [head (first content)]
+    (cond-> content
+      (and head (:relative head))
+      (update 0 assoc :relative false))))
+
+(defn group-to-path
+  [group objects]
+  (let [xform (comp (map #(get objects %))
+                    (map #(-> (convert-to-path % objects))))
+
+        child-as-paths (into [] xform (:shapes group))
+        head (last child-as-paths)
+        head-data (select-keys head style-properties)
+        content (into []
+                      (comp (filter #(= :path (:type %)))
+                            (mapcat #(fix-first-relative (:content %))))
+                      child-as-paths)]
+    (-> group
+        (assoc :type :path)
+        (assoc :content content)
+        (merge head-data)
+        (d/without-keys dissoc-attrs))))
+
+(defn bool-to-path
+  [shape objects]
+
+  (let [children (->> (:shapes shape)
+                      (map #(get objects %))
+                      (map #(convert-to-path % objects)))
+        bool-type (:bool-type shape)
+        head (if (= bool-type :difference) (first children) (last children))
+        head (cond-> head
+               (and (contains? head :svg-attrs) (nil? (:fill-color head)))
+               (assoc :fill-color "#000000"))
+
+        head-data (select-keys head style-properties)
+        content (pb/content-bool (:bool-type shape) (mapv :content children))]
+
+    (-> shape
+        (assoc :type :path)
+        (assoc :content content)
+        (merge head-data)
+        (d/without-keys dissoc-attrs))))
+
+(defn convert-to-path
+  "Transforms the given shape to a path"
+  ([shape]
+   (convert-to-path shape {}))
+  ([{:keys [type x y width height r1 r2 r3 r4 rx metadata] :as shape} objects]
+   (assert (map? objects))
+   (case (:type shape)
+     :group
+     (group-to-path shape objects)
+
+     :bool
+     (bool-to-path shape objects)
+
+     (:rect :circle :image :text)
+     (let [new-content
+           (case type
+             :circle (circle->path x y width height)
+             #_:else (rect->path x y width height r1 r2 r3 r4 rx))
+
+           ;; Apply the transforms that had the shape
+           transform (:transform shape)
+           new-content (cond-> new-content
+                         (some? transform)
+                         (gsp/transform-content (gmt/transform-in (gsc/center-shape shape) transform)))]
+
+       (-> shape
+           (assoc :type :path)
+           (assoc :content new-content)
+           (cond-> (= :image type)
+             (assoc :fill-image metadata))
+           (d/without-keys dissoc-attrs)))
+
+     ;; For the rest return the plain shape
+     shape)))

common/src/app/common/path/subpaths.cljc

@@ -4,10 +4,16 @@
 ;;
 ;; Copyright (c) UXBOX Labs SL
 
-(ns app.util.path.subpaths
+(ns app.common.path.subpaths
   (:require
    [app.common.data :as d]
-   [app.util.path.commands :as upc]))
+   [app.common.geom.point :as gpt]
+   [app.common.path.commands :as upc]))
+
+(defn pt=
+  "Check if two points are close"
+  [p1 p2]
+  (< (gpt/distance p1 p2) 0.1))
 
 (defn make-subpath
   "Creates a subpath either from a single command or with all the data"
@@ -67,16 +73,22 @@
         (fn [subpaths current]
           (let [is-move? (= :move-to (:command current))
                 last-idx (dec (count subpaths))]
-            (if is-move?
+            (cond
+              is-move?
               (conj subpaths (make-subpath current))
-              (update subpaths last-idx add-subpath-command current))))]
+
+              (>= last-idx 0)
+              (update subpaths last-idx add-subpath-command current)
+
+              :else
+              subpaths)))]
     (->> content
          (reduce reduce-subpath []))))
 
 (defn subpaths-join
   "Join two subpaths together when the first finish where the second starts"
   [subpath other]
-  (assert (= (:to subpath) (:from other)))
+  (assert (pt= (:to subpath) (:from other)))
   (-> subpath
       (update :data d/concat (rest (:data other)))
       (assoc :to (:to other))))
@@ -88,21 +100,31 @@
   (let [merge-with-candidate
         (fn [[candidate result] current]
           (cond
-            (= (:to current) (:from current))
+            (pt= (:to current) (:from current))
+            ;; Subpath is already a closed path
             [candidate (conj result current)]
 
-            (= (:to candidate) (:from current))
+            (pt= (:to candidate) (:from current))
             [(subpaths-join candidate current) result]
 
-            (= (:to candidate) (:to current))
+            (pt= (:from candidate) (:to current))
+            [(subpaths-join current candidate) result]
+
+            (pt= (:to candidate) (:to current))
             [(subpaths-join candidate (reverse-subpath current)) result]
 
+            (pt= (:from candidate) (:from current))
+            [(subpaths-join (reverse-subpath current) candidate) result]
+
             :else
             [candidate (conj result current)]))]
 
     (->> subpaths
          (reduce merge-with-candidate [candidate []]))))
 
+(defn is-closed? [subpath]
+  (pt= (:from subpath) (:to subpath)))
+
 (defn close-subpaths
   "Searches a path for posible supaths that can create closed loops and merge them"
   [content]
@@ -114,7 +136,7 @@
 
           (if (some? current)
             (let [[new-current new-subpaths]
-                  (if (= (:from current) (:to current))
+                  (if (is-closed? current)
                     [current subpaths]
                     (merge-paths current subpaths))]
 
@@ -134,3 +156,38 @@
     (->> closed-subpaths
          (mapcat :data)
          (into []))))
+
+(defn reverse-content
+  "Given a content reverse the order of the commands"
+  [content]
+
+  (->> content
+       (get-subpaths)
+       (mapv reverse-subpath)
+       (reverse)
+       (mapcat :data)
+       (into [])))
+
+;; https://mathworld.wolfram.com/PolygonArea.html
+(defn clockwise?
+  "Check whether the first subpath is clockwise or counter-clock wise"
+  [content]
+  (let [subpath (->> content get-subpaths first :data)]
+    (loop [current (first subpath)
+           subpath (rest subpath)
+           first-point nil
+           signed-area 0]
+
+      (if (nil? current)
+        (> signed-area 0)
+
+        (let [{x1 :x y1 :y :as p} (upc/command->point current)
+              last? (nil? (first subpath))
+              first-point (if (nil? first-point) p first-point)
+              {x2 :x y2 :y} (if last? first-point (upc/command->point (first subpath)))
+              signed-area (+ signed-area (- (* x1 y2) (* x2 y1)))]
+
+          (recur (first subpath)
+                 (rest subpath)
+                 first-point
+                 signed-area))))))

common/src/app/common/spec.cljc

@@ -111,6 +111,16 @@
 (s/def ::point gpt/point?)
 (s/def ::id ::uuid)
 
+(s/def ::words
+  (s/conformer
+   (fn [s]
+     (cond
+       (set? s)    s
+       (string? s) (into #{} (map keyword) (str/words s))
+       :else       ::s/invalid))
+   (fn [s]
+     (str/join " " (map name s)))))
+
 (defn bytes?
   "Test if a first parameter is a byte
   array or not."
@@ -196,7 +206,7 @@
                      :name (pr-str spec)
                      :line (:line &env)
                      :file (:file (:meta nsdata))})
-          message (str "Spec Assertion: '" (pr-str spec) "'")]
+          message (str "spec assert: '" (pr-str spec) "'")]
       `(spec-assert* ~spec ~x ~message ~context))))
 
 (defmacro verify
@@ -208,7 +218,7 @@
                    :name (pr-str spec)
                    :line (:line &env)
                    :file (:file (:meta nsdata))})
-        message (str "Spec Assertion: '" (pr-str spec) "'")]
+        message (str "spec verify: '" (pr-str spec) "'")]
     `(spec-assert* ~spec ~x ~message ~context)))
 
 ;; --- Public Api

common/src/app/common/types/interactions.cljc

@@ -0,0 +1,376 @@
+;; 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.types.interactions
+  (:require
+   [app.common.data :as d]
+   [app.common.geom.point :as gpt]
+   [app.common.spec :as us]
+   [clojure.spec.alpha :as s]))
+
+;; WARNING: options are not deleted when changing event or action type, so it can be
+;;          restored if the user changes it back later.
+;;
+;;          But that means that an interaction may have for example a delay or
+;;          destination, even if its type does not require it (but a previous type did).
+;;
+;;          So make sure to use has-delay/has-destination... functions, or similar,
+;;          before reading them.
+
+;; -- Options depending on event type
+
+(s/def ::event-type #{:click
+                      :mouse-press
+                      :mouse-over
+                      :mouse-enter
+                      :mouse-leave
+                      :after-delay})
+
+(s/def ::delay ::us/safe-integer)
+
+(defmulti event-opts-spec :event-type)
+
+(defmethod event-opts-spec :after-delay [_]
+  (s/keys :req-un [::delay]))
+
+(defmethod event-opts-spec :default [_]
+  (s/keys :req-un []))
+
+(s/def ::event-opts
+  (s/multi-spec event-opts-spec ::event-type))
+
+;; -- Options depending on action type
+
+(s/def ::action-type #{:navigate
+                       :open-overlay
+                       :toggle-overlay
+                       :close-overlay
+                       :prev-screen
+                       :open-url})
+
+(s/def ::destination (s/nilable ::us/uuid))
+(s/def ::overlay-pos-type #{:manual
+                            :center
+                            :top-left
+                            :top-right
+                            :top-center
+                            :bottom-left
+                            :bottom-right
+                            :bottom-center})
+(s/def ::overlay-position ::us/point)
+(s/def ::url ::us/string)
+(s/def ::close-click-outside ::us/boolean)
+(s/def ::background-overlay ::us/boolean)
+
+(defmulti action-opts-spec :action-type)
+
+(defmethod action-opts-spec :navigate [_]
+  (s/keys :req-un [::destination]))
+
+(defmethod action-opts-spec :open-overlay [_]
+  (s/keys :req-un [::destination
+                   ::overlay-position
+                   ::overlay-pos-type]
+          :opt-un [::close-click-outside
+                   ::background-overlay]))
+
+(defmethod action-opts-spec :toggle-overlay [_]
+  (s/keys :req-un [::destination
+                   ::overlay-position
+                   ::overlay-pos-type]
+          :opt-un [::close-click-outside
+                   ::background-overlay]))
+
+(defmethod action-opts-spec :close-overlay [_]
+  (s/keys :req-un [::destination]))
+
+(defmethod action-opts-spec :prev-screen [_]
+  (s/keys :req-un []))
+
+(defmethod action-opts-spec :open-url [_]
+  (s/keys :req-un [::url]))
+
+(s/def ::action-opts
+  (s/multi-spec action-opts-spec ::action-type))
+
+;; -- Interaction
+
+(s/def ::classifier
+  (s/keys :req-un [::event-type
+                   ::action-type]))
+
+(s/def ::interaction
+  (s/merge ::classifier
+           ::event-opts
+           ::action-opts))
+
+(s/def ::interactions
+  (s/coll-of ::interaction :kind vector?))
+
+(def default-interaction
+  {:event-type :click
+   :action-type :navigate
+   :destination nil})
+
+(def default-delay 600)
+
+;; -- Helpers for interaction
+
+(declare calc-overlay-pos-initial)
+
+(defn set-event-type
+  [interaction event-type shape]
+  (us/verify ::interaction interaction)
+  (us/verify ::event-type event-type)
+  (assert (or (not= event-type :after-delay)
+              (= (:type shape) :frame)))
+  (if (= (:event-type interaction) event-type)
+    interaction
+    (case event-type
+
+      :after-delay
+      (assoc interaction
+             :event-type event-type
+             :delay (get interaction :delay default-delay))
+
+      (assoc interaction
+             :event-type event-type))))
+
+
+(defn set-action-type
+  [interaction action-type]
+  (us/verify ::interaction interaction)
+  (us/verify ::action-type action-type)
+  (if (= (:action-type interaction) action-type)
+    interaction
+    (case action-type
+
+      :navigate
+      (assoc interaction
+             :action-type action-type
+             :destination (get interaction :destination))
+
+      (:open-overlay :toggle-overlay)
+      (let [overlay-pos-type (get interaction :overlay-pos-type :center)
+            overlay-position (get interaction :overlay-position (gpt/point 0 0))]
+        (assoc interaction
+               :action-type action-type
+               :overlay-pos-type overlay-pos-type
+               :overlay-position overlay-position))
+
+      :close-overlay
+      (assoc interaction
+             :action-type action-type
+             :destination (get interaction :destination))
+
+      :prev-screen
+      (assoc interaction
+             :action-type action-type)
+
+      :open-url
+      (assoc interaction
+             :action-type action-type
+             :url (get interaction :url "")))))
+
+(defn has-delay
+  [interaction]
+  (= (:event-type interaction) :after-delay))
+
+(defn set-delay
+  [interaction delay]
+  (us/verify ::interaction interaction)
+  (us/verify ::delay delay)
+  (assert (has-delay interaction))
+  (assoc interaction :delay delay))
+
+(defn has-destination
+  [interaction]
+  (#{:navigate :open-overlay :toggle-overlay :close-overlay}
+    (:action-type interaction)))
+
+(defn destination?
+  [interaction]
+  (and (has-destination interaction)
+       (some? (:destination interaction))))
+
+(defn set-destination
+  [interaction destination]
+  (us/verify ::interaction interaction)
+  (us/verify ::destination destination)
+  (assert (has-destination interaction))
+  (cond-> interaction
+    :always
+    (assoc :destination destination)
+
+    (or (= (:action-type interaction) :open-overlay)
+        (= (:action-type interaction) :toggle-overlay))
+    (assoc :overlay-pos-type :center
+           :overlay-position (gpt/point 0 0))))
+
+(defn has-url
+  [interaction]
+  (= (:action-type interaction) :open-url))
+
+(defn set-url
+  [interaction url]
+  (us/verify ::interaction interaction)
+  (us/verify ::url url)
+  (assert (has-url interaction))
+  (assoc interaction :url url))
+
+(defn has-overlay-opts
+  [interaction]
+  (#{:open-overlay :toggle-overlay} (:action-type interaction)))
+
+(defn set-overlay-pos-type
+  [interaction overlay-pos-type shape objects]
+  (us/verify ::interaction interaction)
+  (us/verify ::overlay-pos-type overlay-pos-type)
+  (assert (has-overlay-opts interaction))
+  (assoc interaction
+         :overlay-pos-type overlay-pos-type
+         :overlay-position (calc-overlay-pos-initial (:destination interaction)
+                                                     shape
+                                                     objects
+                                                     overlay-pos-type)))
+(defn toggle-overlay-pos-type
+  [interaction overlay-pos-type shape objects]
+  (us/verify ::interaction interaction)
+  (us/verify ::overlay-pos-type overlay-pos-type)
+  (assert (has-overlay-opts interaction))
+  (let [new-pos-type (if (= (:overlay-pos-type interaction) overlay-pos-type)
+                       :manual
+                       overlay-pos-type)]
+    (assoc interaction
+           :overlay-pos-type new-pos-type
+           :overlay-position (calc-overlay-pos-initial (:destination interaction)
+                                                       shape
+                                                       objects
+                                                       new-pos-type))))
+(defn set-overlay-position
+  [interaction overlay-position]
+  (us/verify ::interaction interaction)
+  (us/verify ::overlay-position overlay-position)
+  (assert (has-overlay-opts interaction))
+  (assoc interaction
+         :overlay-pos-type :manual
+         :overlay-position overlay-position))
+
+(defn set-close-click-outside
+  [interaction close-click-outside]
+  (us/verify ::interaction interaction)
+  (us/verify ::us/boolean close-click-outside)
+  (assert (has-overlay-opts interaction))
+  (assoc interaction :close-click-outside close-click-outside))
+
+(defn set-background-overlay
+  [interaction background-overlay]
+  (us/verify ::interaction interaction)
+  (us/verify ::us/boolean background-overlay)
+  (assert (has-overlay-opts interaction))
+  (assoc interaction :background-overlay background-overlay))
+
+(defn- calc-overlay-pos-initial
+  [destination shape objects overlay-pos-type]
+  (if (= overlay-pos-type :manual)
+    (let [dest-frame   (get objects destination)
+          overlay-size (:selrect dest-frame)
+          orig-frame   (if (= (:type shape) :frame)
+                         shape
+                         (get objects (:frame-id shape)))
+          frame-size   (:selrect orig-frame)]
+      (gpt/point (/ (- (:width frame-size) (:width overlay-size)) 2)
+                 (/ (- (:height frame-size) (:height overlay-size)) 2)))
+    (gpt/point 0 0)))
+
+(defn calc-overlay-position
+  [interaction base-frame dest-frame frame-offset]
+  (us/verify ::interaction interaction)
+  (assert (has-overlay-opts interaction))
+  (if (nil? dest-frame)
+    (gpt/point 0 0)
+    (let [overlay-size    (:selrect dest-frame)
+          base-frame-size (:selrect base-frame)]
+      (case (:overlay-pos-type interaction)
+        :center
+        (gpt/point (/ (- (:width base-frame-size) (:width overlay-size)) 2)
+                   (/ (- (:height base-frame-size) (:height overlay-size)) 2))
+
+        :top-left
+        (gpt/point 0 0)
+
+        :top-right
+        (gpt/point (- (:width base-frame-size) (:width overlay-size))
+                   0)
+
+        :top-center
+        (gpt/point (/ (- (:width base-frame-size) (:width overlay-size)) 2)
+                   0)
+
+        :bottom-left
+        (gpt/point 0
+                   (- (:height base-frame-size) (:height overlay-size)))
+
+        :bottom-right
+        (gpt/point (- (:width base-frame-size) (:width overlay-size))
+                   (- (:height base-frame-size) (:height overlay-size)))
+
+        :bottom-center
+        (gpt/point (/ (- (:width base-frame-size) (:width overlay-size)) 2)
+                   (- (:height base-frame-size) (:height overlay-size)))
+
+        :manual
+        (gpt/add (:overlay-position interaction) frame-offset)))))
+
+;; -- Helpers for interactions
+
+(defn add-interaction
+  [interactions interaction]
+  (conj (or interactions []) interaction))
+
+(defn remove-interaction
+  [interactions index]
+  (let [interactions (or interactions [])]
+    (into (subvec interactions 0 index)
+          (subvec interactions (inc index)))))
+
+(defn update-interaction
+  [interactions index update-fn]
+  (update interactions index update-fn))
+
+(defn remap-interactions
+  "Update all interactions whose destination points to a shape in the
+  map to the new id. And remove the ones whose destination does not exist
+  in the map nor in the objects tree."
+  [interactions ids-map objects]
+  (when (some? interactions)
+    (let [xform (comp (filter (fn [interaction]
+                                (let [destination (:destination interaction)]
+                                  (or (nil? destination)
+                                      (contains? ids-map destination)
+                                      (contains? objects destination)))))
+                      (map (fn [interaction]
+                             (d/update-when interaction :destination #(get ids-map % %)))))]
+      (into [] xform interactions))))
+
+(defn actionable?
+  "Check if there is any interaction that is clickable by the user"
+  [interactions]
+  (some #(= (:event-type %) :click) interactions))
+
+(defn flow-origin?
+  "Check if there is any interaction that is the start or the continuation of a flow"
+  [interactions]
+  (some #(and (#{:navigate :open-overlay :toggle-overlay :close-overlay} (:action-type %))
+              (some? (:destination %)))
+        interactions))
+
+(defn flow-to?
+  "Check if there is any interaction that flows into the given frame"
+  [interactions frame-id]
+  (some #(and (#{:navigate :open-overlay :toggle-overlay :close-overlay} (:action-type %))
+              (= (:destination %) frame-id))
+        interactions))

common/src/app/common/types/page_options.cljc

@@ -0,0 +1,94 @@
+;; 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.types.page-options
+  (:require
+   [app.common.data :as d]
+   [app.common.spec :as us]
+   [clojure.spec.alpha :as s]))
+
+;; --- Grid options
+
+(s/def :artboard-grid.color/color ::us/string)
+(s/def :artboard-grid.color/opacity ::us/safe-number)
+
+(s/def :artboard-grid/size ::us/safe-integer)
+(s/def :artboard-grid/color (s/keys :req-un [:artboard-grid.color/color
+                                             :artboard-grid.color/opacity]))
+(s/def :artboard-grid/type #{:stretch :left :center :right})
+(s/def :artboard-grid/item-length (s/nilable ::us/safe-integer))
+(s/def :artboard-grid/gutter (s/nilable ::us/safe-integer))
+(s/def :artboard-grid/margin (s/nilable ::us/safe-integer))
+
+(s/def :artboard-grid/square
+  (s/keys :req-un [:artboard-grid/size
+                   :artboard-grid/color]))
+
+(s/def :artboard-grid/column
+  (s/keys :req-un [:artboard-grid/size
+                   :artboard-grid/color
+                   :artboard-grid/margin
+                   :artboard-grid/gutter]
+          :opt-un [:artboard-grid/type
+                   :artboard-grid/item-length]))
+
+(s/def :artboard-grid/row :artboard-grid/column)
+
+(s/def ::saved-grids
+  (s/keys :opt-un [:artboard-grid/square
+                   :artboard-grid/row
+                   :artboard-grid/column]))
+
+;; --- Background options
+
+(s/def ::background string?)
+
+;; --- Flow options
+
+(s/def :interactions-flow/id ::us/uuid)
+(s/def :interactions-flow/name ::us/string)
+(s/def :interactions-flow/starting-frame ::us/uuid)
+
+(s/def ::flow
+  (s/keys :req-un [:interactions-flow/id
+                   :interactions-flow/name
+                   :interactions-flow/starting-frame]))
+
+(s/def ::flows
+  (s/coll-of ::flow :kind vector?))
+
+;; --- Options
+
+(s/def ::options
+  (s/keys :opt-un [::background
+                   ::saved-grids
+                   ::flows]))
+
+;; --- Helpers for flow
+
+(defn rename-flow
+  [flow name]
+  (assoc flow :name name))
+
+;; --- Helpers for flows
+
+(defn add-flow
+  [flows flow]
+  (conj (or flows []) flow))
+
+(defn remove-flow
+  [flows flow-id]
+  (d/removev #(= (:id %) flow-id) flows))
+
+(defn update-flow
+  [flows flow-id update-fn]
+  (let [index (d/index-of-pred flows #(= (:id %) flow-id))]
+    (update flows index update-fn)))
+
+(defn get-frame-flow
+  [flows frame-id]
+  (d/seek #(= (:starting-frame %) frame-id) flows))
+

docker/devenv/Dockerfile

@@ -3,10 +3,10 @@ LABEL maintainer="Andrey Antukh <niwi@niwi.nz>"
 
 ARG DEBIAN_FRONTEND=noninteractive
 
-ENV NODE_VERSION=v14.17.5 \
+ENV NODE_VERSION=v14.17.6 \
-    CLOJURE_VERSION=1.10.3.933 \
+    CLOJURE_VERSION=1.10.3.967 \
-    CLJKONDO_VERSION=2021.07.28 \
+    CLJKONDO_VERSION=2021.09.15 \
-    BABASHKA_VERSION=0.5.1 \
+    BABASHKA_VERSION=0.6.1 \
     LANG=en_US.UTF-8 \
     LC_ALL=en_US.UTF-8
 
@@ -28,6 +28,7 @@ RUN set -ex; \
         rlwrap \
         unzip \
         fakeroot \
+        netcat \
     ; \
     echo "en_US.UTF-8 UTF-8" >> /etc/locale.gen; \
     locale-gen; \
@@ -173,6 +174,7 @@ COPY files/tmux.conf      /root/.tmux.conf
 COPY files/sudoers        /etc/sudoers
 
 COPY files/start-tmux.sh       /home/start-tmux.sh
+COPY files/start-tmux-back.sh  /home/start-tmux-back.sh
 COPY files/entrypoint.sh       /home/entrypoint.sh
 COPY files/init.sh             /home/init.sh
 

docker/devenv/docker-compose.yaml

@@ -5,7 +5,7 @@ networks:
     driver: bridge
     ipam:
       config:
-        - subnet: 172.177.09.0/24
+        - subnet: 172.177.9.0/24
 
 volumes:
   postgres_data:
@@ -13,6 +13,7 @@ volumes:
 
 services:
   main:
+    profiles: ["full"]
     privileged: true
     image: "penpotapp/devenv:latest"
     build:
@@ -49,6 +50,57 @@ services:
       - PENPOT_SMTP_PASSWORD=
       - PENPOT_SMTP_SSL=false
       - PENPOT_SMTP_TLS=false
+      - PENPOT_FLAGS="enable-cors"
+
+      # LDAP setup
+      - PENPOT_LDAP_HOST=ldap
+      - PENPOT_LDAP_PORT=10389
+      - PENPOT_LDAP_SSL=false
+      - PENPOT_LDAP_STARTTLS=false
+      - PENPOT_LDAP_BASE_DN=ou=people,dc=planetexpress,dc=com
+      - PENPOT_LDAP_BIND_DN=cn=admin,dc=planetexpress,dc=com
+      - PENPOT_LDAP_BIND_PASSWORD=GoodNewsEveryone
+      - PENPOT_LDAP_ATTRS_USERNAME=uid
+      - PENPOT_LDAP_ATTRS_EMAIL=mail
+      - PENPOT_LDAP_ATTRS_FULLNAME=cn
+      - PENPOT_LDAP_ATTRS_PHOTO=jpegPhoto
+
+  backend:
+    profiles: ["backend"]
+    privileged: true
+    image: "penpotapp/devenv:latest"
+    build:
+      context: "."
+    container_name: "penpot-backend"
+    stop_signal: SIGINT
+
+    depends_on:
+      - postgres
+      - redis
+
+    volumes:
+      - "user_data:/home/penpot/"
+      - "${PWD}:/home/penpot/penpot"
+
+    ports:
+      - 6060:6060
+      - 6061:6061
+      - 9090:9090
+
+    environment:
+      - EXTERNAL_UID=${CURRENT_USER_ID}
+      - PENPOT_SECRET_KEY=super-secret-devenv-key
+      # STMP setup
+      - PENPOT_SMTP_ENABLED=true
+      - PENPOT_SMTP_DEFAULT_FROM=no-reply@example.com
+      - PENPOT_SMTP_DEFAULT_REPLY_TO=no-reply@example.com
+      - PENPOT_SMTP_HOST=mailer
+      - PENPOT_SMTP_PORT=1025
+      - PENPOT_SMTP_USERNAME=
+      - PENPOT_SMTP_PASSWORD=
+      - PENPOT_SMTP_SSL=false
+      - PENPOT_SMTP_TLS=false
+      - PENPOT_FLAGS="enable-cors"
 
       # LDAP setup
       - PENPOT_LDAP_HOST=ldap