3pp-mirror/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-07-09 08:37:18 +02:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'staging' into main

Browse source
This commit is contained in:
Andrey Antukh 2021-07-14 11:32:09 +02:00
commit a6d156438f
468 changed files with 16810 additions and 8136 deletions
Download patch file Download diff file Expand all files Collapse all files

46
.circleci/config.yml
View file

@ -9,7 +9,7 @@ jobs:
# CircleCI maintains a library of pre-built images
# documented at https://circleci.com/docs/2.0/circleci-images/
# - image: circleci/postgres:9.4
- image: circleci/postgres:13.1-ram
- image: circleci/postgres:13.3-ram
environment:
POSTGRES_USER: penpot_test
POSTGRES_PASSWORD: penpot_test
@ -29,21 +29,30 @@ jobs:
# Download and cache dependencies
- restore_cache:
keys:
- v1-dependencies-{{ checksum "backend/deps.edn" }}-{{ checksum "frontend/deps.edn"}}
- v1-dependencies-{{ checksum "backend/deps.edn" }}-{{ checksum "frontend/deps.edn"}}-{{ checksum "common/deps.edn"}}
# fallback to using the latest cache if no exact match is found
- v1-dependencies-
# run lint
- run:
working_directory: "./backend"
name: backend lint
command: "clj-kondo --lint src/"
name: common lint
working_directory: "./common"
command: "clj-kondo --parallel --lint src/"
# run test
- run:
name: frontend lint
working_directory: "./frontend"
command: "clj-kondo --parallel --lint src/"
- run:
name: backend lint
working_directory: "./backend"
command: "clj-kondo --parallel --lint src/"
# run backend test
- run:
name: backend test
command: "clojure -M:dev:tests"
working_directory: "./backend"
command: "clojure -X:dev:test"
environment:
PENPOT_TEST_DATABASE_URI: "postgresql://localhost/penpot_test"
PENPOT_TEST_DATABASE_USERNAME: penpot_test
@ -51,11 +60,26 @@ jobs:
PENPOT_TEST_REDIS_URI: "redis://localhost/1"
- run:
working_directory: "./frontend"
name: frontend tests
working_directory: "./frontend"
command: |
yarn install
npx shadow-cljs compile tests
clojure -M:dev:shadow-cljs compile test
node target/tests.js
environment:
JAVA_HOME: /usr/lib/jvm/openjdk16
PATH: /usr/local/nodejs/bin/:/usr/local/bin:/bin:/usr/bin:/usr/lib/jvm/openjdk16/bin
- run:
working_directory: "./common"
name: common tests
command: |
yarn install
clojure -M:dev:shadow-cljs compile test
node target/tests.js
clojure -X:dev:test
environment:
JAVA_HOME: /usr/lib/jvm/openjdk16
PATH: /usr/local/nodejs/bin/:/usr/local/bin:/bin:/usr/bin:/usr/lib/jvm/openjdk16/bin
@ -63,5 +87,5 @@ jobs:
- save_cache:
paths:
- ~/.m2
key: v1-dependencies-{{ checksum "backend/deps.edn" }}-{{ checksum "frontend/deps.edn"}}
key: v1-dependencies-{{ checksum "backend/deps.edn" }}-{{ checksum "frontend/deps.edn"}}-{{ checksum "common/deps.edn"}}

25
.clj-kondo/config.edn
View file

@ -1,14 +1,23 @@
{:lint-as {potok.core/reify clojure.core/reify
promesa.core/let clojure.core/let
{:lint-as
{promesa.core/let clojure.core/let
rumext.alpha/defc clojure.core/defn
rumext.alpha/fnc clojure.core/fn
app.common.data/export clojure.core/def
app.db/with-atomic clojure.core/with-open}
:hooks
{:analyze-call {app.common.data/export hooks.export/export}}
{:analyze-call
{app.common.data/export hooks.export/export
potok.core/reify hooks.export/potok-reify
cljs.core/specify! hooks.export/clojure-specify
app.util.services/defmethod hooks.export/service-defmethod
}}
:output
{:exclude-files ["data_readers.clj"]}
{:exclude-files
["data_readers.clj"
"app/util/perf.cljs"
"app/common/exceptions.cljc"]}
:linters
{:unsorted-required-namespaces
@ -21,12 +30,12 @@
:single-key-in
{:level :warning}
:redundant-do
{:level :off}
:unused-binding
{:exclude-destructured-as true
:exclude-destructured-keys-in-fn-args false
}
:unresolved-symbol
{:exclude ['(app.util.services/defmethod)
]}}}
}}

38
.clj-kondo/hooks/export.clj
View file

@ -9,3 +9,41 @@
(api/token-node (symbol (name (:value sname))))
sname])]
{:node result}))
(defn potok-reify
[{:keys [:node]}]
(let [[rnode rtype & other] (:children node)
result (api/list-node
(into [(api/token-node (symbol "deftype"))
(api/token-node (gensym (name (:k rtype))))
(api/vector-node [])]
other))]
{:node result}))
(defn clojure-specify
[{:keys [:node]}]
(let [[rnode rtype & other] (:children node)
result (api/list-node
(into [(api/token-node (symbol "extend-type"))
(api/token-node (gensym (:string-value rtype)))]
other))]
{:node result}))
(defn service-defmethod
[{:keys [:node]}]
(let [[rnode rtype & other] (:children node)
rsym (gensym (name (:k rtype)))
result (api/list-node
[(api/token-node (symbol "do"))
(api/list-node
[(api/token-node (symbol "declare"))
(api/token-node rsym)])
(api/list-node
(into [(api/token-node (symbol "defmethod"))
(api/token-node rsym)
rtype]
other))])]
{:node result}))

40
CHANGES.md
View file

