Penpot/penpot
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-03-19 19:21:23 -05:00
Code Issues Activity

Merge branch 'staging'

Browse source
This commit is contained in:
Andrey Antukh 2021-10-27 12:45:53 +02:00
commit 78d1c57b7c
306 changed files with 14686 additions and 4386 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.clj-kondo/config.edn
View file

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

6
.gitignore vendored
View file

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

68
CHANGES.md
View file

@ -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

35
backend/deps.edn
View file

@ -12,7 +12,7 @@
org.zeromq/jeromq {:mvn/version "0.5.2"}
com.taoensso/nippy {:mvn/version "3.1.1"}
com.github.luben/zstd-jni {:mvn/version "1.4.9-5"}
com.github.luben/zstd-jni {:mvn/version "1.5.0-4"}
;; NOTE: don't upgrade to latest version, breaking change is
;; introduced on 0.10.0 that suffixes counters with _total if they
@ -24,14 +24,14 @@
org.eclipse.jetty/jetty-servlet]}
io.prometheus/simpleclient_httpserver {:mvn/version "0.9.0"}
io.lettuce/lettuce-core {:mvn/version "6.1.2.RELEASE"}
java-http-clj/java-http-clj {:mvn/version "0.4.2"}
io.lettuce/lettuce-core {:mvn/version "6.1.5.RELEASE"}
java-http-clj/java-http-clj {:mvn/version "0.4.3"}
info.sunng/ring-jetty9-adapter {:mvn/version "0.15.1"}
com.github.seancorfield/next.jdbc {:mvn/version "1.2.659"}
metosin/reitit-ring {:mvn/version "0.5.13"}
org.postgresql/postgresql {:mvn/version "42.2.20"}
com.zaxxer/HikariCP {:mvn/version "4.0.3"}
info.sunng/ring-jetty9-adapter {:mvn/version "0.15.2"}
com.github.seancorfield/next.jdbc {:mvn/version "1.2.709"}
metosin/reitit-ring {:mvn/version "0.5.15"}
org.postgresql/postgresql {:mvn/version "42.2.23"}
com.zaxxer/HikariCP {:mvn/version "5.0.0"}
funcool/datoteka {:mvn/version "2.0.0"}
@ -39,14 +39,20 @@
buddy/buddy-hashers {:mvn/version "1.8.1"}
buddy/buddy-sign {:mvn/version "3.4.1"}
org.jsoup/jsoup {:mvn/version "1.13.1"}
org.jsoup/jsoup {:mvn/version "1.14.2"}
org.im4java/im4java {:mvn/version "1.4.0"}
org.lz4/lz4-java {:mvn/version "1.7.1"}
org.lz4/lz4-java {:mvn/version "1.8.0"}
org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
integrant/integrant {:mvn/version "0.8.0"}
software.amazon.awssdk/s3 {:mvn/version "2.16.62"}}
io.sentry/sentry {:mvn/version "5.1.2"}
;; Pretty Print specs
fipp/fipp {:mvn/version "0.6.24"}
pretty-spec/pretty-spec {:mvn/version "0.1.4"}
software.amazon.awssdk/s3 {:mvn/version "2.17.40"}}
:paths ["src" "resources"]
:aliases
@ -55,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

101
backend/resources/api-doc.css Normal file
View file

@ -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;
}

27
backend/resources/api-doc.js Normal file
View file

@ -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);
}
});
})();

80
backend/resources/api-doc.tmpl Normal file
View file

@ -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>

1
backend/resources/error-report.tmpl
View file

@ -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">

2
backend/scripts/repl
View file

@ -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";

19
backend/scripts/start-dev
View file

@ -10,6 +10,23 @@ if [ ! -e ~/.fixtures-loaded ]; then
touch ~/.fixtures-loaded
fi
clojure -A:dev -M -m app.main
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

2
backend/src/app/cli/fixtures.clj
View file

@ -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]))

2
backend/src/app/cli/manage.clj
View file

@ -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])

2
backend/src/app/cli/migrate_media.clj
View file

@ -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]))

88
backend/src/app/config.clj
View file

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

59
backend/src/app/db.clj
View file

