3pp-mirror/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-07-09 14:57:17 +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 # CircleCI maintains a library of pre-built images
# documented at https://circleci.com/docs/2.0/circleci-images/ # documented at https://circleci.com/docs/2.0/circleci-images/
# - image: circleci/postgres:9.4 # - image: circleci/postgres:9.4
- image: circleci/postgres:13.1-ram - image: circleci/postgres:13.3-ram
environment: environment:
POSTGRES_USER: penpot_test POSTGRES_USER: penpot_test
POSTGRES_PASSWORD: penpot_test POSTGRES_PASSWORD: penpot_test
@ -29,21 +29,30 @@ jobs:
# Download and cache dependencies # Download and cache dependencies
- restore_cache: - restore_cache:
keys: 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 # fallback to using the latest cache if no exact match is found
- v1-dependencies- - v1-dependencies-
# run lint
- run: - run:
working_directory: "./backend" name: common lint
name: backend lint working_directory: "./common"
command: "clj-kondo --lint src/" command: "clj-kondo --parallel --lint src/"
# run test
- run: - run:
name: frontend lint
working_directory: "./frontend"
command: "clj-kondo --parallel --lint src/"
- run:
name: backend lint
working_directory: "./backend" working_directory: "./backend"
command: "clj-kondo --parallel --lint src/"
# run backend test
- run:
name: backend test name: backend test
command: "clojure -M:dev:tests" working_directory: "./backend"
command: "clojure -X:dev:test"
environment: environment:
PENPOT_TEST_DATABASE_URI: "postgresql://localhost/penpot_test" PENPOT_TEST_DATABASE_URI: "postgresql://localhost/penpot_test"
PENPOT_TEST_DATABASE_USERNAME: penpot_test PENPOT_TEST_DATABASE_USERNAME: penpot_test
@ -51,11 +60,26 @@ jobs:
PENPOT_TEST_REDIS_URI: "redis://localhost/1" PENPOT_TEST_REDIS_URI: "redis://localhost/1"
- run: - run:
working_directory: "./frontend"
name: frontend tests name: frontend tests
working_directory: "./frontend"
command: | command: |
yarn install 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: environment:
JAVA_HOME: /usr/lib/jvm/openjdk16 JAVA_HOME: /usr/lib/jvm/openjdk16
PATH: /usr/local/nodejs/bin/:/usr/local/bin:/bin:/usr/bin:/usr/lib/jvm/openjdk16/bin PATH: /usr/local/nodejs/bin/:/usr/local/bin:/bin:/usr/bin:/usr/lib/jvm/openjdk16/bin
@ -63,5 +87,5 @@ jobs:
- save_cache: - save_cache:
paths: paths:
- ~/.m2 - ~/.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"}}

31
.clj-kondo/config.edn
View file