@ -5,6 +5,46 @@
### :sparkles: New features
### :bug: Bugs fixed
### :arrow_up: Deps updates
### :boom: Breaking changes
### :heart: Community contributions by (Thank you!)
## 1.7.0-alpha
### :sparkles: New features
- Allow nested asset groups [Taiga #1716](https://tree.taiga.io/project/penpot/us/1716).
- Allow to ungroup assets [Taiga #1719](https://tree.taiga.io/project/penpot/us/1719).
- Allow to rename assets groups [Taiga #1721](https://tree.taiga.io/project/penpot/us/1721).
- Component constraints (left, right, left and right, center, scale...) [Taiga #1125](https://tree.taiga.io/project/penpot/us/1125).
- Export elements to PDF [Taiga #519](https://tree.taiga.io/project/penpot/us/519).
- Memorize collapse state of assets in panel [Taiga #1718](https://tree.taiga.io/project/penpot/us/1718).
- Headers button sets and menus review [Taiga #1663](https://tree.taiga.io/project/penpot/us/1663).
- Preserve components if possible, when pasted into a different file [Taiga #1063](https://tree.taiga.io/project/penpot/issue/1063).
- Add the ability to offload file data to a cheaper storage when file becomes inactive.
- Import/Export Penpot files from dashboard.
- Double click won't make a shape a path until you change a node [Taiga #1796](https://tree.taiga.io/project/penpot/us/1796)
- Incremental area selection [#779](https://github.com/penpot/penpot/discussions/779)
### :bug: Bugs fixed
- Process numeric input changes only if the value actually changed.
- Remove unnecesary redirect from history when user goes to workspace from dashboard [Taiga #1820](https://tree.taiga.io/project/penpot/issue/1820).
- Detach shapes from deleted assets [Taiga #1850](https://tree.taiga.io/project/penpot/issue/1850).
- Fix tooltip position on view application [Taiga #1819](https://tree.taiga.io/project/penpot/issue/1819).
- Fix dashboard navigation on moving file to other team [Taiga #1817](https://tree.taiga.io/project/penpot/issue/1817).
- Fix workspace header presence styles and invalid link [Taiga #1813](https://tree.taiga.io/project/penpot/issue/1813).
- Fix color-input wrong behavior (on workspace page color) [Taiga #1795](https://tree.taiga.io/project/penpot/issue/1795).
- Fix file contextual menu in shared libraries at dashboard [Taiga #1865](https://tree.taiga.io/project/penpot/issue/1865).
- Fix problem with color picker and fonts [#1049](https://github.com/penpot/penpot/issues/1049)
- Fix negative values in blur [Taiga #1815](https://tree.taiga.io/project/penpot/issue/1815)
- Fix problem when editing color in group [Taiga #1816](https://tree.taiga.io/project/penpot/issue/1816)
- Fix resize/rotate with mouse buttons different than left [#1060](https://github.com/penpot/penpot/issues/1060)
- Fix header partialy visible on fullscreen viewer mode [Taiga #1875](https://tree.taiga.io/project/penpot/issue/1875)
- Fix dynamic alignment enabled with hidden objects [#1063](https://github.com/penpot/penpot/issues/1063)
### :arrow_up: Deps updates
### :boom: Breaking changes
### :heart: Community contributions by (Thank you!)

73
README.md
View file

@ -2,24 +2,60 @@
[uri_license]: https://www.mozilla.org/en-US/MPL/2.0
[uri_license_image]: https://img.shields.io/badge/MPL-2.0-blue.svg
[![License: MPL-2.0][uri_license_image]][uri_license]
[![Gitter](https://badges.gitter.im/sereno-xyz/community.svg)](https://gitter.im/penpot/community)
[![Managed with Taiga.io](https://img.shields.io/badge/managed%20with-TAIGA.io-709f14.svg)](https://tree.taiga.io/project/penpot/ "Managed with Taiga.io")
[![Gitpod ready-to-code](https://img.shields.io/badge/Gitpod-ready--to--code-blue?logo=gitpod)](https://gitpod.io/#https://github.com/penpot/penpot)
<h1 align="center">
<br>
<img src="https://penpot.app/images/readme/readme-logo.jpg" alt="PENPOT">
</h1>
<p align="center"><a href="https://www.mozilla.org/en-US/MPL/2.0" rel="nofollow"><img src="https://camo.githubusercontent.com/3fcf3d6b678ea15fde3cf7d6af0e242160366282d62a7c182d83a50bfee3f45e/68747470733a2f2f696d672e736869656c64732e696f2f62616467652f4d504c2d322e302d626c75652e737667" alt="License: MPL-2.0" data-canonical-src="https://img.shields.io/badge/MPL-2.0-blue.svg" style="max-width:100%;"></a>
<a href="https://gitter.im/penpot/community" rel="nofollow"><img src="https://camo.githubusercontent.com/5b0aecb33434f82a7b158eab7247544235ada0cf7eeb9ce8e52562dd67f614b7/68747470733a2f2f6261646765732e6769747465722e696d2f736572656e6f2d78797a2f636f6d6d756e6974792e737667" alt="Gitter" data-canonical-src="https://badges.gitter.im/sereno-xyz/community.svg" style="max-width:100%;"></a>
<a href="https://tree.taiga.io/project/penpot/" title="Managed with Taiga.io" rel="nofollow"><img src="https://camo.githubusercontent.com/4a1d1112f0272e3393b1e8da312ff4435418e9e2eb4c0964881e3680f90a653c/68747470733a2f2f696d672e736869656c64732e696f2f62616467652f6d616e61676564253230776974682d54414947412e696f2d3730396631342e737667" alt="Managed with Taiga.io" data-canonical-src="https://img.shields.io/badge/managed%20with-TAIGA.io-709f14.svg" style="max-width:100%;"></a>
<a href="https://gitpod.io/#https://github.com/penpot/penpot" rel="nofollow"><img src="https://camo.githubusercontent.com/daadb4894128d1e19b72d80236f5959f1f2b47f9fe081373f3246131f0189f6c/68747470733a2f2f696d672e736869656c64732e696f2f62616467652f476974706f642d72656164792d2d746f2d2d636f64652d626c75653f6c6f676f3d676974706f64" alt="Gitpod ready-to-code" data-canonical-src="https://img.shields.io/badge/Gitpod-ready--to--code-blue?logo=gitpod" style="max-width:100%;"></a></p>
![PENPOT](https://penpot.app/images/readme/home-ui.jpg)
# PENPOT #
## What is Penpot? ##
Penpot is the first Open Source design and prototyping platform meant
for cross-domain teams. Non dependent on operating systems, Penpot is
web based and works with open web standards (SVG). For all and
empowered by the community.
Penpot is the first **Open Source design** and prototyping platform meant for cross-domain teams. Non dependent on operating systems, Penpot is web based and works with open web standards (SVG). For all and empowered by the community.
![PENPOT](https://penpot.app/images/workspace-ui.jpg)
- [How to use](#how-to-use)
- [Help center](#help-center)
- [Contributing](#contributing)
- [Give feedback](#give-feedback)
- [Tutorials](#tutorials)
- [License](#license)
## How to use ##
Login or Register on our Penpot cloud app. Create a team to work together on projects and share design assets or jump right away into Penpot and **start designing** by your own.
✏️ [Start using Penpot](https://design.penpot.app)
You can also install Penpot in a local environment. This section details everything you need to know to get Penpot up and running in production environments. Although it can be installed in many ways, the recommended approach is using **docker** and **docker-compose**.
🐳 [Install docker](https://help.penpot.app/technical-guide/getting-started/)
## Help center ##
In this documentation you will find (almost) everything you need to know about how to work with Penpot. From the interface basics to advanced functionality.
📖 [User guide](https://help.penpot.app/user-guide/)
❓ [FAQs](https://help.penpot.app/faqs/)
🖥️ [Technical guide](https://help.penpot.app/technical-guide/)
❤️ [Contributing guide](https://help.penpot.app/contributing-guide/)
![User guide](https://penpot.app/images/readme/help-center.jpg)
## Contributing ##
<p align="center">
<img src="https://penpot.app/images/open-source.png" alt="Open Source">
</p>
**Open to you!**
We love the open source software community. Contributing is our
@ -28,11 +64,24 @@ and improve Penpot. All your awesome ideas and code are welcome!
Please refer to the [Contributing Guide](./CONTRIBUTING.md)
## Give feedback ##
## Documentation ##
You can ask and answer questions, have open-ended conversations, and follow along on decisions affecting the project.
Please refer to the [help center](https://help.penpot.app).
✉️ [Mail us](mailto:info@penpot.app)
💬 [Github discussions](https://github.com/penpot/penpot/discussions)
🐞 [Github issues](mailto:info@penpot.apphttps://github.com/penpot/penpot/issues)
✍️️ [Gitter](https://gitter.im/penpot/community)
## Tutorials ##
You can ask and answer questions, have open-ended conversations, and follow along on decisions affecting the project.
Would you like to know more about Penpot? We recommend you to visit our youtube channel and learn more about the functionalities and possibilities of Penpot with our video tutorials.
🎞️ [Youtube channel](https://www.youtube.com/channel/UCAqS8G72uv9P5HG1IfgnQ9g)
## License ##

62
backend/deps.edn
View file

@ -1,22 +1,14 @@
{:mvn/repos
{"central" {:url "https://repo1.maven.org/maven2/"}
"clojars" {:url "https://clojars.org/repo"}
"jcenter" {:url "https://jcenter.bintray.com/"}}
{
;; :mvn/repos
;; {"central" {:url "https://repo1.maven.org/maven2/"}
;; "clojars" {:url "https://clojars.org/repo"}
;; "jcenter" {:url "https://jcenter.bintray.com/"}
;; }
:deps
{org.clojure/clojure {:mvn/version "1.10.3"}
org.clojure/data.json {:mvn/version "2.2.3"}
org.clojure/core.async {:mvn/version "1.3.618"}
org.clojure/tools.cli {:mvn/version "1.0.206"}
org.clojure/clojurescript {:mvn/version "1.10.844"}
{penpot/common
{:local/root "../common"}
;; Logging
org.clojure/tools.logging {:mvn/version "1.1.0"}
org.apache.logging.log4j/log4j-api {:mvn/version "2.14.1"}
org.apache.logging.log4j/log4j-core {:mvn/version "2.14.1"}
org.apache.logging.log4j/log4j-web {:mvn/version "2.14.1"}
org.apache.logging.log4j/log4j-jul {:mvn/version "2.14.1"}
org.apache.logging.log4j/log4j-slf4j18-impl {:mvn/version "2.14.1"}
org.slf4j/slf4j-api {:mvn/version "2.0.0-alpha1"}
org.zeromq/jeromq {:mvn/version "0.5.2"}
com.taoensso/nippy {:mvn/version "3.1.1"}
@ -32,69 +24,57 @@
org.eclipse.jetty/jetty-servlet]}
io.prometheus/simpleclient_httpserver {:mvn/version "0.9.0"}
selmer/selmer {:mvn/version "1.12.40"}
expound/expound {:mvn/version "0.8.9"}
com.cognitect/transit-clj {:mvn/version "1.0.324"}
io.lettuce/lettuce-core {:mvn/version "6.1.2.RELEASE"}
java-http-clj/java-http-clj {:mvn/version "0.4.2"}
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"}
metosin/jsonista {:mvn/version "0.3.3"}
org.postgresql/postgresql {:mvn/version "42.2.20"}
com.zaxxer/HikariCP {:mvn/version "4.0.3"}
funcool/datoteka {:mvn/version "2.0.0"}
funcool/promesa {:mvn/version "6.0.1"}
funcool/cuerdas {:mvn/version "2021.05.09-0"}
buddy/buddy-core {:mvn/version "1.10.1"}
buddy/buddy-hashers {:mvn/version "1.8.1"}
buddy/buddy-sign {:mvn/version "3.4.1"}
lambdaisland/uri {:mvn/version "1.4.54"
:exclusions [org.clojure/data.json]}
frankiesardo/linked {:mvn/version "1.3.0"}
danlentz/clj-uuid {:mvn/version "0.1.9"}
org.jsoup/jsoup {:mvn/version "1.13.1"}
org.im4java/im4java {:mvn/version "1.4.0"}
org.lz4/lz4-java {:mvn/version "1.7.1"}
commons-io/commons-io {:mvn/version "2.8.0"}
com.sun.mail/jakarta.mail {:mvn/version "2.0.1"}
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"}
software.amazon.awssdk/s3 {:mvn/version "2.16.62"}}
;; exception printing
io.aviso/pretty {:mvn/version "0.1.37"}
environ/environ {:mvn/version "1.2.0"}}
:paths ["src" "resources" "../common" "common"]
:paths ["src" "resources"]
:aliases
{:dev
{:extra-deps
{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"}
fipp/fipp {:mvn/version "0.6.23"}
criterium/criterium {:mvn/version "0.4.6"}
mockery/mockery {:mvn/version "0.1.4"}}
:extra-paths ["tests" "dev"]}
criterium/criterium {:mvn/version "RELEASE"}
mockery/mockery {:mvn/version "RELEASE"}}
:extra-paths ["test" "dev"]}
:fn-fixtures
{:exec-fn app.cli.fixtures/run
:args {}}
:tests
:kaocha
{:extra-deps {lambdaisland/kaocha {:mvn/version "1.0.829"}}
: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"}}
:exec-fn cognitect.test-runner.api/test}
:outdated
{:extra-deps {com.github.liquidz/antq {:mvn/version "RELEASE"}}
:main-opts ["-m" "antq.core"]}

2
backend/dev/user.clj
View file

@ -50,7 +50,7 @@
;; --- Development Stuff
(defn- run-tests
([] (run-tests #"^app.tests.*"))
([] (run-tests #"^app.*-test$"))
([o]
(repl/refresh)
(cond

1
backend/scripts/build
View file

@ -49,6 +49,7 @@
;; Create the application jar
(spit "./target/dist/version.txt" version)
(-> ($ jar cvf "./target/dist/deps/app.jar" -C ~(first classpath-paths) ".") check)
(-> ($ jar uvf "./target/dist/deps/app.jar" -C "./target/dist" "version.txt") check)
(run! (fn [item]

2
backend/scripts/repl
View file

@ -2,7 +2,7 @@
export PENPOT_ASSERTS_ENABLED=true
export OPTIONS="-A:jmx-remote:dev -J-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager -J-Dlog4j2.configurationFile=log4j2-devenv.xml -J-XX:+UseZGC -J-XX:ConcGCThreads=1 -J-XX:-OmitStackTraceInFastThrow -J-Xms50m -J-Xmx512m";
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";
# export OPTIONS="$OPTIONS -J-XX:-TieredCompilation -J-XX:CompileThreshold=10000";

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

@ -58,11 +58,8 @@
:srepl-host "127.0.0.1"
:srepl-port 6062
:storage-backend :fs
:storage-fs-directory "assets"
:storage-s3-region :eu-central-1
:storage-s3-bucket "penpot-devenv-assets-pre"
:assets-storage-backend :fs
:storage-assets-fs-directory "assets"
:feedback-destination "info@example.com"
:feedback-enabled false
@ -175,10 +172,14 @@
(s/def ::smtp-username (s/nilable ::us/string))
(s/def ::srepl-host ::us/string)
(s/def ::srepl-port ::us/integer)
(s/def ::storage-backend ::us/keyword)
(s/def ::storage-fs-directory ::us/string)
(s/def ::storage-s3-bucket ::us/string)
(s/def ::storage-s3-region ::us/keyword)
(s/def ::assets-storage-backend ::us/keyword)
(s/def ::fdata-storage-backend ::us/keyword)
(s/def ::storage-assets-fs-directory ::us/string)
(s/def ::storage-assets-s3-bucket ::us/string)
(s/def ::storage-assets-s3-region ::us/keyword)
(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)
@ -257,12 +258,20 @@
::smtp-ssl
::smtp-tls
::smtp-username
::srepl-host
::srepl-port
::storage-backend
::storage-fs-directory
::storage-s3-bucket
::storage-s3-region
::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

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

@ -10,13 +10,14 @@
[app.common.exceptions :as ex]
[app.common.geom.point :as gpt]
[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]
[app.util.transit :as t]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
@ -221,14 +222,20 @@
(sql/delete table params opts)
(assoc opts :return-keys true))))
(defn- is-deleted?
[{:keys [deleted-at]}]
(and (dt/instant? deleted-at)
(< (inst-ms deleted-at)
(inst-ms (dt/now)))))
(defn get-by-params
([ds table params]
(get-by-params ds table params nil))
([ds table params {:keys [uncheked] :or {uncheked false} :as opts}]
(let [res (exec-one! ds (sql/select table params opts))]
(when (and (not uncheked)
(or (:deleted-at res) (not res)))
(when (and (not uncheked) (or (not res) (is-deleted? res)))
(ex/raise :type :not-found
:table table
:hint "database object not found"))
res)))
@ -245,8 +252,11 @@
(exec! ds (sql/select table params opts))))
(defn pgobject?
[v]
([v]
(instance? PGobject v))
([v type]
(and (instance? PGobject v)
(= type (.getType ^PGobject v)))))
(defn pginterval?
[v]
@ -339,12 +349,18 @@
(.setType "inet")
(.setValue (str ip-addr))))
(defn decode-inet
[^PGobject o]
(if (= "inet" (.getType o))
(.getValue o)
nil))
(defn tjson
"Encode as transit json."
[data]
(doto (org.postgresql.util.PGobject.)
(.setType "jsonb")
(.setValue (t/encode-verbose-str data))))
(.setValue (t/encode-str data {:type :json-verbose}))))
(defn json
"Encode as plain json."
@ -360,3 +376,25 @@
(defn pgarray->vector
[v]
(vec (.getArray ^PgArray v)))
;; --- Locks
(defn- xact-check-param
[n]
(cond
(uuid? n) (uuid/get-word-high n)
(int? n) n
:else (throw (IllegalArgumentException. "uuid or number allowed"))))
(defn xact-lock!
[conn n]
(let [n (xact-check-param n)]
(exec-one! conn ["select pg_advisory_xact_lock(?::bigint) as lock" n])
true))
(defn xact-try-lock!
[conn n]
(let [n (xact-check-param n)
row (exec-one! conn ["select pg_try_advisory_xact_lock(?::bigint) as lock" n])]
(:lock row)))

4
backend/src/app/db/sql.clj
View file

@ -43,8 +43,8 @@
([table where-params opts]
(let [opts (merge default-opts opts)
opts (cond-> opts
(:for-update opts)
(assoc :suffix "FOR UPDATE"))]
(:for-update opts) (assoc :suffix "FOR UPDATE")
(:for-key-share opts) (assoc :suffix "FOR KEY SHARE"))]
(sql/for-query table where-params opts))))
(defn update

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

@ -49,7 +49,7 @@
{:status 200
:headers {"content-type" (:content-type mdata)
"cache-control" (str "max-age=" (inst-ms cache-max-age))}
:body (sto/get-object-data storage obj)}
:body (sto/get-object-bytes storage obj)}
:s3
(let [url (sto/get-object-url storage obj {:max-age signature-max-age})]

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

@ -6,13 +6,14 @@
(ns app.http.middleware
(:require
[app.common.transit :as t]
[app.metrics :as mtx]
[app.util.json :as json]
[app.util.logging :as l]
[app.util.transit :as t]
[buddy.core.codecs :as bc]
[buddy.core.hash :as bh]
[clojure.java.io :as io]
[ring.core.protocols :as rp]
[ring.middleware.cookies :refer [wrap-cookies]]
[ring.middleware.keyword-params :refer [wrap-keyword-params]]
[ring.middleware.multipart-params :refer [wrap-multipart-params]]
@ -73,17 +74,28 @@
{:name ::parse-request-body
:compile (constantly wrap-parse-request-body)})
(defn- transit-streamable-body
[data opts]
(reify rp/StreamableResponseBody
(write-body-to-stream [_ response output-stream]
(try
(let [tw (t/writer output-stream opts)]
(t/write! tw data))
(finally
(.close ^java.io.OutputStream output-stream))))))
(defn- impl-format-response-body
[response]
[response request]
(let [body (:body response)
type :json-verbose]
opts {:type :json-verbose}]
(cond
(coll? body)
(-> response
(assoc :body (t/encode body {:type type}))
(update :headers assoc
"content-type"
"application/transit+json"))
(update :headers assoc "content-type" "application/transit+json")
(assoc :body
(if (= :post (:request-method request))
(transit-streamable-body body opts)
(t/encode body opts))))
(nil? body)
(assoc response :status 204 :body "")
@ -96,7 +108,7 @@
(fn [request]
(let [response (handler request)]
(cond-> response
(map? response) (impl-format-response-body)))))
(map? response) (impl-format-response-body request)))))
(def format-response-body
{:name ::format-response-body

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

@ -6,10 +6,14 @@
(ns app.http.oauth
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.uri :as u]
[app.config :as cf]
[app.db :as db]
[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]
@ -19,36 +23,6 @@
[cuerdas.core :as str]
[integrant.core :as ig]))
(defn redirect-response
[uri]
{:status 302
:headers {"location" (str uri)}
:body ""})
(defn generate-error-redirect-uri
[cfg]
(-> (u/uri (:public-uri cfg))
(assoc :path "/#/auth/login")
(assoc :query (u/map->query-string {:error "unable-to-auth"}))))
(defn register-profile
[{:keys [rpc] :as cfg} info]
(let [method-fn (get-in rpc [:methods :mutation :login-or-register])
profile (method-fn info)]
(cond-> profile
(some? (:invitation-token info))
(assoc :invitation-token (:invitation-token info)))))
(defn generate-redirect-uri
[{:keys [tokens] :as cfg} profile]
(let [token (or (:invitation-token profile)
(tokens :generate {:iss :auth
:exp (dt/in-future "15m")
:profile-id (:id profile)}))]
(-> (u/uri (:public-uri cfg))
(assoc :path "/#/auth/verify-token")
(assoc :query (u/map->query-string {:token token})))))
(defn- build-redirect-uri
[{:keys [provider] :as cfg}]
(let [public (u/uri (:public-uri cfg))]
@ -146,6 +120,7 @@
(string? roles) (into #{} (str/words roles))
(vector? roles) (into #{} roles)
:else #{}))]
;; check if profile has a configured set of roles
(when-not (set/subset? provider-roles profile-roles)
(ex/raise :type :internal
@ -175,6 +150,63 @@
{}
params))
(defn- retrieve-profile
[{:keys [pool] :as cfg} info]
(with-open [conn (db/open pool)]
(some->> (:email info)
(profile/retrieve-profile-data-by-email conn)
(profile/populate-additional-data conn)
(profile/decode-profile-row))))
(defn- redirect-response
[uri]
{:status 302
:headers {"location" (str uri)}
:body ""})
(defn- generate-error-redirect
[cfg error]
(let [uri (-> (u/uri (:public-uri cfg))
(assoc :path "/#/auth/login")
(assoc :query (u/map->query-string {:error "unable-to-auth" :hint (ex-message error)})))]
(redirect-response uri)))
(defn- generate-redirect
[{:keys [tokens session audit] :as cfg} request info profile]
(if profile
(let [sxf ((:create session) (:id profile))
token (or (:invitation-token info)
(tokens :generate {:iss :auth
:exp (dt/in-future "15m")
:profile-id (:id profile)}))
params {:token token}
uri (-> (u/uri (:public-uri cfg))
(assoc :path "/#/auth/verify-token")
(assoc :query (u/map->query-string params)))]
(when (fn? audit)
(audit :cmd :submit
:type "mutation"
:name "login"
:profile-id (:id profile)
:ip-addr (audit/parse-client-ip request)
:props (audit/profile->props profile)))
(->> (redirect-response uri)
(sxf request)))
(let [info (assoc info
:iss :prepared-register
:exp (dt/in-future {:hours 48}))
token (tokens :generate info)
params (d/without-nils
{:token token
:fullname (:fullname info)})
uri (-> (u/uri (:public-uri cfg))
(assoc :path "/#/auth/register/validate")
(assoc :query (u/map->query-string params)))]
(redirect-response uri))))
(defn- auth-handler
[{:keys [tokens] :as cfg} {:keys [params] :as request}]
(let [invitation (:invitation-token params)
@ -189,17 +221,15 @@
:body {:redirect-uri uri}}))
(defn- callback-handler
[{:keys [session] :as cfg} request]
[cfg request]
(try
(let [info (retrieve-info cfg request)
profile (register-profile cfg info)
uri (generate-redirect-uri cfg profile)
sxf ((:create session) (:id profile))]
(->> (redirect-response uri)
(sxf request)))
(catch Exception _e
(-> (generate-error-redirect-uri cfg)
(redirect-response)))))
profile (retrieve-profile cfg info)]
(generate-redirect cfg request info profile))
(catch Exception e
(l/warn :hint "error on oauth process"
:cause e)
(generate-error-redirect cfg e))))
;; --- INIT
@ -210,8 +240,8 @@
(s/def ::tokens fn?)
(s/def ::rpc map?)
(defmethod ig/pre-init-spec :app.http.oauth/handlers [_]
(s/keys :req-un [::public-uri ::session ::tokens ::rpc]))
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::public-uri ::session ::tokens ::rpc ::db/pool]))
(defn wrap-handler
[cfg handler]
@ -225,7 +255,7 @@
(-> (assoc @cfg :provider provider)
(handler request)))))
(defmethod ig/init-key :app.http.oauth/handlers
(defmethod ig/init-key ::handler
[_ cfg]
(let [cfg (initialize cfg)]
{:handler (wrap-handler cfg auth-handler)

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

@ -7,8 +7,10 @@
(ns app.loggers.audit
"Services related to the user activity (audit log)."
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.transit :as t]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
@ -16,13 +18,25 @@
[app.util.http :as http]
[app.util.logging :as l]
[app.util.time :as dt]
[app.util.transit :as t]
[app.worker :as wrk]
[clojure.core.async :as a]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[integrant.core :as ig]
[lambdaisland.uri :as u]))
(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 profile->props
[profile]
(-> profile
(select-keys [:is-active :is-muted :auth-backend :email :default-team-id :default-project-id :fullname :lang])
(d/without-nils)))
(defn clean-props
[{:keys [profile-id] :as event}]
(letfn [(clean-common [props]
@ -50,6 +64,7 @@
(assoc k (name v))))
{}
props))]
(update event :props #(-> % clean-common clean-profile-id clean-complex-data))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -87,11 +102,12 @@
:cause res)))
(recur)))
(fn [& [cmd & params]]
(fn [& {:keys [cmd] :as params}]
(let [params (dissoc params :cmd)]
(case cmd
:stop (a/close! input)
:submit (when-not (a/offer! input (first params))
(l/warn :msg "activity channel is full")))))))
:submit (when-not (a/offer! input params)
(l/warn :msg "activity channel is full"))))))))
(defn- persist-events
@ -101,12 +117,13 @@
(:name event)
(:type event)
(:profile-id event)
(some-> (:ip-addr event) db/inet)
(db/tjson (:props event))])]
(aa/with-thread executor
(db/with-atomic [conn pool]
(db/insert-multi! conn :audit-log
[:id :name :type :profile-id :props]
[:id :name :type :profile-id :ip-addr :props]
(sequence (map event->row) events))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -147,17 +164,22 @@
(defn archive-events
[{:keys [pool uri tokens] :as cfg}]
(letfn [(decode-row [{:keys [props] :as row}]
(letfn [(decode-row [{:keys [props ip-addr] :as row}]
(cond-> row
(db/pgobject? props)
(assoc :props (db/decode-transit-pgobject props))))
(assoc :props (db/decode-transit-pgobject props))
(row->event [{:keys [name type created-at profile-id props]}]
{:type type
(db/pgobject? ip-addr "inet")
(assoc :ip-addr (db/decode-inet ip-addr))))
(row->event [{:keys [name type created-at profile-id props ip-addr]}]
(cond-> {:type type
:name name
:timestamp created-at
:profile-id profile-id
:props props})
:props props}
(some? ip-addr)
(update :context assoc :source-ip ip-addr)))
(send [events]
(let [token (tokens :generate {:iss "authentication"
@ -168,7 +190,7 @@
"origin" (cf/get :public-uri)
"cookie" (u/map->query-string {:auth-token token})}
params {:uri uri
:timeout 5000
:timeout 6000
:method :post
:headers headers
:body body}
@ -187,7 +209,6 @@
(db/with-atomic [conn pool]
(let [rows (db/exec! conn [sql:retrieve-batch-of-audit-log])
xform (comp (map decode-row)
(map row->event))
events (into [] xform rows)]

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

@ -40,7 +40,8 @@
(defmethod ig/init-key ::reporter
[_ {:keys [receiver uri] :as cfg}]
(l/info :msg "intializing mattermost error reporter" :uri uri)
(when uri
(l/info :msg "initializing mattermost error reporter" :uri uri)
(let [output (a/chan (a/sliding-buffer 128)
(filter #(= (:level %) "error")))]
(receiver :sub output)
@ -51,11 +52,12 @@
(do
(a/<! (handle-event cfg msg))
(recur)))))
output))
output)))
(defmethod ig/halt-key! ::reporter
[_ output]
(a/close! output))
(when output
(a/close! output)))
(defn- send-mattermost-notification!
[cfg {:keys [host version id] :as cdata}]
@ -110,7 +112,7 @@
(aa/with-thread executor
(try
(let [cdata (parse-event event)]
(when (and (:uri cfg) @enabled-mattermost)
(when @enabled-mattermost
(send-mattermost-notification! cfg cdata))
(persist-on-database! cfg cdata))
(catch Exception e

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

@ -44,7 +44,7 @@
:redis-uri (cf/get :redis-uri)}
:app.tokens/tokens
{:props (ig/ref :app.setup/props)}
{:keys (ig/ref :app.setup/keys)}
:app.storage/gc-deleted-task
{:pool (ig/ref :app.db/pool)
@ -90,7 +90,7 @@
:tokens (ig/ref :app.tokens/tokens)
:public-uri (cf/get :public-uri)
:metrics (ig/ref :app.metrics/metrics)
:oauth (ig/ref :app.http.oauth/handlers)
:oauth (ig/ref :app.http.oauth/handler)
:assets (ig/ref :app.http.assets/handlers)
:storage (ig/ref :app.storage/storage)
:sns-webhook (ig/ref :app.http.awsns/handler)
@ -107,10 +107,12 @@
:app.http.feedback/handler
{:pool (ig/ref :app.db/pool)}
:app.http.oauth/handlers
:app.http.oauth/handler
{:rpc (ig/ref :app.rpc/rpc)
:session (ig/ref :app.http.session/session)
:pool (ig/ref :app.db/pool)
:tokens (ig/ref :app.tokens/tokens)
:audit (ig/ref :app.loggers.audit/collector)
:public-uri (cf/get :public-uri)}
;; RLimit definition for password hashing
@ -166,27 +168,34 @@
:tasks (ig/ref :app.worker/registry)
:pool (ig/ref :app.db/pool)
:schedule
[{:cron #app/cron "0 0 0 * * ? *" ;; daily
[{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :file-media-gc}
{:cron #app/cron "0 0 * * * ?" ;; hourly
:task :file-xlog-gc}
{:cron #app/cron "0 0 1 * * ?" ;; daily (1 hour shift)
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :storage-deleted-gc}
{:cron #app/cron "0 0 2 * * ?" ;; daily (2 hour shift)
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :storage-touched-gc}
{:cron #app/cron "0 0 3 * * ?" ;; daily (3 hour shift)
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :session-gc}
{:cron #app/cron "0 0 * * * ?" ;; hourly
:task :storage-recheck}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :objects-gc}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :tasks-gc}
(when (cf/get :fdata-storage-backed)
{:cron #app/cron "0 0 * * * ?" ;; hourly
:task :file-offload})
(when (cf/get :audit-archive-enabled)
{:cron #app/cron "0 0 * * * ?" ;; every 1h
:task :audit-archive})
@ -203,6 +212,7 @@
{:metrics (ig/ref :app.metrics/metrics)
: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)
@ -213,6 +223,7 @@
:tasks-gc (ig/ref :app.tasks.tasks-gc/handler)
: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)}}
@ -236,6 +247,11 @@
{: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)}
@ -245,7 +261,13 @@
:app.tasks.file-xlog-gc/handler
{:pool (ig/ref :app.db/pool)
:max-age (dt/duration {:hours 24})}
:max-age (dt/duration {:hours 72})}
:app.tasks.file-offload/handler
{:pool (ig/ref :app.db/pool)
:max-age (dt/duration {:seconds 5})
:storage (ig/ref :app.storage/storage)
:backend (cf/get :fdata-storage-backed :fdata-s3)}
:app.tasks.telemetry/handler
{:pool (ig/ref :app.db/pool)
@ -261,6 +283,9 @@
{:pool (ig/ref :app.db/pool)
:key (cf/get :secret-key)}
:app.setup/keys
{:props (ig/ref :app.setup/props)}
:app.loggers.zmq/receiver
{:endpoint (cf/get :loggers-zmq-uri)}
@ -297,23 +322,32 @@
:app.storage/storage
{:pool (ig/ref :app.db/pool)
:executor (ig/ref :app.worker/executor)
:backend (cf/get :storage-backend :fs)
:backends {:s3 (ig/ref [::main :app.storage.s3/backend])
:db (ig/ref [::main :app.storage.db/backend])
:fs (ig/ref [::main :app.storage.fs/backend])
:tmp (ig/ref [::tmp :app.storage.fs/backend])}}
:backend (cf/get :assets-storage-backend :assets-fs)
:backends {:assets-s3 (ig/ref [::assets :app.storage.s3/backend])
:assets-db (ig/ref [::assets :app.storage.db/backend])
:assets-fs (ig/ref [::assets :app.storage.fs/backend])
:s3 (ig/ref [::assets :app.storage.s3/backend])
:db (ig/ref [::assets :app.storage.db/backend])
:fs (ig/ref [::assets :app.storage.fs/backend])
:tmp (ig/ref [::tmp :app.storage.fs/backend])
:fdata-s3 (ig/ref [::fdata :app.storage.s3/backend])}}
[::main :app.storage.s3/backend]
{:region (cf/get :storage-s3-region)
:bucket (cf/get :storage-s3-bucket)}
[::fdata :app.storage.s3/backend]
{:region (cf/get :storage-fdata-s3-region)
:bucket (cf/get :storage-fdata-s3-bucket)
:prefix (cf/get :storage-fdata-s3-prefix)}
[::main :app.storage.fs/backend]
{:directory (cf/get :storage-fs-directory)}
[::assets :app.storage.s3/backend]
{:region (cf/get :storage-assets-s3-region)
:bucket (cf/get :storage-assets-s3-bucket)}
[::assets :app.storage.fs/backend]
{:directory (cf/get :storage-assets-fs-directory)}
[::tmp :app.storage.fs/backend]
{:directory "/tmp/penpot"}
[::main :app.storage.db/backend]
[::assets :app.storage.db/backend]
{:pool (ig/ref :app.db/pool)}})
(def system nil)

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

@ -210,9 +210,15 @@
([a b]
(mobj :inc)
(origf a b))
([a b & more]
([a b c]
(mobj :inc)
(apply origf a b more)))
(origf a b c))
([a b c d]
(mobj :inc)
(origf a b c d))
([a b c d & more]
(mobj :inc)
(apply origf a b c d more)))
(assoc mdata ::original origf))))
([rootf mobj labels]
(let [mdata (meta rootf)

18
backend/src/app/migrations.clj
View file

@ -175,6 +175,24 @@
{:name "0055-mod-file-media-object-table"
:fn (mg/resource "app/migrations/sql/0055-mod-file-media-object-table.sql")}
{:name "0056-add-missing-index-on-deleted-at"
:fn (mg/resource "app/migrations/sql/0056-add-missing-index-on-deleted-at.sql")}
{:name "0057-del-profile-on-delete-trigger"
:fn (mg/resource "app/migrations/sql/0057-del-profile-on-delete-trigger.sql")}
{:name "0058-del-team-on-delete-trigger"
:fn (mg/resource "app/migrations/sql/0058-del-team-on-delete-trigger.sql")}
{:name "0059-mod-audit-log-table"
:fn (mg/resource "app/migrations/sql/0059-mod-audit-log-table.sql")}
{:name "0060-mod-file-change-table"
:fn (mg/resource "app/migrations/sql/0060-mod-file-change-table.sql")}
{:name "0061-mod-file-table"
:fn (mg/resource "app/migrations/sql/0061-mod-file-table.sql")}
])

15
backend/src/app/migrations/sql/0056-add-missing-index-on-deleted-at.sql Normal file
View file

@ -0,0 +1,15 @@
CREATE INDEX profile_deleted_at_idx
ON profile(deleted_at, id)
WHERE deleted_at IS NOT NULL;
CREATE INDEX project_deleted_at_idx
ON project(deleted_at, id)
WHERE deleted_at IS NOT NULL;
CREATE INDEX team_deleted_at_idx
ON team(deleted_at, id)
WHERE deleted_at IS NOT NULL;
CREATE INDEX team_font_variant_deleted_at_idx
ON team_font_variant(deleted_at, id)
WHERE deleted_at IS NOT NULL;

2
backend/src/app/migrations/sql/0057-del-profile-on-delete-trigger.sql Normal file
View file

@ -0,0 +1,2 @@
DROP TRIGGER profile__on_delete__tgr ON profile CASCADE;
DROP FUNCTION on_delete_profile ();

2
backend/src/app/migrations/sql/0058-del-team-on-delete-trigger.sql Normal file
View file

@ -0,0 +1,2 @@
DROP TRIGGER team__on_delete__tgr ON team CASCADE;
DROP FUNCTION on_delete_team ();

2
backend/src/app/migrations/sql/0059-mod-audit-log-table.sql Normal file
View file

@ -0,0 +1,2 @@
ALTER TABLE audit_log
ADD COLUMN ip_addr inet NULL;

2
backend/src/app/migrations/sql/0060-mod-file-change-table.sql Normal file
View file

@ -0,0 +1,2 @@
ALTER TABLE file_change
ALTER COLUMN data DROP NOT NULL;

10
backend/src/app/migrations/sql/0061-mod-file-table.sql Normal file
View file

@ -0,0 +1,10 @@
CREATE INDEX IF NOT EXISTS file__modified_at__with__data__idx
ON file (modified_at, id)
WHERE data IS NOT NULL;
ALTER TABLE file
ADD COLUMN data_backend text NULL,
ALTER COLUMN data_backend SET STORAGE EXTERNAL;
DROP TRIGGER file_on_update_tgr ON file;
DROP FUNCTION handle_file_update ();

8
backend/src/app/migrations/sql/0062-fix-metadata-media.sql Normal file
View file

@ -0,0 +1,8 @@
-- Fix problem with content-type inconherence
UPDATE storage_object so
SET metadata = jsonb_set(metadata, '{~:content-type}', to_jsonb(fmo.mtype))
FROM file_media_object fmo
WHERE so.id = fmo.media_id and
so.metadata->>'~:content-type' != fmo.mtype;

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

@ -8,12 +8,12 @@
"A websocket based notifications mechanism."
(:require
[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.util.transit :as t]
[app.worker :as wrk]
[clojure.core.async :as a]
[clojure.spec.alpha :as s]
@ -163,7 +163,7 @@
;; when connection is closed
(mtx-aconn :dec)
(mtx-sessions :observe (/ (inst-ms (dt/duration-between created-at (dt/now))) 1000.0))
(mtx-sessions :observe (/ (inst-ms (dt/diff created-at (dt/now))) 1000.0))
;; close subscription
(a/close! sub-ch))))

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

@ -32,9 +32,10 @@
[methods {:keys [profile-id] :as request}]
(let [type (keyword (get-in request [:path-params :type]))
data (d/merge (:params request)
data (merge (:params request)
(:body-params request)
(:uploads request))
(:uploads request)
{::request request})
data (if profile-id
(assoc data :profile-id profile-id)
@ -50,12 +51,15 @@
(defn- rpc-mutation-handler
[methods {:keys [profile-id] :as request}]
(let [type (keyword (get-in request [:path-params :type]))
data (d/merge (:params request)
data (merge (:params request)
(:body-params request)
(:uploads request))
(:uploads request)
{::request request})
data (if profile-id
(assoc data :profile-id profile-id)
(dissoc data :profile-id))
result ((get methods type default-handler) data)
mdata (meta result)]
(cond->> {:status 200 :body result}
@ -85,7 +89,6 @@
(rlm/execute rlinst (f cfg params))))
f))
(defn- wrap-impl
[{:keys [audit] :as cfg} f mdata]
(let [f (wrap-with-rlimits cfg f mdata)
@ -95,23 +98,34 @@
(l/trace :action "register" :name (::sv/name mdata))
(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"))
(let [params (us/conform spec params)
result (f cfg params)
resultm (meta result)]
(when (and (::type cfg) (fn? audit))
(let [profile-id (or (:profile-id 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 :submit {:type (::type cfg)
(audit :cmd :submit
:type (::type cfg)
:name (or (::audit/name resultm)
(::sv/name mdata))
:profile-id profile-id
:props props})))
:ip-addr (audit/parse-client-ip request)
:props (audit/profile->props props))))
result))))
(defn- process-method

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

@ -15,7 +15,7 @@
[app.rpc.mutations.profile :as profile]
[app.setup.initial-data :as sid]
[app.util.services :as sv]
[app.worker :as wrk]
[app.util.time :as dt]
[buddy.core.codecs :as bc]
[buddy.core.nonce :as bn]
[clojure.spec.alpha :as s]))
@ -35,6 +35,7 @@
:email email
:fullname fullname
:is-demo true
:deleted-at (dt/in-future cfg/deletion-delay)
:password password
:props {:onboarding-viewed true}}]
@ -48,12 +49,6 @@
(#'profile/create-profile-relations conn)
(sid/load-initial-project! conn))
;; Schedule deletion of the demo profile
(wrk/submit! {::wrk/task :delete-profile
::wrk/delay cfg/deletion-delay
::wrk/conn conn
:profile-id id})
(with-meta {:email email
:password password}
{::audit/profile-id id}))))

126
backend/src/app/rpc/mutations/files.clj
View file

@ -11,17 +11,19 @@
[app.common.pages.migrations :as pmg]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.config :as cf]
[app.db :as db]
[app.rpc.permissions :as perms]
[app.rpc.queries.files :as files]
[app.rpc.queries.projects :as proj]
[app.storage.impl :as simpl]
[app.util.blob :as blob]
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s]))
(declare create-file)
;; --- Helpers & Specs
(s/def ::id ::us/uuid)
@ -32,8 +34,6 @@
;; --- Mutation: Create File
(declare create-file)
(s/def ::is-shared ::us/boolean)
(s/def ::create-file
(s/keys :req-un [::profile-id ::name ::project-id]
@ -45,7 +45,6 @@
(proj/check-edition-permissions! conn profile-id project-id)
(create-file conn params)))
(defn create-file-role
[conn {:keys [file-id profile-id role]}]
(let [params {:file-id file-id
@ -54,21 +53,24 @@
(db/insert! conn :file-profile-rel))))
(defn create-file
[conn {:keys [id name project-id is-shared]
:or {is-shared false}
[conn {:keys [id name project-id is-shared data deleted-at]
:or {is-shared false
deleted-at nil}
:as params}]
(let [id (or id (uuid/next))
data (cp/make-file-data id)
(let [id (or id (:id data) (uuid/next))
data (or data (cp/make-file-data id))
file (db/insert! conn :file
{:id id
:project-id project-id
:name name
:is-shared is-shared
:data (blob/encode data)})]
:data (blob/encode data)
:deleted-at deleted-at})]
(->> (assoc params :file-id id :role :owner)
(create-file-role conn))
(assoc file :data data)))
(assoc file :data data)))
;; --- Mutation: Rename File
@ -109,7 +111,6 @@
{:is-shared is-shared}
{:id id}))
;; --- Mutation: Delete File
(declare mark-file-deleted)
@ -122,13 +123,6 @@
(db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id id)
;; Schedule object deletion
(wrk/submit! {::wrk/task :delete-object
::wrk/delay cfg/deletion-delay
::wrk/conn conn
:id id
:type :file})
(mark-file-deleted conn params)))
(defn mark-file-deleted
@ -175,7 +169,7 @@
(s/keys :req-un [::profile-id ::file-id ::library-id]))
(sv/defmethod ::unlink-file-from-library
[{:keys [pool] :as cfg} {:keys [profile-id file-id library-id] :as params}]
[{: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)
(unlink-file-from-library conn params)))
@ -195,7 +189,7 @@
(s/keys :req-un [::profile-id ::file-id ::library-id]))
(sv/defmethod ::update-sync
[{:keys [pool] :as cfg} {:keys [profile-id file-id library-id] :as params}]
[{: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)
(update-sync conn params)))
@ -207,7 +201,6 @@
{:file-id file-id
:library-file-id library-id}))
;; --- Mutation: Ignore updates in linked files
(declare ignore-sync)
@ -216,7 +209,7 @@
(s/keys :req-un [::profile-id ::file-id ::date]))
(sv/defmethod ::ignore-sync
[{:keys [pool] :as cfg} {:keys [profile-id file-id date] :as params}]
[{: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)
(ignore-sync conn params)))
@ -278,15 +271,31 @@
(sv/defmethod ::update-file
[{:keys [pool] :as cfg} {:keys [id profile-id] :as params}]
(db/with-atomic [conn pool]
(let [{:keys [id] :as file} (db/get-by-id conn :file id {:for-update true})]
(db/xact-lock! conn id)
(let [{:keys [id] :as file} (db/get-by-id conn :file id {:for-key-share true})]
(files/check-edition-permissions! conn profile-id id)
(update-file (assoc cfg :conn conn)
(assoc params :file file)))))
(defn- take-snapshot?
"Defines the rule when file `data` snapshot should be saved."
[{:keys [revn modified-at] :as file}]
;; The snapshot will be saved every 20 changes or if the last
;; modification is older than 3 hour.
(or (zero? (mod revn 20))
(> (inst-ms (dt/diff modified-at (dt/now)))
(inst-ms (dt/duration {:hours 3})))))
(defn- delete-from-storage
[{:keys [storage] :as cfg} file]
(when-let [backend (simpl/resolve-backend storage (cf/get :fdata-storage-backend))]
(simpl/del-object backend file)))
(defn- update-file
[{:keys [conn] :as cfg} {:keys [file changes changes-with-metadata session-id profile-id] :as params}]
(when (> (:revn params)
(:revn file))
(ex/raise :type :validation
:code :revn-conflict
:hint "The incoming revision number is greater that stored version."
@ -297,7 +306,8 @@
(mapcat :changes changes-with-metadata)
changes)
file (-> file
ts (dt/now)
file (-> (files/retrieve-data cfg file)
(update :revn inc)
(update :data (fn [data]
(-> data
@ -311,26 +321,55 @@
{:id (uuid/next)
:session-id session-id
:profile-id profile-id
:created-at ts
:file-id (:id file)
:revn (:revn file)
:data (:data file)
:data (when (take-snapshot? file)
(:data file))
:changes (blob/encode changes)})
;; Update file
(db/update! conn :file
{:revn (:revn file)
:data (:data file)
:data-backend nil
:modified-at ts
:has-media-trimmed false}
{:id (:id file)})
(let [params (-> params (assoc :file file
:changes changes))]
;; We need to delete the data from external storage backend
(when-not (nil? (:data-backend file))
(delete-from-storage cfg file))
(db/update! conn :project
{:modified-at ts}
{:id (:project-id file)})
(let [params (assoc params :file file :changes changes)]
;; Send asynchronous notifications
(send-notifications cfg params)
;; Retrieve and return lagged data
(retrieve-lagged-changes conn params))))
(def ^:private
sql:lagged-changes
"select s.id, s.revn, s.file_id,
s.session_id, s.changes
from file_change as s
where s.file_id = ?
and s.revn > ?
order by s.created_at asc")
(defn- retrieve-lagged-changes
[conn params]
(->> (db/exec! conn [sql:lagged-changes (:id params) (:revn params)])
(into [] (comp (map files/decode-row)
(map (fn [row]
(cond-> row
(= (:revn row) (:revn (:file params)))
(assoc :changes []))))))))
(defn- send-notifications
[{:keys [msgbus conn] :as cfg} {:keys [file changes session-id] :as params}]
(let [lchanges (filter library-change? changes)]
@ -362,17 +401,24 @@
[conn project-id]
(:team-id (db/get-by-id conn :project project-id {:columns [:team-id]})))
(def ^:private
sql:lagged-changes
"select s.id, s.revn, s.file_id,
s.session_id, s.changes
from file_change as s
where s.file_id = ?
and s.revn > ?
order by s.created_at asc")
(defn- retrieve-lagged-changes
[conn params]
(->> (db/exec! conn [sql:lagged-changes (:id params) (:revn params)])
(mapv files/decode-row)))
;; TEMPORARY FILE CREATION
(s/def ::create-temp-file ::create-file)
(sv/defmethod ::create-temp-file
[{:keys [pool] :as cfg} {:keys [profile-id project-id] :as params}]
(db/with-atomic [conn pool]
(proj/check-edition-permissions! conn profile-id project-id)
(create-file conn (assoc params :deleted-at (dt/in-future {:days 1})))))
(s/def ::persist-temp-file
(s/keys :req-un [::id ::profile-id]))
(sv/defmethod ::persist-temp-file
[{:keys [pool] :as cfg} {:keys [id profile-id] :as params}]
(db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id id)
(db/update! conn :file
{:deleted-at nil}
{:id id})))

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

@ -104,21 +104,10 @@
(db/with-atomic [conn pool]
(teams/check-edition-permissions! conn profile-id team-id)
(let [items (db/query conn :team-font-variant
{:font-id id :team-id team-id}
{:for-update true})]
(doseq [item items]
;; Schedule object deletion
(wrk/submit! {::wrk/task :delete-object
::wrk/delay cf/deletion-delay
::wrk/conn conn
:id (:id item)
:type :team-font-variant}))
(db/update! conn :team-font-variant
{:deleted-at (dt/now)}
{:font-id id :team-id team-id})
nil)))
nil))
;; --- DELETE FONT VARIANT

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

@ -9,7 +9,10 @@
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.config :as cfg]
[app.rpc.mutations.profile :refer [login-or-register]]
[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.services :as sv]
[clj-ldap.client :as ldap]
[clojure.spec.alpha :as s]
@ -34,6 +37,7 @@
;; --- Mutation: login-with-ldap
(declare authenticate)
(declare login-or-register)
(s/def ::email ::us/email)
(s/def ::password ::us/string)
@ -44,12 +48,15 @@
:opt-un [::invitation-token]))
(sv/defmethod ::login-with-ldap {:auth false :rlimit :password}
[{:keys [pool session tokens] :as cfg} {:keys [email password invitation-token] :as params}]
[{:keys [pool session tokens] :as cfg} params]
(db/with-atomic [conn pool]
(let [info (authenticate params)
cfg (assoc cfg :conn pool)]
cfg (assoc cfg :conn conn)]
(when-not info
(ex/raise :type :validation
:code :wrong-credentials))
(let [profile (login-or-register cfg {:email (:email info)
:backend (:backend info)
:fullname (:fullname info)})]
@ -63,12 +70,15 @@
:member-id (:id profile)
:member-email (:email profile))
token (tokens :generate claims)]
(with-meta
{:invitation-token token}
{:transform-response ((:create session) (:id profile))}))
(with-meta {:invitation-token token}
{:transform-response ((:create session) (:id profile))
::audit/props (:props profile)
::audit/profile-id (:id profile)}))
(with-meta profile
{:transform-response ((:create session) (:id profile))})))))
{:transform-response ((:create session) (:id profile))
::audit/props (:props profile)
::audit/profile-id (:id profile)}))))))
(defn- replace-several [s & {:as replacements}]
(reduce-kv clojure.string/replace s replacements))
@ -88,11 +98,25 @@
(first (ldap/search cpool base-dn params))))
(defn- authenticate
[{:keys [password] :as params}]
[{:keys [password email] :as params}]
(with-open [conn (connect)]
(when-let [{:keys [dn] :as luser} (get-ldap-user conn params)]
(when (ldap/bind? conn dn password)
{:photo (get luser (keyword (cfg/get :ldap-attrs-photo)))
:fullname (get luser (keyword (cfg/get :ldap-attrs-fullname)))
:email (get luser (keyword (cfg/get :ldap-attrs-email)))
:email email
:backend "ldap"}))))
(defn- login-or-register
[{:keys [conn] :as cfg} info]
(or (some->> (:email info)
(profile-q/retrieve-profile-data-by-email conn)
(profile-q/populate-additional-data conn)
(profile-q/decode-profile-row))
(let [params (-> info
(assoc :is-active true)
(assoc :is-demo false))]
(->> params
(profile-m/create-profile conn)
(profile-m/create-profile-relations conn)
(profile-q/strip-private-attrs)))))

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

@ -167,7 +167,7 @@
:opt-un [::name]))
(sv/defmethod ::duplicate-file
[{:keys [pool] :as cfg} {:keys [profile-id file-id name] :as params}]
[{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
(db/with-atomic [conn pool]
(let [file (db/get-by-id conn :file file-id)
index {file-id (uuid/next)}
@ -187,7 +187,7 @@
:opt-un [::name]))
(sv/defmethod ::duplicate-project
[{:keys [pool] :as cfg} {:keys [profile-id project-id name] :as params}]
[{:keys [pool] :as cfg} {:keys [profile-id project-id] :as params}]
(db/with-atomic [conn pool]
(let [project (db/get-by-id conn :project project-id)]
(teams/check-edition-permissions! conn profile-id (:team-id project))

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

@ -92,7 +92,7 @@
(defn create-file-media-object
[{:keys [conn storage] :as cfg} {:keys [file-id is-local name content] :as params}]
[{:keys [conn storage] :as cfg} {:keys [id file-id is-local name content] :as params}]
(media/validate-media-type (:content-type content))
(let [storage (assoc storage :conn conn)
source-path (fs/path (:tempfile content))
@ -118,7 +118,7 @@
(sto/put-object storage {:content (sto/content (:data thumb) (:size thumb))
:content-type (:mtype thumb)}))]
(db/insert! conn :file-media-object
{:id (uuid/next)
{:id (or id (uuid/next))
:file-id file-id
:is-local is-local
:name name

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

@ -22,7 +22,6 @@
[app.storage :as sto]
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as wrk]
[buddy.hashers :as hashers]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]))
@ -37,106 +36,14 @@
(s/def ::password ::us/not-empty-string)
(s/def ::old-password ::us/not-empty-string)
(s/def ::theme ::us/string)
;; --- Mutation: Register Profile
(s/def ::invitation-token ::us/not-empty-string)
(declare annotate-profile-register)
(declare check-profile-existence!)
(declare create-profile)
(declare create-profile-relations)
(declare email-domain-in-whitelist?)
(declare register-profile)
(s/def ::invitation-token ::us/not-empty-string)
(s/def ::terms-privacy ::us/boolean)
(s/def ::register-profile
(s/keys :req-un [::email ::password ::fullname ::terms-privacy]
:opt-un [::invitation-token]))
(sv/defmethod ::register-profile {:auth false :rlimit :password}
[{:keys [pool tokens session] :as cfg} params]
(when-not (cfg/get :registration-enabled)
(ex/raise :type :restriction
:code :registration-disabled))
(when-let [domains (cfg/get :registration-domain-whitelist)]
(when-not (email-domain-in-whitelist? domains (:email params))
(ex/raise :type :validation
:code :email-domain-is-not-allowed)))
(when-not (:terms-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))))
(defn- annotate-profile-register
"A helper for properly increase the profile-register metric once the
transaction is completed."
[metrics profile]
(fn []
(when (::created profile)
((get-in metrics [:definitions :profile-register]) :inc))))
(defn- register-profile
[{:keys [conn tokens session metrics] :as cfg} params]
(check-profile-existence! conn params)
(let [profile (->> (create-profile conn params)
(create-profile-relations conn))
profile (assoc profile ::created true)]
(sid/load-initial-project! conn profile)
(if-let [token (:invitation-token params)]
;; If invitation token comes in params, this is because the
;; user comes from team-invitation process; in this case,
;; regenerate token and send back to the user a new invitation
;; token (and mark current session as logged).
(let [claims (tokens :verify {:token token :iss :team-invitation})
claims (assoc claims
:member-id (:id profile)
:member-email (:email profile))
token (tokens :generate claims)
resp {:invitation-token token}]
(with-meta resp
{:transform-response ((:create session) (:id profile))
:before-complete (annotate-profile-register metrics profile)
::audit/props (:props profile)
::audit/profile-id (:id profile)}))
;; If no token is provided, send a verification email
(let [vtoken (tokens :generate
{:iss :verify-email
:exp (dt/in-future "48h")
:profile-id (:id profile)
:email (:email profile)})
ptoken (tokens :generate-predefined
{:iss :profile-identity
:profile-id (:id profile)})]
;; Don't allow proceed in register page if the email is
;; already reported as permanent bounced
(when (eml/has-bounce-reports? conn (:email profile))
(ex/raise :type :validation
:code :email-has-permanent-bounces
:hint "looks like the email has one or many bounces reported"))
(eml/send! {::eml/conn conn
::eml/factory eml/register
:public-uri (:public-uri cfg)
:to (:email profile)
:name (:fullname profile)
:token vtoken
:extra-data ptoken})
(with-meta profile
{:before-complete (annotate-profile-register metrics profile)
::audit/props (:props profile)
::audit/profile-id (:id profile)})))))
(defn email-domain-in-whitelist?
"Returns true if email's domain is in the given whitelist or if
given whitelist is an empty string."
@ -178,28 +85,176 @@
{:update false
:valid false})))
(defn decode-profile-row
[{:keys [props] :as profile}]
(cond-> profile
(db/pgobject? props "jsonb")
(assoc :props (db/decode-transit-pgobject props))))
;; --- MUTATION: Prepare Register
(s/def ::prepare-register-profile
(s/keys :req-un [::email ::password]
:opt-un [::invitation-token]))
(sv/defmethod ::prepare-register-profile {:auth false}
[{:keys [pool tokens] :as cfg} params]
(when-not (cfg/get :registration-enabled)
(ex/raise :type :restriction
:code :registration-disabled))
(when-let [domains (cfg/get :registration-domain-whitelist)]
(when-not (email-domain-in-whitelist? domains (:email params))
(ex/raise :type :validation
:code :email-domain-is-not-allowed)))
;; Don't allow proceed in preparing registration if the profile is
;; already reported as spamer.
(when (eml/has-bounce-reports? pool (:email params))
(ex/raise :type :validation
:code :email-has-permanent-bounces
:hint "looks like the email has one or many bounces reported"))
(check-profile-existence! pool params)
(let [params (assoc params
:backend "penpot"
:iss :prepared-register
:exp (dt/in-future "48h"))
token (tokens :generate params)]
{:token token}))
;; --- 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]))
(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))))
(defn- annotate-profile-register
"A helper for properly increase the profile-register metric once the
transaction is completed."
[metrics]
(fn []
((get-in metrics [:definitions :profile-register]) :inc)))
(defn register-profile
[{:keys [conn tokens session metrics] :as cfg} {:keys [token] :as params}]
(let [claims (tokens :verify {:token token :iss :prepared-register})
params (merge params claims)]
(check-profile-existence! conn params)
(let [profile (->> params
(create-profile conn)
(create-profile-relations conn)
(decode-profile-row))]
(sid/load-initial-project! conn profile)
(cond
;; If invitation token comes in params, this is because the
;; user comes from team-invitation process; in this case,
;; regenerate token and send back to the user a new invitation
;; token (and mark current session as logged).
(some? (:invitation-token params))
(let [token (:invitation-token params)
claims (tokens :verify {:token token :iss :team-invitation})
claims (assoc claims
:member-id (:id profile)
:member-email (:email profile))
token (tokens :generate claims)
resp {:invitation-token token}]
(with-meta resp
{:transform-response ((:create session) (:id profile))
:before-complete (annotate-profile-register metrics)
::audit/props (audit/profile->props profile)
::audit/profile-id (:id profile)}))
;; If auth backend is different from "penpot" means user is
;; registring using third party auth mechanism; in this case
;; we need to mark this session as logged.
(not= "penpot" (:auth-backend profile))
(with-meta (profile/strip-private-attrs profile)
{:transform-response ((:create session) (:id profile))
:before-complete (annotate-profile-register metrics)
::audit/props (audit/profile->props profile)
::audit/profile-id (:id profile)})
;; In all other cases, send a verification email.
:else
(let [vtoken (tokens :generate
{:iss :verify-email
:exp (dt/in-future "48h")
:profile-id (:id profile)
:email (:email profile)})
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)
:to (:email profile)
:name (:fullname profile)
:token vtoken
:extra-data ptoken})
(with-meta profile
{:before-complete (annotate-profile-register metrics)
::audit/props (audit/profile->props profile)
::audit/profile-id (:id profile)}))))))
(defn create-profile
"Create the profile entry on the database with limited input
filling all the other fields with defaults."
[conn {:keys [id fullname email password is-active is-muted is-demo opts]
:or {is-active false is-muted false is-demo false}
:as params}]
(let [id (or id (uuid/next))
is-active (if is-demo true is-active)
props (-> params extract-props db/tjson)
password (derive-password password)
"Create the profile entry on the database with limited input filling
all the other fields with defaults."
[conn params]
(let [id (or (:id params) (uuid/next))
props (-> (extract-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))
backend (:backend params "penpot")
is-demo (:is-demo params false)
is-muted (:is-muted params false)
is-active (:is-active params (or (not= "penpot" backend) is-demo))
email (str/lower (:email params))
params {:id id
:fullname fullname
:email (str/lower email)
:auth-backend "penpot"
:fullname (:fullname params)
:email email
:auth-backend backend
:lang locale
:password password
:deleted-at (:deleted-at params)
:props props
:is-active is-active
:is-muted is-muted
:is-demo is-demo}]
(try
(-> (db/insert! conn :profile params opts)
(update :props db/decode-transit-pgobject))
(-> (db/insert! conn :profile params)
(decode-profile-row))
(catch org.postgresql.util.PSQLException e
(let [state (.getSQLState e)]
(if (not= state "23505")
@ -231,7 +286,7 @@
(assoc :default-team-id (:id team))
(assoc :default-project-id (:id project)))))
;; --- Mutation: Login
;; --- MUTATION: Login
(s/def ::email ::us/email)
(s/def ::scope ::us/string)
@ -241,7 +296,7 @@
:opt-un [::scope ::invitation-token]))
(sv/defmethod ::login {:auth false :rlimit :password}
[{:keys [pool session tokens] :as cfg} {:keys [email password scope] :as params}]
[{:keys [pool session tokens] :as cfg} {:keys [email password] :as params}]
(letfn [(check-password [profile password]
(when (= (:password profile) "!")
(ex/raise :type :validation
@ -264,7 +319,8 @@
(let [profile (->> (profile/retrieve-profile-data-by-email conn email)
(validate-profile)
(profile/strip-private-attrs)
(profile/populate-additional-data conn))]
(profile/populate-additional-data conn)
(decode-profile-row))]
(if-let [token (:invitation-token params)]
;; If the request comes with an invitation token, this means
;; that user wants to accept it with different user. A very
@ -279,90 +335,25 @@
token (tokens :generate claims)]
(with-meta {:invitation-token token}
{:transform-response ((:create session) (:id profile))
::audit/props (audit/profile->props profile)
::audit/profile-id (:id profile)}))
(with-meta profile
{:transform-response ((:create session) (:id profile))
::audit/props (audit/profile->props profile)
::audit/profile-id (:id profile)}))))))
;; --- Mutation: Logout
;; --- MUTATION: Logout
(s/def ::logout
(s/keys :req-un [::profile-id]))
(sv/defmethod ::logout
[{:keys [pool session] :as cfg} {:keys [profile-id] :as params}]
[{:keys [session] :as cfg} _]
(with-meta {}
{:transform-response (:delete session)}))
;; --- Mutation: Register if not exists
(declare login-or-register)
(s/def ::backend ::us/string)
(s/def ::login-or-register
(s/keys :req-un [::email ::fullname ::backend]))
(sv/defmethod ::login-or-register {:auth false}
[{:keys [pool metrics] :as cfg} params]
(db/with-atomic [conn pool]
(let [profile (-> (assoc cfg :conn conn)
(login-or-register params))
props (merge
(select-keys profile [:backend :fullname :email])
(:props profile))]
(with-meta profile
{:before-complete (annotate-profile-register metrics profile)
::audit/name (if (::created profile) "register" "login")
::audit/props props
::audit/profile-id (:id profile)}))))
(defn login-or-register
[{:keys [conn] :as cfg} {:keys [email] :as params}]
(letfn [(info->lang [{:keys [locale] :as info}]
(when (and (string? locale)
(not (str/blank? locale)))
locale))
(create-profile [conn {:keys [fullname backend email props] :as info}]
(let [params {:id (uuid/next)
:fullname fullname
:email (str/lower email)
:lang (info->lang props)
:auth-backend backend
:is-active true
:password "!"
:props (db/tjson props)
:is-demo false}]
(-> (db/insert! conn :profile params)
(update :props db/decode-transit-pgobject))))
(update-profile [conn info profile]
(let [props (merge (:props profile)
(:props info))]
(db/update! conn :profile
{:props (db/tjson props)
:modified-at (dt/now)}
{:id (:id profile)})
(assoc profile :props props)))
(register-profile [conn params]
(let [profile (->> (create-profile conn params)
(create-profile-relations conn))]
(sid/load-initial-project! conn profile)
(assoc profile ::created true)))]
(let [profile (profile/retrieve-profile-data-by-email conn email)
profile (if profile
(->> profile
(update-profile conn params)
(profile/populate-additional-data conn))
(register-profile conn params))]
(profile/strip-private-attrs profile))))
;; --- Mutation: Update Profile (own)
;; --- MUTATION: Update Profile (own)
(defn- update-profile
[conn {:keys [id fullname lang theme] :as params}]
@ -382,7 +373,7 @@
(update-profile conn params)
nil))
;; --- Mutation: Update Password
;; --- MUTATION: Update Password
(declare validate-password!)
(declare update-profile-password!)
@ -391,7 +382,7 @@
(s/keys :req-un [::profile-id ::password ::old-password]))
(sv/defmethod ::update-profile-password {:rlimit :password}
[{:keys [pool] :as cfg} {:keys [password profile-id] :as params}]
[{:keys [pool] :as cfg} {:keys [password] :as params}]
(db/with-atomic [conn pool]
(let [profile (validate-password! conn params)]
(update-profile-password! conn (assoc profile :password password))
@ -411,7 +402,7 @@
{:password (derive-password password)}
{:id id}))
;; --- Mutation: Update Photo
;; --- MUTATION: Update Photo
(declare update-profile-photo)
@ -446,7 +437,7 @@
nil)
;; --- Mutation: Request Email Change
;; --- MUTATION: Request Email Change
(declare request-email-change)
(declare change-email-inmediatelly)
@ -514,7 +505,7 @@
[conn id]
(db/get-by-id conn :profile id {:for-update true}))
;; --- Mutation: Request Profile Recovery
;; --- MUTATION: Request Profile Recovery
(s/def ::request-profile-recovery
(s/keys :req-un [::email]))
@ -563,7 +554,7 @@
(send-email-notification conn))))))
;; --- Mutation: Recover Profile
;; --- MUTATION: Recover Profile
(s/def ::token ::us/not-empty-string)
(s/def ::recover-profile
@ -584,7 +575,7 @@
(update-password conn))
nil)))
;; --- Mutation: Update Profile Props
;; --- MUTATION: Update Profile Props
(s/def ::props map?)
(s/def ::update-profile-props
@ -606,7 +597,7 @@
nil)))
;; --- Mutation: Delete Profile
;; --- MUTATION: Delete Profile
(declare check-can-delete-profile!)
(declare mark-profile-as-deleted!)
@ -619,12 +610,6 @@
(db/with-atomic [conn pool]
(check-can-delete-profile! conn profile-id)
;; Schedule a complete deletion of profile
(wrk/submit! {::wrk/task :delete-profile
::wrk/delay cfg/deletion-delay
::wrk/conn conn
:profile-id profile-id})
(db/update! conn :profile
{:deleted-at (dt/now)}
{:id profile-id})

10
backend/src/app/rpc/mutations/projects.clj
View file

@ -8,14 +8,12 @@
(:require
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.rpc.permissions :as perms]
[app.rpc.queries.projects :as proj]
[app.rpc.queries.teams :as teams]
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s]))
;; --- Helpers & Specs
@ -123,14 +121,6 @@
[{:keys [pool] :as cfg} {:keys [id profile-id] :as params}]
(db/with-atomic [conn pool]
(proj/check-edition-permissions! conn profile-id id)
;; Schedule object deletion
(wrk/submit! {::wrk/task :delete-object
::wrk/delay cfg/deletion-delay
::wrk/conn conn
:id id
:type :project})
(db/update! conn :project
{:deleted-at (dt/now)}
{:id id})

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

@ -10,7 +10,6 @@
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
[app.emails :as eml]
[app.media :as media]
@ -21,7 +20,6 @@
[app.storage :as sto]
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[datoteka.core :as fs]))
@ -135,13 +133,6 @@
(ex/raise :type :validation
:code :only-owner-can-delete-team))
;; Schedule object deletion
(wrk/submit! {::wrk/task :delete-object
::wrk/delay cfg/deletion-delay
::wrk/conn conn
:id id
:type :team})
(db/update! conn :team
{:deleted-at (dt/now)}
{:id id})

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