@ -9,13 +9,13 @@
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.geom.point :as gpt]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.transit :as t]
[app.common.uuid :as uuid]
[app.db.sql :as sql]
[app.metrics :as mtx]
[app.util.json :as json]
[app.util.logging :as l]
[app.util.migrations :as mg]
[app.util.time :as dt]
[clojure.java.io :as io]
@ -46,28 +46,26 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare instrument-jdbc!)
(declare apply-migrations!)
(s/def ::name keyword?)
(s/def ::uri ::us/not-empty-string)
(s/def ::min-pool-size ::us/integer)
(s/def ::max-pool-size ::us/integer)
(s/def ::migrations map?)
(s/def ::read-only ::us/boolean)
(defmethod ig/pre-init-spec ::pool [_]
(s/keys :req-un [::uri ::name ::min-pool-size ::max-pool-size ::migrations ::mtx/metrics]))
(s/keys :req-un [::uri ::name ::min-pool-size ::max-pool-size]
:opt-un [::migrations ::mtx/metrics ::read-only]))
(defmethod ig/init-key ::pool
[_ {:keys [migrations metrics] :as cfg}]
(l/info :action "initialize connection pool"
:name (d/name (:name cfg))
:uri (:uri cfg))
(instrument-jdbc! (:registry metrics))
[_ {:keys [migrations metrics name] :as cfg}]
(l/info :action "initialize connection pool" :name (d/name name) :uri (:uri cfg))
(some-> metrics :registry instrument-jdbc!)
(let [pool (create-pool cfg)]
(when (seq migrations)
(with-open [conn ^AutoCloseable (open pool)]
(mg/setup! conn)
(doseq [[name steps] migrations]
(mg/migrate! conn {:name (d/name name) :steps steps}))))
(some->> (seq migrations) (apply-migrations! pool))
pool))
(defmethod ig/halt-key! ::pool
@ -84,37 +82,50 @@
:name "database_query_total"
:help "An absolute counter of database queries."}))
(defn- apply-migrations!
[pool migrations]
(with-open [conn ^AutoCloseable (open pool)]
(mg/setup! conn)
(doseq [[name steps] migrations]
(mg/migrate! conn {:name (d/name name) :steps steps}))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; API & Impl
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def initsql
(str "SET statement_timeout = 120000;\n"
"SET idle_in_transaction_session_timeout = 120000;"))
(str "SET statement_timeout = 200000;\n"
"SET idle_in_transaction_session_timeout = 200000;"))
(defn- create-datasource-config
[{:keys [metrics] :as cfg}]
[{:keys [metrics read-only] :or {read-only false} :as cfg}]
(let [dburi (:uri cfg)
username (:username cfg)
password (:password cfg)
config (HikariConfig.)
mtf (PrometheusMetricsTrackerFactory. (:registry metrics))]
config (HikariConfig.)]
(doto config
(.setJdbcUrl (str "jdbc:" dburi))
(.setPoolName (d/name (:name cfg)))
(.setAutoCommit true)
(.setReadOnly false)
(.setConnectionTimeout 8000) ;; 8seg
(.setValidationTimeout 8000) ;; 8seg
(.setIdleTimeout 120000) ;; 2min
(.setMaxLifetime 1800000) ;; 30min
(.setReadOnly read-only)
(.setConnectionTimeout 10000) ;; 10seg
(.setValidationTimeout 10000) ;; 10seg
(.setIdleTimeout 120000) ;; 2min
(.setMaxLifetime 1800000) ;; 30min
(.setMinimumIdle (:min-pool-size cfg 0))
(.setMaximumPoolSize (:max-pool-size cfg 30))
(.setMetricsTrackerFactory mtf)
(.setConnectionInitSql initsql)
(.setInitializationFailTimeout -1))
;; When metrics namespace is provided
(when metrics
(->> (:registry metrics)
(PrometheusMetricsTrackerFactory.)
(.setMetricsTrackerFactory config)))
(when username (.setUsername config username))
(when password (.setPassword config password))
config))
(defn pool?
@ -127,7 +138,7 @@
[pool]
(.isClosed ^HikariDataSource pool))
(defn- create-pool
(defn create-pool
[cfg]
(let [dsc (create-datasource-config cfg)]
(jdbc-dt/read-as-instant)

41
backend/src/app/emails.clj
View file

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

8
backend/src/app/http.clj
View file

@ -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)}]

2
backend/src/app/http/awsns.clj
View file

@ -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]

53
backend/src/app/http/doc.clj Normal file
View file

