mirror of
https://github.com/penpot/penpot.git
synced 2025-03-19 11:11:21 -05:00
Merge branch 'staging'
This commit is contained in:
commit
78d1c57b7c
306 changed files with 14686 additions and 4386 deletions
|
@ -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
6
.gitignore
vendored
|
@ -38,4 +38,8 @@ node_modules
|
|||
/deploy
|
||||
/web
|
||||
/_dump
|
||||
/vendor/svgclean/bundle*.js
|
||||
/vendor/svgclean/bundle*.js
|
||||
|
||||
.calva
|
||||
.clj-kondo
|
||||
.lsp
|
||||
|
|
68
CHANGES.md
68
CHANGES.md
|
@ -1,31 +1,91 @@
|
|||
# CHANGELOG
|
||||
|
||||
|
||||
## :rocket: Next
|
||||
|
||||
### :boom: Breaking changes
|
||||
### :sparkles: New features
|
||||
### :bug: Bugs fixed
|
||||
### :arrow_up: Deps updates
|
||||
### :boom: Breaking changes
|
||||
### :heart: Community contributions by (Thank you!)
|
||||
|
||||
|
||||
## 1.9.0-alpha
|
||||
|
||||
### :boom: Breaking changes
|
||||
|
||||
- Some stroke-caps can change behaviour.
|
||||
- Text display bug fix could potentialy make some texts jump a line.
|
||||
|
||||
### :sparkles: New features
|
||||
|
||||
- Add boolean shapes: intersections, unions, difference and exclusions[Taiga #748](https://tree.taiga.io/project/penpot/us/748).
|
||||
- Add advanced prototyping [Taiga #244](https://tree.taiga.io/project/penpot/us/244).
|
||||
- Add multiple flows [Taiga #2091](https://tree.taiga.io/project/penpot/us/2091).
|
||||
- Change order of the teams menu so it's in the joined time order.
|
||||
|
||||
### :bug: Bugs fixed
|
||||
|
||||
- Enhance duplicating prototype connections behaviour [Taiga #2093](https://tree.taiga.io/project/penpot/us/2093).
|
||||
- Ignore constraints in horizontal or vertical flip [Taiga #2038](https://tree.taiga.io/project/penpot/issue/2038).
|
||||
- Fix color and typographies refs lost when duplicated file [Taiga #2165](https://tree.taiga.io/project/penpot/issue/2165).
|
||||
- Fix problem with overflow dropdown on stroke-cap [#1216](https://github.com/penpot/penpot/issues/1216).
|
||||
- Fix menu context for single element nested in components [#1186](https://github.com/penpot/penpot/issues/1186).
|
||||
- Fix error screen when operations over comments fail [#1219](https://github.com/penpot/penpot/issues/1219).
|
||||
- Fix undo problem when changing typography/color from library [#1230](https://github.com/penpot/penpot/issues/1230).
|
||||
- Fix problem with text margin while rendering [#1231](https://github.com/penpot/penpot/issues/1231).
|
||||
- Fix problem with masked texts on exporting [Taiga #2116](https://tree.taiga.io/project/penpot/issue/2116).
|
||||
- Fix text editor enter behaviour with centered texts [Taiga #2126](https://tree.taiga.io/project/penpot/issue/2126).
|
||||
- Fix residual stroke on imported svg [Taiga #2125](https://tree.taiga.io/project/penpot/issue/2125).
|
||||
- Add links for terms of service and privacy policy in register checkbox [Taiga #2020](https://tree.taiga.io/project/penpot/issue/2020).
|
||||
- Allow three character hex and web colors in color picker hex input [#1184](https://github.com/penpot/penpot/issues/1184).
|
||||
- Allow lowercase search for fonts [#1180](https://github.com/penpot/penpot/issues/1180).
|
||||
- Fix group renaming problem [Taiga #1969](https://tree.taiga.io/project/penpot/issue/1969).
|
||||
- Fix export group with shadows on children [Taiga #2036](https://tree.taiga.io/project/penpot/issue/2036).
|
||||
- Fix zoom context menu in viewer [Taiga #2041](https://tree.taiga.io/project/penpot/issue/2041).
|
||||
- Fix stroke caps adjustments in relation with stroke size [Taiga #2123](https://tree.taiga.io/project/penpot/issue/2123).
|
||||
- Fix problem duplicating paths [Taiga #2147](https://tree.taiga.io/project/penpot/issue/2147).
|
||||
- Fix problem inheriting attributes from SVG root when importing [Taiga #2124](https://tree.taiga.io/project/penpot/issue/2124).
|
||||
- Fix problem with lines and inside/outside stroke [Taiga #2146](https://tree.taiga.io/project/penpot/issue/2146).
|
||||
- Add stroke width in selection calculation [Taiga #2146](https://tree.taiga.io/project/penpot/issue/2146).
|
||||
- Fix shift+wheel to horizontal scrolling in MacOS [#1217](https://github.com/penpot/penpot/issues/1217).
|
||||
- Fix path stroke is not working properly with high thickness [Taiga #2154](https://tree.taiga.io/project/penpot/issue/2154).
|
||||
- Fix bug with transformation operations [Taiga #2155](https://tree.taiga.io/project/penpot/issue/2155).
|
||||
- Fix bug in firefox when a text box is inside a mask [Taiga #2152](https://tree.taiga.io/project/penpot/issue/2152).
|
||||
- Fix problem with stroke inside/outside [Taiga #2186](https://tree.taiga.io/project/penpot/issue/2186)
|
||||
- Fix masks export area [Taiga #2189](https://tree.taiga.io/project/penpot/issue/2189)
|
||||
- Fix paste in place in arboards [Taiga #2188](https://tree.taiga.io/project/penpot/issue/2188)
|
||||
- Fix font size input stuck on selection change [Taiga #2184](https://tree.taiga.io/project/penpot/issue/2184)
|
||||
- Fix stroke cut on shapes export [Taiga #2171](https://tree.taiga.io/project/penpot/issue/2171)
|
||||
- Fix no color when boolean with an SVG [Taiga #2193](https://tree.taiga.io/project/penpot/issue/2193)
|
||||
- Fix unlink color styles at strokes [Taiga #2206](https://tree.taiga.io/project/penpot/issue/2206).
|
||||
|
||||
### :arrow_up: Deps updates
|
||||
|
||||
### :heart: Community contributions by (Thank you!)
|
||||
|
||||
- To the translation community for the hard work on making penpot
|
||||
available on so many languages.
|
||||
|
||||
|
||||
|
||||
## 1.8.4-alpha
|
||||
|
||||
### :bug: Bugs fixed
|
||||
|
||||
- Fix problem importing components [Taiga #2151](https://tree.taiga.io/project/penpot/issue/2151)
|
||||
- Fix problem importing components [Taiga #2151](https://tree.taiga.io/project/penpot/issue/2151).
|
||||
|
||||
## 1.8.3-alpha
|
||||
|
||||
### :sparkles: New features
|
||||
|
||||
- Adds progress report to importing process
|
||||
- Adds progress report to importing process.
|
||||
|
||||
## 1.8.2-alpha
|
||||
|
||||
### :bug: Bugs fixed
|
||||
|
||||
- Fix problem with masking images in viewer [#1238](https://github.com/penpot/penpot/issues/1238)
|
||||
- Fix problem with masking images in viewer [#1238](https://github.com/penpot/penpot/issues/1238).
|
||||
|
||||
## 1.8.1-alpha
|
||||
|
||||
|
|
|
@ -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
101
backend/resources/api-doc.css
Normal 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
27
backend/resources/api-doc.js
Normal 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
80
backend/resources/api-doc.tmpl
Normal 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>
|
||||
|
|
@ -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">
|
||||
|
|
|
@ -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";
|
||||
|
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -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]))
|
||||
|
||||
|
|
|
@ -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])
|
||||
|
|
|
@ -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]))
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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,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)}]
|
||||
|
|
|
@ -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
53
backend/src/app/http/doc.clj
Normal 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 ""}))))
|
|
@ -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 _]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)})
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
126
backend/src/app/loggers/database.clj
Normal 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"})))))
|
|
@ -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]
|
||||
|
|
|
@ -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
172
backend/src/app/loggers/sentry.clj
Normal 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)))
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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,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})
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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})
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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))
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
|
@ -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))))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
23
backend/src/app/rpc/queries/share_link.clj
Normal 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)))
|
||||
|
|
@ -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
|
||||
|
|
|
@ -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])))
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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)))))
|
|
@ -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)
|
||||
|
|
@ -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]))
|
||||
|
|
|
@ -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]))
|
||||
|
|
|
@ -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]))
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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]))
|
||||
|
|
|
@ -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))
|
|
@ -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]))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
@ -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]
|
||||
|
|
|
@ -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)]
|
||||
|
|
|
@ -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"}]
|
||||
|
|
|
@ -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)))))
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))))))))
|
||||
|
||||
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
32
common/src/app/common/geom/shapes/bool.cljc
Normal 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))))
|
|
@ -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))))
|
||||
|
|
|
@ -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))))
|
||||
|
||||
|
|
|
@ -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?)))))
|
||||
|
|
|
@ -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)))))
|
||||
|
|
|
@ -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
297
common/src/app/common/logging.cljc
Normal 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)))
|
||||
|
||||
|
|
@ -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)))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
167
common/src/app/common/pages/changes_builder.cljc
Normal 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))))))
|
|
@ -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)))
|
||||
|
||||
|
|
|
@ -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))))
|
||||
|
|
|
@ -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
309
common/src/app/common/path/bool.cljc
Normal 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 [])))
|
|
@ -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
227
common/src/app/common/path/shapes_to_path.cljc
Normal 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)))
|
|
@ -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))))))
|
|
@ -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
376
common/src/app/common/types/interactions.cljc
Normal 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
94
common/src/app/common/types/page_options.cljc
Normal 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))
|
||||
|
|
@ -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"]
|
||||
|
|
|
@ -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
Loading…
Add table
Reference in a new issue