@ -9,10 +9,12 @@
[app.common.pages.migrations :as pmg]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.rpc.permissions :as perms]
[app.rpc.queries.projects :as projects]
[app.rpc.queries.teams :as teams]
[app.storage.impl :as simpl]
[app.util.blob :as blob]
[app.util.services :as sv]
[clojure.spec.alpha :as s]))
@ -171,9 +173,21 @@
;; --- Query: File (By ID)
(defn- retrieve-data*
[{:keys [storage] :as cfg} file]
(when-let [backend (simpl/resolve-backend storage (cf/get :fdata-storage-backend))]
(simpl/get-object-bytes backend file)))
(defn retrieve-data
[cfg file]
(if (bytes? (:data file))
file
(assoc file :data (retrieve-data* cfg file))))
(defn retrieve-file
[conn id]
(-> (db/get-by-id conn :file id)
[{:keys [conn] :as cfg} id]
(->> (db/get-by-id conn :file id)
(retrieve-data cfg)
(decode-row)
(pmg/migrate-file)))
@ -183,8 +197,9 @@
(sv/defmethod ::file
[{: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 conn id)))
(retrieve-file cfg id))))
(s/def ::page
(s/keys :req-un [::profile-id ::file-id]))
@ -217,11 +232,11 @@
(update data :objects update-objects)))
(sv/defmethod ::page
[{:keys [pool] :as cfg} {:keys [profile-id file-id id strip-thumbnails]}]
[{:keys [pool] :as cfg} {:keys [profile-id file-id]}]
[{:keys [pool] :as cfg} {:keys [profile-id file-id strip-thumbnails]}]
(db/with-atomic [conn pool]
(check-edition-permissions! conn profile-id file-id)
(let [file (retrieve-file conn file-id)
(let [cfg (assoc cfg :conn conn)
file (retrieve-file cfg file-id)
page-id (get-in file [:data :pages 0])]
(cond-> (get-in file [:data :pages-index page-id])
strip-thumbnails
@ -245,7 +260,7 @@
(s/keys :req-un [::profile-id ::team-id]))
(sv/defmethod ::shared-files
[{:keys [pool] :as cfg} {:keys [profile-id team-id] :as params}]
[{:keys [pool] :as cfg} {:keys [team-id] :as params}]
(into [] decode-row-xf (db/exec! pool [sql:shared-files team-id])))
@ -270,30 +285,43 @@
(s/keys :req-un [::profile-id ::team-id]))
(sv/defmethod ::team-shared-files
[{:keys [pool] :as cfg} {:keys [profile-id team-id] :as params}]
[{:keys [pool] :as cfg} {:keys [team-id] :as params}]
(db/exec! pool [sql:team-shared-files team-id]))
;; --- Query: File Libraries used by a File
(def ^:private sql:file-libraries
"select fl.*,
flr.synced_at as synced_at
from file as fl
inner join file_library_rel as flr on (flr.library_file_id = fl.id)
where flr.file_id = ?
and fl.deleted_at is null")
"WITH RECURSIVE libs AS (
SELECT fl.*, flr.synced_at
FROM file AS fl
JOIN file_library_rel AS flr ON (flr.library_file_id = fl.id)
WHERE flr.file_id = ?::uuid
UNION
SELECT fl.*, flr.synced_at
FROM file AS fl
JOIN file_library_rel AS flr ON (flr.library_file_id = fl.id)
JOIN libs AS l ON (flr.file_id = l.id)
)
SELECT l.id,
l.data,
l.project_id,
l.created_at,
l.modified_at,
l.deleted_at,
l.name,
l.revn,
l.synced_at
FROM libs AS l
WHERE l.deleted_at IS NULL OR l.deleted_at > now();")
(defn retrieve-file-libraries
[conn is-indirect file-id]
(let [libraries (->> (db/exec! conn [sql:file-libraries file-id])
[{:keys [conn] :as cfg} is-indirect file-id]
(let [xform (comp
(map #(assoc % :is-indirect is-indirect))
(into #{} decode-row-xf))]
(reduce #(into %1 (retrieve-file-libraries conn true %2))
libraries
(map :id libraries))))
(map #(retrieve-data cfg %))
(map decode-row))]
(into #{} xform (db/exec! conn [sql:file-libraries file-id]))))
(s/def ::file-libraries
(s/keys :req-un [::profile-id ::file-id]))
@ -301,8 +329,9 @@
(sv/defmethod ::file-libraries
[{: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)
(retrieve-file-libraries conn false file-id)))
(retrieve-file-libraries cfg false file-id))))
;; --- QUERY: team-recent-files
@ -334,7 +363,6 @@
(teams/check-read-permissions! conn profile-id team-id)
(db/exec! conn [sql:team-recent-files team-id])))
;; --- Helpers
(defn decode-row

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

@ -11,7 +11,8 @@
[app.common.uuid :as uuid]
[app.db :as db]
[app.util.services :as sv]
[clojure.spec.alpha :as s]))
[clojure.spec.alpha :as s]
[cuerdas.core :as str]))
;; --- Helpers & Specs
@ -72,7 +73,8 @@
(defn decode-profile-row
[{:keys [props] :as row}]
(cond-> row
(db/pgobject? props) (assoc :props (db/decode-transit-pgobject props))))
(db/pgobject? props "jsonb")
(assoc :props (db/decode-transit-pgobject props))))
(defn retrieve-profile-data
[conn id]
@ -90,16 +92,11 @@
profile))
(def sql:retrieve-profile-by-email
"select p.* from profile as p
where p.email = lower(?)
and p.deleted_at is null")
(defn retrieve-profile-data-by-email
[conn email]
(let [sql [sql:retrieve-profile-by-email email]]
(some-> (db/exec-one! conn sql)
(decode-profile-row))))
(try
(db/get-by-params conn :profile {:email (str/lower email)})
(catch Exception _e)))
;; --- Attrs Helpers

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