@ -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 ""}))))

62
backend/src/app/http/errors.clj
View file

@ -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]
[cuerdas.core :as str]
[expound.alpha :as expound]))
[clojure.pprint]
[cuerdas.core :as str]))
(defn- explain-error
[error]
(with-out-str
(expound/printer (:data error))))
(defn- parse-client-ip
[{:keys [headers] :as request}]
(or (some-> (get headers "x-forwarded-for") (str/split ",") first)
(get headers "x-real-ip")
(get request :remote-addr)))
(defn- 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)]
(merge
{:id (uuid/next)
:path (:uri request)
:method (:request-method request)
:params (:params request)
:data edata}
(let [data (ex-data error)]
(d/without-nils
(merge
{:id (str (uuid/next))
:path (str (:uri request))
:method (name (:request-method request))
:hint (or (:hint data) (ex-message error))
:params (stringify-data (:params request))
:data (stringify-data (dissoc data :explain))
:ip-addr (parse-client-ip request)
:explain (str/prune (:explain data) (* 1024 1024) "[...]")}
(when-let [id (:profile-id request)]
{:profile-id id})
(let [headers (:headers request)]
{:user-agent (get headers "user-agent")
:frontend-version (get headers "x-frontend-version" "unknown")})
(when (and (map? edata) (:data edata))
{:explain (explain-error edata)}))))
(when (map? data)
{:error-type (:type data)
:error-code (:code data)})))))
(defmulti handle-exception
(fn [err & _rest]
@ -43,7 +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
(map? (:data edata))
(-> (assoc :explain (explain-error edata))
(dissoc :data)))})))
:body (dissoc edata :data)})))
(defmethod handle-exception :assertion
[error request]
@ -77,9 +91,7 @@
{:status 500
:body {:type :server-error
:code :assertion
:data (-> edata
(assoc :explain (explain-error edata))
(dissoc :data))}}))
:data (dissoc edata :data)}}))
(defmethod handle-exception :not-found
[err _]

8
backend/src/app/http/feedback.clj
View file

@ -10,7 +10,7 @@
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.config :as cfg]
[app.config :as cf]
[app.db :as db]
[app.emails :as eml]
[app.rpc.queries.profile :as profile]
@ -24,8 +24,8 @@
(defmethod ig/init-key ::handler
[_ {:keys [pool] :as scfg}]
(let [ftoken (cfg/get :feedback-token ::no-token)
enabled (cfg/get :feedback-enabled)]
(let [ftoken (cf/get :feedback-token ::no-token)
enabled (contains? cf/flags :user-feedback)]
(fn [{:keys [profile-id] :as request}]
(let [token (get-in request [:headers "x-feedback-token"])
params (d/merge (:params request)
@ -58,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

29
backend/src/app/http/middleware.clj
View file

@ -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)})

24
backend/src/app/http/oauth.clj
View file

@ -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 "pm-")
(str/starts-with? sk "utm_"))
(assoc (-> sk str/kebab keyword) v))))
(str/starts-with? sk "utm_")
(assoc (->> sk str/kebab (keyword "penpot")) v))))
{}
params))
@ -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

9
backend/src/app/http/session.clj
View file

@ -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]

64
backend/src/app/loggers/audit.clj
View file

@ -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}]
(fn [{:keys [params _headers _cookies profile-id] :as request}]
(when enabled
[_ {:keys [executor] :as cfg}]
(fn [{:keys [params profile-id] :as request}]
(when (contains? cf/flags :audit-log)
(let [events (->> (:events params)
(remove #(not= profile-id (:profile-id %)))
(us/conform ::events))
@ -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}]
(when enabled
(l/info :msg "intializing audit collector")
[_ cfg]
(when (contains? cf/flags :audit-log)
(l/info :msg "intializing audit log collector")
(let [input (a/chan 512 event-xform)
buffer (aa/batch input {:max-batch-size 100
:max-batch-age (* 10 1000) ; 10s
@ -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)
(ex/raise :type :internal
:code :unable-to-send-events
:hint "unable to send events"
:context resp))))
(if (= (:status resp) 204)
true
(do
(l/warn :hint "unable to archive events"
:resp-status (:status resp))
false))))
(mark-as-archived [conn rows]
(db/exec-one! conn ["update audit_log set archived_at=now() where id = ANY(?)"
@ -290,26 +292,14 @@
events (into [] xform rows)]
(when-not (empty? events)
(l/debug :action "archive-events" :uri uri :events (count events))
(send events)
(mark-as-archived conn rows)
:continue)))))
(when (send events)
(mark-as-archived conn rows)
: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)))

126
backend/src/app/loggers/database.clj Normal file
View file

@ -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"})))))

2
backend/src/app/loggers/loki.clj
View file

@ -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]