@ -1,14 +1,23 @@
{:lint-as {potok.core/reify clojure.core/reify {:lint-as
promesa.core/let clojure.core/let {promesa.core/let clojure.core/let
rumext.alpha/defc clojure.core/defn rumext.alpha/defc clojure.core/defn
app.common.data/export clojure.core/def rumext.alpha/fnc clojure.core/fn
app.db/with-atomic clojure.core/with-open} app.common.data/export clojure.core/def
app.db/with-atomic clojure.core/with-open}
:hooks :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 :output
{:exclude-files ["data_readers.clj"]} {:exclude-files
["data_readers.clj"
"app/util/perf.cljs"
"app/common/exceptions.cljc"]}
:linters :linters
{:unsorted-required-namespaces {:unsorted-required-namespaces
@ -21,12 +30,12 @@
:single-key-in :single-key-in
{:level :warning} {:level :warning}
:redundant-do
{:level :off}
:unused-binding :unused-binding
{:exclude-destructured-as true {:exclude-destructured-as true
:exclude-destructured-keys-in-fn-args false :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)))) (api/token-node (symbol (name (:value sname))))
sname])] sname])]
{:node result})) {: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 ### :sparkles: New features
### :bug: Bugs fixed ### :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 ### :arrow_up: Deps updates
### :boom: Breaking changes ### :boom: Breaking changes
### :heart: Community contributions by (Thank you!) ### :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]: https://www.mozilla.org/en-US/MPL/2.0
[uri_license_image]: https://img.shields.io/badge/MPL-2.0-blue.svg [uri_license_image]: https://img.shields.io/badge/MPL-2.0-blue.svg
[![License: MPL-2.0][uri_license_image]][uri_license] <h1 align="center">
[![Gitter](https://badges.gitter.im/sereno-xyz/community.svg)](https://gitter.im/penpot/community) <br>
[![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") <img src="https://penpot.app/images/readme/readme-logo.jpg" alt="PENPOT">
[![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>
<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 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.
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 ## ## Contributing ##
<p align="center">
<img src="https://penpot.app/images/open-source.png" alt="Open Source">
</p>
**Open to you!** **Open to you!**
We love the open source software community. Contributing is our 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) 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 ## ## License ##

62
backend/deps.edn
View file

@ -1,22 +1,14 @@
{:mvn/repos {
{"central" {:url "https://repo1.maven.org/maven2/"} ;; :mvn/repos
"clojars" {:url "https://clojars.org/repo"} ;; {"central" {:url "https://repo1.maven.org/maven2/"}
"jcenter" {:url "https://jcenter.bintray.com/"}} ;; "clojars" {:url "https://clojars.org/repo"}
;; "jcenter" {:url "https://jcenter.bintray.com/"}
;; }
:deps :deps
{org.clojure/clojure {:mvn/version "1.10.3"} {penpot/common
org.clojure/data.json {:mvn/version "2.2.3"} {:local/root "../common"}
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"}
;; Logging ;; 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"} org.zeromq/jeromq {:mvn/version "0.5.2"}
com.taoensso/nippy {:mvn/version "3.1.1"} com.taoensso/nippy {:mvn/version "3.1.1"}
@ -32,69 +24,57 @@
org.eclipse.jetty/jetty-servlet]} org.eclipse.jetty/jetty-servlet]}
io.prometheus/simpleclient_httpserver {:mvn/version "0.9.0"} 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"} io.lettuce/lettuce-core {:mvn/version "6.1.2.RELEASE"}
java-http-clj/java-http-clj {:mvn/version "0.4.2"} java-http-clj/java-http-clj {:mvn/version "0.4.2"}
info.sunng/ring-jetty9-adapter {:mvn/version "0.15.1"} info.sunng/ring-jetty9-adapter {:mvn/version "0.15.1"}
com.github.seancorfield/next.jdbc {:mvn/version "1.2.659"} com.github.seancorfield/next.jdbc {:mvn/version "1.2.659"}
metosin/reitit-ring {:mvn/version "0.5.13"} metosin/reitit-ring {:mvn/version "0.5.13"}
metosin/jsonista {:mvn/version "0.3.3"}
org.postgresql/postgresql {:mvn/version "42.2.20"} org.postgresql/postgresql {:mvn/version "42.2.20"}
com.zaxxer/HikariCP {:mvn/version "4.0.3"} com.zaxxer/HikariCP {:mvn/version "4.0.3"}
funcool/datoteka {:mvn/version "2.0.0"} 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-core {:mvn/version "1.10.1"}
buddy/buddy-hashers {:mvn/version "1.8.1"} buddy/buddy-hashers {:mvn/version "1.8.1"}
buddy/buddy-sign {:mvn/version "3.4.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.jsoup/jsoup {:mvn/version "1.13.1"}
org.im4java/im4java {:mvn/version "1.4.0"} org.im4java/im4java {:mvn/version "1.4.0"}
org.lz4/lz4-java {:mvn/version "1.7.1"} 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"} org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
integrant/integrant {:mvn/version "0.8.0"} 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 :paths ["src" "resources"]
io.aviso/pretty {:mvn/version "0.1.37"}
environ/environ {:mvn/version "1.2.0"}}
:paths ["src" "resources" "../common" "common"]
:aliases :aliases
{:dev {:dev
{:extra-deps {:extra-deps
{com.bhauman/rebel-readline {:mvn/version "RELEASE"} {com.bhauman/rebel-readline {:mvn/version "RELEASE"}
org.clojure/tools.namespace {:mvn/version "RELEASE"} org.clojure/tools.namespace {:mvn/version "RELEASE"}
org.clojure/test.check {: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 "RELEASE"}
criterium/criterium {:mvn/version "0.4.6"} mockery/mockery {:mvn/version "RELEASE"}}
mockery/mockery {:mvn/version "0.1.4"}} :extra-paths ["test" "dev"]}
:extra-paths ["tests" "dev"]}
:fn-fixtures :fn-fixtures
{:exec-fn app.cli.fixtures/run {:exec-fn app.cli.fixtures/run
:args {}} :args {}}
:tests :kaocha
{:extra-deps {lambdaisland/kaocha {:mvn/version "1.0.829"}} {:extra-deps {lambdaisland/kaocha {:mvn/version "1.0.829"}}
:main-opts ["-m" "kaocha.runner"]} :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 :outdated
{:extra-deps {com.github.liquidz/antq {:mvn/version "RELEASE"}} {:extra-deps {com.github.liquidz/antq {:mvn/version "RELEASE"}}
:main-opts ["-m" "antq.core"]} :main-opts ["-m" "antq.core"]}

2
backend/dev/user.clj
View file

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

1
backend/scripts/build
View file

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

2
backend/scripts/repl
View file

@ -2,7 +2,7 @@
export PENPOT_ASSERTS_ENABLED=true 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:+UnlockDiagnosticVMOptions";
# export OPTIONS="$OPTIONS -J-XX:-TieredCompilation -J-XX:CompileThreshold=10000"; # 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-host "127.0.0.1"
:srepl-port 6062 :srepl-port 6062
:storage-backend :fs :assets-storage-backend :fs
:storage-assets-fs-directory "assets"
:storage-fs-directory "assets"
:storage-s3-region :eu-central-1
:storage-s3-bucket "penpot-devenv-assets-pre"
:feedback-destination "info@example.com" :feedback-destination "info@example.com"
:feedback-enabled false :feedback-enabled false
@ -175,10 +172,14 @@
(s/def ::smtp-username (s/nilable ::us/string)) (s/def ::smtp-username (s/nilable ::us/string))
(s/def ::srepl-host ::us/string) (s/def ::srepl-host ::us/string)
(s/def ::srepl-port ::us/integer) (s/def ::srepl-port ::us/integer)
(s/def ::storage-backend ::us/keyword) (s/def ::assets-storage-backend ::us/keyword)
(s/def ::storage-fs-directory ::us/string) (s/def ::fdata-storage-backend ::us/keyword)
(s/def ::storage-s3-bucket ::us/string) (s/def ::storage-assets-fs-directory ::us/string)
(s/def ::storage-s3-region ::us/keyword) (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-enabled ::us/boolean)
(s/def ::telemetry-uri ::us/string) (s/def ::telemetry-uri ::us/string)
(s/def ::telemetry-with-taiga ::us/boolean) (s/def ::telemetry-with-taiga ::us/boolean)
@ -257,12 +258,20 @@
::smtp-ssl ::smtp-ssl
::smtp-tls ::smtp-tls
::smtp-username ::smtp-username
::srepl-host ::srepl-host
::srepl-port ::srepl-port
::storage-backend
::storage-fs-directory ::assets-storage-backend
::storage-s3-bucket ::storage-assets-fs-directory
::storage-s3-region ::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-enabled
::telemetry-uri ::telemetry-uri
::telemetry-referer ::telemetry-referer

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

@ -10,13 +10,14 @@
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.geom.point :as gpt] [app.common.geom.point :as gpt]
[app.common.spec :as us] [app.common.spec :as us]
[app.common.transit :as t]
[app.common.uuid :as uuid]
[app.db.sql :as sql] [app.db.sql :as sql]
[app.metrics :as mtx] [app.metrics :as mtx]
[app.util.json :as json] [app.util.json :as json]
[app.util.logging :as l] [app.util.logging :as l]
[app.util.migrations :as mg] [app.util.migrations :as mg]
[app.util.time :as dt] [app.util.time :as dt]
[app.util.transit :as t]
[clojure.java.io :as io] [clojure.java.io :as io]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[integrant.core :as ig] [integrant.core :as ig]
@ -221,14 +222,20 @@
(sql/delete table params opts) (sql/delete table params opts)
(assoc opts :return-keys true)))) (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 (defn get-by-params
([ds table params] ([ds table params]
(get-by-params ds table params nil)) (get-by-params ds table params nil))
([ds table params {:keys [uncheked] :or {uncheked false} :as opts}] ([ds table params {:keys [uncheked] :or {uncheked false} :as opts}]
(let [res (exec-one! ds (sql/select table params opts))] (let [res (exec-one! ds (sql/select table params opts))]
(when (and (not uncheked) (when (and (not uncheked) (or (not res) (is-deleted? res)))
(or (:deleted-at res) (not res)))
(ex/raise :type :not-found (ex/raise :type :not-found
:table table
:hint "database object not found")) :hint "database object not found"))
res))) res)))
@ -245,8 +252,11 @@
(exec! ds (sql/select table params opts)))) (exec! ds (sql/select table params opts))))
(defn pgobject? (defn pgobject?
[v] ([v]
(instance? PGobject v)) (instance? PGobject v))
([v type]
(and (instance? PGobject v)
(= type (.getType ^PGobject v)))))
(defn pginterval? (defn pginterval?
[v] [v]
@ -339,12 +349,18 @@
(.setType "inet") (.setType "inet")
(.setValue (str ip-addr)))) (.setValue (str ip-addr))))
(defn decode-inet
[^PGobject o]
(if (= "inet" (.getType o))
(.getValue o)
nil))
(defn tjson (defn tjson
"Encode as transit json." "Encode as transit json."
[data] [data]
(doto (org.postgresql.util.PGobject.) (doto (org.postgresql.util.PGobject.)
(.setType "jsonb") (.setType "jsonb")
(.setValue (t/encode-verbose-str data)))) (.setValue (t/encode-str data {:type :json-verbose}))))
(defn json (defn json
"Encode as plain json." "Encode as plain json."
@ -360,3 +376,25 @@
(defn pgarray->vector (defn pgarray->vector
[v] [v]
(vec (.getArray ^PgArray 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] ([table where-params opts]
(let [opts (merge default-opts opts) (let [opts (merge default-opts opts)
opts (cond-> opts opts (cond-> opts
(:for-update opts) (:for-update opts) (assoc :suffix "FOR UPDATE")
(assoc :suffix "FOR UPDATE"))] (:for-key-share opts) (assoc :suffix "FOR KEY SHARE"))]
(sql/for-query table where-params opts)))) (sql/for-query table where-params opts))))
(defn update (defn update

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

@ -49,7 +49,7 @@
{:status 200 {:status 200
:headers {"content-type" (:content-type mdata) :headers {"content-type" (:content-type mdata)
"cache-control" (str "max-age=" (inst-ms cache-max-age))} "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 :s3
(let [url (sto/get-object-url storage obj {:max-age signature-max-age})] (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 (ns app.http.middleware
(:require (:require
[app.common.transit :as t]
[app.metrics :as mtx] [app.metrics :as mtx]
[app.util.json :as json] [app.util.json :as json]
[app.util.logging :as l] [app.util.logging :as l]
[app.util.transit :as t]
[buddy.core.codecs :as bc] [buddy.core.codecs :as bc]
[buddy.core.hash :as bh] [buddy.core.hash :as bh]
[clojure.java.io :as io] [clojure.java.io :as io]
[ring.core.protocols :as rp]
[ring.middleware.cookies :refer [wrap-cookies]] [ring.middleware.cookies :refer [wrap-cookies]]
[ring.middleware.keyword-params :refer [wrap-keyword-params]] [ring.middleware.keyword-params :refer [wrap-keyword-params]]
[ring.middleware.multipart-params :refer [wrap-multipart-params]] [ring.middleware.multipart-params :refer [wrap-multipart-params]]
@ -73,17 +74,28 @@
{:name ::parse-request-body {:name ::parse-request-body
:compile (constantly wrap-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 (defn- impl-format-response-body
[response] [response request]
(let [body (:body response) (let [body (:body response)
type :json-verbose] opts {:type :json-verbose}]
(cond (cond
(coll? body) (coll? body)
(-> response (-> response
(assoc :body (t/encode body {:type type})) (update :headers assoc "content-type" "application/transit+json")
(update :headers assoc (assoc :body
"content-type" (if (= :post (:request-method request))
"application/transit+json")) (transit-streamable-body body opts)
(t/encode body opts))))
(nil? body) (nil? body)
(assoc response :status 204 :body "") (assoc response :status 204 :body "")
@ -96,7 +108,7 @@
(fn [request] (fn [request]
(let [response (handler request)] (let [response (handler request)]
(cond-> response (cond-> response
(map? response) (impl-format-response-body))))) (map? response) (impl-format-response-body request)))))
(def format-response-body (def format-response-body
{:name ::format-response-body {:name ::format-response-body

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

@ -6,10 +6,14 @@
(ns app.http.oauth (ns app.http.oauth
(:require (:require
[app.common.data :as d]
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.spec :as us] [app.common.spec :as us]
[app.common.uri :as u] [app.common.uri :as u]
[app.config :as cf] [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.http :as http]
[app.util.logging :as l] [app.util.logging :as l]
[app.util.time :as dt] [app.util.time :as dt]
@ -19,36 +23,6 @@
[cuerdas.core :as str] [cuerdas.core :as str]
[integrant.core :as ig])) [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 (defn- build-redirect-uri
[{:keys [provider] :as cfg}] [{:keys [provider] :as cfg}]
(let [public (u/uri (:public-uri cfg))] (let [public (u/uri (:public-uri cfg))]
@ -146,6 +120,7 @@
(string? roles) (into #{} (str/words roles)) (string? roles) (into #{} (str/words roles))
(vector? roles) (into #{} roles) (vector? roles) (into #{} roles)
:else #{}))] :else #{}))]
;; check if profile has a configured set of roles ;; check if profile has a configured set of roles
(when-not (set/subset? provider-roles profile-roles) (when-not (set/subset? provider-roles profile-roles)
(ex/raise :type :internal (ex/raise :type :internal
@ -175,6 +150,63 @@
{} {}
params)) 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 (defn- auth-handler
[{:keys [tokens] :as cfg} {:keys [params] :as request}] [{:keys [tokens] :as cfg} {:keys [params] :as request}]
(let [invitation (:invitation-token params) (let [invitation (:invitation-token params)
@ -189,17 +221,15 @@
:body {:redirect-uri uri}})) :body {:redirect-uri uri}}))
(defn- callback-handler (defn- callback-handler
[{:keys [session] :as cfg} request] [cfg request]
(try (try
(let [info (retrieve-info cfg request) (let [info (retrieve-info cfg request)
profile (register-profile cfg info) profile (retrieve-profile cfg info)]
uri (generate-redirect-uri cfg profile) (generate-redirect cfg request info profile))
sxf ((:create session) (:id profile))] (catch Exception e
(->> (redirect-response uri) (l/warn :hint "error on oauth process"
(sxf request))) :cause e)
(catch Exception _e (generate-error-redirect cfg e))))
(-> (generate-error-redirect-uri cfg)
(redirect-response)))))
;; --- INIT ;; --- INIT
@ -210,8 +240,8 @@
(s/def ::tokens fn?) (s/def ::tokens fn?)
(s/def ::rpc map?) (s/def ::rpc map?)
(defmethod ig/pre-init-spec :app.http.oauth/handlers [_] (defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::public-uri ::session ::tokens ::rpc])) (s/keys :req-un [::public-uri ::session ::tokens ::rpc ::db/pool]))
(defn wrap-handler (defn wrap-handler
[cfg handler] [cfg handler]
@ -225,7 +255,7 @@
(-> (assoc @cfg :provider provider) (-> (assoc @cfg :provider provider)
(handler request))))) (handler request)))))
(defmethod ig/init-key :app.http.oauth/handlers (defmethod ig/init-key ::handler
[_ cfg] [_ cfg]
(let [cfg (initialize cfg)] (let [cfg (initialize cfg)]
{:handler (wrap-handler cfg auth-handler) {:handler (wrap-handler cfg auth-handler)

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

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

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

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

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

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

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

@ -210,9 +210,15 @@
([a b] ([a b]
(mobj :inc) (mobj :inc)
(origf a b)) (origf a b))
([a b & more] ([a b c]
(mobj :inc) (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)))) (assoc mdata ::original origf))))
([rootf mobj labels] ([rootf mobj labels]
(let [mdata (meta rootf) (let [mdata (meta rootf)

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

@ -175,6 +175,24 @@
{:name "0055-mod-file-media-object-table" {:name "0055-mod-file-media-object-table"
:fn (mg/resource "app/migrations/sql/0055-mod-file-media-object-table.sql")} :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." "A websocket based notifications mechanism."
(:require (:require
[app.common.spec :as us] [app.common.spec :as us]
[app.common.transit :as t]
[app.db :as db] [app.db :as db]
[app.metrics :as mtx] [app.metrics :as mtx]
[app.util.async :as aa] [app.util.async :as aa]
[app.util.logging :as l] [app.util.logging :as l]
[app.util.time :as dt] [app.util.time :as dt]
[app.util.transit :as t]
[app.worker :as wrk] [app.worker :as wrk]
[clojure.core.async :as a] [clojure.core.async :as a]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
@ -163,7 +163,7 @@
;; when connection is closed ;; when connection is closed
(mtx-aconn :dec) (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 ;; close subscription
(a/close! sub-ch)))) (a/close! sub-ch))))

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

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

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

@ -15,7 +15,7 @@
[app.rpc.mutations.profile :as profile] [app.rpc.mutations.profile :as profile]
[app.setup.initial-data :as sid] [app.setup.initial-data :as sid]
[app.util.services :as sv] [app.util.services :as sv]
[app.worker :as wrk] [app.util.time :as dt]
[buddy.core.codecs :as bc] [buddy.core.codecs :as bc]
[buddy.core.nonce :as bn] [buddy.core.nonce :as bn]
[clojure.spec.alpha :as s])) [clojure.spec.alpha :as s]))
@ -35,6 +35,7 @@
:email email :email email
:fullname fullname :fullname fullname
:is-demo true :is-demo true
:deleted-at (dt/in-future cfg/deletion-delay)
:password password :password password
:props {:onboarding-viewed true}}] :props {:onboarding-viewed true}}]
@ -48,12 +49,6 @@
(#'profile/create-profile-relations conn) (#'profile/create-profile-relations conn)
(sid/load-initial-project! 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 (with-meta {:email email
:password password} :password password}
{::audit/profile-id id})))) {::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.pages.migrations :as pmg]
[app.common.spec :as us] [app.common.spec :as us]
[app.common.uuid :as uuid] [app.common.uuid :as uuid]
[app.config :as cfg] [app.config :as cf]
[app.db :as db] [app.db :as db]
[app.rpc.permissions :as perms] [app.rpc.permissions :as perms]
[app.rpc.queries.files :as files] [app.rpc.queries.files :as files]
[app.rpc.queries.projects :as proj] [app.rpc.queries.projects :as proj]
[app.storage.impl :as simpl]
[app.util.blob :as blob] [app.util.blob :as blob]
[app.util.services :as sv] [app.util.services :as sv]
[app.util.time :as dt] [app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s])) [clojure.spec.alpha :as s]))
(declare create-file)
;; --- Helpers & Specs ;; --- Helpers & Specs
(s/def ::id ::us/uuid) (s/def ::id ::us/uuid)
@ -32,8 +34,6 @@
;; --- Mutation: Create File ;; --- Mutation: Create File
(declare create-file)
(s/def ::is-shared ::us/boolean) (s/def ::is-shared ::us/boolean)
(s/def ::create-file (s/def ::create-file
(s/keys :req-un [::profile-id ::name ::project-id] (s/keys :req-un [::profile-id ::name ::project-id]
@ -45,7 +45,6 @@
(proj/check-edition-permissions! conn profile-id project-id) (proj/check-edition-permissions! conn profile-id project-id)
(create-file conn params))) (create-file conn params)))
(defn create-file-role (defn create-file-role
[conn {:keys [file-id profile-id role]}] [conn {:keys [file-id profile-id role]}]
(let [params {:file-id file-id (let [params {:file-id file-id
@ -54,21 +53,24 @@
(db/insert! conn :file-profile-rel)))) (db/insert! conn :file-profile-rel))))
(defn create-file (defn create-file
[conn {:keys [id name project-id is-shared] [conn {:keys [id name project-id is-shared data deleted-at]
:or {is-shared false} :or {is-shared false
deleted-at nil}
:as params}] :as params}]
(let [id (or id (uuid/next)) (let [id (or id (:id data) (uuid/next))
data (cp/make-file-data id) data (or data (cp/make-file-data id))
file (db/insert! conn :file file (db/insert! conn :file
{:id id {:id id
:project-id project-id :project-id project-id
:name name :name name
:is-shared is-shared :is-shared is-shared
:data (blob/encode data)})] :data (blob/encode data)
:deleted-at deleted-at})]
(->> (assoc params :file-id id :role :owner) (->> (assoc params :file-id id :role :owner)
(create-file-role conn)) (create-file-role conn))
(assoc file :data data)))
(assoc file :data data)))
;; --- Mutation: Rename File ;; --- Mutation: Rename File
@ -109,7 +111,6 @@
{:is-shared is-shared} {:is-shared is-shared}
{:id id})) {:id id}))
;; --- Mutation: Delete File ;; --- Mutation: Delete File
(declare mark-file-deleted) (declare mark-file-deleted)
@ -122,13 +123,6 @@
(db/with-atomic [conn pool] (db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id id) (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))) (mark-file-deleted conn params)))
(defn mark-file-deleted (defn mark-file-deleted
@ -175,7 +169,7 @@
(s/keys :req-un [::profile-id ::file-id ::library-id])) (s/keys :req-un [::profile-id ::file-id ::library-id]))
(sv/defmethod ::unlink-file-from-library (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] (db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id file-id) (files/check-edition-permissions! conn profile-id file-id)
(unlink-file-from-library conn params))) (unlink-file-from-library conn params)))
@ -195,7 +189,7 @@
(s/keys :req-un [::profile-id ::file-id ::library-id])) (s/keys :req-un [::profile-id ::file-id ::library-id]))
(sv/defmethod ::update-sync (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] (db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id file-id) (files/check-edition-permissions! conn profile-id file-id)
(update-sync conn params))) (update-sync conn params)))
@ -207,7 +201,6 @@
{:file-id file-id {:file-id file-id
:library-file-id library-id})) :library-file-id library-id}))
;; --- Mutation: Ignore updates in linked files ;; --- Mutation: Ignore updates in linked files
(declare ignore-sync) (declare ignore-sync)
@ -216,7 +209,7 @@
(s/keys :req-un [::profile-id ::file-id ::date])) (s/keys :req-un [::profile-id ::file-id ::date]))
(sv/defmethod ::ignore-sync (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] (db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id file-id) (files/check-edition-permissions! conn profile-id file-id)
(ignore-sync conn params))) (ignore-sync conn params)))
@ -278,15 +271,31 @@
(sv/defmethod ::update-file (sv/defmethod ::update-file
[{:keys [pool] :as cfg} {:keys [id profile-id] :as params}] [{:keys [pool] :as cfg} {:keys [id profile-id] :as params}]
(db/with-atomic [conn pool] (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) (files/check-edition-permissions! conn profile-id id)
(update-file (assoc cfg :conn conn) (update-file (assoc cfg :conn conn)
(assoc params :file file))))) (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 (defn- update-file
[{:keys [conn] :as cfg} {:keys [file changes changes-with-metadata session-id profile-id] :as params}] [{:keys [conn] :as cfg} {:keys [file changes changes-with-metadata session-id profile-id] :as params}]
(when (> (:revn params) (when (> (:revn params)
(:revn file)) (:revn file))
(ex/raise :type :validation (ex/raise :type :validation
:code :revn-conflict :code :revn-conflict
:hint "The incoming revision number is greater that stored version." :hint "The incoming revision number is greater that stored version."
@ -297,7 +306,8 @@
(mapcat :changes changes-with-metadata) (mapcat :changes changes-with-metadata)
changes) changes)
file (-> file ts (dt/now)
file (-> (files/retrieve-data cfg file)
(update :revn inc) (update :revn inc)
(update :data (fn [data] (update :data (fn [data]
(-> data (-> data
@ -311,26 +321,55 @@
{:id (uuid/next) {:id (uuid/next)
:session-id session-id :session-id session-id
:profile-id profile-id :profile-id profile-id
:created-at ts
:file-id (:id file) :file-id (:id file)
:revn (:revn file) :revn (:revn file)
:data (:data file) :data (when (take-snapshot? file)
(:data file))
:changes (blob/encode changes)}) :changes (blob/encode changes)})
;; Update file ;; Update file
(db/update! conn :file (db/update! conn :file
{:revn (:revn file) {:revn (:revn file)
:data (:data file) :data (:data file)
:data-backend nil
:modified-at ts
:has-media-trimmed false} :has-media-trimmed false}
{:id (:id file)}) {:id (:id file)})
(let [params (-> params (assoc :file file ;; We need to delete the data from external storage backend
:changes changes))] (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 asynchronous notifications
(send-notifications cfg params) (send-notifications cfg params)
;; Retrieve and return lagged data ;; Retrieve and return lagged data
(retrieve-lagged-changes conn params)))) (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 (defn- send-notifications
[{:keys [msgbus conn] :as cfg} {:keys [file changes session-id] :as params}] [{:keys [msgbus conn] :as cfg} {:keys [file changes session-id] :as params}]
(let [lchanges (filter library-change? changes)] (let [lchanges (filter library-change? changes)]
@ -362,17 +401,24 @@
[conn project-id] [conn project-id]
(:team-id (db/get-by-id conn :project project-id {:columns [:team-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 ;; TEMPORARY FILE CREATION
[conn params]
(->> (db/exec! conn [sql:lagged-changes (:id params) (:revn params)])
(mapv files/decode-row)))
(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})))

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

@ -104,21 +104,10 @@
(db/with-atomic [conn pool] (db/with-atomic [conn pool]
(teams/check-edition-permissions! conn profile-id team-id) (teams/check-edition-permissions! conn profile-id team-id)
(let [items (db/query conn :team-font-variant (db/update! conn :team-font-variant
{:font-id id :team-id team-id} {:deleted-at (dt/now)}
{:for-update true})] {:font-id id :team-id team-id})
(doseq [item items] nil))
;; 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)))
;; --- DELETE FONT VARIANT ;; --- DELETE FONT VARIANT

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

@ -9,7 +9,10 @@
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.spec :as us] [app.common.spec :as us]
[app.config :as cfg] [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] [app.util.services :as sv]
[clj-ldap.client :as ldap] [clj-ldap.client :as ldap]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
@ -34,6 +37,7 @@
;; --- Mutation: login-with-ldap ;; --- Mutation: login-with-ldap
(declare authenticate) (declare authenticate)
(declare login-or-register)
(s/def ::email ::us/email) (s/def ::email ::us/email)
(s/def ::password ::us/string) (s/def ::password ::us/string)
@ -44,31 +48,37 @@
:opt-un [::invitation-token])) :opt-un [::invitation-token]))
(sv/defmethod ::login-with-ldap {:auth false :rlimit :password} (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]
(let [info (authenticate params) (db/with-atomic [conn pool]
cfg (assoc cfg :conn pool)] (let [info (authenticate params)
(when-not info cfg (assoc cfg :conn conn)]
(ex/raise :type :validation
:code :wrong-credentials))
(let [profile (login-or-register cfg {:email (:email info)
:backend (:backend info)
:fullname (:fullname info)})]
(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)]
(with-meta
{:invitation-token token}
{:transform-response ((:create session) (:id profile))}))
(with-meta profile (when-not info
{:transform-response ((:create session) (:id profile))}))))) (ex/raise :type :validation
:code :wrong-credentials))
(let [profile (login-or-register cfg {:email (:email info)
:backend (:backend info)
:fullname (:fullname info)})]
(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)]
(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))
::audit/props (:props profile)
::audit/profile-id (:id profile)}))))))
(defn- replace-several [s & {:as replacements}] (defn- replace-several [s & {:as replacements}]
(reduce-kv clojure.string/replace s replacements)) (reduce-kv clojure.string/replace s replacements))
@ -88,11 +98,25 @@
(first (ldap/search cpool base-dn params)))) (first (ldap/search cpool base-dn params))))
(defn- authenticate (defn- authenticate
[{:keys [password] :as params}] [{:keys [password email] :as params}]
(with-open [conn (connect)] (with-open [conn (connect)]
(when-let [{:keys [dn] :as luser} (get-ldap-user conn params)] (when-let [{:keys [dn] :as luser} (get-ldap-user conn params)]
(when (ldap/bind? conn dn password) (when (ldap/bind? conn dn password)
{:photo (get luser (keyword (cfg/get :ldap-attrs-photo))) {:photo (get luser (keyword (cfg/get :ldap-attrs-photo)))
:fullname (get luser (keyword (cfg/get :ldap-attrs-fullname))) :fullname (get luser (keyword (cfg/get :ldap-attrs-fullname)))
:email (get luser (keyword (cfg/get :ldap-attrs-email))) :email email
:backend "ldap"})))) :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])) :opt-un [::name]))
(sv/defmethod ::duplicate-file (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] (db/with-atomic [conn pool]
(let [file (db/get-by-id conn :file file-id) (let [file (db/get-by-id conn :file file-id)
index {file-id (uuid/next)} index {file-id (uuid/next)}
@ -187,7 +187,7 @@
:opt-un [::name])) :opt-un [::name]))
(sv/defmethod ::duplicate-project (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] (db/with-atomic [conn pool]
(let [project (db/get-by-id conn :project project-id)] (let [project (db/get-by-id conn :project project-id)]
(teams/check-edition-permissions! conn profile-id (:team-id project)) (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 (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)) (media/validate-media-type (:content-type content))
(let [storage (assoc storage :conn conn) (let [storage (assoc storage :conn conn)
source-path (fs/path (:tempfile content)) source-path (fs/path (:tempfile content))
@ -118,7 +118,7 @@
(sto/put-object storage {:content (sto/content (:data thumb) (:size thumb)) (sto/put-object storage {:content (sto/content (:data thumb) (:size thumb))
:content-type (:mtype thumb)}))] :content-type (:mtype thumb)}))]
(db/insert! conn :file-media-object (db/insert! conn :file-media-object
{:id (uuid/next) {:id (or id (uuid/next))
:file-id file-id :file-id file-id
:is-local is-local :is-local is-local
:name name :name name

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

@ -22,7 +22,6 @@
[app.storage :as sto] [app.storage :as sto]
[app.util.services :as sv] [app.util.services :as sv]
[app.util.time :as dt] [app.util.time :as dt]
[app.worker :as wrk]
[buddy.hashers :as hashers] [buddy.hashers :as hashers]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[cuerdas.core :as str])) [cuerdas.core :as str]))
@ -37,106 +36,14 @@
(s/def ::password ::us/not-empty-string) (s/def ::password ::us/not-empty-string)
(s/def ::old-password ::us/not-empty-string) (s/def ::old-password ::us/not-empty-string)
(s/def ::theme ::us/string) (s/def ::theme ::us/string)
(s/def ::invitation-token ::us/not-empty-string)
;; --- Mutation: Register Profile
(declare annotate-profile-register) (declare annotate-profile-register)
(declare check-profile-existence!) (declare check-profile-existence!)
(declare create-profile) (declare create-profile)
(declare create-profile-relations) (declare create-profile-relations)
(declare email-domain-in-whitelist?)
(declare register-profile) (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? (defn email-domain-in-whitelist?
"Returns true if email's domain is in the given whitelist or if "Returns true if email's domain is in the given whitelist or if
given whitelist is an empty string." given whitelist is an empty string."
@ -178,28 +85,176 @@
{:update false {:update false
:valid 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 (defn create-profile
"Create the profile entry on the database with limited input "Create the profile entry on the database with limited input filling
filling all the other fields with defaults." all the other fields with defaults."
[conn {:keys [id fullname email password is-active is-muted is-demo opts] [conn params]
:or {is-active false is-muted false is-demo false} (let [id (or (:id params) (uuid/next))
:as params}]
(let [id (or id (uuid/next)) props (-> (extract-props params)
is-active (if is-demo true is-active) (merge (:props params))
props (-> params extract-props db/tjson) (assoc :accept-terms-and-privacy (:accept-terms-and-privacy params true))
password (derive-password password) (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 params {:id id
:fullname fullname :fullname (:fullname params)
:email (str/lower email) :email email
:auth-backend "penpot" :auth-backend backend
:lang locale
:password password :password password
:deleted-at (:deleted-at params)
:props props :props props
:is-active is-active :is-active is-active
:is-muted is-muted :is-muted is-muted
:is-demo is-demo}] :is-demo is-demo}]
(try (try
(-> (db/insert! conn :profile params opts) (-> (db/insert! conn :profile params)
(update :props db/decode-transit-pgobject)) (decode-profile-row))
(catch org.postgresql.util.PSQLException e (catch org.postgresql.util.PSQLException e
(let [state (.getSQLState e)] (let [state (.getSQLState e)]
(if (not= state "23505") (if (not= state "23505")
@ -231,7 +286,7 @@
(assoc :default-team-id (:id team)) (assoc :default-team-id (:id team))
(assoc :default-project-id (:id project))))) (assoc :default-project-id (:id project)))))
;; --- Mutation: Login ;; --- MUTATION: Login
(s/def ::email ::us/email) (s/def ::email ::us/email)
(s/def ::scope ::us/string) (s/def ::scope ::us/string)
@ -241,7 +296,7 @@
:opt-un [::scope ::invitation-token])) :opt-un [::scope ::invitation-token]))
(sv/defmethod ::login {:auth false :rlimit :password} (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] (letfn [(check-password [profile password]
(when (= (:password profile) "!") (when (= (:password profile) "!")
(ex/raise :type :validation (ex/raise :type :validation
@ -264,7 +319,8 @@
(let [profile (->> (profile/retrieve-profile-data-by-email conn email) (let [profile (->> (profile/retrieve-profile-data-by-email conn email)
(validate-profile) (validate-profile)
(profile/strip-private-attrs) (profile/strip-private-attrs)
(profile/populate-additional-data conn))] (profile/populate-additional-data conn)
(decode-profile-row))]
(if-let [token (:invitation-token params)] (if-let [token (:invitation-token params)]
;; If the request comes with an invitation token, this means ;; If the request comes with an invitation token, this means
;; that user wants to accept it with different user. A very ;; that user wants to accept it with different user. A very
@ -279,90 +335,25 @@
token (tokens :generate claims)] token (tokens :generate claims)]
(with-meta {:invitation-token token} (with-meta {:invitation-token token}
{:transform-response ((:create session) (:id profile)) {:transform-response ((:create session) (:id profile))
::audit/props (audit/profile->props profile)
::audit/profile-id (:id profile)})) ::audit/profile-id (:id profile)}))
(with-meta profile (with-meta profile
{:transform-response ((:create session) (:id profile)) {:transform-response ((:create session) (:id profile))
::audit/props (audit/profile->props profile)
::audit/profile-id (:id profile)})))))) ::audit/profile-id (:id profile)}))))))
;; --- Mutation: Logout ;; --- MUTATION: Logout
(s/def ::logout (s/def ::logout
(s/keys :req-un [::profile-id])) (s/keys :req-un [::profile-id]))
(sv/defmethod ::logout (sv/defmethod ::logout
[{:keys [pool session] :as cfg} {:keys [profile-id] :as params}] [{:keys [session] :as cfg} _]
(with-meta {} (with-meta {}
{:transform-response (:delete session)})) {:transform-response (:delete session)}))
;; --- MUTATION: Update Profile (own)
;; --- 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)
(defn- update-profile (defn- update-profile
[conn {:keys [id fullname lang theme] :as params}] [conn {:keys [id fullname lang theme] :as params}]
@ -382,7 +373,7 @@
(update-profile conn params) (update-profile conn params)
nil)) nil))
;; --- Mutation: Update Password ;; --- MUTATION: Update Password
(declare validate-password!) (declare validate-password!)
(declare update-profile-password!) (declare update-profile-password!)
@ -391,7 +382,7 @@
(s/keys :req-un [::profile-id ::password ::old-password])) (s/keys :req-un [::profile-id ::password ::old-password]))
(sv/defmethod ::update-profile-password {:rlimit :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] (db/with-atomic [conn pool]
(let [profile (validate-password! conn params)] (let [profile (validate-password! conn params)]
(update-profile-password! conn (assoc profile :password password)) (update-profile-password! conn (assoc profile :password password))
@ -411,7 +402,7 @@
{:password (derive-password password)} {:password (derive-password password)}
{:id id})) {:id id}))
;; --- Mutation: Update Photo ;; --- MUTATION: Update Photo
(declare update-profile-photo) (declare update-profile-photo)
@ -446,7 +437,7 @@
nil) nil)
;; --- Mutation: Request Email Change ;; --- MUTATION: Request Email Change
(declare request-email-change) (declare request-email-change)
(declare change-email-inmediatelly) (declare change-email-inmediatelly)
@ -514,7 +505,7 @@
[conn id] [conn id]
(db/get-by-id conn :profile id {:for-update true})) (db/get-by-id conn :profile id {:for-update true}))
;; --- Mutation: Request Profile Recovery ;; --- MUTATION: Request Profile Recovery
(s/def ::request-profile-recovery (s/def ::request-profile-recovery
(s/keys :req-un [::email])) (s/keys :req-un [::email]))
@ -563,7 +554,7 @@
(send-email-notification conn)))))) (send-email-notification conn))))))
;; --- Mutation: Recover Profile ;; --- MUTATION: Recover Profile
(s/def ::token ::us/not-empty-string) (s/def ::token ::us/not-empty-string)
(s/def ::recover-profile (s/def ::recover-profile
@ -584,7 +575,7 @@
(update-password conn)) (update-password conn))
nil))) nil)))
;; --- Mutation: Update Profile Props ;; --- MUTATION: Update Profile Props
(s/def ::props map?) (s/def ::props map?)
(s/def ::update-profile-props (s/def ::update-profile-props
@ -606,7 +597,7 @@
nil))) nil)))
;; --- Mutation: Delete Profile ;; --- MUTATION: Delete Profile
(declare check-can-delete-profile!) (declare check-can-delete-profile!)
(declare mark-profile-as-deleted!) (declare mark-profile-as-deleted!)
@ -619,12 +610,6 @@
(db/with-atomic [conn pool] (db/with-atomic [conn pool]
(check-can-delete-profile! conn profile-id) (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 (db/update! conn :profile
{:deleted-at (dt/now)} {:deleted-at (dt/now)}
{:id profile-id}) {:id profile-id})

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

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

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

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

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

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

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

@ -11,7 +11,8 @@
[app.common.uuid :as uuid] [app.common.uuid :as uuid]
[app.db :as db] [app.db :as db]
[app.util.services :as sv] [app.util.services :as sv]
[clojure.spec.alpha :as s])) [clojure.spec.alpha :as s]
[cuerdas.core :as str]))
;; --- Helpers & Specs ;; --- Helpers & Specs
@ -72,7 +73,8 @@
(defn decode-profile-row (defn decode-profile-row
[{:keys [props] :as row}] [{:keys [props] :as row}]
(cond-> 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 (defn retrieve-profile-data
[conn id] [conn id]
@ -90,16 +92,11 @@
profile)) 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 (defn retrieve-profile-data-by-email
[conn email] [conn email]
(let [sql [sql:retrieve-profile-by-email email]] (try
(some-> (db/exec-one! conn sql) (db/get-by-params conn :profile {:email (str/lower email)})
(decode-profile-row)))) (catch Exception _e)))
;; --- Attrs Helpers ;; --- Attrs Helpers

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

@ -42,12 +42,13 @@
(sv/defmethod ::viewer-bundle {:auth false} (sv/defmethod ::viewer-bundle {:auth false}
[{:keys [pool] :as cfg} {:keys [profile-id file-id page-id token] :as params}] [{:keys [pool] :as cfg} {:keys [profile-id file-id page-id token] :as params}]
(db/with-atomic [conn pool] (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)) project (retrieve-project conn (:project-id file))
page (get-in file [:data :pages-index page-id]) page (get-in file [:data :pages-index page-id])
file (merge (dissoc file :data) file (merge (dissoc file :data)
(select-keys (:data file) [:colors :media :typographies])) (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)) users (teams/retrieve-users conn (:team-id project))
fonts (db/query conn :team-font-variant 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))))

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