@ -42,12 +42,13 @@
(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 [file (files/retrieve-file conn file-id)
(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 conn false file-id)
libs (files/retrieve-file-libraries cfg false file-id)
users (teams/retrieve-users conn (:team-id project))
fonts (db/query conn :team-font-variant

29
backend/src/app/setup/keys.clj Normal file
View file

@ -0,0 +1,29 @@
;; 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.setup.keys
"Keys derivation service."
(:require
[app.common.spec :as us]
[buddy.core.kdf :as bk]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(s/def ::secret-key ::us/string)
(s/def ::props (s/keys :req-un [::secret-key]))
(defmethod ig/pre-init-spec :app.setup/keys [_]
(s/keys :req-un [::props]))
(defmethod ig/init-key :app.setup/keys
[_ {:keys [props] :as cfg}]
(fn [& {:keys [salt _]}]
(let [engine (bk/engine {:key (:secret-key props)
:salt salt
:alg :hkdf
:digest :blake2b-512})]
(bk/get-bytes engine 32))))

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

@ -9,6 +9,7 @@
(:require
[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]
@ -41,14 +42,17 @@
(defmethod ig/init-key ::server
[_ {:keys [port host name] :as cfg}]
(when (and port host name)
(l/info :msg "initializing server repl" :port port :host host :name name)
(ccs/start-server {:address host
:port port
:name name
:accept 'app.srepl/repl})
cfg)
cfg))
(defmethod ig/halt-key! ::server
[_ cfg]
(ccs/stop-server (:name cfg)))
(when cfg
(ccs/stop-server (:name cfg))))

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

@ -5,7 +5,7 @@
;; Copyright (c) UXBOX Labs SL
(ns app.storage
"File Storage abstraction layer."
"Objects storage abstraction layer."
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
@ -20,13 +20,9 @@
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.core :as fs]
[integrant.core :as ig]
[promesa.exec :as px])
(:import
java.io.InputStream))
[promesa.exec :as px]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Storage Module State
@ -39,7 +35,11 @@
(s/def ::db ::sdb/backend)
(s/def ::backends
(s/keys :opt-un [::s3 ::fs ::db]))
(s/map-of ::us/keyword
(s/nilable
(s/or :s3 ::ss3/backend
:fs ::sfs/backend
:db ::sdb/backend))))
(defmethod ig/pre-init-spec ::storage [_]
(s/keys :req-un [::backend ::wrk/executor ::db/pool ::backends]))
@ -50,8 +50,9 @@
(assoc :backends (d/without-nils backends))))
(defmethod ig/init-key ::storage
[_ cfg]
cfg)
[_ {:keys [backends] :as cfg}]
(-> (d/without-nils cfg)
(assoc :backends (d/without-nils backends))))
(s/def ::storage
(s/keys :req-un [::backends ::wrk/executor ::db/pool ::backend]))
@ -151,8 +152,6 @@
;; API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare resolve-backend)
(defn object->relative-path
[{:keys [id] :as obj}]
(impl/id->path id))
@ -185,7 +184,7 @@
(px/run! executor #(register-recheck storage backend (:id object)))
;; Store the data finally on the underlying storage subsystem.
(-> (resolve-backend storage backend)
(-> (impl/resolve-backend storage backend)
(impl/put-object object content))
object))
@ -201,28 +200,37 @@
;; if the source and destination backends are the same, we
;; proceed to use the fast path with specific copy
;; implementation on backend.
(-> (resolve-backend storage (:backend storage))
(-> (impl/resolve-backend storage (:backend storage))
(impl/copy-object object object*))
;; if the source and destination backends are different, we just
;; need to obtain the streams and proceed full copy of the data
(with-open [^InputStream input
(-> (resolve-backend storage (:backend object))
(with-open [is (-> (impl/resolve-backend storage (:backend object))
(impl/get-object-data object))]
(-> (resolve-backend storage (:backend storage))
(impl/put-object object* (impl/content input (:size object))))))
(-> (impl/resolve-backend storage (:backend storage))
(impl/put-object object* (impl/content is (:size object))))))
object*))
(defn get-object-data
"Return an input stream instance of the object content."
[{:keys [pool conn] :as storage} object]
(us/assert ::storage storage)
(when (or (nil? (:expired-at object))
(dt/is-after? (:expired-at object) (dt/now)))
(-> (assoc storage :conn (or conn pool))
(resolve-backend (:backend object))
(impl/resolve-backend (:backend object))
(impl/get-object-data object))))
(defn get-object-bytes
"Returns a byte array of object content."
[{:keys [pool conn] :as storage} object]
(us/assert ::storage storage)
(when (or (nil? (:expired-at object))
(dt/is-after? (:expired-at object) (dt/now)))
(-> (assoc storage :conn (or conn pool))
(impl/resolve-backend (:backend object))
(impl/get-object-bytes object))))
(defn get-object-url
([storage object]
(get-object-url storage object nil))
@ -231,14 +239,14 @@
(when (or (nil? (:expired-at object))
(dt/is-after? (:expired-at object) (dt/now)))
(-> (assoc storage :conn (or conn pool))
(resolve-backend (:backend object))
(impl/resolve-backend (:backend object))
(impl/get-object-url object options)))))
(defn get-object-path
"Get the Path to the object. Only works with `:fs` type of
storages."
[storage object]
(let [backend (resolve-backend storage (:backend object))]
(let [backend (impl/resolve-backend storage (:backend object))]
(when (not= :fs (:type backend))
(ex/raise :type :internal
:code :operation-not-allowed
@ -254,16 +262,7 @@
(-> (assoc storage :conn (or conn pool))
(delete-database-object (if (uuid? id-or-obj) id-or-obj (:id id-or-obj)))))
;; --- impl
(defn resolve-backend
[{:keys [conn pool] :as storage} backend-id]
(let [backend (get-in storage [:backends backend-id])]
(when-not backend
(ex/raise :type :internal
:code :backend-not-configured
:hint (str/fmt "backend '%s' not configured" backend-id)))
(assoc backend :conn (or conn pool))))
(d/export impl/resolve-backend)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Garbage Collection: Permanently delete objects
@ -295,7 +294,7 @@
(some-> (seq rows) (group-by-backend))))
(delete-in-bulk [conn [backend ids]]
(let [backend (resolve-backend storage backend)
(let [backend (impl/resolve-backend storage backend)
backend (assoc backend :conn conn)]
(impl/del-objects-in-bulk backend ids)))]
@ -445,7 +444,7 @@
(some-> (seq rows) (group-results))))
(delete-group [conn [backend ids]]
(let [backend (resolve-backend storage backend)
(let [backend (impl/resolve-backend storage backend)
backend (assoc backend :conn conn)]
(impl/del-objects-in-bulk backend ids)))

12
backend/src/app/storage/db.clj
View file

@ -46,12 +46,24 @@
(let [result (db/exec-one! conn ["select data from storage_data where id=?" id])]
(ByteArrayInputStream. (:data result))))
(defmethod impl/get-object-bytes :db
[{:keys [conn] :as backend} {:keys [id] :as object}]
(let [result (db/exec-one! conn ["select data from storage_data where id=?" id])]
(:data result)))
(defmethod impl/get-object-url :db
[_ _]
(throw (UnsupportedOperationException. "not supported")))
(defmethod impl/del-object :db
[_ _]
;; NOOP: because deleting the row already deletes the file data from
;; the database.
nil)
(defmethod impl/del-objects-in-bulk :db
[_ _]
;; NOOP: because deleting the row already deletes the file data from
;; the database.
nil)

12
backend/src/app/storage/fs.clj
View file

@ -79,6 +79,10 @@
:path (str full)))
(io/input-stream full)))
(defmethod impl/get-object-bytes :fs
[backend object]
(fs/slurp-bytes (impl/get-object-data backend object)))
(defmethod impl/get-object-url :fs
[{:keys [uri] :as backend} {:keys [id] :as object} _]
(update uri :path
@ -87,6 +91,13 @@
(str existing (impl/id->path id))
(str existing "/" (impl/id->path id))))))
(defmethod impl/del-object :fs
[backend {:keys [id] :as object}]
(let [base (fs/path (:directory backend))
path (fs/path (impl/id->path id))
path (fs/join base path)]
(Files/deleteIfExists ^Path path)))
(defmethod impl/del-objects-in-bulk :fs
[backend ids]
(let [base (fs/path (:directory backend))]
@ -94,3 +105,4 @@
(let [path (fs/path (impl/id->path id))
path (fs/join base path)]
(Files/deleteIfExists ^Path path)))))

49
backend/src/app/storage/impl.clj
View file