139
backend/src/app/loggers/mattermost.clj
View file

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

172
backend/src/app/loggers/sentry.clj Normal file
View file

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

5
backend/src/app/loggers/zmq.clj
View file

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

63
backend/src/app/main.clj
View file

@ -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-archive-gc (ig/ref :app.loggers.audit/archive-gc-task)}}
:audit-log-archive (ig/ref :app.loggers.audit/archive-task)
:audit-log-gc (ig/ref :app.loggers.audit/gc-task)}}
:app.emails/sendmail-handler
{:host (cf/get :smtp-host)
:port (cf/get :smtp-port)
:ssl (cf/get :smtp-ssl)
:tls (cf/get :smtp-tls)
:enabled (cf/get :smtp-enabled)
:username (cf/get :smtp-username)
:password (cf/get :smtp-password)
:metrics (ig/ref :app.metrics/metrics)
@ -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)
:enabled (cf/get :audit-archive-enabled false)
{:uri (cf/get :audit-log-archive-uri)
:tokens (ig/ref :app.tokens/tokens)
:pool (ig/ref :app.db/pool)}
:app.loggers.audit/archive-gc-task
{:enabled (cf/get :audit-archive-gc-enabled false)
:max-age (cf/get :audit-archive-gc-max-age cf/deletion-delay)
:app.loggers.audit/gc-task
{:max-age (cf/get :audit-log-gc-max-age cf/deletion-delay)
:pool (ig/ref :app.db/pool)}
:app.loggers.loki/reporter
@ -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)

4
backend/src/app/media.clj
View file

@ -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

2
backend/src/app/metrics.clj
View file

@ -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

2
backend/src/app/msgbus.clj
View file

@ -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]

3
backend/src/app/notifications.clj
View file

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

62
backend/src/app/rpc.clj
View file