@ -9,6 +9,7 @@
(:require (:require
[app.common.spec :as us] [app.common.spec :as us]
[app.srepl.main] [app.srepl.main]
[app.util.logging :as l]
[clojure.core.server :as ccs] [clojure.core.server :as ccs]
[clojure.main :as cm] [clojure.main :as cm]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
@ -41,14 +42,17 @@
(defmethod ig/init-key ::server (defmethod ig/init-key ::server
[_ {:keys [port host name] :as cfg}] [_ {:keys [port host name] :as cfg}]
(ccs/start-server {:address host (when (and port host name)
:port port (l/info :msg "initializing server repl" :port port :host host :name name)
:name name (ccs/start-server {:address host
:accept 'app.srepl/repl}) :port port
cfg) :name name
:accept 'app.srepl/repl})
cfg))
(defmethod ig/halt-key! ::server (defmethod ig/halt-key! ::server
[_ cfg] [_ cfg]
(ccs/stop-server (:name cfg))) (when cfg
(ccs/stop-server (:name cfg))))

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

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

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

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

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

@ -8,10 +8,10 @@
"Storage backends abstraction layer." "Storage backends abstraction layer."
(:require (:require
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.uuid :as uuid] [app.common.uuid :as uuid]
[buddy.core.codecs :as bc] [buddy.core.codecs :as bc]
[clojure.java.io :as io]) [clojure.java.io :as io]
[cuerdas.core :as str])
(:import (:import
java.nio.ByteBuffer java.nio.ByteBuffer
java.util.UUID java.util.UUID
@ -45,6 +45,14 @@
:code :invalid-storage-backend :code :invalid-storage-backend
:context cfg)) :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))) (defmulti get-object-url (fn [cfg _ _] (:type cfg)))
(defmethod get-object-url :default (defmethod get-object-url :default
@ -54,6 +62,14 @@
:context cfg)) :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))) (defmulti del-objects-in-bulk (fn [cfg _] (:type cfg)))
(defmethod del-objects-in-bulk :default (defmethod del-objects-in-bulk :default
@ -62,7 +78,6 @@
:code :invalid-storage-backend :code :invalid-storage-backend
:context cfg)) :context cfg))
;; --- HELPERS ;; --- HELPERS
(defn uuid->hex (defn uuid->hex
@ -109,7 +124,10 @@
(make-output-stream [_ opts] (make-output-stream [_ opts]
(throw (UnsupportedOperationException. "not implemented"))) (throw (UnsupportedOperationException. "not implemented")))
clojure.lang.Counted clojure.lang.Counted
(count [_] size)))) (count [_] size)
java.lang.AutoCloseable
(close [_]))))
(defn string->content (defn string->content
[^String v] [^String v]
@ -129,7 +147,10 @@
clojure.lang.Counted clojure.lang.Counted
(count [_] (count [_]
(alength data))))) (alength data))
java.lang.AutoCloseable
(close [_]))))
(defn- input-stream->content (defn- input-stream->content
[^InputStream is size] [^InputStream is size]
@ -137,7 +158,7 @@
IContentObject IContentObject
io/IOFactory io/IOFactory
(make-reader [_ opts] (make-reader [_ opts]
(io/make-reader is opts)) (io/make-reader is opts))
(make-writer [_ opts] (make-writer [_ opts]
(throw (UnsupportedOperationException. "not implemented"))) (throw (UnsupportedOperationException. "not implemented")))
(make-input-stream [_ opts] (make-input-stream [_ opts]
@ -146,7 +167,11 @@
(throw (UnsupportedOperationException. "not implemented"))) (throw (UnsupportedOperationException. "not implemented")))
clojure.lang.Counted clojure.lang.Counted
(count [_] size))) (count [_] size)
java.lang.AutoCloseable
(close [_]
(.close is))))
(defn content (defn content
([data] (content data nil)) ([data] (content data nil))
@ -179,10 +204,20 @@
(defn slurp-bytes (defn slurp-bytes
[content] [content]
(us/assert content? content)
(with-open [input (io/input-stream content) (with-open [input (io/input-stream content)
output (java.io.ByteArrayOutputStream. (count content))] output (java.io.ByteArrayOutputStream. (count content))]
(io/copy input output) (io/copy input output)
(.toByteArray 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))))

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

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

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

@ -4,6 +4,9 @@
;; ;;
;; Copyright (c) UXBOX Labs SL ;; Copyright (c) UXBOX Labs SL
;; TODO: DEPRECATED
;; Should be removed in the 1.8.x
(ns app.tasks.delete-object (ns app.tasks.delete-object
"Generic task for permanent deletion of objects." "Generic task for permanent deletion of objects."
(:require (:require

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

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

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

@ -100,6 +100,7 @@
:id (:id mobj) :id (:id mobj)
:media-id (:media-id mobj) :media-id (:media-id mobj)
:thumbnail-id (:thumbnail-id mobj)) :thumbnail-id (:thumbnail-id mobj))
;; NOTE: deleting the file-media-object in the database ;; NOTE: deleting the file-media-object in the database
;; automatically marks as toched the referenced storage ;; automatically marks as toched the referenced storage
;; objects. The touch mechanism is needed because many files can ;; 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 (:require
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.spec :as us] [app.common.spec :as us]
[app.common.transit :as t]
[app.util.time :as dt] [app.util.time :as dt]
[app.util.transit :as t]
[buddy.core.kdf :as bk]
[buddy.sign.jwe :as jwe] [buddy.sign.jwe :as jwe]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[integrant.core :as ig])) [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 (defn- generate
[cfg claims] [cfg claims]
(let [payload (t/encode claims)] (let [payload (t/encode claims)]
@ -50,13 +41,6 @@
:params params)) :params params))
claims)) 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 (defn- generate-predefined
[cfg {:keys [iss profile-id] :as params}] [cfg {:keys [iss profile-id] :as params}]
(case iss (case iss
@ -70,9 +54,14 @@
:code :not-implemented :code :not-implemented
:hint "no predefined token"))) :hint "no predefined token")))
(s/def ::keys fn?)
(defmethod ig/pre-init-spec ::tokens [_]
(s/keys :req-un [::keys]))
(defmethod ig/init-key ::tokens (defmethod ig/init-key ::tokens
[_ {:keys [props] :as cfg}] [_ {:keys [keys] :as cfg}]
(let [secret (derive-tokens-secret (:secret-key props)) (let [secret (keys :salt "tokens" :size 32)
cfg (assoc cfg ::secret secret)] cfg (assoc cfg ::secret secret)]
(fn [action params] (fn [action params]
(case action (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 "A generic blob storage encoding. Mainly used for page data, page
options and txlog payload storage." options and txlog payload storage."
(:require (:require
[app.common.transit :as t]
[app.config :as cf] [app.config :as cf]
[app.util.transit :as t]
[taoensso.nippy :as n]) [taoensso.nippy :as n])
(:import (:import
java.io.ByteArrayInputStream java.io.ByteArrayInputStream
@ -108,7 +108,7 @@
cdata (byte-array mlen) cdata (byte-array mlen)
clen (Zstd/compressByteArray ^bytes cdata 0 mlen clen (Zstd/compressByteArray ^bytes cdata 0 mlen
^bytes data 0 dlen ^bytes data 0 dlen
4)] 6)]
(with-open [^ByteArrayOutputStream baos (ByteArrayOutputStream. (+ (alength cdata) 2 4)) (with-open [^ByteArrayOutputStream baos (ByteArrayOutputStream. (+ (alength cdata) 2 4))
^DataOutputStream dos (DataOutputStream. baos)] ^DataOutputStream dos (DataOutputStream. baos)]
(.writeShort dos (short 3)) ;; version number (.writeShort dos (short 3)) ;; version number

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

@ -10,13 +10,14 @@
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[cuerdas.core :as str]) [cuerdas.core :as str])
(:import (:import
java.time.Instant
java.time.Duration java.time.Duration
java.util.Date java.time.Instant
java.time.ZonedDateTime java.time.OffsetDateTime
java.time.ZoneId java.time.ZoneId
java.time.ZonedDateTime
java.time.format.DateTimeFormatter java.time.format.DateTimeFormatter
java.time.temporal.TemporalAmount java.time.temporal.TemporalAmount
java.util.Date
org.apache.logging.log4j.core.util.CronExpression)) org.apache.logging.log4j.core.util.CronExpression))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -54,28 +55,37 @@
(obj->duration ms-or-obj))) (obj->duration ms-or-obj)))
(defn duration-between (defn duration-between
{:deprecated true}
[t1 t2] [t1 t2]
(Duration/between t1 t2)) (Duration/between t1 t2))
(letfn [(conformer [v] (defn diff
(cond [t1 t2]
(duration? v) v (Duration/between t1 t2))
(string? v) (s/def ::duration
(try (s/conformer
(duration v) (fn [v]
(catch java.time.format.DateTimeParseException _e (cond
::s/invalid)) (duration? v) v
:else (string? v)
::s/invalid)) (try
(unformer [v] (duration v)
(subs (str v) 2))] (catch java.time.format.DateTimeParseException _e
(s/def ::duration (s/conformer conformer unformer))) ::s/invalid))
:else
::s/invalid))
(fn [v]
(subs (str v) 2))))
(extend-protocol clojure.core/Inst (extend-protocol clojure.core/Inst
java.time.Duration 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 (defmethod print-method Duration
[mv ^java.io.Writer writer] [mv ^java.io.Writer writer]

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

@ -436,7 +436,7 @@
(s/assert dt/cron? cron) (s/assert dt/cron? cron)
(let [now (dt/now) (let [now (dt/now)
next (dt/next-valid-instant-from cron 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 (defn- schedule-task
[{:keys [scheduler] :as cfg} {:keys [cron] :as 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 ;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-bounces-handling (ns app.bounce-handling-test
(:require (:require
[clojure.pprint :refer [pprint]]
[app.http.awsns :as awsns]
[app.emails :as emails]
[app.tests.helpers :as th]
[app.db :as db] [app.db :as db]
[app.emails :as emails]
[app.http.awsns :as awsns]
[app.test-helpers :as th]
[app.util.time :as dt] [app.util.time :as dt]
[mockery.core :refer [with-mocks]] [clojure.pprint :refer [pprint]]
[clojure.test :as t])) [clojure.test :as t]
[mockery.core :refer [with-mocks]]))
(t/use-fixtures :once th/state-init) (t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset) (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 ;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-emails (ns app.emails-test
(:require (:require
[clojure.test :as t] [clojure.test :as t]
[promesa.core :as p] [promesa.core :as p]
[app.db :as db] [app.db :as db]
[app.emails :as emails] [app.emails :as emails]
[app.tests.helpers :as th])) [app.test-helpers :as th]))
(t/use-fixtures :once th/state-init) (t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset) (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 ;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-files (ns app.services-files-test
(:require (:require
[app.common.uuid :as uuid] [app.common.uuid :as uuid]
[app.db :as db] [app.db :as db]
[app.http :as http] [app.http :as http]
[app.storage :as sto] [app.storage :as sto]
[app.tests.helpers :as th] [app.test-helpers :as th]
[app.util.time :as dt]
[clojure.test :as t] [clojure.test :as t]
[datoteka.core :as fs])) [datoteka.core :as fs]))
@ -134,7 +135,7 @@
(t/deftest file-media-gc-task (t/deftest file-media-gc-task
(letfn [(create-file-media-object [{:keys [profile-id file-id]}] (letfn [(create-file-media-object [{:keys [profile-id file-id]}]
(let [mfile {:filename "sample.jpg" (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" :content-type "image/jpeg"
:size 312043} :size 312043}
params {::th/type :upload-file-media-object params {::th/type :upload-file-media-object
@ -337,3 +338,69 @@
(t/is (th/ex-info? error)) (t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found)))) (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 ;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-fonts (ns app.services-fonts-test
(:require (:require
[app.common.uuid :as uuid] [app.common.uuid :as uuid]
[app.db :as db] [app.db :as db]
[app.http :as http] [app.http :as http]
[app.storage :as sto] [app.storage :as sto]
[app.tests.helpers :as th] [app.test-helpers :as th]
[clojure.java.io :as io] [clojure.java.io :as io]
[clojure.test :as t] [clojure.test :as t]
[datoteka.core :as fs])) [datoteka.core :as fs]))
@ -24,7 +24,7 @@
proj-id (:default-project-id prof) proj-id (:default-project-id prof)
font-id (uuid/custom 10 1) 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)) (fs/slurp-bytes))
params {::th/type :create-font-variant params {::th/type :create-font-variant
@ -59,7 +59,7 @@
proj-id (:default-project-id prof) proj-id (:default-project-id prof)
font-id (uuid/custom 10 1) 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)) (fs/slurp-bytes))
params {::th/type :create-font-variant 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 ;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-management (ns app.services-management-test
(:require (:require
[app.common.uuid :as uuid] [app.common.uuid :as uuid]
[app.db :as db] [app.db :as db]
[app.http :as http] [app.http :as http]
[app.storage :as sto] [app.storage :as sto]
[app.tests.helpers :as th] [app.test-helpers :as th]
[clojure.test :as t] [clojure.test :as t]
[buddy.core.bytes :as b] [buddy.core.bytes :as b]
[datoteka.core :as fs])) [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 ;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-media (ns app.services-media-test
(:require (:require
[app.common.uuid :as uuid] [app.common.uuid :as uuid]
[app.db :as db] [app.db :as db]
[app.storage :as sto] [app.storage :as sto]
[app.tests.helpers :as th] [app.test-helpers :as th]
[clojure.test :as t] [clojure.test :as t]
[datoteka.core :as fs])) [datoteka.core :as fs]))
@ -57,7 +57,7 @@
:project-id (:default-project-id prof) :project-id (:default-project-id prof)
:is-shared false}) :is-shared false})
mfile {:filename "sample.jpg" mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/tests/_files/sample.jpg") :tempfile (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg" :content-type "image/jpeg"
:size 312043} :size 312043}

226
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 ;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-profile (ns app.services-profile-test
(:require (: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.db :as db]
[app.rpc.mutations.profile :as profile] [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 teams
;; TODO: profile deletion with owner teams ;; TODO: profile deletion with owner teams
@ -108,7 +109,7 @@
:profile-id (:id profile) :profile-id (:id profile)
:file {:filename "sample.jpg" :file {:filename "sample.jpg"
:size 123123 :size 123123
:tempfile "tests/app/tests/_files/sample.jpg" :tempfile (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg"}} :content-type "image/jpeg"}}
out (th/mutation! data)] out (th/mutation! data)]
@ -117,7 +118,7 @@
)) ))
(t/deftest profile-deletion-simple (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) prof (th/create-profile* 1)
file (th/create-file* 1 {:profile-id (:id prof) file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof) :project-id (:default-project-id prof)
@ -125,23 +126,14 @@
;; profile is not deleted because it does not meet all ;; profile is not deleted because it does not meet all
;; conditions to be deleted. ;; conditions to be deleted.
(let [result (task {:props {:profile-id (:id prof)}})] (let [result (task {:max-age (dt/duration 0)})]
(t/is (nil? result))) (t/is (nil? result)))
;; Request profile to be deleted ;; Request profile to be deleted
(with-mocks [mock {:target 'app.worker/submit! :return nil}] (let [params {::th/type :delete-profile
(let [params {::th/type :delete-profile :profile-id (:id prof)}
:profile-id (:id prof)} out (th/mutation! params)]
out (th/mutation! params)] (t/is (nil? (:error out))))
(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))))))
;; query files after profile soft deletion ;; query files after profile soft deletion
(let [params {::th/type :files (let [params {::th/type :files
@ -153,8 +145,8 @@
(t/is (= 1 (count (:result out))))) (t/is (= 1 (count (:result out)))))
;; execute permanent deletion task ;; execute permanent deletion task
(let [result (task {:props {:profile-id (:id prof)}})] (let [result (task {:max-age (dt/duration "-1m")})]
(t/is (true? result))) (t/is (nil? result)))
;; query profile after delete ;; query profile after delete
(let [params {::th/type :profile (let [params {::th/type :profile
@ -165,17 +157,6 @@
error-data (ex-data error)] error-data (ex-data error)]
(t/is (th/ex-info? error)) (t/is (th/ex-info? error))
(t/is (= (:type error-data) :not-found)))) (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 (t/deftest registration-domain-whitelist
@ -187,126 +168,95 @@
(t/testing "not allowed email domain" (t/testing "not allowed email domain"
(t/is (false? (profile/email-domain-in-whitelist? whitelist "username@somedomain.com")))))) (t/is (false? (profile/email-domain-in-whitelist? whitelist "username@somedomain.com"))))))
(t/deftest test-register-with-no-terms-and-privacy (t/deftest prepare-register-and-register-profile
(let [data {::th/type :register-profile (let [data {::th/type :prepare-register-profile
:email "user@example.com" :email "user@example.com"
:password "foobar" :password "foobar"}
:fullname "foobar"
:terms-privacy nil}
out (th/mutation! data) out (th/mutation! data)
error (:error out) token (get-in out [:result :token])]
edata (ex-data error)] (t/is (string? token))
(t/is (th/ex-info? error))
(t/is (= (:type edata) :validation))
(t/is (= (:code edata) :spec-validation))))
(t/deftest test-register-with-bad-terms-and-privacy
(let [data {::th/type :register-profile
:email "user@example.com"
:password "foobar"
:fullname "foobar"
:terms-privacy false}
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) :invalid-terms-and-privacy))))
(t/deftest test-register-when-registration-disabled ;; try register without accepting terms
(let [data {::th/type :register-profile
:token token
:fullname "foobar"
:accept-terms-and-privacy false}
out (th/mutation! data)]
(let [error (:error out)]
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :invalid-terms-and-privacy))))
;; try register without token
(let [data {::th/type :register-profile
:fullname "foobar"
: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 (with-mocks [mock {:target 'app.config/get
:return (th/mock-config-get-with :return (th/mock-config-get-with
{:registration-enabled false})}] {: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) (let [profile (th/create-profile* 1)
data {::th/type :register-profile data {::th/type :prepare-register-profile
:email (:email profile) :email (:email profile)
:password "foobar" :password "foobar"}]
:fullname "foobar" (let [{:keys [result error] :as out} (th/mutation! data)]
: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)]
;; (th/print-result! out) ;; (th/print-result! out)
(let [mock (deref mock) (t/is (th/ex-info? error))
[params] (:call-args mock)] (t/is (th/ex-of-type? error :validation))
;; (clojure.pprint/pprint params) (t/is (th/ex-of-code? error :email-already-exists)))))
(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/deftest test-register-profile-with-bounced-email (t/deftest test-register-profile-with-bounced-email
(with-mocks [mock {:target 'app.emails/send! (let [pool (:app.db/pool th/*system*)
:return nil}] data {::th/type :prepare-register-profile
(let [pool (:app.db/pool th/*system*) :email "user@example.com"
data {::th/type :register-profile :password "foobar"}]
: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)
(let [mock (deref mock)] (th/create-global-complaint-for pool {:type :bounce :email "user@example.com"})
(t/is (false? (:called? mock))))
(let [error (:error out) (let [{:keys [result error] :as out} (th/mutation! data)]
edata (ex-data error)] (t/is (th/ex-info? error))
(t/is (th/ex-info? error)) (t/is (th/ex-of-type? error :validation))
(t/is (= (:type edata) :validation)) (t/is (th/ex-of-code? error :email-has-permanent-bounces)))))
(t/is (= (:code edata) :email-has-permanent-bounces))))))
(t/deftest test-register-profile-with-complained-email (t/deftest test-register-profile-with-complained-email
(with-mocks [mock {:target 'app.emails/send! :return nil}] (let [pool (:app.db/pool th/*system*)
(let [pool (:app.db/pool th/*system*) data {::th/type :prepare-register-profile
data {::th/type :register-profile :email "user@example.com"
:email "user@example.com" :password "foobar"}]
:password "foobar"
:fullname "foobar"
:terms-privacy true}
_ (th/create-global-complaint-for pool {:type :complaint :email "user@example.com"})
out (th/mutation! data)]
(let [mock (deref mock)] (th/create-global-complaint-for pool {:type :complaint :email "user@example.com"})
(t/is (true? (:called? mock)))) (let [{:keys [result error] :as out} (th/mutation! data)]
(t/is (nil? error))
(let [result (:result out)] (t/is (string? (:token result))))))
(t/is (= (:email data) (:email result)))))))
(t/deftest test-email-change-request (t/deftest test-email-change-request
(with-mocks [email-send-mock {:target 'app.emails/send! :return nil} (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 ;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-projects (ns app.services-projects-test
(:require (:require
[clojure.test :as t] [app.common.uuid :as uuid]
[promesa.core :as p]
[app.db :as db] [app.db :as db]
[app.http :as http] [app.http :as http]
[app.tests.helpers :as th] [app.test-helpers :as th]
[app.common.uuid :as uuid])) [app.util.time :as dt]
[clojure.test :as t]))
(t/use-fixtures :once th/state-init) (t/use-fixtures :once th/state-init)
(t/use-fixtures :each th/database-reset) (t/use-fixtures :each th/database-reset)
@ -170,3 +170,71 @@
(t/is (th/ex-info? error)) (t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :not-found)))) (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 ;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-teams (ns app.services-teams-test
(:require (:require
[app.common.uuid :as uuid] [app.common.uuid :as uuid]
[app.db :as db] [app.db :as db]
[app.http :as http] [app.http :as http]
[app.storage :as sto] [app.storage :as sto]
[app.tests.helpers :as th] [app.test-helpers :as th]
[mockery.core :refer [with-mocks]] [app.util.time :as dt]
[clojure.test :as t] [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 :once th/state-init)
(t/use-fixtures :each th/database-reset) (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 ;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-services-viewer (ns app.services-viewer-test
(:require (:require
[clojure.test :as t]
[datoteka.core :as fs]
[app.common.uuid :as uuid] [app.common.uuid :as uuid]
[app.db :as db] [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 :once th/state-init)
(t/use-fixtures :each th/database-reset) (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 ;; Copyright (c) UXBOX Labs SL
(ns app.tests.test-storage (ns app.storage-test
(:require (:require
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.db :as db] [app.db :as db]
[app.storage :as sto] [app.storage :as sto]
[app.tests.helpers :as th] [app.test-helpers :as th]
[app.util.time :as dt] [app.util.time :as dt]
[clojure.java.io :as io] [clojure.java.io :as io]
[clojure.test :as t] [clojure.test :as t]
@ -22,7 +22,6 @@
th/database-reset th/database-reset
th/clean-storage)) th/clean-storage))
;; TODO: add specific tests for DB backend.
(t/deftest put-and-retrieve-object (t/deftest put-and-retrieve-object
(let [storage (:app.storage/storage th/*system*) (let [storage (:app.storage/storage th/*system*)
@ -106,7 +105,7 @@
:project-id (:default-project-id prof) :project-id (:default-project-id prof)
:is-shared false}) :is-shared false})
mfile {:filename "sample.jpg" mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/tests/_files/sample.jpg") :tempfile (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg" :content-type "image/jpeg"
:size 312043} :size 312043}
@ -167,7 +166,7 @@
:project-id (:default-project-id prof) :project-id (:default-project-id prof)
:is-shared false}) :is-shared false})
mfile {:filename "sample.jpg" mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/tests/_files/sample.jpg") :tempfile (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg" :content-type "image/jpeg"
:size 312043} :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 ;; Copyright (c) UXBOX Labs SL
(ns app.tests.helpers (ns app.test-helpers
(:require (:require
[app.common.data :as d] [app.common.data :as d]
[app.common.pages :as cp] [app.common.pages :as cp]

4
backend/tests.edn
View file

@ -1,5 +1,5 @@
#kaocha/v1 #kaocha/v1
{:tests {:tests
[{:id :unit [{:id :unit
:test-paths ["tests" "src"] :test-paths ["test" "src"]
:ns-patterns ["test-.*"]}]} :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 #?(:cljs
(:require-macros [app.common.data])) (:require-macros [app.common.data]))
(:require (:require
[linked.set :as lks]
[app.common.math :as mth] [app.common.math :as mth]
[cljs.analyzer.api :as aapi]
[clojure.set :as set] [clojure.set :as set]
#?(:clj [cljs.analyzer.api :as aapi]) [cuerdas.core :as str]
#?(:cljs [cljs.reader :as r] #?(:cljs [cljs.reader :as r]
:clj [clojure.edn :as r]) :clj [clojure.edn :as r])
#?(:cljs [cljs.core :as core] #?(:cljs [cljs.core :as core]
:clj [clojure.core :as core])) :clj [clojure.core :as core])
[linked.set :as lks])
#?(:clj #?(:clj
(:import linked.set.LinkedSet))) (:import linked.set.LinkedSet)))
@ -274,7 +276,7 @@
;; Data Parsing / Conversion ;; Data Parsing / Conversion
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- nan? (defn nan?
[v] [v]
(not= v v)) (not= v v))
@ -456,13 +458,18 @@
kw (if (keyword? kw) (name kw) kw)] kw (if (keyword? kw) (name kw) kw)]
(keyword (str prefix kw)))) (keyword (str prefix kw))))
(defn tap (defn tap
"Simpilar to the tap in rxjs but for plain collections" "Simpilar to the tap in rxjs but for plain collections"
[f coll] [f coll]
(f coll) (f coll)
coll) coll)
(defn tap-r
"Same but with args reversed, for -> threads"
[coll f]
(f coll)
coll)
(defn map-diff (defn map-diff
"Given two maps returns the diff of its attributes in a map where "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 the keys will be the attributes that change and the values the previous
@ -478,12 +485,11 @@
:var [2 nil]} :var [2 nil]}
:d [nil 10] } :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] [m1 m2]
(let [m1ks (keys m1) (let [m1ks (set (keys m1))
m2ks (keys m2) m2ks (set (keys m2))
keys (set/union m1ks m2ks) keys (set/union m1ks m2ks)
diff-attr diff-attr
@ -503,3 +509,65 @@
(->> keys (->> keys
(reduce diff-attr {})))) (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)) (assoc-in stack [:items index] value))
(defn undo (defn undo
[{index :index items :items :as stack}] [stack]
(update stack :index dec)) (update stack :index dec))
(defn redo (defn redo
@ -56,5 +56,5 @@
(update :index inc))) (update :index inc)))
(defn size (defn size
[{index :index items :items :as stack}] [{index :index :as stack}]
(inc index)) (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 (ns app.common.geom.align
(:require (:require
[clojure.spec.alpha :as s] [app.common.data :as d]
[app.common.geom.shapes :as gsh] [app.common.geom.shapes :as gsh]
[app.common.data :as d])) [clojure.spec.alpha :as s]))
;; --- Alignment ;; --- Alignment

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

@ -8,10 +8,9 @@
(:require (:require
#?(:cljs [cljs.pprint :as pp] #?(:cljs [cljs.pprint :as pp]
:clj [clojure.pprint :as pp]) :clj [clojure.pprint :as pp])
[cuerdas.core :as str]
[app.common.data :as d] [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 ;; --- Matrix Impl
@ -27,6 +26,15 @@
([a b c d e f] ([a b c d e f]
(Matrix. 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 (defn multiply
([{m1a :a m1b :b m1c :c m1d :d m1e :e m1f :f} ([{m1a :a m1b :b m1c :c m1d :d m1e :e m1f :f}
{m2a :a m2b :b m2c :c m2d :d m2e :e m2f :f}] {m2a :a m2b :b m2c :c m2d :d m2e :e m2f :f}]
@ -40,6 +48,21 @@
([m1 m2 & others] ([m1 m2 & others]
(reduce multiply (multiply 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 (defn substract
[{m1a :a m1b :b m1c :c m1d :d m1e :e m1f :f} [{m1a :a m1b :b m1c :c m1d :d m1e :e m1f :f}
{m2a :a m2b :b m2c :c m2d :d m2e :e m2f :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 (ns app.common.geom.shapes
(:require (:require
[app.common.data :as d] [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.point :as gpt]
[app.common.geom.shapes.common :as gco] [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.path :as gsp]
[app.common.geom.shapes.rect :as gpr] [app.common.geom.shapes.rect :as gpr]
[app.common.geom.shapes.transforms :as gtr] [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}))
;; --- Setup (Initialize) ;; --- Setup (Initialize)
;; FIXME: Is this the correct place for these functions? ;; FIXME: Is this the correct place for these functions?
@ -101,6 +62,10 @@
[shape {:keys [x y]}] [shape {:keys [x y]}]
(gtr/move shape (gpt/negate (gpt/point 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 ;; --- Helpers
(defn fully-contained? (defn fully-contained?
@ -161,15 +126,6 @@
(assoc :selrect selrect (assoc :selrect selrect
:points points)))) :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 ;; EXPORTS
(d/export gco/center-shape) (d/export gco/center-shape)
@ -184,16 +140,20 @@
(d/export gpr/points->rect) (d/export gpr/points->rect)
(d/export gpr/center->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/transform-matrix)
(d/export gtr/inverse-transform-matrix) (d/export gtr/inverse-transform-matrix)
(d/export gtr/transform-point-center) (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-points)
(d/export gtr/transform-rect)
(d/export gtr/calculate-adjust-matrix) (d/export gtr/calculate-adjust-matrix)
(d/export gtr/move) (d/export gtr/update-group-selrect)
(d/export gtr/absolute-move) (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 ;; PATHS
(d/export gsp/content->points) (d/export gsp/content->points)
@ -204,3 +164,4 @@
(d/export gin/overlaps?) (d/export gin/overlaps?)
(d/export gin/has-point?) (d/export gin/has-point?)
(d/export gin/has-point-rect?) (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

42
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 (ns app.common.geom.shapes.intersect
(:require (:require
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.common.geom.matrix :as gmt] [app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.geom.shapes.path :as gpp] [app.common.geom.shapes.path :as gpp]
[app.common.geom.shapes.rect :as gpr] [app.common.geom.shapes.rect :as gpr]
[app.common.math :as mth])) [app.common.math :as mth]))
@ -113,11 +112,10 @@
;; Even-odd algorithm ;; Even-odd algorithm
;; Cast a ray from the point in any direction and count the intersections ;; Cast a ray from the point in any direction and count the intersections
;; if it's odd the point is inside the polygon ;; if it's odd the point is inside the polygon
(let [] (->> lines
(->> lines (filter #(intersect-ray? p %))
(filter #(intersect-ray? p %)) (count)
(count) (odd?)))
(odd?))))
(defn- next-windup (defn- next-windup
"Calculates the next windup number for the nonzero algorithm" "Calculates the next windup number for the nonzero algorithm"
@ -173,7 +171,7 @@
(defn overlaps-path? (defn overlaps-path?
"Checks if the given rect overlaps with the path in any point" "Checks if the given rect overlaps with the path in any point"
[shape rect] [shape rect]
(let [;; If paths are too complex the intersection is too expensive (let [;; If paths are too complex the intersection is too expensive
;; we fallback to check its bounding box otherwise the performance penalty ;; we fallback to check its bounding box otherwise the performance penalty
;; is too big ;; is too big
@ -186,7 +184,7 @@
(points->lines (:points shape)) (points->lines (:points shape))
(gpp/path->lines shape)) (gpp/path->lines shape))
start-point (-> shape :content (first) :params (gpt/point))] start-point (-> shape :content (first) :params (gpt/point))]
(or (is-point-inside-nonzero? (first rect-points) path-lines) (or (is-point-inside-nonzero? (first rect-points) path-lines)
(is-point-inside-nonzero? start-point rect-lines) (is-point-inside-nonzero? start-point rect-lines)
(intersects-lines? rect-lines path-lines)))) (intersects-lines? rect-lines path-lines))))
@ -197,14 +195,14 @@
(let [center (gpt/point cx cy) (let [center (gpt/point cx cy)
transform (gmt/transform-in center transform) 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 ;; Ellipse inequality formula
;; https://en.wikipedia.org/wiki/Ellipse#Shifted_ellipse ;; https://en.wikipedia.org/wiki/Ellipse#Shifted_ellipse
(let [v (+ (/ (mth/sq (- px cx)) v (+ (/ (mth/sq (- px cx))
(mth/sq rx)) (mth/sq rx))
(/ (mth/sq (- py cy)) (/ (mth/sq (- py cy))
(mth/sq ry)))] (mth/sq ry)))]
(<= v 1)))) (<= v 1)))
(defn intersects-line-ellipse? (defn intersects-line-ellipse?
"Checks wether a single line intersects with the given ellipse" "Checks wether a single line intersects with the given ellipse"
@ -272,13 +270,13 @@
center (gpt/point (+ x (/ width 2)) center (gpt/point (+ x (/ width 2))
(+ y (/ height 2))) (+ y (/ height 2)))
ellipse-data {:cx (:x center) ellipse-data {:cx (:x center)
:cy (:y center) :cy (:y center)
:rx (/ width 2) :rx (/ width 2)
:ry (/ height 2) :ry (/ height 2)
:transform (:transform-inverse shape)}] :transform (:transform-inverse shape)}]
(or (is-point-inside-evenodd? center rect-lines) (or (is-point-inside-evenodd? center rect-lines)
(is-point-inside-ellipse? (first rect-points) ellipse-data) (is-point-inside-ellipse? (first rect-points) ellipse-data)
(intersects-lines-ellipse? rect-lines ellipse-data)))) (intersects-lines-ellipse? rect-lines ellipse-data))))
@ -304,3 +302,9 @@
(let [lines (points->lines (:points shape))] (let [lines (points->lines (:points shape))]
;; TODO: Will only work for simple shapes ;; TODO: Will only work for simple shapes
(is-point-inside-evenodd? point lines))) (is-point-inside-evenodd? point lines)))
(defn rect-contains-shape?
[rect shape]
(->> shape
:points
(every? (partial has-point-rect? rect))))

13
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 (ns app.common.geom.shapes.path
(:require (:require
[app.common.data :as d]
[app.common.geom.point :as gpt] [app.common.geom.point :as gpt]
[app.common.geom.shapes.rect :as gpr] [app.common.geom.shapes.rect :as gpr]
[app.common.math :as mth] [app.common.math :as mth]))
[app.common.data :as d]))
(defn content->points [content] (defn content->points [content]
(->> content (->> content
@ -79,7 +79,7 @@
;; When the term a is close to zero we have a linear equation ;; When the term a is close to zero we have a linear equation
[(/ (- c) b)] [(/ (- c) b)]
;; If a is not close to zero return the two roots for a cuadratic ;; If a is not close to zero return the two roots for a cuadratic
(not (mth/almost-zero? a)) (not (mth/almost-zero? a))
[(/ (+ (- b) sqrt-b2-4ac) [(/ (+ (- b) sqrt-b2-4ac)
(* 2 a)) (* 2 a))
@ -156,7 +156,8 @@
(mapv #(update % :params transform-params) content))) (mapv #(update % :params transform-params) content)))
(defn transform-content [content transform] (defn transform-content
[content transform]
(let [set-tr (fn [params px py] (let [set-tr (fn [params px py]
(let [tr-point (-> (gpt/point (get params px) (get params py)) (let [tr-point (-> (gpt/point (get params px) (get params py))
(gpt/transform transform))] (gpt/transform transform))]
@ -267,7 +268,7 @@
(and (< (d ht) (d t1)) (< (d ht) (d t2))) (and (< (d ht) (d t1)) (< (d ht) (d t2)))
[ht1 ht2] [ht1 ht2]
(< (d t1) (d t2)) (< (d t1) (d t2))
[t1 ht] [t1 ht]
@ -324,7 +325,7 @@
(if (and (some? acc) (or (not cur) (<= min-dist cur-dist))) (if (and (some? acc) (or (not cur) (<= min-dist cur-dist)))
[min-p min-dist] [min-p min-dist]
[cur-p cur-dist]))] [cur-p cur-dist]))]
(->> (:content shape) (->> (:content shape)
(d/with-prev) (d/with-prev)
(map point+distance) (map point+distance)

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