@ -8,10 +8,10 @@
"Storage backends abstraction layer."
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[buddy.core.codecs :as bc]
[clojure.java.io :as io])
[clojure.java.io :as io]
[cuerdas.core :as str])
(:import
java.nio.ByteBuffer
java.util.UUID
@ -45,6 +45,14 @@
:code :invalid-storage-backend
:context cfg))
(defmulti get-object-bytes (fn [cfg _] (:type cfg)))
(defmethod get-object-bytes :default
[cfg _]
(ex/raise :type :internal
:code :invalid-storage-backend
:context cfg))
(defmulti get-object-url (fn [cfg _ _] (:type cfg)))
(defmethod get-object-url :default
@ -54,6 +62,14 @@
:context cfg))
(defmulti del-object (fn [cfg _] (:type cfg)))
(defmethod del-object :default
[cfg _]
(ex/raise :type :internal
:code :invalid-storage-backend
:context cfg))
(defmulti del-objects-in-bulk (fn [cfg _] (:type cfg)))
(defmethod del-objects-in-bulk :default
@ -62,7 +78,6 @@
:code :invalid-storage-backend
:context cfg))
;; --- HELPERS
(defn uuid->hex
@ -109,7 +124,10 @@
(make-output-stream [_ opts]
(throw (UnsupportedOperationException. "not implemented")))
clojure.lang.Counted
(count [_] size))))
(count [_] size)
java.lang.AutoCloseable
(close [_]))))
(defn string->content
[^String v]
@ -129,7 +147,10 @@
clojure.lang.Counted
(count [_]
(alength data)))))
(alength data))
java.lang.AutoCloseable
(close [_]))))
(defn- input-stream->content
[^InputStream is size]
@ -146,7 +167,11 @@
(throw (UnsupportedOperationException. "not implemented")))
clojure.lang.Counted
(count [_] size)))
(count [_] size)
java.lang.AutoCloseable
(close [_]
(.close is))))
(defn content
([data] (content data nil))
@ -179,10 +204,20 @@
(defn slurp-bytes
[content]
(us/assert content? content)
(with-open [input (io/input-stream content)
output (java.io.ByteArrayOutputStream. (count content))]
(io/copy input output)
(.toByteArray output)))
(defn resolve-backend
[{:keys [conn pool] :as storage} backend-id]
(when backend-id
(let [backend (get-in storage [:backends backend-id])]
(when-not backend
(ex/raise :type :internal
:code :backend-not-configured
:hint (str/fmt "backend '%s' not configured" backend-id)))
(assoc backend
:conn (or conn pool)
:id backend-id))))

74
backend/src/app/storage/s3.clj
View file

@ -5,7 +5,7 @@
;; Copyright (c) UXBOX Labs SL
(ns app.storage.s3
"Storage backends abstraction layer."
"S3 Storage backend implementation."
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
@ -18,25 +18,34 @@
[integrant.core :as ig])
(:import
java.time.Duration
java.io.InputStream
java.util.Collection
software.amazon.awssdk.core.sync.RequestBody
software.amazon.awssdk.core.ResponseBytes
;; software.amazon.awssdk.core.ResponseInputStream
software.amazon.awssdk.regions.Region
software.amazon.awssdk.services.s3.S3Client
software.amazon.awssdk.services.s3.model.Delete
software.amazon.awssdk.services.s3.model.CopyObjectRequest
software.amazon.awssdk.services.s3.model.DeleteObjectsRequest
software.amazon.awssdk.services.s3.model.DeleteObjectsResponse
software.amazon.awssdk.services.s3.model.DeleteObjectRequest
software.amazon.awssdk.services.s3.model.GetObjectRequest
software.amazon.awssdk.services.s3.model.ObjectIdentifier
software.amazon.awssdk.services.s3.model.PutObjectRequest
;; software.amazon.awssdk.services.s3.model.GetObjectResponse
software.amazon.awssdk.services.s3.presigner.S3Presigner
software.amazon.awssdk.services.s3.presigner.model.GetObjectPresignRequest
software.amazon.awssdk.services.s3.presigner.model.PresignedGetObjectRequest))
software.amazon.awssdk.services.s3.presigner.model.PresignedGetObjectRequest
))
(declare put-object)
(declare copy-object)
(declare get-object)
(declare get-object-bytes)
(declare get-object-data)
(declare get-object-url)
(declare del-object)
(declare del-object-in-bulk)
(declare build-s3-client)
(declare build-s3-presigner)
@ -87,12 +96,20 @@
(defmethod impl/get-object-data :s3
[backend object]
(get-object backend object))
(get-object-data backend object))
(defmethod impl/get-object-bytes :s3
[backend object]
(get-object-bytes backend object))
(defmethod impl/get-object-url :s3
[backend object options]
(get-object-url backend object options))
(defmethod impl/del-object :s3
[backend object]
(del-object backend object))
(defmethod impl/del-objects-in-bulk :s3
[backend ids]
(del-object-in-bulk backend ids))
@ -104,19 +121,19 @@
(case region
:eu-central-1 Region/EU_CENTRAL_1))
(defn- build-s3-client
(defn build-s3-client
[{:keys [region]}]
(.. (S3Client/builder)
(region (lookup-region region))
(build)))
(defn- build-s3-presigner
(defn build-s3-presigner
[{:keys [region]}]
(.. (S3Presigner/builder)
(region (lookup-region region))
(build)))
(defn- put-object
(defn put-object
[{:keys [client bucket prefix]} {:keys [id] :as object} content]
(let [path (str prefix (impl/id->path id))
mdata (meta object)
@ -125,14 +142,15 @@
(bucket bucket)
(contentType mtype)
(key path)
(build))
content (RequestBody/fromInputStream (io/input-stream content)
(count content))]
(build))]
(with-open [^InputStream is (io/input-stream content)]
(let [content (RequestBody/fromInputStream is (count content))]
(.putObject ^S3Client client
^PutObjectRequest request
^RequestBody content)))
^RequestBody content)))))
(defn- copy-object
(defn copy-object
[{:keys [client bucket prefix]} src-object dst-object]
(let [source-path (str prefix (impl/id->path (:id src-object)))
source-mdata (meta src-object)
@ -146,22 +164,33 @@
(contentType source-mtype)
(build))]
(.copyObject ^S3Client client
^CopyObjectRequest request)))
(.copyObject ^S3Client client ^CopyObjectRequest request)))
(defn- get-object
(defn get-object-data
[{:keys [client bucket prefix]} {:keys [id]}]
(let [gor (.. (GetObjectRequest/builder)
(bucket bucket)
(key (str prefix (impl/id->path id)))
(build))
obj (.getObject ^S3Client client ^GetObjectRequest gor)]
obj (.getObject ^S3Client client ^GetObjectRequest gor)
;; rsp (.response ^ResponseInputStream obj)
;; len (.contentLength ^GetObjectResponse rsp)
]
(io/input-stream obj)))
(defn get-object-bytes
[{:keys [client bucket prefix]} {:keys [id]}]
(let [gor (.. (GetObjectRequest/builder)
(bucket bucket)
(key (str prefix (impl/id->path id)))
(build))
obj (.getObjectAsBytes ^S3Client client ^GetObjectRequest gor)]
(.asByteArray ^ResponseBytes obj)))
(def default-max-age
(dt/duration {:minutes 10}))
(defn- get-object-url
(defn get-object-url
[{:keys [presigner bucket prefix]} {:keys [id]} {:keys [max-age] :or {max-age default-max-age}}]
(us/assert dt/duration? max-age)
(let [gor (.. (GetObjectRequest/builder)
@ -175,7 +204,16 @@
pgor (.presignGetObject ^S3Presigner presigner ^GetObjectPresignRequest gopr)]
(u/uri (str (.url ^PresignedGetObjectRequest pgor)))))
(defn- del-object-in-bulk
(defn del-object
[{:keys [bucket client prefix]} {:keys [id] :as obj}]
(let [dor (.. (DeleteObjectRequest/builder)
(bucket bucket)
(key (str prefix (impl/id->path id)))
(build))]
(.deleteObject ^S3Client client
^DeleteObjectRequest dor)))
(defn del-object-in-bulk
[{:keys [bucket client prefix]} ids]
(let [oids (map (fn [id]
(.. (ObjectIdentifier/builder)

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

@ -4,6 +4,9 @@
;;
;; 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

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

@ -14,6 +14,9 @@
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
;; TODO: DEPRECATED
;; Should be removed in the 1.8.x
(declare delete-profile-data)
;; --- INIT

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

@ -100,6 +100,7 @@
:id (:id mobj)
:media-id (:media-id mobj)
:thumbnail-id (:thumbnail-id mobj))
;; NOTE: deleting the file-media-object in the database
;; automatically marks as toched the referenced storage
;; objects. The touch mechanism is needed because many files can

63
backend/src/app/tasks/file_offload.clj Normal file
View file

@ -0,0 +1,63 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) UXBOX Labs SL
(ns app.tasks.file-offload
"A maintenance task that offloads file data to an external storage (S3)."
(:require
[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]))
(def sql:offload-candidates-chunk
"select f.id, f.data from file as f
where f.data is not null
and f.modified_at < now() - ?::interval
order by f.modified_at
limit 10")
(defn- retrieve-candidates
[{:keys [conn max-age]}]
(db/exec! conn [sql:offload-candidates-chunk max-age]))
(defn- offload-candidate
[{:keys [storage conn backend] :as cfg} {:keys [id data] :as file}]
(l/debug :action "offload file data" :id id)
(let [backend (simpl/resolve-backend storage backend)]
(->> (simpl/content data)
(simpl/put-object backend file))
(db/update! conn :file
{:data nil
:data-backend (name (:id backend))}
{:id id})))
;; ---- STATE INIT
(s/def ::max-age ::dt/duration)
(s/def ::backend ::us/keyword)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool ::max-age ::sto/storage ::backend]))
(defmethod ig/init-key ::handler
[_ {:keys [pool max-age] :as cfg}]
(fn [_]
(db/with-atomic [conn pool]
(let [max-age (db/interval max-age)
cfg (-> cfg
(assoc :conn conn)
(assoc :max-age max-age))]
(loop [n 0]
(let [candidates (retrieve-candidates cfg)]
(if (seq candidates)
(do
(run! (partial offload-candidate cfg) candidates)
(recur (+ n (count candidates))))
(l/debug :hint "offload summary" :count n))))))))

171
backend/src/app/tasks/objects_gc.clj Normal file
View file

@ -0,0 +1,171 @@
;; 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.objects-gc
"A maintenance task that performs a general purpose garbage collection
of deleted objects."
(:require
[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]
[integrant.core :as ig]))
(def target-tables
["profile"
"team"
"file"
"project"
"team_font_variant"])
(defmulti delete-objects :table)
(def sql:delete-objects
"with deleted as (
select id from %(table)s
where deleted_at is not null
and deleted_at < now() - ?::interval
order by deleted_at
limit %(limit)s
)
delete from %(table)s
where id in (select id from deleted)
returning *")
;; --- IMPL: generic object deletion
(defmethod delete-objects :default
[{:keys [conn max-age table] :as cfg}]
(let [sql (str/fmt sql:delete-objects
{:table table :limit 50})
result (db/exec! conn [sql max-age])]
(doseq [{:keys [id] :as item} result]
(l/trace :action "delete object" :table table :id id))
(count result)))
;; --- IMPL: file deletion
(defmethod delete-objects "file"
[{:keys [conn max-age table storage] :as cfg}]
(let [sql (str/fmt sql:delete-objects
{:table table :limit 50})
result (db/exec! conn [sql max-age])
backend (simpl/resolve-backend storage (cf/get :fdata-storage-backend))]
(doseq [{:keys [id] :as item} result]
(l/trace :action "delete object" :table table :id id)
(when backend
(simpl/del-object backend item)))
(count result)))
;; --- IMPL: team-font-variant deletion
(defmethod delete-objects "team_font_variant"
[{:keys [conn max-age storage table] :as cfg}]
(let [sql (str/fmt sql:delete-objects
{:table table :limit 50})
fonts (db/exec! conn [sql max-age])
storage (assoc storage :conn conn)]
(doseq [{:keys [id] :as font} fonts]
(l/trace :action "delete object" :table table :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)))
(count fonts)))
;; --- IMPL: team deletion
(defmethod delete-objects "team"
[{:keys [conn max-age storage table] :as cfg}]
(let [sql (str/fmt sql:delete-objects
{:table table :limit 50})
teams (db/exec! conn [sql max-age])
storage (assoc storage :conn conn)]
(doseq [{:keys [id] :as team} teams]
(l/trace :action "delete object" :table table :id id)
(some->> (:photo-id team) (sto/del-object storage)))
(count teams)))
;; --- IMPL: profile deletion
(def sql:retrieve-deleted-profiles
"select id, photo_id from profile
where deleted_at is not null
and deleted_at < now() - ?::interval
order by deleted_at
limit %(limit)s
for update")
(def sql:mark-owned-teams-deleted
"with owned as (
select tpr.team_id as id
from team_profile_rel as tpr
where tpr.is_owner is true
and tpr.profile_id = ?
)
update team set deleted_at = now() - ?::interval
where id in (select id from owned)")
(defmethod delete-objects "profile"
[{:keys [conn max-age storage table] :as cfg}]
(let [sql (str/fmt sql:retrieve-deleted-profiles {:limit 50})
profiles (db/exec! conn [sql max-age])
storage (assoc storage :conn conn)]
(doseq [{:keys [id] :as profile} profiles]
(l/trace :action "delete object" :table table :id id)
;; Mark the owned teams as deleted; this enables them to be procesed
;; in the same transaction in the "team" table step.
(db/exec-one! conn [sql:mark-owned-teams-deleted id max-age])
;; Mark as deleted the storage object related with the photo-id
;; field.
(some->> (:photo-id profile) (sto/del-object storage))
;; And finally, permanently delete the profile.
(db/delete! conn :profile {:id id}))
(count profiles)))
;; --- INIT
(defn- process-table
[{:keys [table] :as cfg}]
(loop [n 0]
(let [res (delete-objects cfg)]
(if (pos? res)
(recur (+ n res))
(l/debug :hint "table gc summary" :table table :deleted n)))))
(s/def ::max-age ::dt/duration)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool ::sto/storage ::max-age]))
(defmethod ig/init-key ::handler
[_ {:keys [pool max-age] :as cfg}]
(fn [task]
;; Checking first on task argument allows properly testing it.
(let [max-age (get task :max-age max-age)]
(db/with-atomic [conn pool]
(let [max-age (db/interval max-age)
cfg (-> cfg
(assoc :max-age max-age)
(assoc :conn conn))]
(doseq [table target-tables]
(process-table (assoc cfg :table table))))))))

27
backend/src/app/tokens.clj
View file

@ -9,21 +9,12 @@
(:require
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.transit :as t]
[app.util.time :as dt]
[app.util.transit :as t]
[buddy.core.kdf :as bk]
[buddy.sign.jwe :as jwe]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(defn- derive-tokens-secret
[key]
(let [engine (bk/engine {:key key
:salt "tokens"
:alg :hkdf
:digest :blake2b-512})]
(bk/get-bytes engine 32)))
(defn- generate
[cfg claims]
(let [payload (t/encode claims)]
@ -50,13 +41,6 @@
:params params))
claims))
(s/def ::secret-key ::us/string)
(s/def ::props
(s/keys :req-un [::secret-key]))
(defmethod ig/pre-init-spec ::tokens [_]
(s/keys :req-un [::props]))
(defn- generate-predefined
[cfg {:keys [iss profile-id] :as params}]
(case iss
@ -70,9 +54,14 @@
:code :not-implemented
:hint "no predefined token")))
(s/def ::keys fn?)
(defmethod ig/pre-init-spec ::tokens [_]
(s/keys :req-un [::keys]))
(defmethod ig/init-key ::tokens
[_ {:keys [props] :as cfg}]
(let [secret (derive-tokens-secret (:secret-key props))
[_ {:keys [keys] :as cfg}]
(let [secret (keys :salt "tokens" :size 32)
cfg (assoc cfg ::secret secret)]
(fn [action params]
(case action

4
backend/src/app/util/blob.clj
View file

@ -8,8 +8,8 @@
"A generic blob storage encoding. Mainly used for page data, page
options and txlog payload storage."
(:require
[app.common.transit :as t]
[app.config :as cf]
[app.util.transit :as t]
[taoensso.nippy :as n])
(:import
java.io.ByteArrayInputStream
@ -108,7 +108,7 @@
cdata (byte-array mlen)
clen (Zstd/compressByteArray ^bytes cdata 0 mlen
^bytes data 0 dlen
4)]
6)]
(with-open [^ByteArrayOutputStream baos (ByteArrayOutputStream. (+ (alength cdata) 2 4))
^DataOutputStream dos (DataOutputStream. baos)]
(.writeShort dos (short 3)) ;; version number

26
backend/src/app/util/time.clj
View file

@ -10,13 +10,14 @@
[clojure.spec.alpha :as s]
[cuerdas.core :as str])
(:import
java.time.Instant
java.time.Duration
java.util.Date
java.time.ZonedDateTime
java.time.Instant
java.time.OffsetDateTime
java.time.ZoneId
java.time.ZonedDateTime
java.time.format.DateTimeFormatter
java.time.temporal.TemporalAmount
java.util.Date
org.apache.logging.log4j.core.util.CronExpression))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -54,10 +55,17 @@
(obj->duration ms-or-obj)))
(defn duration-between
{:deprecated true}
[t1 t2]
(Duration/between t1 t2))
(letfn [(conformer [v]
(defn diff
[t1 t2]
(Duration/between t1 t2))
(s/def ::duration
(s/conformer
(fn [v]
(cond
(duration? v) v
@ -69,13 +77,15 @@
:else
::s/invalid))
(unformer [v]
(subs (str v) 2))]
(s/def ::duration (s/conformer conformer unformer)))
(fn [v]
(subs (str v) 2))))
(extend-protocol clojure.core/Inst
java.time.Duration
(inst-ms* [v] (.toMillis ^Duration v)))
(inst-ms* [v] (.toMillis ^Duration v))
OffsetDateTime
(inst-ms* [v] (.toEpochMilli (.toInstant ^OffsetDateTime v))))
(defmethod print-method Duration
[mv ^java.io.Writer writer]

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

@ -436,7 +436,7 @@
(s/assert dt/cron? cron)
(let [now (dt/now)
next (dt/next-valid-instant-from cron now)]
(inst-ms (dt/duration-between now next))))
(inst-ms (dt/diff now next))))
(defn- schedule-task
[{:keys [scheduler] :as cfg} {:keys [cron] :as task}]

14
backend/tests/app/tests/test_bounces_handling.clj → backend/test/app/bounce_handling_test.clj
View file

@ -4,16 +4,16 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-bounces-handling
(ns app.bounce-handling-test
(:require
[clojure.pprint :refer [pprint]]
[app.http.awsns :as awsns]
[app.emails :as emails]
[app.tests.helpers :as th]
[app.db :as db]
[app.emails :as emails]
[app.http.awsns :as awsns]
[app.test-helpers :as th]
[app.util.time :as dt]
[mockery.core :refer [with-mocks]]
[clojure.test :as t]))
[clojure.pprint :refer [pprint]]
[clojure.test :as t]
[mockery.core :refer [with-mocks]]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)

4
backend/tests/app/tests/test_emails.clj → backend/test/app/emails_test.clj
View file

@ -4,13 +4,13 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-emails
(ns app.emails-test
(:require
[clojure.test :as t]
[promesa.core :as p]
[app.db :as db]
[app.emails :as emails]
[app.tests.helpers :as th]))
[app.test-helpers :as th]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)

73
backend/tests/app/tests/test_services_files.clj → backend/test/app/services_files_test.clj
View file