@ -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,36 +97,39 @@
auth? (:auth mdata true)]
(l/trace :action "register" :name (::sv/name mdata))
(fn [params]
(with-meta
(fn [params]
;; Raise authentication error when rpc method requires auth but
;; no profile-id is found in the request.
(when (and auth? (not (uuid? (:profile-id params))))
(ex/raise :type :authentication
:code :authentication-required
:hint "authentication required for this endpoint"))
;; Raise authentication error when rpc method requires auth but
;; no profile-id is found in the request.
(when (and auth? (not (uuid? (:profile-id params))))
(ex/raise :type :authentication
:code :authentication-required
:hint "authentication required for this endpoint"))
(let [params' (dissoc params ::request)
params' (us/conform spec params')
result (f cfg params')]
(let [params' (dissoc params ::request)
params' (us/conform spec params')
result (f cfg params')]
;; When audit log is enabled (default false).
(when (fn? audit)
(let [resultm (meta result)
request (::request params)
profile-id (or (:profile-id params')
(:profile-id result)
(::audit/profile-id resultm))
props (d/merge params' (::audit/props resultm))]
(audit :cmd :submit
:type (::type cfg)
:name (or (::audit/name resultm)
(::sv/name mdata))
:profile-id profile-id
:ip-addr (audit/parse-client-ip request)
:props props)))
;; When audit log is enabled (default false).
(when (fn? audit)
(let [resultm (meta result)
request (::request params)
profile-id (or (:profile-id params')
(:profile-id result)
(::audit/profile-id resultm))
props (d/merge params' (::audit/props resultm))]
(audit :cmd :submit
:type (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.svg)
'app.rpc.queries.fonts)
(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

6
backend/src/app/rpc/mutations/demo.clj
View file

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

9
backend/src/app/rpc/mutations/fonts.clj
View file

@ -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})

2
backend/src/app/rpc/mutations/ldap.clj
View file

@ -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]

14
backend/src/app/rpc/mutations/management.clj
View file

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

60
backend/src/app/rpc/mutations/profile.clj
View file

@ -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
::accept-terms-and-privacy]
:opt-un [::accept-newsletter-subscription]))
(s/keys :req-un [::token ::fullname]))
(sv/defmethod ::register-profile {:auth false :rlimit :password}
[{:keys [pool] :as cfg} params]
(when-not (:accept-terms-and-privacy params)
(ex/raise :type :validation
:code :invalid-terms-and-privacy))
(db/with-atomic [conn pool]
(let [cfg (assoc cfg :conn conn)]
(register-profile cfg params))))
(-> (assoc cfg :conn conn)
(register-profile params))))
(defn- annotate-profile-register
"A helper for properly increase the profile-register metric once the
@ -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
(and (string? locale) (not (str/blank? locale)) locale))
locale (:locale params)
locale (when (and (string? locale) (not (str/blank? locale)))
locale)
backend (:backend params "penpot")
is-demo (:is-demo params false)
@ -359,11 +350,14 @@
(defn- update-profile
[conn {:keys [id fullname lang theme] :as params}]
(db/update! conn :profile
{:fullname fullname
:lang lang
:theme theme}
{:id id}))
(let [profile (db/update! conn :profile
{:fullname fullname
:lang lang
:theme theme}
{:id id})]
(-> profile
(profile/decode-profile-row)
(profile/strip-private-attrs))))
(s/def ::update-profile
(s/keys :req-un [::id ::fullname]
@ -372,8 +366,9 @@
(sv/defmethod ::update-profile
[{:keys [pool] :as cfg} params]
(db/with-atomic [conn pool]
(update-profile conn params)
nil))
(let [profile (update-profile conn params)]
(with-meta profile
{::audit/props (audit/profile->props profile)}))))
;; --- MUTATION: Update Password
@ -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]
(if (nil? v)
(dissoc props k)
(assoc props k v)))
;; We don't accept namespaced keys
(if (simple-ident? k)
(if (nil? v)
(dissoc props k)
(assoc props k v))
props))
(:props profile)
props)]
(db/update! conn :profile
{:props (db/tjson props)}
{:id profile-id})

5
backend/src/app/rpc/mutations/share_link.clj
View file

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

8
backend/src/app/rpc/mutations/teams.clj
View file

@ -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)]
(when-not (some :is-owner perms)
(let [perms (teams/get-permissions conn profile-id id)]
(when-not (:is-owner perms)
(ex/raise :type :validation
:code :only-owner-can-delete-team))
@ -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))

40
backend/src/app/rpc/mutations/verify_token.clj
View file

@ -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
(accept-invitation cfg claims)
(let [profile (accept-invitation cfg claims)]
(if (= member-id profile-id)
;; If the current session is already matches the invited
;; member, then just return the token and leave the frontend
@ -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
(accept-invitation cfg (assoc claims :member-id profile-id))
(assoc claims :state :created))
(let [profile (accept-invitation cfg (assoc claims :member-id profile-id))]
(with-meta
(assoc claims :state :created)
{::audit/name "accept-team-invitation"
::audit/props (merge
(audit/profile->props profile)
{:team-id (:team-id claims)
:role (:role claims)})
::audit/profile-id profile-id}))
;; This happens when member-id is filled but the accessing user is
;; not logged-in. In this case we proceed to accept invitation and
;; leave the user logged-in.
(and (nil? profile-id)
(uuid? member-id))
(do
(accept-invitation cfg claims)
(let [profile (accept-invitation cfg claims)]
(with-meta
(assoc claims :state :created)
{:transform-response ((:create session) member-id)}))
{:transform-response ((:create session) member-id)
::audit/name "accept-team-invitation"
::audit/props (merge
(audit/profile->props profile)
{:team-id (:team-id claims)
:role (:role claims)})
::audit/profile-id member-id}))
;; In this case, we wait until frontend app redirect user to
;; registeration page, the user is correctly registered and the

49
backend/src/app/rpc/mutations/viewer.clj
View file

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

49
backend/src/app/rpc/permissions.clj
View file

@ -41,59 +41,24 @@
"A simple factory for edition permission predicate functions."
[qfn]
(us/assert fn? qfn)
(fn [& args]
(let [rows (apply qfn args)]
(when-not (or (empty? rows)
(not (or (some :can-edit rows)
(some :is-admin rows)
(some :is-owner rows))))
rows))))
(fn check
([perms] (:can-edit perms))
([conn & args] (check (apply qfn conn args)))))
(defn make-read-predicate-fn
"A simple factory for read permission predicate functions."
[qfn]
(us/assert fn? qfn)
(fn [& args]
(let [rows (apply qfn args)]
(when (seq rows)
rows))))
(fn check
([perms] (:can-read perms))
([conn & args] (check (apply qfn conn args)))))
(defn make-check-fn
"Helper that converts a predicate permission function to a check
function (function that raises an exception)."
[pred]
(fn [& args]
(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))))

94
backend/src/app/rpc/queries/files.clj
View file

@ -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)]
(check-edition-permissions! conn profile-id id)
(retrieve-file cfg id))))
(let [cfg (assoc cfg :conn conn)
perms (get-permissions conn profile-id id)]
(check-read-permissions! perms)
(some-> (retrieve-file cfg id)
(assoc :permissions perms)))))
(s/def ::page
(s/keys :req-un [::profile-id ::file-id]))
@ -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

6
backend/src/app/rpc/queries/profile.clj
View file

@ -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

27
backend/src/app/rpc/queries/projects.clj
View file

@ -31,18 +31,31 @@
where ppr.project_id = ?
and ppr.profile_id = ?")
(defn- retrieve-project-permissions
(defn- get-permissions
[conn profile-id project-id]
(db/exec! conn [sql:project-permissions
project-id profile-id
project-id profile-id]))
(let [rows (db/exec! conn [sql:project-permissions
project-id profile-id
project-id profile-id])
is-owner (boolean (some :is-owner rows))
is-admin (boolean (some :is-admin rows))
can-edit (boolean (some :can-edit rows))]
(when (seq rows)
{:is-owner is-owner
:is-admin (or is-owner is-admin)
:can-edit (or is-owner is-admin can-edit)
:can-read true})))
(def has-edit-permissions?
(perms/make-edition-predicate-fn get-permissions))
(def has-read-permissions?
(perms/make-read-predicate-fn get-permissions))
(def check-edition-permissions!
(perms/make-edition-check-fn retrieve-project-permissions))
(perms/make-check-fn has-edit-permissions?))
(def check-read-permissions!
(perms/make-read-check-fn retrieve-project-permissions))
(perms/make-check-fn has-read-permissions?))
;; --- Query: Projects

42
backend/src/app/rpc/queries/recent_files.clj
View file

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

23
backend/src/app/rpc/queries/share_link.clj Normal file
View file

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

43
backend/src/app/rpc/queries/teams.clj
View file

@ -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

88
backend/src/app/rpc/queries/viewer.clj
View file

@ -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 (retrieve-share-link cfg file-id share-id)]
slink (slnk/retrieve-share-link conn 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])))

2
backend/src/app/srepl.clj
View file

@ -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]

2
backend/src/app/storage.clj
View file

@ -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]

70
backend/src/app/tasks/delete_object.clj
View file

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

79
backend/src/app/tasks/delete_profile.clj
View file

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

2
backend/src/app/tasks/file_media_gc.clj
View file

@ -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]))

2
backend/src/app/tasks/file_offload.clj
View file

@ -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]))

2
backend/src/app/tasks/file_xlog_gc.clj
View file

@ -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]))

2
backend/src/app/tasks/objects_gc.clj
View file

@ -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]

2
backend/src/app/tasks/tasks_gc.clj
View file

@ -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]))

110
backend/src/app/util/logging.clj
View file

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

2
backend/src/app/util/migrations.clj
View file

@ -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]))

35
backend/src/app/util/services.clj
View file

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

15
backend/src/app/rpc/queries/svg.clj → backend/src/app/util/svg.clj
View file

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

2
backend/src/app/worker.clj
View file

@ -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]

17
backend/test/app/services_files_test.clj
View file

@ -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)]

24
backend/test/app/services_profile_test.clj
View file

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

6
backend/test/app/services_teams_test.clj
View file

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

11
backend/test/app/test_helpers.clj
View file

@ -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]

10
common/src/app/common/data.cljc
View file

@ -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]

5
common/src/app/common/exceptions.cljc
View file

@ -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

117
common/src/app/common/file_builder.cljc
View file