@ -4,13 +4,14 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-files
(ns app.services-files-test
(:require
[app.common.uuid :as uuid]
[app.db :as db]
[app.http :as http]
[app.storage :as sto]
[app.tests.helpers :as th]
[app.test-helpers :as th]
[app.util.time :as dt]
[clojure.test :as t]
[datoteka.core :as fs]))
@ -134,7 +135,7 @@
(t/deftest file-media-gc-task
(letfn [(create-file-media-object [{:keys [profile-id file-id]}]
(let [mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/tests/_files/sample.jpg")
:tempfile (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg"
:size 312043}
params {::th/type :upload-file-media-object
@ -337,3 +338,69 @@
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found))))
(t/deftest deletion-test
(let [task (:app.tasks.objects-gc/handler th/*system*)
profile1 (th/create-profile* 1)
file (th/create-file* 1 {:project-id (:default-project-id profile1)
:profile-id (:id profile1)})]
;; file is not deleted because it does not meet all
;; conditions to be deleted.
(let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result)))
;; query the list of files
(let [data {::th/type :project-files
:project-id (:default-project-id profile1)
:profile-id (:id profile1)}
out (th/query! data)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(let [result (:result out)]
(t/is (= 1 (count result)))))
;; Request file to be deleted
(let [params {::th/type :delete-file
:id (:id file)
:profile-id (:id profile1)}
out (th/mutation! params)]
(t/is (nil? (:error out))))
;; query the list of files after soft deletion
(let [data {::th/type :project-files
:project-id (:default-project-id profile1)
: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)))))
;; run permanent deletion (should be noop)
(let [result (task {:max-age (dt/duration {:minutes 1})})]
(t/is (nil? result)))
;; query the list of file libraries of a after hard deletion
(let [data {::th/type :file-libraries
:file-id (:id file)
: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)))))
;; run permanent deletion
(let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result)))
;; query the list of file libraries of a after hard deletion
(let [data {::th/type :file-libraries
:file-id (:id file)
:profile-id (:id profile1)}
out (th/query! data)]
;; (th/print-result! out)
(let [error (:error out)
error-data (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type error-data) :not-found))))
))

8
backend/tests/app/tests/test_services_fonts.clj → backend/test/app/services_fonts_test.clj
View file

@ -4,13 +4,13 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-fonts
(ns app.services-fonts-test
(:require
[app.common.uuid :as uuid]
[app.db :as db]
[app.http :as http]
[app.storage :as sto]
[app.tests.helpers :as th]
[app.test-helpers :as th]
[clojure.java.io :as io]
[clojure.test :as t]
[datoteka.core :as fs]))
@ -24,7 +24,7 @@
proj-id (:default-project-id prof)
font-id (uuid/custom 10 1)
ttfdata (-> (io/resource "app/tests/_files/font-1.ttf")
ttfdata (-> (io/resource "app/test_files/font-1.ttf")
(fs/slurp-bytes))
params {::th/type :create-font-variant
@ -59,7 +59,7 @@
proj-id (:default-project-id prof)
font-id (uuid/custom 10 1)
data (-> (io/resource "app/tests/_files/font-1.woff")
data (-> (io/resource "app/test_files/font-1.woff")
(fs/slurp-bytes))
params {::th/type :create-font-variant

4
backend/tests/app/tests/test_services_management.clj → backend/test/app/services_management_test.clj
View file

@ -4,13 +4,13 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-management
(ns app.services-management-test
(:require
[app.common.uuid :as uuid]
[app.db :as db]
[app.http :as http]
[app.storage :as sto]
[app.tests.helpers :as th]
[app.test-helpers :as th]
[clojure.test :as t]
[buddy.core.bytes :as b]
[datoteka.core :as fs]))

6
backend/tests/app/tests/test_services_media.clj → backend/test/app/services_media_test.clj
View file

@ -4,12 +4,12 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-media
(ns app.services-media-test
(:require
[app.common.uuid :as uuid]
[app.db :as db]
[app.storage :as sto]
[app.tests.helpers :as th]
[app.test-helpers :as th]
[clojure.test :as t]
[datoteka.core :as fs]))
@ -57,7 +57,7 @@
:project-id (:default-project-id prof)
:is-shared false})
mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/tests/_files/sample.jpg")
:tempfile (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg"
:size 312043}

204
backend/tests/app/tests/test_services_profile.clj → backend/test/app/services_profile_test.clj
View file

@ -4,16 +4,17 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-profile
(ns app.services-profile-test
(:require
[clojure.test :as t]
[clojure.java.io :as io]
[mockery.core :refer [with-mocks]]
[cuerdas.core :as str]
[datoteka.core :as fs]
[app.db :as db]
[app.rpc.mutations.profile :as profile]
[app.tests.helpers :as th]))
[app.test-helpers :as th]
[app.util.time :as dt]
[clojure.java.io :as io]
[clojure.test :as t]
[cuerdas.core :as str]
[datoteka.core :as fs]
[mockery.core :refer [with-mocks]]))
;; TODO: profile deletion with teams
;; TODO: profile deletion with owner teams
@ -108,7 +109,7 @@
:profile-id (:id profile)
:file {:filename "sample.jpg"
:size 123123
:tempfile "tests/app/tests/_files/sample.jpg"
:tempfile (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg"}}
out (th/mutation! data)]
@ -117,7 +118,7 @@
))
(t/deftest profile-deletion-simple
(let [task (:app.tasks.delete-profile/handler th/*system*)
(let [task (:app.tasks.objects-gc/handler th/*system*)
prof (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
@ -125,23 +126,14 @@
;; profile is not deleted because it does not meet all
;; conditions to be deleted.
(let [result (task {:props {:profile-id (:id prof)}})]
(let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result)))
;; Request profile to be deleted
(with-mocks [mock {:target 'app.worker/submit! :return nil}]
(let [params {::th/type :delete-profile
:profile-id (:id prof)}
out (th/mutation! params)]
(t/is (nil? (:error out)))
;; check the mock
(let [mock (deref mock)
mock-params (first (:call-args mock))]
(t/is (:called? mock))
(t/is (= 1 (:call-count mock)))
(t/is (= :delete-profile (:app.worker/task mock-params)))
(t/is (= (:id prof) (:profile-id mock-params))))))
(t/is (nil? (:error out))))
;; query files after profile soft deletion
(let [params {::th/type :files
@ -153,8 +145,8 @@
(t/is (= 1 (count (:result out)))))
;; execute permanent deletion task
(let [result (task {:props {:profile-id (:id prof)}})]
(t/is (true? result)))
(let [result (task {:max-age (dt/duration "-1m")})]
(t/is (nil? result)))
;; query profile after delete
(let [params {::th/type :profile
@ -165,17 +157,6 @@
error-data (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type error-data) :not-found))))
;; query files after profile soft deletion
(let [params {::th/type :files
:project-id (:default-project-id prof)
:profile-id (:id prof)}
out (th/query! params)]
;; (th/print-result! out)
(let [error (:error out)
error-data (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type error-data) :not-found))))
))
(t/deftest registration-domain-whitelist
@ -187,126 +168,95 @@
(t/testing "not allowed email domain"
(t/is (false? (profile/email-domain-in-whitelist? whitelist "username@somedomain.com"))))))
(t/deftest test-register-with-no-terms-and-privacy
(let [data {::th/type :register-profile
(t/deftest prepare-register-and-register-profile
(let [data {::th/type :prepare-register-profile
:email "user@example.com"
:password "foobar"
:fullname "foobar"
:terms-privacy nil}
:password "foobar"}
out (th/mutation! data)
error (:error out)
edata (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type edata) :validation))
(t/is (= (:code edata) :spec-validation))))
token (get-in out [:result :token])]
(t/is (string? token))
(t/deftest test-register-with-bad-terms-and-privacy
;; try register without accepting terms
(let [data {::th/type :register-profile
:email "user@example.com"
:password "foobar"
:token token
:fullname "foobar"
:terms-privacy false}
out (th/mutation! data)
error (:error out)
edata (ex-data error)]
:accept-terms-and-privacy false}
out (th/mutation! data)]
(let [error (:error out)]
(t/is (th/ex-info? error))
(t/is (= (:type edata) :validation))
(t/is (= (:code edata) :invalid-terms-and-privacy))))
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :invalid-terms-and-privacy))))
(t/deftest test-register-when-registration-disabled
;; try register without token
(let [data {::th/type :register-profile
:fullname "foobar"
:accept-terms-and-privacy true}
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 :spec-validation))))
;; try correct register
(let [data {::th/type :register-profile
:token token
:fullname "foobar"
: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/deftest prepare-register-with-registration-disabled
(with-mocks [mock {:target 'app.config/get
:return (th/mock-config-get-with
{:registration-enabled false})}]
(let [data {::th/type :register-profile
:email "user@example.com"
:password "foobar"
:fullname "foobar"
:terms-privacy true}
out (th/mutation! data)
error (:error out)
edata (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type edata) :restriction))
(t/is (= (:code edata) :registration-disabled)))))
(t/deftest test-register-existing-profile
(let [data {::th/type :prepare-register-profile
:email "user@example.com"
:password "foobar"}]
(let [{:keys [result error] :as out} (th/mutation! data)]
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :restriction))
(t/is (th/ex-of-code? error :registration-disabled))))))
(t/deftest prepare-register-with-existing-user
(let [profile (th/create-profile* 1)
data {::th/type :register-profile
data {::th/type :prepare-register-profile
:email (:email profile)
:password "foobar"
:fullname "foobar"
:terms-privacy true}
out (th/mutation! data)
error (:error out)
edata (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type edata) :validation))
(t/is (= (:code edata) :email-already-exists))))
(t/deftest test-register-profile
(with-mocks [mock {:target 'app.emails/send!
:return nil}]
(let [pool (:app.db/pool th/*system*)
data {::th/type :register-profile
:email "user@example.com"
:password "foobar"
:fullname "foobar"
:terms-privacy true}
out (th/mutation! data)]
:password "foobar"}]
(let [{:keys [result error] :as out} (th/mutation! data)]
;; (th/print-result! out)
(let [mock (deref mock)
[params] (:call-args mock)]
;; (clojure.pprint/pprint params)
(t/is (:called? mock))
(t/is (= (:email data) (:to params)))
(t/is (contains? params :extra-data))
(t/is (contains? params :token)))
(let [result (:result out)]
(t/is (false? (:is-demo result)))
(t/is (= (:email data) (:email result)))
(t/is (= "penpot" (:auth-backend result)))
(t/is (= "foobar" (:fullname result)))
(t/is (not (contains? result :password)))))))
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :email-already-exists)))))
(t/deftest test-register-profile-with-bounced-email
(with-mocks [mock {:target 'app.emails/send!
:return nil}]
(let [pool (:app.db/pool th/*system*)
data {::th/type :register-profile
data {::th/type :prepare-register-profile
:email "user@example.com"
:password "foobar"
:fullname "foobar"
:terms-privacy true}
_ (th/create-global-complaint-for pool {:type :bounce :email "user@example.com"})
out (th/mutation! data)]
;; (th/print-result! out)
:password "foobar"}]
(let [mock (deref mock)]
(t/is (false? (:called? mock))))
(th/create-global-complaint-for pool {:type :bounce :email "user@example.com"})
(let [error (:error out)
edata (ex-data error)]
(let [{:keys [result error] :as out} (th/mutation! data)]
(t/is (th/ex-info? error))
(t/is (= (:type edata) :validation))
(t/is (= (:code edata) :email-has-permanent-bounces))))))
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :email-has-permanent-bounces)))))
(t/deftest test-register-profile-with-complained-email
(with-mocks [mock {:target 'app.emails/send! :return nil}]
(let [pool (:app.db/pool th/*system*)
data {::th/type :register-profile
data {::th/type :prepare-register-profile
:email "user@example.com"
:password "foobar"
:fullname "foobar"
:terms-privacy true}
_ (th/create-global-complaint-for pool {:type :complaint :email "user@example.com"})
out (th/mutation! data)]
:password "foobar"}]
(let [mock (deref mock)]
(t/is (true? (:called? mock))))
(let [result (:result out)]
(t/is (= (:email data) (:email result)))))))
(th/create-global-complaint-for pool {:type :complaint :email "user@example.com"})
(let [{:keys [result error] :as out} (th/mutation! data)]
(t/is (nil? error))
(t/is (string? (:token result))))))
(t/deftest test-email-change-request
(with-mocks [email-send-mock {:target 'app.emails/send! :return nil}

78
backend/tests/app/tests/test_services_projects.clj → backend/test/app/services_projects_test.clj
View file

@ -4,14 +4,14 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-projects
(ns app.services-projects-test
(:require
[clojure.test :as t]
[promesa.core :as p]
[app.common.uuid :as uuid]
[app.db :as db]
[app.http :as http]
[app.tests.helpers :as th]
[app.common.uuid :as uuid]))
[app.test-helpers :as th]
[app.util.time :as dt]
[clojure.test :as t]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
@ -170,3 +170,71 @@
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found))))
(t/deftest test-deletion
(let [task (:app.tasks.objects-gc/handler th/*system*)
profile1 (th/create-profile* 1)
project (th/create-project* 1 {:team-id (:default-team-id profile1)
:profile-id (:id profile1)})]
;; project is not deleted because it does not meet all
;; conditions to be deleted.
(let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result)))
;; query the list of projects
(let [data {::th/type :projects
:team-id (:default-team-id profile1)
:profile-id (:id profile1)}
out (th/query! data)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(let [result (:result out)]
(t/is (= 2 (count result)))))
;; Request project to be deleted
(let [params {::th/type :delete-project
:id (:id project)
:profile-id (:id profile1)}
out (th/mutation! params)]
(t/is (nil? (:error out))))
;; query the list of projects after soft deletion
(let [data {::th/type :projects
:team-id (:default-team-id profile1)
:profile-id (:id profile1)}
out (th/query! data)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(let [result (:result out)]
(t/is (= 1 (count result)))))
;; run permanent deletion (should be noop)
(let [result (task {:max-age (dt/duration {:minutes 1})})]
(t/is (nil? result)))
;; query the list of files of a after soft deletion
(let [data {::th/type :project-files
:project-id (:id project)
: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)))))
;; run permanent deletion
(let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result)))
;; query the list of files of a after hard deletion
(let [data {::th/type :project-files
:project-id (:id project)
:profile-id (:id profile1)}
out (th/query! data)]
;; (th/print-result! out)
(let [error (:error out)
error-data (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type error-data) :not-found))))
))

83
backend/tests/app/tests/test_services_teams.clj → backend/test/app/services_teams_test.clj
View file

@ -4,16 +4,17 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-teams
(ns app.services-teams-test
(:require
[app.common.uuid :as uuid]
[app.db :as db]
[app.http :as http]
[app.storage :as sto]
[app.tests.helpers :as th]
[mockery.core :refer [with-mocks]]
[app.test-helpers :as th]
[app.util.time :as dt]
[clojure.test :as t]
[datoteka.core :as fs]))
[datoteka.core :as fs]
[mockery.core :refer [with-mocks]]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)
@ -80,6 +81,80 @@
)))
(t/deftest test-deletion
(let [task (:app.tasks.objects-gc/handler th/*system*)
profile1 (th/create-profile* 1 {:is-active true})
team (th/create-team* 1 {:profile-id (:id profile1)})
pool (:app.db/pool th/*system*)
data {::th/type :delete-team
:team-id (:id team)
:profile-id (:id profile1)}]
;; team is not deleted because it does not meet all
;; conditions to be deleted.
(let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result)))
;; query the list of teams
(let [data {::th/type :teams
:profile-id (:id profile1)}
out (th/query! data)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(let [result (:result out)]
(t/is (= 2 (count result)))
(t/is (= (:id team) (get-in result [1 :id])))
(t/is (= (:default-team-id profile1) (get-in result [0 :id])))))
;; Request team to be deleted
(let [params {::th/type :delete-team
:id (:id team)
:profile-id (:id profile1)}
out (th/mutation! params)]
(t/is (nil? (:error out))))
;; query the list of teams after soft deletion
(let [data {::th/type :teams
:profile-id (:id profile1)}
out (th/query! data)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(let [result (:result out)]
(t/is (= 1 (count result)))
(t/is (= (:default-team-id profile1) (get-in result [0 :id])))))
;; run permanent deletion (should be noop)
(let [result (task {:max-age (dt/duration {:minutes 1})})]
(t/is (nil? result)))
;; query the list of projects of a after hard deletion
(let [data {::th/type :projects
:team-id (:id team)
:profile-id (:id profile1)}
out (th/query! data)]
;; (th/print-result! out)
(t/is (nil? (:error out)))
(let [result (:result out)]
(t/is (= 0 (count result)))))
;; run permanent deletion
(let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result)))
;; query the list of projects of a after hard deletion
(let [data {::th/type :projects
:team-id (:id team)
:profile-id (:id profile1)}
out (th/query! data)]
;; (th/print-result! out)
(let [error (:error out)
error-data (ex-data error)]
(t/is (th/ex-info? error))
(t/is (= (:type error-data) :not-found))))
))

8
backend/tests/app/tests/test_services_viewer.clj → backend/test/app/services_viewer_test.clj
View file

@ -4,13 +4,13 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-viewer
(ns app.services-viewer-test
(:require
[clojure.test :as t]
[datoteka.core :as fs]
[app.common.uuid :as uuid]
[app.db :as db]
[app.tests.helpers :as th]))
[app.test-helpers :as th]
[clojure.test :as t]
[datoteka.core :as fs]))
(t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset)

9
backend/tests/app/tests/test_storage.clj → backend/test/app/storage_test.clj
View file

@ -4,12 +4,12 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-storage
(ns app.storage-test
(:require
[app.common.exceptions :as ex]
[app.db :as db]
[app.storage :as sto]
[app.tests.helpers :as th]
[app.test-helpers :as th]
[app.util.time :as dt]
[clojure.java.io :as io]
[clojure.test :as t]
@ -22,7 +22,6 @@
th/database-reset
th/clean-storage))
;; TODO: add specific tests for DB backend.
(t/deftest put-and-retrieve-object
(let [storage (:app.storage/storage th/*system*)
@ -106,7 +105,7 @@
:project-id (:default-project-id prof)
:is-shared false})
mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/tests/_files/sample.jpg")
:tempfile (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg"
:size 312043}
@ -167,7 +166,7 @@
:project-id (:default-project-id prof)
:is-shared false})
mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/tests/_files/sample.jpg")
:tempfile (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg"
:size 312043}

0
backend/tests/app/tests/_files/font-1.otf → backend/test/app/test_files/font-1.otf
View file

0
backend/tests/app/tests/_files/font-1.ttf → backend/test/app/test_files/font-1.ttf
View file

0
backend/tests/app/tests/_files/font-1.woff → backend/test/app/test_files/font-1.woff
View file

0
backend/tests/app/tests/_files/font-2.otf → backend/test/app/test_files/font-2.otf
View file

0
backend/tests/app/tests/_files/font-2.woff → backend/test/app/test_files/font-2.woff
View file

0
backend/tests/app/tests/_files/sample.jpg → backend/test/app/test_files/sample.jpg
View file

Side by side Swipe Overlay

Before

Width:  |  Height:  |  Size: 305 KiB

After

Width:  |  Height:  |  Size: 305 KiB

Before After
Before After

0
backend/tests/app/tests/_files/sample1.svg → backend/test/app/test_files/sample1.svg
View file

Side by side Swipe Overlay

Before

Width:  |  Height:  |  Size: 3.5 KiB

After

Width:  |  Height:  |  Size: 3.5 KiB

Before After
Before After

0
backend/tests/app/tests/_files/sample2.svg → backend/test/app/test_files/sample2.svg
View file

Side by side Swipe Overlay

Before

Width:  |  Height:  |  Size: 2.1 KiB

After

Width:  |  Height:  |  Size: 2.1 KiB

Before After
Before After

2
backend/tests/app/tests/helpers.clj → backend/test/app/test_helpers.clj
View file

@ -4,7 +4,7 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.tests.helpers
(ns app.test-helpers
(:require
[app.common.data :as d]
[app.common.pages :as cp]

4
backend/tests.edn
View file

@ -1,5 +1,5 @@
#kaocha/v1
{:tests
[{:id :unit
:test-paths ["tests" "src"]
:ns-patterns ["test-.*"]}]}
:test-paths ["test" "src"]
:ns-patterns [".*-test$"]}]}

424
common/app/common/geom/shapes/transforms.cljc
View file

@ -1,424 +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.common.geom.shapes.transforms
(:require
[app.common.attrs :as attrs]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.common :as gco]
[app.common.geom.shapes.path :as gpa]
[app.common.geom.shapes.rect :as gpr]
[app.common.math :as mth]
[app.common.data :as d]
[app.common.text :as txt]))
;; --- Relative Movement
(defn move-selrect [selrect {dx :x dy :y}]
(-> selrect
(d/update-when :x + dx)
(d/update-when :y + dy)
(d/update-when :x1 + dx)
(d/update-when :y1 + dy)
(d/update-when :x2 + dx)
(d/update-when :y2 + dy)))
(defn move-points [points move-vec]
(->> points
(mapv #(gpt/add % move-vec))))
(defn move
"Move the shape relativelly to its current
position applying the provided delta."
[shape {dx :x dy :y}]
(let [dx (d/check-num dx)
dy (d/check-num dy)
move-vec (gpt/point dx dy)]
(-> shape
(update :selrect move-selrect move-vec)
(update :points move-points move-vec)
(d/update-when :x + dx)
(d/update-when :y + dy)
(cond-> (= :path (:type shape))
(update :content gpa/move-content move-vec)))))
;; --- Absolute Movement
(declare absolute-move-rect)
(defn absolute-move
"Move the shape to the exactly specified position."
[shape {:keys [x y]}]
(let [dx (- (d/check-num x) (-> shape :selrect :x))
dy (- (d/check-num y) (-> shape :selrect :y))]
(move shape (gpt/point dx dy))))
(defn- modif-rotation [shape]
(let [cur-rotation (d/check-num (:rotation shape))
delta-angle (d/check-num (get-in shape [:modifiers :rotation]))]
(mod (+ cur-rotation delta-angle) 360)))
(defn transform-matrix
"Returns a transformation matrix without changing the shape properties.
The result should be used in a `transform` attribute in svg"
([shape] (transform-matrix shape nil))
([shape params] (transform-matrix shape params (or (gco/center-shape shape)
(gpt/point 0 0))))
([{:keys [flip-x flip-y] :as shape} {:keys [no-flip]} shape-center]
(-> (gmt/matrix)
(gmt/translate shape-center)
(gmt/multiply (:transform shape (gmt/matrix)))
(cond->
(and (not no-flip) flip-x) (gmt/scale (gpt/point -1 1))
(and (not no-flip) flip-y) (gmt/scale (gpt/point 1 -1)))
(gmt/translate (gpt/negate shape-center)))))
(defn inverse-transform-matrix
([shape]
(let [shape-center (or (gco/center-shape shape)
(gpt/point 0 0))]
(inverse-transform-matrix shape shape-center)))
([{:keys [flip-x flip-y] :as shape} center]
(let []
(-> (gmt/matrix)
(gmt/translate center)
(cond->
flip-x (gmt/scale (gpt/point -1 1))
flip-y (gmt/scale (gpt/point 1 -1)))
(gmt/multiply (:transform-inverse shape (gmt/matrix)))
(gmt/translate (gpt/negate center))))))
(defn transform-point-center
"Transform a point around the shape center"
[point center matrix]
(gpt/transform
point
(gmt/multiply (gmt/translate-matrix center)
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))]
(gpr/points->rect points)))
(defn normalize-scale
"We normalize the scale so it's not too close to 0"
[scale]
(cond
(and (< scale 0) (> scale -0.01)) -0.01
(and (>= scale 0) (< scale 0.01)) 0.01
:else scale))
(defn modifiers->transform
[center modifiers]
(let [ds-modifier (:displacement modifiers (gmt/matrix))
{res-x :x res-y :y} (:resize-vector modifiers (gpt/point 1 1))
;; Normalize x/y vector coordinates because scale by 0 is infinite
res-x (normalize-scale res-x)
res-y (normalize-scale res-y)
resize (gpt/point res-x res-y)
origin (:resize-origin modifiers (gpt/point 0 0))
resize-transform (:resize-transform modifiers (gmt/matrix))
resize-transform-inverse (:resize-transform-inverse modifiers (gmt/matrix))
rt-modif (or (:rotation modifiers) 0)
center (gpt/transform center ds-modifier)
transform (-> (gmt/matrix)
;; Applies the current resize transformation
(gmt/translate origin)
(gmt/multiply resize-transform)
(gmt/scale resize)
(gmt/multiply resize-transform-inverse)
(gmt/translate (gpt/negate origin))
;; Applies the stacked transformations
(gmt/translate center)
(gmt/multiply (gmt/rotate-matrix rt-modif))
(gmt/translate (gpt/negate center))
;; Displacement
(gmt/multiply ds-modifier))]
transform))
(defn- calculate-skew-angle
"Calculates the skew angle of the paralelogram given by the points"
[[p1 _ p3 p4]]
(let [v1 (gpt/to-vec p3 p4)
v2 (gpt/to-vec p4 p1)]
;; If one of the vectors is zero it's a rectangle with 0 height or width
;; We don't skew these
(if (or (gpt/almost-zero? v1)
(gpt/almost-zero? v2))
0
(- 90 (gpt/angle-with-other v1 v2)))))
(defn- calculate-height
"Calculates the height of a paralelogram given by the points"
[[p1 _ _ p4]]
(-> (gpt/to-vec p4 p1)
(gpt/length)))
(defn- calculate-width
"Calculates the width of a paralelogram given by the points"
[[p1 p2 _ _]]
(-> (gpt/to-vec p1 p2)
(gpt/length)))
(defn- calculate-rotation
"Calculates the rotation between two shapes given the resize vector direction"
[center points-shape1 points-shape2 flip-x flip-y]
(let [idx-1 0
idx-2 (cond (and flip-x (not flip-y)) 1
(and flip-x flip-y) 2
(and (not flip-x) flip-y) 3
:else 0)
p1 (nth points-shape1 idx-1)
p2 (nth points-shape2 idx-2)
v1 (gpt/to-vec center p1)
v2 (gpt/to-vec center p2)
rot-angle (gpt/angle-with-other v1 v2)
rot-sign (gpt/angle-sign v1 v2)]
(* rot-sign rot-angle)))
(defn- calculate-dimensions
[[p1 p2 p3 _]]
(let [width (gpt/distance p1 p2)
height (gpt/distance p2 p3)]
{:width width :height height}))
(defn calculate-adjust-matrix
"Calculates a matrix that is a series of transformations we have to do to the transformed rectangle so that
after applying them the end result is the `shape-pathn-temp`.
This is compose of three transformations: skew, resize and rotation"
([points-temp points-rec] (calculate-adjust-matrix points-temp points-rec false false))
([points-temp points-rec flip-x flip-y]
(let [center (gco/center-points points-temp)
stretch-matrix (gmt/matrix)
skew-angle (calculate-skew-angle points-temp)
;; When one of the axis is flipped we have to reverse the skew
;; skew-angle (if (neg? (* (:x resize-vector) (:y resize-vector))) (- skew-angle) skew-angle )
skew-angle (if (and (or flip-x flip-y)
(not (and flip-x flip-y))) (- skew-angle) skew-angle )
skew-angle (if (mth/nan? skew-angle) 0 skew-angle)
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)))
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)))
w3 (if-not (mth/almost-zero? w2) (/ w1 w2) 1)
w3 (if (mth/nan? w3) 1 w3)
stretch-matrix (gmt/multiply stretch-matrix (gmt/scale-matrix (gpt/point w3 h3)))
rotation-angle (calculate-rotation
center
(transform-points points-rec (gco/center-points points-rec) stretch-matrix)
points-temp
flip-x
flip-y)
stretch-matrix (gmt/multiply (gmt/rotate-matrix rotation-angle) stretch-matrix)
;; This is the inverse to be able to remove the transformation
stretch-matrix-inverse (-> (gmt/matrix)
(gmt/scale (gpt/point (/ 1 w3) (/ 1 h3)))
(gmt/skew (- skew-angle) 0)
(gmt/rotate (- rotation-angle)))]
[stretch-matrix stretch-matrix-inverse rotation-angle])))
(defn apply-transform
"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))
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-dim (calculate-dimensions points-temp)
;; This rectangle is the new data for the current rectangle. We want to change our rectangle
;; to have this width, height, x, y
rect-shape (-> (gco/make-centered-rect
center
(:width points-temp-dim)
(:height points-temp-dim))
(update :width max 1)
(update :height max 1))
rect-points (gpr/rect->points rect-shape)
[matrix matrix-inverse] (calculate-adjust-matrix points-temp rect-points (:flip-x shape) (:flip-y shape))
rect-shape (cond-> rect-shape
round-coords?
(-> (update :x mth/round)
(update :y mth/round)
(update :width mth/round)
(update :height mth/round)))
shape (cond
(= :path (:type shape))
(-> shape
(update :content #(gpa/transform-content % transform)))
:else
(-> shape
(merge rect-shape)))
base-rotation (or (:rotation shape) 0)
modif-rotation (or (get-in shape [:modifiers :rotation]) 0)]
(as-> shape $
(update $ :transform #(gmt/multiply (or % (gmt/matrix)) matrix))
(update $ :transform-inverse #(gmt/multiply matrix-inverse (or % (gmt/matrix))))
(assoc $ :points (into [] points))
(assoc $ :selrect (gpr/rect->selrect rect-shape))
(assoc $ :rotation (mod (+ base-rotation modif-rotation) 360)))))
(defn set-flip [shape modifiers]
(let [rx (get-in modifiers [:resize-vector :x])
ry (get-in modifiers [:resize-vector :y])]
(cond-> shape
(and rx (< rx 0)) (-> (update :flip-x not)
(update :rotation -))
(and ry (< ry 0)) (-> (update :flip-y not)
(update :rotation -)))))
(defn apply-displacement [shape]
(let [modifiers (:modifiers shape)]
(if (contains? modifiers :displacement)
(let [mov-vec (-> (gpt/point 0 0)
(gpt/transform (:displacement modifiers)))
shape (move shape mov-vec)
modifiers (dissoc modifiers :displacement)]
(-> shape
(assoc :modifiers modifiers)
(cond-> (empty? modifiers)
(dissoc :modifiers))))
shape)))
(defn apply-text-resize
[shape orig-shape modifiers]
(if (and (= (:type shape) :text)
(:resize-scale-text modifiers))
(let [merge-attrs (fn [attrs]
(let [font-size (-> (get attrs :font-size 14)
(d/parse-double)
(* (-> modifiers :resize-vector :x))
(str)
)]
(attrs/merge attrs {:font-size font-size})))]
(update shape :content #(txt/transform-nodes
txt/is-text-node?
merge-attrs
%)))
shape))
(defn transform-shape
([shape]
(transform-shape shape nil))
([shape {:keys [round-coords?]
:or {round-coords? true}}]
(let [shape (apply-displacement shape)
center (gco/center-shape shape)
modifiers (:modifiers shape)]
(if (and modifiers center)
(let [transform (modifiers->transform center modifiers)]
(-> shape
(set-flip modifiers)
(apply-transform transform round-coords?)
(apply-text-resize shape modifiers)
(dissoc :modifiers)))
shape))))
(defn update-group-viewbox
"Updates the viewbox for groups imported from SVG's"
[{:keys [selrect svg-viewbox] :as group} new-selrect]
(let [;; Gets deltas for the selrect to update the svg-viewbox (for svg-imports)
deltas {:x (- (:x new-selrect 0) (:x selrect 0))
:y (- (:y new-selrect 0) (:y selrect 0))
:width (- (:width new-selrect 1) (:width selrect 1))
:height (- (:height new-selrect 1) (:height selrect 1))}]
(cond-> group
(and (some? svg-viewbox) (some? selrect) (some? new-selrect))
(update :svg-viewbox
#(-> %
(update :x + (:x deltas))
(update :y + (:y deltas))
(update :width + (:width deltas))
(update :height + (:height deltas)))))))
(defn update-group-selrect [group children]
(let [shape-center (gco/center-shape group)
transform (:transform group (gmt/matrix))
transform-inverse (:transform-inverse group (gmt/matrix))
;; Points for every shape inside the group
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)))
;; 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))))
;; Calculte the new selrect
new-selrect (gpr/points->selrect base-points)]
;; Updates the shape and the applytransform-rect will update the other properties
(-> group
(update-group-viewbox new-selrect)
(assoc :selrect new-selrect)
(assoc :points new-points)
;; We're regenerating the selrect from its children so we
;; need to remove the flip flags
(assoc :flip-x false)
(assoc :flip-y false)
(apply-transform (gmt/matrix) true))))

72
common/deps.edn Normal file
View file

@ -0,0 +1,72 @@
{:deps
{org.clojure/clojure {:mvn/version "1.10.3"}
org.clojure/data.json {:mvn/version "2.3.1"}
org.clojure/core.async {:mvn/version "1.3.618"}
org.clojure/tools.cli {:mvn/version "1.0.206"}
metosin/jsonista {:mvn/version "0.3.3"}
org.clojure/clojurescript {:mvn/version "1.10.844"}
;; Logging
org.clojure/tools.logging {:mvn/version "1.1.0"}
org.apache.logging.log4j/log4j-api {:mvn/version "2.14.1"}
org.apache.logging.log4j/log4j-core {:mvn/version "2.14.1"}
org.apache.logging.log4j/log4j-web {:mvn/version "2.14.1"}
org.apache.logging.log4j/log4j-jul {:mvn/version "2.14.1"}
org.apache.logging.log4j/log4j-slf4j18-impl {:mvn/version "2.14.1"}
org.slf4j/slf4j-api {:mvn/version "2.0.0-alpha1"}
selmer/selmer {:mvn/version "1.12.40"}
expound/expound {:mvn/version "0.8.9"}
com.cognitect/transit-clj {:mvn/version "1.0.324"}
com.cognitect/transit-cljs {:mvn/version "0.8.269"}
java-http-clj/java-http-clj {:mvn/version "0.4.2"}
funcool/promesa {:mvn/version "6.0.1"}
funcool/cuerdas {:mvn/version "2021.05.29-0"}
lambdaisland/uri {:mvn/version "1.4.70"
:exclusions [org.clojure/data.json]}
frankiesardo/linked {:mvn/version "1.3.0"}
danlentz/clj-uuid {:mvn/version "0.1.9"}
commons-io/commons-io {:mvn/version "2.8.0"}
com.sun.mail/jakarta.mail {:mvn/version "2.0.1"}
;; exception printing
io.aviso/pretty {:mvn/version "0.1.37"}
environ/environ {:mvn/version "1.2.0"}}
:paths ["src"]
:aliases
{:dev
{:extra-deps
{org.clojure/tools.namespace {:mvn/version "RELEASE"}
org.clojure/test.check {:mvn/version "RELEASE"}
org.clojure/tools.deps.alpha {:mvn/version "RELEASE"}
thheller/shadow-cljs {:mvn/version "2.12.6"}
criterium/criterium {:mvn/version "RELEASE"}
mockery/mockery {:mvn/version "RELEASE"}}
:extra-paths ["test" "dev"]}
:repl
{:extra-deps
{com.bhauman/rebel-readline {:mvn/version "RELEASE"}}
:main-opts ["-m" "rebel-readline.main"]}
:kaocha
{:extra-deps {lambdaisland/kaocha {:mvn/version "RELEASE"}}
:main-opts ["-m" "kaocha.runner"]}
:test
{:extra-paths ["test"]
:extra-deps {io.github.cognitect-labs/test-runner
{:git/url "https://github.com/cognitect-labs/test-runner.git"
:sha "705ad25bbf0228b1c38d0244a36001c2987d7337"}}
:exec-fn cognitect.test-runner.api/test}
:shadow-cljs
{:main-opts ["-m" "shadow.cljs.devtools.cli"]}
:outdated
{:extra-deps {com.github.liquidz/antq {:mvn/version "RELEASE"}}
:main-opts ["-m" "antq.core"]}}}

51
common/dev/user.clj Normal file
View file

@ -0,0 +1,51 @@
;; 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 user
(:require
[clojure.java.io :as io]
[clojure.pprint :refer [pprint print-table]]
[clojure.repl :refer :all]
[clojure.spec.alpha :as s]
[clojure.spec.gen.alpha :as sgen]
[clojure.test :as test]
[clojure.tools.namespace.repl :as repl]
[clojure.walk :refer [macroexpand-all]]
[criterium.core :refer [quick-bench bench with-progress-reporting]]))
;; --- Benchmarking Tools
(defmacro run-quick-bench
[& exprs]
`(with-progress-reporting (quick-bench (do ~@exprs) :verbose)))
(defmacro run-quick-bench'
[& exprs]
`(quick-bench (do ~@exprs)))
(defmacro run-bench
[& exprs]
`(with-progress-reporting (bench (do ~@exprs) :verbose)))
(defmacro run-bench'
[& exprs]
`(bench (do ~@exprs)))
;; --- Development Stuff
(defn- run-tests
([] (run-tests #"^app.common.tests.*"))
([o]
(repl/refresh)
(cond
(instance? java.util.regex.Pattern o)
(test/run-all-tests o)
(symbol? o)
(if-let [sns (namespace o)]
(do (require (symbol sns))
(test/test-vars [(resolve o)]))
(test/test-ns o)))))

13
common/package.json Normal file
View file

@ -0,0 +1,13 @@
{
"name": "penpot-common",
"version": "1.0.0",
"main": "index.js",
"license": "MPL-2.0",
"dependencies": {
"luxon": "^1.27.0"
},
"devDependencies": {
"source-map-support": "^0.5.19",
"ws": "^7.4.6"
}
}

17
common/shadow-cljs.edn Normal file
View file

@ -0,0 +1,17 @@
{:deps {:aliases [:dev]}
;; :http {:port 3448}
;; :nrepl {:port 3447}
:jvm-opts ["-Xmx700m" "-Xms100m" "-XX:+UseSerialGC" "-XX:-OmitStackTraceInFastThrow"]
:builds
{:test
{:target :node-test
:output-to "target/tests.js"
:ns-regexp "^app.common.*-test$"
;; :autorun true
:compiler-options
{:output-feature-set :es-next
:output-wrapper false
:warnings {:fn-deprecated false}}}}}

0
common/app/common/attrs.cljc → common/src/app/common/attrs.cljc
View file

86
common/app/common/data.cljc → common/src/app/common/data.cljc
View file

@ -10,14 +10,16 @@
#?(:cljs
(:require-macros [app.common.data]))
(:require
[linked.set :as lks]
[app.common.math :as mth]
[cljs.analyzer.api :as aapi]
[clojure.set :as set]
#?(:clj [cljs.analyzer.api :as aapi])
[cuerdas.core :as str]
#?(:cljs [cljs.reader :as r]
:clj [clojure.edn :as r])
#?(:cljs [cljs.core :as core]
:clj [clojure.core :as core]))
:clj [clojure.core :as core])
[linked.set :as lks])
#?(:clj
(:import linked.set.LinkedSet)))
@ -274,7 +276,7 @@
;; Data Parsing / Conversion
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- nan?
(defn nan?
[v]
(not= v v))
@ -456,13 +458,18 @@
kw (if (keyword? kw) (name kw) kw)]
(keyword (str prefix kw))))
(defn tap
"Simpilar to the tap in rxjs but for plain collections"
[f coll]
(f coll)
coll)
(defn tap-r
"Same but with args reversed, for -> threads"
[coll f]
(f coll)
coll)
(defn map-diff
"Given two maps returns the diff of its attributes in a map where
the keys will be the attributes that change and the values the previous
@ -478,12 +485,11 @@
:var [2 nil]}
:d [nil 10] }
If both maps are identical the result will be an empty map
"
If both maps are identical the result will be an empty map."
[m1 m2]
(let [m1ks (keys m1)
m2ks (keys m2)
(let [m1ks (set (keys m1))
m2ks (set (keys m2))
keys (set/union m1ks m2ks)
diff-attr
@ -503,3 +509,65 @@
(->> keys
(reduce diff-attr {}))))
(defn- extract-numeric-suffix
[basename]
(if-let [[_ p1 p2] (re-find #"(.*)-([0-9]+)$" basename)]
[p1 (+ 1 (parse-integer p2))]
[basename 1]))
(defn unique-name
"A unique name generator"
([basename used]
(unique-name basename used false))
([basename used prefix-first?]
(assert (string? basename))
(assert (set? used))
(let [[prefix initial] (extract-numeric-suffix basename)]
(if (and (not prefix-first?)
(not (contains? used basename)))
basename
(loop [counter initial]
(let [candidate (if (and (= 1 counter) prefix-first?)
(str prefix)
(str prefix "-" counter))]
(if (contains? used candidate)
(recur (inc counter))
candidate)))))))
(defn deep-mapm
"Applies a map function to an associative map and recurses over its children
when it's a vector or a map"
[mfn m]
(let [do-map
(fn [entry]
(let [[k v] (mfn entry)]
(cond
(or (vector? v) (map? v))
[k (deep-mapm mfn v)]
:else
(mfn [k v]))))]
(cond
(map? m)
(into {} (map do-map) m)
(vector? m)
(into [] (map (partial deep-mapm mfn)) m)
:else
m)))
(defn not-empty?
[coll]
(boolean (seq coll)))
(defn kebab-keys [m]
(->> m
(deep-mapm
(fn [[k v]]
(if (or (keyword? k) (string? k))
[(keyword (str/kebab (name k))) v]
[k v])))))

4
common/app/common/data/undo_stack.cljc → common/src/app/common/data/undo_stack.cljc
View file

@ -46,7 +46,7 @@
(assoc-in stack [:items index] value))
(defn undo
[{index :index items :items :as stack}]
[stack]
(update stack :index dec))
(defn redo
@ -56,5 +56,5 @@
(update :index inc)))
(defn size
[{index :index items :items :as stack}]
[{index :index :as stack}]
(inc index))

0
common/app/common/exceptions.cljc → common/src/app/common/exceptions.cljc
View file

467
common/src/app/common/file_builder.cljc Normal file
View file

@ -0,0 +1,467 @@
;; 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.file-builder
"A version parsing helper."
(:require
[app.common.data :as d]
[app.common.geom.matrix :as gmt]
[app.common.geom.shapes :as gsh]
[app.common.pages.changes :as ch]
[app.common.pages.init :as init]
[app.common.pages.spec :as spec]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[cuerdas.core :as str]))
(def root-frame uuid/zero)
(def conjv (fnil conj []))
(def conjs (fnil conj #{}))
;; This flag controls if we should execute spec validation after every commit
(def verify-on-commit? true)
(defn- commit-change
([file change]
(commit-change file change nil))
([file change {:keys [add-container?]
:or {add-container? false}}]
(let [component-id (:current-component-id file)
change (cond-> change
(and add-container? (some? component-id))
(assoc :component-id component-id)
(and add-container? (nil? component-id))
(assoc :page-id (:current-page-id file)
:frame-id (:current-frame-id file)))]
(when verify-on-commit?
(us/assert ::spec/change change))
(-> file
(update :changes conjv change)
(update :data ch/process-changes [change] verify-on-commit?)))))
(defn- lookup-objects
([file]
(if (some? (:current-component-id file))
(get-in file [:data :components (:current-component-id file) :objects])
(get-in file [:data :pages-index (:current-page-id file) :objects]))))
(defn- lookup-shape [file shape-id]
(-> (lookup-objects file)
(get shape-id)))
(defn- commit-shape [file obj]
(let [parent-id (-> file :parent-stack peek)]
(-> file
(commit-change
{:type :add-obj
:id (:id obj)
:obj obj
:parent-id parent-id}
{:add-container? true}))))
(defn setup-rect-selrect [obj]
(let [rect (select-keys obj [:x :y :width :height])
center (gsh/center-rect rect)
transform (:transform obj (gmt/matrix))
selrect (gsh/rect->selrect rect)
points (-> (gsh/rect->points rect)
(gsh/transform-points center transform))]
(-> obj
(assoc :selrect selrect)
(assoc :points points))))
(defn- setup-path-selrect
[obj]
(let [content (:content obj)
center (:center obj)
transform-inverse
(->> (:transform-inverse obj (gmt/matrix))
(gmt/transform-in center))
transform
(->> (:transform obj (gmt/matrix))
(gmt/transform-in center))
content' (gsh/transform-content content transform-inverse)
selrect (gsh/content->selrect content')
points (-> (gsh/rect->points selrect)
(gsh/transform-points transform))]
(-> obj
(dissoc :center)
(assoc :selrect selrect)
(assoc :points points))))
(defn- setup-selrect
[obj]
(if (= (:type obj) :path)
(setup-path-selrect obj)
(setup-rect-selrect obj)))
(defn- generate-name
[type data]
(if (= type :svg-raw)
(let [tag (get-in data [:content :tag])]
(str "svg-" (cond (string? tag) tag
(keyword? tag) (d/name tag)
(nil? tag) "node"
:else (str tag))))
(str/capital (d/name type))))
(defn- add-name
[file name]
(let [container-id (or (:current-component-id file)
(:current-page-id file))]
(-> file
(update-in [:unames container-id] conjs name))))
(defn- unique-name
[name file]
(let [container-id (or (:current-component-id file)
(:current-page-id file))
unames (get-in file [:unames container-id])]
(d/unique-name name (or unames #{}))))
(defn clear-names [file]
(dissoc file :unames))
(defn- check-name
"Given a tag returns its layer name"
[data file type]
(cond-> data
(nil? (:name data))
(assoc :name (generate-name type data))
:always
(update :name unique-name file)))
;; PUBLIC API
(defn create-file
([name]
(create-file (uuid/next) name))
([id name]
{:id id
:name name
:data (-> init/empty-file-data
(assoc :id id))
;; We keep the changes so we can send them to the backend
:changes []}))
(defn add-page
[file data]
(assert (nil? (:current-component-id file)))
(let [page-id (or (:id data) (uuid/next))
page (-> init/empty-page-data
(assoc :id page-id)
(d/deep-merge data))]
(-> file
(commit-change
{:type :add-page
:page page})
;; Current page being edited
(assoc :current-page-id page-id)
;; Current frame-id
(assoc :current-frame-id root-frame)
;; Current parent stack we'll be nesting
(assoc :parent-stack [root-frame])
;; Last object id added
(assoc :last-id nil))))
(defn close-page [file]
(assert (nil? (:current-component-id file)))
(-> file
(dissoc :current-page-id)
(dissoc :parent-stack)
(dissoc :last-id)
(clear-names)))
(defn add-artboard [file data]
(assert (nil? (:current-component-id file)))
(let [obj (-> (init/make-minimal-shape :frame)
(merge data)
(check-name file :frame)
(setup-selrect)
(d/without-nils))]
(-> file
(commit-shape obj)
(assoc :current-frame-id (:id obj))
(assoc :last-id (:id obj))
(add-name (:name obj))
(update :parent-stack conjv (:id obj)))))
(defn close-artboard [file]
(assert (nil? (:current-component-id file)))
(-> file
(assoc :current-frame-id root-frame)
(update :parent-stack pop)))
(defn add-group [file data]
(let [frame-id (:current-frame-id file)
selrect init/empty-selrect
name (:name data)
obj (-> (init/make-minimal-group frame-id selrect name)
(merge data)
(check-name file :group)
(d/without-nils))]
(-> file
(commit-shape obj)
(assoc :last-id (:id obj))
(add-name (:name obj))
(update :parent-stack conjv (:id obj)))))
(defn close-group [file]
(let [group-id (-> file :parent-stack peek)
group (lookup-shape file group-id)
children (->> group :shapes (mapv #(lookup-shape file %)))
file
(cond
(empty? children)
(commit-change
file
{:type :del-obj
:id group-id}
{:add-container? true})
(:masked-group? group)
(let [mask (first children)]
(commit-change
file
{:type :mod-obj
:id group-id
:operations
[{:type :set :attr :x :val (-> mask :selrect :x)}
{:type :set :attr :y :val (-> mask :selrect :y)}
{:type :set :attr :width :val (-> mask :selrect :width)}
{:type :set :attr :height :val (-> mask :selrect :height)}
{:type :set :attr :flip-x :val (-> mask :flip-x)}
{:type :set :attr :flip-y :val (-> mask :flip-y)}
{:type :set :attr :selrect :val (-> mask :selrect)}
{:type :set :attr :points :val (-> mask :points)}]}
{:add-container? true}))
:else
(let [group' (gsh/update-group-selrect group children)]
(commit-change
file
{:type :mod-obj
:id group-id
:operations
[{:type :set :attr :selrect :val (:selrect group')}
{:type :set :attr :points :val (:points group')}
{:type :set :attr :x :val (-> group' :selrect :x)}
{:type :set :attr :y :val (-> group' :selrect :y)}
{:type :set :attr :width :val (-> group' :selrect :width)}
{:type :set :attr :height :val (-> group' :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)
(lookup-shape file frame-id))
obj (-> (init/make-minimal-shape type)
(merge data)
(check-name file :type)
(setup-selrect)
(d/without-nils))
obj (cond-> obj
frame (gsh/translate-from-frame frame))]
(-> file
(commit-shape obj)
(assoc :last-id (:id obj))
(add-name (:name obj)))))
(defn create-rect [file data]
(create-shape file :rect data))
(defn create-circle [file data]
(create-shape file :circle data))
(defn create-path [file data]
(create-shape file :path data))
(defn create-text [file data]
(create-shape file :text data))
(defn create-image [file data]
(create-shape file :image data))
(declare close-svg-raw)
(defn create-svg-raw [file data]
(let [file (as-> file $
(create-shape $ :svg-raw data)
(update $ :parent-stack conjv (:last-id $)))
create-child
(fn [file child]
(-> file
(create-svg-raw (assoc data
:id (uuid/next)
:content child))
(close-svg-raw)))]
;; First :content is the the shape attribute, the other content is the
;; XML children
(reduce create-child file (get-in data [:content :content]))))
(defn close-svg-raw [file]
(-> file
(update :parent-stack pop)))
(defn add-interaction
[file from-id {:keys [action-type event-type destination]}]
(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
(conjv
{:action-type action-type
:event-type event-type
:destination destination}))]
(commit-change
file
{:type :mod-obj
:page-id (:current-page-id file)
:id from-id
:operations
[{:type :set :attr :interactions :val interactions}]})))
(defn generate-changes
[file]
(:changes file))
(defn add-library-color
[file color]
(let [id (or (:id color) (uuid/next))]
(-> file
(commit-change
{:type :add-color
:id id
:color (assoc color :id id)})
(assoc :last-id id))))
(defn add-library-typography
[file typography]
(let [id (or (:id typography) (uuid/next))]
(-> file
(commit-change
{:type :add-typography
:id id
:typography (assoc typography :id id)})
(assoc :last-id id))))
(defn add-library-media
[file media]
(let [id (or (:id media) (uuid/next))]
(-> file
(commit-change
{:type :add-media
:object (assoc media :id id)})
(assoc :last-id id))))
(defn start-component
[file data]
(let [selrect init/empty-selrect
name (:name data)
path (:path data)
obj (-> (init/make-minimal-group nil selrect name)
(merge data)
(check-name file :group)
(d/without-nils))]
(-> file
(commit-change
{:type :add-component
:id (:id obj)
:name name
:path path
:shapes [obj]})
(assoc :last-id (:id obj))
(update :parent-stack conjv (:id obj))
(assoc :current-component-id (:id obj)))))
(defn finish-component
[file]
(let [component-id (:current-component-id file)
component (lookup-shape file component-id)
children (->> component :shapes (mapv #(lookup-shape file %)))
file
(cond
(empty? children)
(commit-change
file
{:type :del-component
:id component-id})
(:masked-group? component)
(let [mask (first children)]
(commit-change
file
{:type :mod-obj
:id component-id
:operations
[{:type :set :attr :x :val (-> mask :selrect :x)}
{:type :set :attr :y :val (-> mask :selrect :y)}
{:type :set :attr :width :val (-> mask :selrect :width)}
{:type :set :attr :height :val (-> mask :selrect :height)}
{:type :set :attr :flip-x :val (-> mask :flip-x)}
{:type :set :attr :flip-y :val (-> mask :flip-y)}
{:type :set :attr :selrect :val (-> mask :selrect)}
{:type :set :attr :points :val (-> mask :points)}]}
{:add-container? true}))
:else
(let [component' (gsh/update-group-selrect component children)]
(commit-change
file
{:type :mod-obj
:id component-id
:operations
[{:type :set :attr :selrect :val (:selrect component')}
{:type :set :attr :points :val (:points component')}
{:type :set :attr :x :val (-> component' :selrect :x)}
{:type :set :attr :y :val (-> component' :selrect :y)}
{:type :set :attr :width :val (-> component' :selrect :width)}
{:type :set :attr :height :val (-> component' :selrect :height)}]}
{:add-container? true})))]
(-> file
(dissoc :current-component-id)
(update :parent-stack pop))))

4
common/app/common/geom/align.cljc → common/src/app/common/geom/align.cljc
View file

@ -6,9 +6,9 @@
(ns app.common.geom.align
(:require
[clojure.spec.alpha :as s]
[app.common.data :as d]
[app.common.geom.shapes :as gsh]
[app.common.data :as d]))
[clojure.spec.alpha :as s]))
;; --- Alignment

29
common/app/common/geom/matrix.cljc → common/src/app/common/geom/matrix.cljc
View file

@ -8,10 +8,9 @@
(:require
#?(:cljs [cljs.pprint :as pp]
:clj [clojure.pprint :as pp])
[cuerdas.core :as str]
[app.common.data :as d]
[app.common.math :as mth]
[app.common.geom.point :as gpt]))
[app.common.geom.point :as gpt]
[app.common.math :as mth]))
;; --- Matrix Impl
@ -27,6 +26,15 @@
([a b c d e f]
(Matrix. a b c d e f)))
(def number-regex #"[+-]?\d*(\.\d+)?(e[+-]?\d+)?")
(defn str->matrix
[matrix-str]
(let [params (->> (re-seq number-regex matrix-str)
(filter #(-> % first seq))
(map (comp d/parse-double first)))]
(apply matrix params)))
(defn multiply
([{m1a :a m1b :b m1c :c m1d :d m1e :e m1f :f}
{m2a :a m2b :b m2c :c m2d :d m2e :e m2f :f}]
@ -40,6 +48,21 @@
([m1 m2 & others]
(reduce multiply (multiply m1 m2) others)))
(defn add-translate
"Given two TRANSLATE matrixes (only e and f have significative
values), combine them. Quicker than multiplying them, for this
precise case."
([{m1e :e m1f :f} {m2e :e m2f :f}]
(Matrix.
1
0
0
1
(+ m1e m2e)
(+ m1f m2f)))
([m1 m2 & others]
(reduce add-translate (add-translate m1 m2) others)))
(defn substract
[{m1a :a m1b :b m1c :c m1d :d m1e :e m1f :f}
{m2a :a m2b :b m2c :c m2d :d m2e :e m2f :f}]

0
common/app/common/geom/point.cljc → common/src/app/common/geom/point.cljc
View file

0
common/app/common/geom/proportions.cljc → common/src/app/common/geom/proportions.cljc
View file

71
common/app/common/geom/shapes.cljc → common/src/app/common/geom/shapes.cljc
View file

@ -7,51 +7,12 @@
(ns app.common.geom.shapes
(:require
[app.common.data :as d]
[app.common.math :as mth]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[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.intersect :as gin]
[app.common.spec :as us]))
;; --- Resize (Dimensions)
(defn resize-modifiers
[shape attr value]
(us/assert map? shape)
(us/assert #{:width :height} attr)
(us/assert number? value)
(let [{:keys [proportion proportion-lock]} shape
size (select-keys (:selrect shape) [:width :height])
new-size (if-not proportion-lock
(assoc size attr value)
(if (= attr :width)
(-> size
(assoc :width value)
(assoc :height (/ value proportion)))
(-> size
(assoc :height value)
(assoc :width (* value proportion)))))
width (:width new-size)
height (:height new-size)
shape-transform (:transform shape (gmt/matrix))
shape-transform-inv (:transform-inverse shape (gmt/matrix))
shape-center (gco/center-shape shape)
{sr-width :width sr-height :height} (:selrect shape)
origin (-> (gpt/point (:selrect shape))
(gtr/transform-point-center shape-center shape-transform))
scalev (gpt/divide (gpt/point width height)
(gpt/point sr-width sr-height))]
{:resize-vector scalev
:resize-origin origin
:resize-transform shape-transform
:resize-transform-inverse shape-transform-inv}))
[app.common.geom.shapes.transforms :as gtr]))
;; --- Setup (Initialize)
;; FIXME: Is this the correct place for these functions?
@ -101,6 +62,10 @@
[shape {:keys [x y]}]
(gtr/move shape (gpt/negate (gpt/point x y))) )
(defn translate-from-frame
[shape {:keys [x y]}]
(gtr/move shape (gpt/point x y)) )
;; --- Helpers
(defn fully-contained?
@ -161,15 +126,6 @@
(assoc :selrect selrect
:points points))))
(defn rotation-modifiers
[shape center angle]
(let [displacement (let [shape-center (gco/center-shape shape)]
(-> (gmt/matrix)
(gmt/rotate angle center)
(gmt/rotate (- angle) shape-center)))]
{:rotation angle
:displacement displacement}))
;; EXPORTS
(d/export gco/center-shape)
@ -184,16 +140,20 @@
(d/export gpr/points->rect)
(d/export gpr/center->rect)
(d/export gtr/transform-shape)
(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-rect)
(d/export gtr/update-group-selrect)
(d/export gtr/transform-points)
(d/export gtr/transform-rect)
(d/export gtr/calculate-adjust-matrix)
(d/export gtr/move)
(d/export gtr/absolute-move)
(d/export gtr/update-group-selrect)
(d/export gtr/resize-modifiers)
(d/export gtr/rotation-modifiers)
(d/export gtr/merge-modifiers)
(d/export gtr/transform-shape)
(d/export gtr/calc-child-modifiers)
;; PATHS
(d/export gsp/content->points)
@ -204,3 +164,4 @@
(d/export gin/overlaps?)
(d/export gin/has-point?)
(d/export gin/has-point-rect?)
(d/export gin/rect-contains-shape?)

0
common/app/common/geom/shapes/common.cljc → common/src/app/common/geom/shapes/common.cljc
View file

18
common/app/common/geom/shapes/intersect.cljc → common/src/app/common/geom/shapes/intersect.cljc
View file

@ -6,9 +6,8 @@
(ns app.common.geom.shapes.intersect
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.path :as gpp]
[app.common.geom.shapes.rect :as gpr]
[app.common.math :as mth]))
@ -113,11 +112,10 @@
;; Even-odd algorithm
;; Cast a ray from the point in any direction and count the intersections
;; if it's odd the point is inside the polygon
(let []
(->> lines
(filter #(intersect-ray? p %))
(count)
(odd?))))
(odd?)))
(defn- next-windup
"Calculates the next windup number for the nonzero algorithm"
@ -197,14 +195,14 @@
(let [center (gpt/point cx cy)
transform (gmt/transform-in center transform)
{px :x py :y} (gpt/transform point transform)]
{px :x py :y} (gpt/transform point transform)
;; Ellipse inequality formula
;; https://en.wikipedia.org/wiki/Ellipse#Shifted_ellipse
(let [v (+ (/ (mth/sq (- px cx))
v (+ (/ (mth/sq (- px cx))
(mth/sq rx))
(/ (mth/sq (- py cy))
(mth/sq ry)))]
(<= v 1))))
(<= v 1)))
(defn intersects-line-ellipse?
"Checks wether a single line intersects with the given ellipse"
@ -304,3 +302,9 @@
(let [lines (points->lines (:points shape))]
;; TODO: Will only work for simple shapes
(is-point-inside-evenodd? point lines)))
(defn rect-contains-shape?
[rect shape]
(->> shape
:points
(every? (partial has-point-rect? rect))))

7
common/app/common/geom/shapes/path.cljc → common/src/app/common/geom/shapes/path.cljc
View file

@ -6,10 +6,10 @@
(ns app.common.geom.shapes.path
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.rect :as gpr]
[app.common.math :as mth]
[app.common.data :as d]))
[app.common.math :as mth]))
(defn content->points [content]
(->> content
@ -156,7 +156,8 @@
(mapv #(update % :params transform-params) content)))
(defn transform-content [content transform]
(defn transform-content
[content transform]
(let [set-tr (fn [params px py]
(let [tr-point (-> (gpt/point (get params px) (get params py))
(gpt/transform transform))]

0
common/app/common/geom/shapes/rect.cljc → common/src/app/common/geom/shapes/rect.cljc
View file

693
common/src/app/common/geom/shapes/transforms.cljc Normal file
View file

@ -0,0 +1,693 @@
;; 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.transforms
(:require
[app.common.attrs :as attrs]
[app.common.data :as d]
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.common :as gco]
[app.common.geom.shapes.path :as gpa]
[app.common.geom.shapes.rect :as gpr]
[app.common.math :as mth]
[app.common.pages.spec :as spec]
[app.common.spec :as us]
[app.common.text :as txt]))
;; --- Relative Movement
(defn- move-selrect [selrect {dx :x dy :y}]
(-> selrect
(d/update-when :x + dx)
(d/update-when :y + dy)
(d/update-when :x1 + dx)
(d/update-when :y1 + dy)
(d/update-when :x2 + dx)
(d/update-when :y2 + dy)))
(defn- move-points [points move-vec]
(->> points
(mapv #(gpt/add % move-vec))))
(defn move
"Move the shape relativelly to its current
position applying the provided delta."
[shape {dx :x dy :y}]
(let [dx (d/check-num dx)
dy (d/check-num dy)
move-vec (gpt/point dx dy)]
(-> shape
(update :selrect move-selrect move-vec)
(update :points move-points move-vec)
(d/update-when :x + dx)
(d/update-when :y + dy)
(cond-> (= :path (:type shape))
(update :content gpa/move-content move-vec)))))
;; --- Absolute Movement
(defn absolute-move
"Move the shape to the exactly specified position."
[shape {:keys [x y]}]
(let [dx (- (d/check-num x) (-> shape :selrect :x))
dy (- (d/check-num y) (-> shape :selrect :y))]
(move shape (gpt/point dx dy))))
; ---- Geometric operations
(defn- normalize-scale
"We normalize the scale so it's not too close to 0"
[scale]
(cond
(and (< scale 0) (> scale -0.01)) -0.01
(and (>= scale 0) (< scale 0.01)) 0.01
:else scale))
(defn- calculate-skew-angle
"Calculates the skew angle of the paralelogram given by the points"
[[p1 _ p3 p4]]
(let [v1 (gpt/to-vec p3 p4)
v2 (gpt/to-vec p4 p1)]
;; If one of the vectors is zero it's a rectangle with 0 height or width
;; We don't skew these
(if (or (gpt/almost-zero? v1)
(gpt/almost-zero? v2))
0
(- 90 (gpt/angle-with-other v1 v2)))))
(defn- calculate-height
"Calculates the height of a paralelogram given by the points"
[[p1 _ _ p4]]
(-> (gpt/to-vec p4 p1)
(gpt/length)))
(defn- calculate-width
"Calculates the width of a paralelogram given by the points"
[[p1 p2 _ _]]
(-> (gpt/to-vec p1 p2)
(gpt/length)))
(defn- calculate-rotation
"Calculates the rotation between two shapes given the resize vector direction"
[center points-shape1 points-shape2 flip-x flip-y]
(let [idx-1 0
idx-2 (cond (and flip-x (not flip-y)) 1
(and flip-x flip-y) 2
(and (not flip-x) flip-y) 3
:else 0)
p1 (nth points-shape1 idx-1)
p2 (nth points-shape2 idx-2)
v1 (gpt/to-vec center p1)
v2 (gpt/to-vec center p2)
rot-angle (gpt/angle-with-other v1 v2)
rot-sign (gpt/angle-sign v1 v2)]
(* rot-sign rot-angle)))
(defn- calculate-dimensions
[[p1 p2 p3 _]]
(let [width (gpt/distance p1 p2)
height (gpt/distance p2 p3)]
{:width width :height height}))
;; --- Transformation matrix operations
(defn transform-matrix
"Returns a transformation matrix without changing the shape properties.
The result should be used in a `transform` attribute in svg"
([shape] (transform-matrix shape nil))
([shape params] (transform-matrix shape params (or (gco/center-shape shape)
(gpt/point 0 0))))
([{:keys [flip-x flip-y] :as shape} {:keys [no-flip]} shape-center]
(-> (gmt/matrix)
(gmt/translate shape-center)
(gmt/multiply (:transform shape (gmt/matrix)))
(cond->
(and (not no-flip) flip-x) (gmt/scale (gpt/point -1 1))
(and (not no-flip) flip-y) (gmt/scale (gpt/point 1 -1)))
(gmt/translate (gpt/negate shape-center)))))
(defn inverse-transform-matrix
([shape]
(let [shape-center (or (gco/center-shape shape)
(gpt/point 0 0))]
(inverse-transform-matrix shape shape-center)))
([{:keys [flip-x flip-y] :as shape} center]
(-> (gmt/matrix)
(gmt/translate center)
(cond->
flip-x (gmt/scale (gpt/point -1 1))
flip-y (gmt/scale (gpt/point 1 -1)))
(gmt/multiply (:transform-inverse shape (gmt/matrix)))
(gmt/translate (gpt/negate center)))))
(defn transform-point-center
"Transform a point around the shape center"
[point center matrix]
(gpt/transform
point
(gmt/multiply (gmt/translate-matrix center)
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))]
(gpr/points->rect points)))
(defn calculate-adjust-matrix
"Calculates a matrix that is a series of transformations we have to do to the transformed rectangle so that
after applying them the end result is the `shape-pathn-temp`.
This is compose of three transformations: skew, resize and rotation"
([points-temp points-rec] (calculate-adjust-matrix points-temp points-rec false false))
([points-temp points-rec flip-x flip-y]
(let [center (gco/center-points points-temp)
stretch-matrix (gmt/matrix)
skew-angle (calculate-skew-angle points-temp)
;; When one of the axis is flipped we have to reverse the skew
;; skew-angle (if (neg? (* (:x resize-vector) (:y resize-vector))) (- skew-angle) skew-angle )
skew-angle (if (and (or flip-x flip-y)
(not (and flip-x flip-y))) (- skew-angle) skew-angle )
skew-angle (if (mth/nan? skew-angle) 0 skew-angle)
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)))
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)))
w3 (if-not (mth/almost-zero? w2) (/ w1 w2) 1)
w3 (if (mth/nan? w3) 1 w3)
stretch-matrix (gmt/multiply stretch-matrix (gmt/scale-matrix (gpt/point w3 h3)))
rotation-angle (calculate-rotation
center
(transform-points points-rec (gco/center-points points-rec) stretch-matrix)
points-temp
flip-x
flip-y)
stretch-matrix (gmt/multiply (gmt/rotate-matrix rotation-angle) stretch-matrix)
;; This is the inverse to be able to remove the transformation
stretch-matrix-inverse (-> (gmt/matrix)
(gmt/scale (gpt/point (/ 1 w3) (/ 1 h3)))
(gmt/skew (- skew-angle) 0)
(gmt/rotate (- rotation-angle)))]
[stretch-matrix stretch-matrix-inverse rotation-angle])))
(defn- apply-transform
"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))
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-dim (calculate-dimensions points-temp)
;; This rectangle is the new data for the current rectangle. We want to change our rectangle
;; to have this width, height, x, y
rect-shape (-> (gco/make-centered-rect
center
(:width points-temp-dim)
(:height points-temp-dim))
(update :width max 1)
(update :height max 1))
rect-points (gpr/rect->points rect-shape)
[matrix matrix-inverse] (calculate-adjust-matrix points-temp rect-points (:flip-x shape) (:flip-y shape))
rect-shape (cond-> rect-shape
round-coords?
(-> (update :x mth/round)
(update :y mth/round)
(update :width mth/round)
(update :height mth/round)))
shape (cond
(= :path (:type shape))
(-> shape
(update :content #(gpa/transform-content % transform)))
:else
(-> shape
(merge rect-shape)))
base-rotation (or (:rotation shape) 0)
modif-rotation (or (get-in shape [:modifiers :rotation]) 0)]
(as-> shape $
(update $ :transform #(gmt/multiply (or % (gmt/matrix)) matrix))
(update $ :transform-inverse #(gmt/multiply matrix-inverse (or % (gmt/matrix))))
(assoc $ :points (into [] points))
(assoc $ :selrect (gpr/rect->selrect rect-shape))
(assoc $ :rotation (mod (+ base-rotation modif-rotation) 360)))))
(defn- update-group-viewbox
"Updates the viewbox for groups imported from SVG's"
[{:keys [selrect svg-viewbox] :as group} new-selrect]
(let [;; Gets deltas for the selrect to update the svg-viewbox (for svg-imports)
deltas {:x (- (:x new-selrect 0) (:x selrect 0))
:y (- (:y new-selrect 0) (:y selrect 0))
:width (- (:width new-selrect 1) (:width selrect 1))
:height (- (:height new-selrect 1) (:height selrect 1))}]
(cond-> group
(and (some? svg-viewbox) (some? selrect) (some? new-selrect))
(update :svg-viewbox
#(-> %
(update :x + (:x deltas))
(update :y + (:y deltas))
(update :width + (:width deltas))
(update :height + (:height deltas)))))))
(defn update-group-selrect [group children]
(let [shape-center (gco/center-shape group)
;; Points for every shape inside the group
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)))
;; 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))))
;; Calculte the new selrect
new-selrect (gpr/points->selrect base-points)]
;; Updates the shape and the applytransform-rect will update the other properties
(-> group
(update-group-viewbox new-selrect)
(assoc :selrect new-selrect)
(assoc :points new-points)
;; We're regenerating the selrect from its children so we
;; need to remove the flip flags
(assoc :flip-x false)
(assoc :flip-y false)
(apply-transform (gmt/matrix) true))))
;; --- Modifiers
;; The `modifiers` structure contains a list of transformations to
;; do make to a shape, in this order:
;;
;; - resize-origin (gpt/point) + resize-vector (gpt/point)
;; apply a scale vector to all points of the shapes, starting
;; from the origin point.
;;
;; - resize-origin-2 + resize-vector-2
;; same as the previous one, for cases in that we need to make
;; two vectors from different origin points.
;;
;; - displacement (gmt/matrix)
;; apply a translation matrix to the shape
;;
;; - rotation (gmt/matrix)
;; apply a rotation matrix to the shape
;;
;; - resize-transform (gmt/matrix) + resize-transform-inverse (gmt/matrix)
;; a copy of the rotation matrix currently applied to the shape;
;; this is needed temporarily to apply the resize vectors.
;;
;; - resize-scale-text (bool)
;; tells if the resize vectors must be applied to text shapes
;; or not.
(defn resize-modifiers
[shape attr value]
(us/assert map? shape)
(us/assert #{:width :height} attr)
(us/assert number? value)
(let [{:keys [proportion proportion-lock]} shape
size (select-keys (:selrect shape) [:width :height])
new-size (if-not proportion-lock
(assoc size attr value)
(if (= attr :width)
(-> size
(assoc :width value)
(assoc :height (/ value proportion)))
(-> size
(assoc :height value)
(assoc :width (* value proportion)))))
width (:width new-size)
height (:height new-size)
shape-transform (:transform shape (gmt/matrix))
shape-transform-inv (:transform-inverse shape (gmt/matrix))
shape-center (gco/center-shape shape)
{sr-width :width sr-height :height} (:selrect shape)
origin (-> (gpt/point (:selrect shape))
(transform-point-center shape-center shape-transform))
scalev (gpt/divide (gpt/point width height)
(gpt/point sr-width sr-height))]
{:resize-vector scalev
:resize-origin origin
:resize-transform shape-transform
:resize-transform-inverse shape-transform-inv}))
(defn rotation-modifiers
[shape center angle]
(let [displacement (let [shape-center (gco/center-shape shape)]
(-> (gmt/matrix)
(gmt/rotate angle center)
(gmt/rotate (- angle) shape-center)))]
{:rotation angle
:displacement displacement}))
(defn merge-modifiers
[objects modifiers]
(let [set-modifier
(fn [objects [id modifiers]]
(-> objects
(d/update-when id merge modifiers)))]
(->> modifiers
(reduce set-modifier objects))))
(defn- modifiers->transform
[center modifiers]
(let [ds-modifier (:displacement modifiers (gmt/matrix))
{res-x :x res-y :y} (:resize-vector modifiers (gpt/point 1 1))
{res-x-2 :x res-y-2 :y} (:resize-vector-2 modifiers (gpt/point 1 1))
;; Normalize x/y vector coordinates because scale by 0 is infinite
res-x (normalize-scale res-x)
res-y (normalize-scale res-y)
resize (gpt/point res-x res-y)
res-x-2 (normalize-scale res-x-2)
res-y-2 (normalize-scale res-y-2)
resize-2 (gpt/point res-x-2 res-y-2)
origin (:resize-origin modifiers (gpt/point 0 0))
origin-2 (:resize-origin-2 modifiers (gpt/point 0 0))
resize-transform (:resize-transform modifiers (gmt/matrix))
resize-transform-inverse (:resize-transform-inverse modifiers (gmt/matrix))
rt-modif (or (:rotation modifiers) 0)
center (gpt/transform center ds-modifier)
transform (-> (gmt/matrix)
;; Applies the current resize transformation
(gmt/translate origin)
(gmt/multiply resize-transform)
(gmt/scale resize)
(gmt/multiply resize-transform-inverse)
(gmt/translate (gpt/negate origin))
(gmt/translate origin-2)
(gmt/multiply resize-transform)
(gmt/scale resize-2)
(gmt/multiply resize-transform-inverse)
(gmt/translate (gpt/negate origin-2))
;; Applies the stacked transformations
(gmt/translate center)
(gmt/multiply (gmt/rotate-matrix rt-modif))
(gmt/translate (gpt/negate center))
;; Displacement
(gmt/multiply ds-modifier))]
transform))
(defn- set-flip [shape modifiers]
(let [rx (get-in modifiers [:resize-vector :x])
ry (get-in modifiers [:resize-vector :y])]
(cond-> shape
(and rx (< rx 0)) (-> (update :flip-x not)
(update :rotation -))
(and ry (< ry 0)) (-> (update :flip-y not)
(update :rotation -)))))
(defn- apply-displacement [shape]
(let [modifiers (:modifiers shape)]
(if (contains? modifiers :displacement)
(let [mov-vec (-> (gpt/point 0 0)
(gpt/transform (:displacement modifiers)))
shape (move shape mov-vec)
modifiers (dissoc modifiers :displacement)]
(-> shape
(assoc :modifiers modifiers)
(cond-> (empty? modifiers)
(dissoc :modifiers))))
shape)))
(defn- apply-text-resize
[shape modifiers]
(if (and (= (:type shape) :text)
(:resize-scale-text modifiers))
(let [merge-attrs (fn [attrs]
(let [font-size (-> (get attrs :font-size 14)
(d/parse-double)
(* (get-in modifiers [:resize-vector :x] 1))
(* (get-in modifiers [:resize-vector-2 :x] 1))
(str))]
(attrs/merge attrs {:font-size font-size})))]
(update shape :content #(txt/transform-nodes
txt/is-text-node?
merge-attrs
%)))
shape))
(defn transform-shape
([shape]
(transform-shape shape nil))
([shape {:keys [round-coords?]
:or {round-coords? true}}]
(let [shape (apply-displacement shape)
center (gco/center-shape shape)
modifiers (:modifiers shape)]
(if (and modifiers center)
(let [transform (modifiers->transform center modifiers)]
(-> shape
(set-flip modifiers)
(apply-transform transform round-coords?)
(apply-text-resize modifiers)
(dissoc :modifiers)))
shape))))
(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]
(let [parent-rect (:selrect parent)
child-rect (:selrect child)
;; Apply the modifiers to the parent's selrect, to check the difference with
;; the original, and calculate child transformations from this.
;;
;; Note that a shape's selrect is always "horizontal" (i.e. without applying
;; the shape transform, that may include some rotation and skew). Thus, to
;; apply the modifiers, we first apply to them the transform-inverse.
parent-displacement (-> (gpt/point 0 0)
(gpt/transform (get parent-modifiers :displacement (gmt/matrix)))
(gpt/transform (:resize-transform-inverse parent-modifiers (gmt/matrix)))
(gmt/translate-matrix))
parent-origin (-> (:resize-origin parent-modifiers)
((d/nilf transform-point-center)
(gco/center-shape parent)
(:resize-transform-inverse parent-modifiers (gmt/matrix))))
parent-origin-2 (-> (:resize-origin-2 parent-modifiers)
((d/nilf transform-point-center)
(gco/center-shape parent)
(:resize-transform-inverse parent-modifiers (gmt/matrix))))
parent-vector (get parent-modifiers :resize-vector (gpt/point 1 1))
parent-vector-2 (get parent-modifiers :resize-vector-2 (gpt/point 1 1))
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))
(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))
modifiers-h (case constraints-h
:left
(let [delta-left (- (:x1 transformed-parent-rect) (:x1 parent-rect))]
(if-not (mth/almost-zero? delta-left)
{:displacement (gpt/point delta-left 0)} ;; we convert to matrix below
{}))
:right
(let [delta-right (- (:x2 transformed-parent-rect) (:x2 parent-rect))]
(if-not (mth/almost-zero? delta-right)
{:displacement (gpt/point delta-right 0)}
{}))
:leftright
(let [delta-left (- (:x1 transformed-parent-rect) (:x1 parent-rect))
delta-width (- (:width transformed-parent-rect) (:width parent-rect))]
(if (or (not (mth/almost-zero? delta-left))
(not (mth/almost-zero? delta-width)))
{:displacement (gpt/point delta-left 0)
:resize-origin (-> (gpt/point (+ (:x1 child-rect) delta-left)
(:y1 child-rect))
(transform-point-center
(gco/center-rect child-rect)
(:transform child (gmt/matrix))))
:resize-vector (gpt/point (/ (+ (:width child-rect) delta-width)
(:width child-rect)) 1)}
{}))
:center
(let [parent-center (gco/center-rect parent-rect)
transformed-parent-center (gco/center-rect transformed-parent-rect)
delta-center (- (:x transformed-parent-center) (:x parent-center))]
(if-not (mth/almost-zero? delta-center)
{:displacement (gpt/point delta-center 0)}
{}))
:scale
(cond-> {}
(and (:resize-vector parent-modifiers)
(not (mth/close? (:x (:resize-vector parent-modifiers)) 1)))
(assoc :resize-origin (:resize-origin parent-modifiers)
:resize-vector (gpt/point (:x (:resize-vector parent-modifiers)) 1))
(and (:resize-vector-2 parent-modifiers)
(not (mth/close? (:x (:resize-vector-2 parent-modifiers)) 1)))
(assoc :resize-origin-2 (:resize-origin-2 parent-modifiers)
:resize-vector-2 (gpt/point (:x (:resize-vector-2 parent-modifiers)) 1))
(:displacement parent-modifiers)
(assoc :displacement
(gpt/point (-> (gpt/point 0 0)
(gpt/transform (:displacement parent-modifiers))
(gpt/transform (:resize-transform-inverse parent-modifiers (gmt/matrix)))
(:x))
0)))
{})
modifiers-v (case constraints-v
:top
(let [delta-top (- (:y1 transformed-parent-rect) (:y1 parent-rect))]
(if-not (mth/almost-zero? delta-top)
{:displacement (gpt/point 0 delta-top)} ;; we convert to matrix below
{}))
:bottom
(let [delta-bottom (- (:y2 transformed-parent-rect) (:y2 parent-rect))]
(if-not (mth/almost-zero? delta-bottom)
{:displacement (gpt/point 0 delta-bottom)}
{}))
:topbottom
(let [delta-top (- (:y1 transformed-parent-rect) (:y1 parent-rect))
delta-height (- (:height transformed-parent-rect) (:height parent-rect))]
(if (or (not (mth/almost-zero? delta-top))
(not (mth/almost-zero? delta-height)))
{:displacement (gpt/point 0 delta-top)
:resize-origin (-> (gpt/point (:x1 child-rect)
(+ (:y1 child-rect) delta-top))
(transform-point-center
(gco/center-rect child-rect)
(:transform child (gmt/matrix))))
:resize-vector (gpt/point 1 (/ (+ (:height child-rect) delta-height)
(:height child-rect)))}
{}))
:center
(let [parent-center (gco/center-rect parent-rect)
transformed-parent-center (gco/center-rect transformed-parent-rect)
delta-center (- (:y transformed-parent-center) (:y parent-center))]
(if-not (mth/almost-zero? delta-center)
{:displacement (gpt/point 0 delta-center)}
{}))
:scale
(cond-> {}
(and (:resize-vector parent-modifiers)
(not (mth/close? (:y (:resize-vector parent-modifiers)) 1)))
(assoc :resize-origin (:resize-origin parent-modifiers)
:resize-vector (gpt/point 1 (:y (:resize-vector parent-modifiers))))
(and (:resize-vector-2 parent-modifiers)
(not (mth/close? (:y (:resize-vector-2 parent-modifiers)) 1)))
(assoc :resize-origin-2 (:resize-origin-2 parent-modifiers)
:resize-vector-2 (gpt/point 1 (:y (:resize-vector-2 parent-modifiers))))
(:displacement parent-modifiers)
(assoc :displacement
(gpt/point 0 (-> (gpt/point 0 0)
(gpt/transform (:displacement parent-modifiers))
(gpt/transform (:resize-transform-inverse parent-modifiers (gmt/matrix)))
(:y)))))
{})]
;; Build final child modifiers. Apply transform again to the result, to get the
;; real modifiers that need to be applied to the child, including rotation as needed.
(cond-> {}
(or (:displacement modifiers-h) (:displacement modifiers-v))
(assoc :displacement (gmt/translate-matrix
(-> (gpt/point (get (:displacement modifiers-h) :x 0)
(get (:displacement modifiers-v) :y 0))
(gpt/transform
(:resize-transform parent-modifiers (gmt/matrix))))))
(:resize-vector modifiers-h)
(assoc :resize-origin (:resize-origin modifiers-h)
:resize-vector (gpt/point (get (:resize-vector modifiers-h) :x 1)
(get (:resize-vector modifiers-h) :y 1)))
(:resize-vector modifiers-v)
(assoc :resize-origin-2 (:resize-origin modifiers-v)
:resize-vector-2 (gpt/point (get (:resize-vector modifiers-v) :x 1)
(get (:resize-vector modifiers-v) :y 1)))
(:resize-transform parent-modifiers)
(assoc :resize-transform (:resize-transform parent-modifiers)
:resize-transform-inverse (:resize-transform-inverse parent-modifiers)))))

0
common/app/common/math.cljc → common/src/app/common/math.cljc
View file

0
common/app/common/media.cljc → common/src/app/common/media.cljc
View file

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