@ -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)
:interactions
(filterv #(or (not= (:action-type %) action-type)
(not= (:event-type %) event-type))))
interactions (-> interactions
(let [{:keys [event-type action-type]} (read-classifier interaction-src)
{:keys [delay]} (read-event-opts interaction-src)
{:keys [destination overlay-pos-type overlay-position url
close-click-outside background-overlay]} (read-action-opts interaction-src)
interactions (-> (lookup-shape file from-id)
:interactions
(conjv
{:action-type action-type
:event-type event-type
:destination destination}))]
(d/without-nils {:event-type event-type
:action-type action-type
:delay delay
:destination destination
:overlay-pos-type overlay-pos-type
:overlay-position overlay-position
:url url
:close-click-outside close-click-outside
:background-overlay background-overlay})))]
(commit-change
file
{:type :mod-obj

39
common/src/app/common/flags.cljc
View file

@ -9,24 +9,31 @@
(:require
[cuerdas.core :as str]))
(def default
#{:backend-asserts
:api-doc
:registration
:demo-users})
(defn parse
[default flags]
(loop [flags (seq flags)
result default]
(let [item (first flags)]
(if (nil? item)
result
(let [sname (name item)]
(cond
(str/starts-with? sname "enable-")
(recur (rest flags)
(conj result (keyword (subs sname 7))))
([flags] (parse flags #{}))
([flags default]
(loop [flags (seq flags)
result default]
(let [item (first flags)]
(if (nil? item)
result
(let [sname (name item)]
(cond
(str/starts-with? sname "enable-")
(recur (rest flags)
(conj result (keyword (subs sname 7))))
(str/starts-with? sname "disable-")
(recur (rest flags)
(disj result (keyword (subs sname 8))))
(str/starts-with? sname "disable-")
(recur (rest flags)
(disj result (keyword (subs sname 8))))
:else
(recur (rest flags) result)))))))
:else
(recur (rest flags) result))))))))

18
common/src/app/common/geom/point.cljc
View file

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

19
common/src/app/common/geom/shapes.cljc
View file

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

32
common/src/app/common/geom/shapes/bool.cljc Normal file
View file

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

12
common/src/app/common/geom/shapes/common.cljc
View file

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

20
common/src/app/common/geom/shapes/intersect.cljc
View file

@ -284,12 +284,19 @@
(defn overlaps?
"General case to check for overlaping between shapes and a rectangle"
[shape rect]
(or (not shape)
(let [path? (= :path (:type shape))
circle? (= :circle (:type shape))]
(and (overlaps-rect-points? rect (:points shape))
(or (not path?) (overlaps-path? shape rect))
(or (not circle?) (overlaps-ellipse? shape rect))))))
(let [stroke-width (/ (or (:stroke-width shape) 0) 2)
rect (-> rect
(update :x - stroke-width)
(update :y - stroke-width)
(update :width + (* 2 stroke-width))
(update :height + (* 2 stroke-width))
)]
(or (not shape)
(let [path? (= :path (:type shape))
circle? (= :circle (:type shape))]
(and (overlaps-rect-points? rect (:points shape))
(or (not path?) (overlaps-path? shape rect))
(or (not circle?) (overlaps-ellipse? shape rect)))))))
(defn has-point-rect?
[rect point]
@ -308,3 +315,4 @@
(->> shape
:points
(every? (partial has-point-rect? rect))))

783
common/src/app/common/geom/shapes/path.cljc
View file

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

53
common/src/app/common/geom/shapes/rect.cljc
View file

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

60
common/src/app/common/geom/shapes/transforms.cljc
View file

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

297
common/src/app/common/logging.cljc Normal file
View file

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

25
common/src/app/common/math.cljc
View file

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

5
common/src/app/common/pages.cljc
View file

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

6
common/src/app/common/pages/changes.cljc
View file

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

167
common/src/app/common/pages/changes_builder.cljc Normal file
View file

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

25
common/src/app/common/pages/helpers.cljc
View file

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

26
common/src/app/common/pages/indices.cljc
View file

@ -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?
(->> parents
(map #(get objects %))
(filter #(:masked-group? %))
;; Retrieve the masking element
(mapv #(get objects (->> % :shapes first)))))]
(let [lookup-object (fn [id] (get objects id))
get-clip-parents
(fn [shape]
(cond-> []
(:masked-group? shape)
(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))))

138
common/src/app/common/pages/spec.cljc
View file

@ -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/offset ::safe-number)
(s/def :internal.gradient.stop/opacity ::us/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-y ::safe-number)
(s/def :internal.gradient/end-x ::safe-number)
(s/def :internal.gradient/end-y ::safe-number)
(s/def :internal.gradient/width ::safe-number)
(s/def :internal.gradient/start-x ::us/safe-number)
(s/def :internal.gradient/start-y ::us/safe-number)
(s/def :internal.gradient/end-x ::us/safe-number)
(s/def :internal.gradient/end-y ::us/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-y ::safe-number)
(s/def :internal.shadow/blur ::safe-number)
(s/def :internal.shadow/spread ::safe-number)
(s/def :internal.shadow/offset-x ::us/safe-number)
(s/def :internal.shadow/offset-y ::us/safe-number)
(s/def :internal.shadow/blur ::us/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/line-height ::safe-number)
(s/def :internal.shape/letter-spacing ::us/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/ry ::safe-number)
(s/def :internal.shape/r1 ::safe-number)
(s/def :internal.shape/r2 ::safe-number)
(s/def :internal.shape/r3 ::safe-number)
(s/def :internal.shape/r4 ::safe-number)
(s/def :internal.shape/rx ::us/safe-number)
(s/def :internal.shape/ry ::us/safe-number)
(s/def :internal.shape/r1 ::us/safe-number)
(s/def :internal.shape/r2 ::us/safe-number)
(s/def :internal.shape/r3 ::us/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/y ::safe-number)
(s/def :internal.shape/cx ::safe-number)
(s/def :internal.shape/cy ::safe-number)
(s/def :internal.shape/width ::safe-number)
(s/def :internal.shape/height ::safe-number)
(s/def :internal.shape/x ::us/safe-number)
(s/def :internal.shape/y ::us/safe-number)
(s/def :internal.shape/cx ::us/safe-number)
(s/def :internal.shape/cy ::us/safe-number)
(s/def :internal.shape/width ::us/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/y1 ::safe-number)
(s/def :internal.shape/x2 ::safe-number)
(s/def :internal.shape/y2 ::safe-number)
(s/def :internal.shape/x1 ::us/safe-number)
(s/def :internal.shape/y1 ::us/safe-number)
(s/def :internal.shape/x2 ::us/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/height ::safe-integer)
(s/def :internal.media-object/width ::us/safe-integer)
(s/def :internal.media-object/height ::us/safe-integer)
(s/def :internal.media-object/mtype ::string)
(s/def ::media-object

309
common/src/app/common/path/bool.cljc Normal file
View file

@ -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 [])))

3
frontend/src/app/util/path/commands.cljs → common/src/app/common/path/commands.cljc
View file

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

227
common/src/app/common/path/shapes_to_path.cljc Normal file
View file

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

75
frontend/src/app/util/path/subpaths.cljs → common/src/app/common/path/subpaths.cljc
View file

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

14
common/src/app/common/spec.cljc
View file

@ -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

376
common/src/app/common/types/interactions.cljc Normal file
View file

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

94
common/src/app/common/types/page_options.cljc Normal file
View file

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

16
docker/devenv/Dockerfile
View file

@ -3,10 +3,10 @@ LABEL maintainer="Andrey Antukh <niwi@niwi.nz>"
ARG DEBIAN_FRONTEND=noninteractive
ENV NODE_VERSION=v14.17.5 \
CLOJURE_VERSION=1.10.3.933 \
CLJKONDO_VERSION=2021.07.28 \
BABASHKA_VERSION=0.5.1 \
ENV NODE_VERSION=v14.17.6 \
CLOJURE_VERSION=1.10.3.967 \
CLJKONDO_VERSION=2021.09.15 \
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; \
@ -172,9 +173,10 @@ COPY files/vimrc /root/.vimrc
COPY files/tmux.conf /root/.tmux.conf
COPY files/sudoers /etc/sudoers
COPY files/start-tmux.sh /home/start-tmux.sh
COPY files/entrypoint.sh /home/entrypoint.sh
COPY files/init.sh /home/init.sh
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
ENTRYPOINT ["/home/entrypoint.sh"]
CMD ["/home/init.sh"]

54
docker/devenv/docker-compose.yaml
View file

@ -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

Some files were not shown because too many files have changed in this diff Show more