3pp-mirror/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-05-29 06:26:12 +02:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'staging'

Browse source
This commit is contained in:
Andrey Antukh 2022-03-01 11:10:27 +01:00
commit fae79d67e6
332 changed files with 12392 additions and 6659 deletions
Download patch file Download diff file Expand all files Collapse all files

51
.github/ISSUE_TEMPLATE/bug_report.md vendored
View file

@ -8,49 +8,48 @@ assignees: ''
---
**Describe the bug**
A clear and concise description of what the bug is.
**To Reproduce**
Steps to reproduce the behavior:
1. Go to '...'
2. Click on '....'
3. Scroll down to '....'
4. See error
**Expected behavior**
A clear and concise description of what you expected to happen.
**Actual behavior**
A clear and concise description of what happens instead; what the bug is.
**Screenshots**
If applicable, add screenshots to help explain your problem.
**Desktop (please complete the following information):**
- OS: (e.g. iOS)
- Browser (e.g. chrome, safari)
- Version (e.g. 22)
- OS (e.g. iOS):
- Browser & version (e.g. Chrome 89.0):
**Smartphone (please complete the following information):**
- Device: (e.g. iPhone6)
- OS: (e.g. iOS8.1)
- Browser (e.g. stock browser, safari)
- Version (e.g. 22)
- Device & model (e.g. iPhone 6):
- OS & version (e.g. iOS 8.1):
- Browser & version (e.g. stock browser 22):
**Environment (please complete the following information):**
Specify if using SAAS (https://design.penpot.app) or self-hosted instance.
- Host (e.g. https://design.penpot.app, local instance):
If self-hosted instance, add OS and runtime information to help explain your problem.
*If self-hosted:*
- OS Version (e.g. Ubuntu 16.04):
- Docker / Docker-compose version (e.g. Docker version 18.03.0-ce, build 0520e24):
- Image version (e.g. Alpine):
- OS Version: (e.g. Ubuntu 16.04)
Docker commands or docker-compose file (if possible and if proceed.x):
```
Also provide Docker commands or docker-compose file if possible and if proceed.x
- Docker / Docker-compose Version: (e.g. Docker version 18.03.0-ce, build 0520e24)
- Image (e.g. alpine)
**Frontend Stack Trace (if self-hosted)**
```
Frontend Stack Trace:
<details>
```
@ -59,8 +58,7 @@ Also provide Docker commands or docker-compose file if possible and if proceed.x
</details>
**Backend Stack Trace (if self-hosted)**
Backend Stack Trace:
<details>
```
@ -69,5 +67,6 @@ Also provide Docker commands or docker-compose file if possible and if proceed.x
</details>
**Additional context**
Add any other context about the problem here.
**Additional context:**
Any other context about the problem.

4
.gitignore vendored
View file

@ -1,6 +1,7 @@
*-init.clj
*.jar
*.penpot
*.orig
.calva
.clj-kondo
.cpcache
@ -33,13 +34,16 @@
/exporter/.shadow-cljs
/exporter/target
/frontend/.shadow-cljs
/frontend/package-lock.json
/frontend/cypress/videos/*/
/frontend/cypress/fixtures/validuser.json
/frontend/dist/
/frontend/npm-debug.log
/frontend/out/
/frontend/resources/fonts/experiments
/frontend/resources/public/*
/frontend/target/
/frontend/cypress/videos/*/
/media
/telemetry/
/vendor/**/target

61
CHANGES.md
View file

@ -1,5 +1,52 @@
# CHANGELOG
## 1.12.0-beta
### :boom: Breaking changes
### :sparkles: New features
- Open feedback in a new window [Taiga #2901](https://tree.taiga.io/project/penpot/us/2901)
- Improve usage of file menu [Taiga #2853](https://tree.taiga.io/project/penpot/us/2853)
- Rotation to snap to 15º intervals with shift [Taiga #2437](https://tree.taiga.io/project/penpot/issue/2437)
- Support border radius and stroke properties for images [Taiga #497](https://tree.taiga.io/project/penpot/us/497)
- Disallow using same password as user email [Taiga #2454](https://tree.taiga.io/project/penpot/us/2454)
- Add configurable nudge amount [Taiga #910](https://tree.taiga.io/project/penpot/us/910)
- Add stroke properties for image shapes [Taiga #497](https://tree.taiga.io/project/penpot/us/497)
- On user settings, hide the theme selector as long as we only have one theme [Taiga #2610](https://tree.taiga.io/project/penpot/us/2610)
- Automatically open comments from dashboard notifications [Taiga #2605](https://tree.taiga.io/project/penpot/us/2605)
- Enhance the behaviour of the artboards list on view mode [Taiga #2634](https://tree.taiga.io/project/penpot/us/2634)
- Add recent used fonts in font selection widget [Taiga #1381](https://tree.taiga.io/project/penpot/us/1381)
- Allow to align items relative to groups [Taiga #2533](https://tree.taiga.io/project/penpot/us/2533)
- Scroll bars [Taiga #2550](https://tree.taiga.io/project/penpot/task/2550)
- Add select layer option to context menu [Taiga #2474](https://tree.taiga.io/project/penpot/us/2474)
- Guides [Taiga #290](https://tree.taiga.io/project/penpot/us/290)
- Improve file menu by adding semantically groups [Github #1203](https://github.com/penpot/penpot/issues/1203)
- Add update components in bulk option in context menu [Taiga #1975](https://tree.taiga.io/project/penpot/us/1975)
- Create first E2E tests [Taiga #2608](https://tree.taiga.io/project/penpot/task/2608), [Taiga #2608](https://tree.taiga.io/project/penpot/task/2608)
- Redesign of workspace toolbars [Taiga #2319](https://tree.taiga.io/project/penpot/us/2319)
- Graphic Tablet usability improvements [Taiga #1913](https://tree.taiga.io/project/penpot/us/1913)
- Improved mouse collision detection for groups and text shapes [Taiga #2452](https://tree.taiga.io/project/penpot/us/2452), [Taiga #2453](https://tree.taiga.io/project/penpot/us/2453)
- Add support for alternative S3 storage providers and all aws regions [#1267](https://github.com/penpot/penpot/issues/1267)
### :bug: Bugs fixed
- Fixed ungroup typography when editing it [Taiga #2391](https://tree.taiga.io/project/penpot/issue/2391)
- Fixed error when trying to post an empty comment [Taiga #2603](https://tree.taiga.io/project/penpot/issue/2603)
- Fixed missing translation strings [Taiga #2786](https://tree.taiga.io/project/penpot/issue/2786)
- Fixed color palette outside viewport [Taiga #2715](https://tree.taiga.io/project/penpot/issue/2715)
- Fixed missing translate string [Taiga #2780](https://tree.taiga.io/project/penpot/issue/2780)
- Fixed handoff shadow type text [Taiga #2717](https://tree.taiga.io/project/penpot/issue/2717)
- Fixed components get "dirty" marker when moved [Taiga #2764](https://tree.taiga.io/project/penpot/issue/2764)
- Fixed cannot align objects in a group that is not part of a frame [Taiga #2762](https://tree.taiga.io/project/penpot/issue/2762)
- Fix problem with double click on exit path editing [Taiga #2906](https://tree.taiga.io/project/penpot/issue/2906)
- Fixed alignment of layers with children [Taiga #2862](https://tree.taiga.io/project/penpot/issue/2862)
### :heart: Community contributions by (Thank you!)
- Cleanup unused static images (by @rhcarvalho) [#1561](https://github.com/penpot/penpot/pull/1561)
- Compress static images to save space (by @rhcarvalho) [#1562](https://github.com/penpot/penpot/pull/1562)
## 1.11.2-beta
### :bug: Bugs fixed
@ -18,7 +65,6 @@
- Increase default max connection pool size to 60
- Reduce resource usage of the error reporter.
## 1.11.1-beta
### :bug: Bugs fixed
@ -30,11 +76,8 @@
- Update nodejs version to 16.13.1 on docker images.
## 1.11.0-beta
### :boom: Breaking changes
### :sparkles: New features
- Add an option to hide artboards names on the viewport [Taiga #2034](https://tree.taiga.io/project/penpot/issue/2034)
@ -112,7 +155,7 @@
### :arrow_up: Deps updates
- Update devenv docker image dependencies.
- Update devenv docker image dependencies
### :heart: Community contributions by (Thank you!)
@ -124,13 +167,13 @@
### :sparkles: Enhacements
- Allow parametrice file snapshoting interval.
- Allow parametrice file snapshoting interval
### :bug: Bugs fixed
- Fix issue on :mov-object change impl.
- Minor fix on how file changes log is persisted.
- Fix many issues on error reporting.
- Fix issue on :mov-object change impl
- Minor fix on how file changes log is persisted
- Fix many issues on error reporting
## 1.10.3-beta

15
backend/deps.edn
View file

@ -6,7 +6,7 @@
org.zeromq/jeromq {:mvn/version "0.5.2"}
com.taoensso/nippy {:mvn/version "3.1.1"}
com.github.luben/zstd-jni {:mvn/version "1.5.1-1"}
com.github.luben/zstd-jni {:mvn/version "1.5.2-1"}
org.clojure/data.fressian {:mvn/version "1.0.0"}
io.prometheus/simpleclient {:mvn/version "0.14.1"}
@ -25,7 +25,7 @@
com.github.seancorfield/next.jdbc {:mvn/version "1.2.761"}
metosin/reitit-ring {:mvn/version "0.5.15"}
org.postgresql/postgresql {:mvn/version "42.3.1"}
org.postgresql/postgresql {:mvn/version "42.3.2"}
com.zaxxer/HikariCP {:mvn/version "5.0.1"}
funcool/datoteka {:mvn/version "2.0.0"}
@ -39,11 +39,11 @@
org.clojars.pntblnk/clj-ldap {:mvn/version "0.0.17"}
integrant/integrant {:mvn/version "0.8.0"}
io.sentry/sentry {:mvn/version "5.5.2"}
io.sentry/sentry {:mvn/version "5.6.1"}
;; Pretty Print specs
pretty-spec/pretty-spec {:mvn/version "0.1.4"}
software.amazon.awssdk/s3 {:mvn/version "2.17.111"}}
software.amazon.awssdk/s3 {:mvn/version "2.17.122"}}
:paths ["src" "resources" "target/classes"]
:aliases
@ -59,13 +59,10 @@
:extra-paths ["test" "dev"]}
:build
{:extra-deps {io.github.clojure/tools.build {:git/tag "v0.7.4" :git/sha "ac442da"}}
{:extra-deps
{io.github.clojure/tools.build {:git/tag "v0.7.5" :git/sha "34727f7"}}
:ns-default build}
:kaocha
{:extra-deps {lambdaisland/kaocha {:mvn/version "RELEASE"}}
:main-opts ["-m" "kaocha.runner"]}
:test
{:extra-paths ["test"]
:extra-deps

1
backend/dev/user.clj
View file

@ -6,6 +6,7 @@
(ns user
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.geom.matrix :as gmt]
[app.common.perf :as perf]

12
backend/scripts/repl
View file

@ -10,6 +10,18 @@
# export PENPOT_DATABASE_PASSWORD="penpot_pre"
# export PENPOT_FLAGS="enable-asserts enable-audit-log $PENPOT_FLAGS"
# Initialize MINIO config
# mc alias set penpot-s3/ http://minio:9000 minioadmin minioadmin
# mc admin user add penpot-s3 penpot-devenv penpot-devenv
# mc admin policy set penpot-s3 readwrite user=penpot-devenv
# mc mb penpot-s3/penpot -p
# export AWS_ACCESS_KEY_ID=penpot-devenv
# export AWS_SECRET_ACCESS_KEY=penpot-devenv
# export PENPOT_ASSETS_STORAGE_BACKEND=assets-s3
# export PENPOT_STORAGE_ASSETS_S3_ENDPOINT=http://minio:9000
# export PENPOT_STORAGE_ASSETS_S3_REGION=eu-central-1
# export PENPOT_STORAGE_ASSETS_S3_BUCKET=penpot
export OPTIONS="
-A:dev \
-J-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager \

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

@ -41,9 +41,7 @@
data))
(def defaults
{:http-server-port 6060
:http-server-host "0.0.0.0"
:host "devenv"
{:host "devenv"
:tenant "dev"
:database-uri "postgresql://postgres/penpot"
:database-username "penpot"
@ -106,12 +104,21 @@
(s/def ::file-change-snapshot-every ::us/integer)
(s/def ::file-change-snapshot-timeout ::dt/duration)
(s/def ::default-executor-parallelism ::us/integer)
(s/def ::blocking-executor-parallelism ::us/integer)
(s/def ::worker-executor-parallelism ::us/integer)
(s/def ::secret-key ::us/string)
(s/def ::allow-demo-users ::us/boolean)
(s/def ::assets-path ::us/string)
(s/def ::authenticated-cookie-domain ::us/string)
(s/def ::database-password (s/nilable ::us/string))
(s/def ::database-uri ::us/string)
(s/def ::database-username (s/nilable ::us/string))
(s/def ::database-readonly ::us/boolean)
(s/def ::database-min-pool-size ::us/integer)
(s/def ::database-max-pool-size ::us/integer)
(s/def ::default-blob-version ::us/integer)
(s/def ::error-report-webhook ::us/string)
(s/def ::user-feedback-destination ::us/string)
@ -134,6 +141,8 @@
(s/def ::host ::us/string)
(s/def ::http-server-port ::us/integer)
(s/def ::http-server-host ::us/string)
(s/def ::http-server-min-threads ::us/integer)
(s/def ::http-server-max-threads ::us/integer)
(s/def ::http-session-idle-max-age ::dt/duration)
(s/def ::http-session-updater-batch-max-age ::dt/duration)
(s/def ::http-session-updater-batch-max-size ::us/integer)
@ -179,9 +188,11 @@
(s/def ::storage-assets-fs-directory ::us/string)
(s/def ::storage-assets-s3-bucket ::us/string)
(s/def ::storage-assets-s3-region ::us/keyword)
(s/def ::storage-assets-s3-endpoint ::us/string)
(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 ::storage-fdata-s3-endpoint ::us/string)
(s/def ::telemetry-uri ::us/string)
(s/def ::telemetry-with-taiga ::us/boolean)
(s/def ::tenant ::us/string)
@ -198,11 +209,18 @@
::allow-demo-users
::audit-log-archive-uri
::audit-log-gc-max-age
::authenticated-cookie-domain
::database-password
::database-uri
::database-username
::database-readonly
::database-min-pool-size
::database-max-pool-size
::default-blob-version
::error-report-webhook
::default-executor-parallelism
::blocking-executor-parallelism
::worker-executor-parallelism
::file-change-snapshot-every
::file-change-snapshot-timeout
::user-feedback-destination
@ -225,6 +243,8 @@
::host
::http-server-host
::http-server-port
::http-server-max-threads
::http-server-min-threads
::http-session-idle-max-age
::http-session-updater-batch-max-age
::http-session-updater-batch-max-size
@ -274,10 +294,12 @@
::storage-assets-fs-directory
::storage-assets-s3-bucket
::storage-assets-s3-region
::storage-assets-s3-endpoint
::fdata-storage-backend
::storage-fdata-s3-bucket
::storage-fdata-s3-region
::storage-fdata-s3-prefix
::storage-fdata-s3-endpoint
::telemetry-enabled
::telemetry-uri
::telemetry-referer

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

@ -47,13 +47,12 @@
;; Initialization
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare instrument-jdbc!)
(declare apply-migrations!)
(s/def ::connection-timeout ::us/integer)
(s/def ::max-pool-size ::us/integer)
(s/def ::max-size ::us/integer)
(s/def ::min-size ::us/integer)
(s/def ::migrations map?)
(s/def ::min-pool-size ::us/integer)
(s/def ::name keyword?)
(s/def ::password ::us/string)
(s/def ::read-only ::us/boolean)
@ -62,38 +61,49 @@
(s/def ::validation-timeout ::us/integer)
(defmethod ig/pre-init-spec ::pool [_]
(s/keys :req-un [::uri ::name ::username ::password]
:opt-un [::min-pool-size
::max-pool-size
(s/keys :req-un [::uri ::name
::min-size
::max-size
::connection-timeout
::validation-timeout
::migrations
::validation-timeout]
:opt-un [::migrations
::username
::password
::mtx/metrics
::read-only]))
(defmethod ig/prep-key ::pool
[_ cfg]
(merge {:name :main
:min-size 0
:max-size 30
:connection-timeout 10000
:validation-timeout 10000
:idle-timeout 120000 ; 2min
:max-lifetime 1800000 ; 30m
:read-only false}
(d/without-nils cfg)))
(defmethod ig/init-key ::pool
[_ {:keys [migrations metrics name] :as cfg}]
(l/info :action "initialize connection pool" :name (d/name name) :uri (:uri cfg))
(some-> metrics :registry instrument-jdbc!)
[_ {:keys [migrations name read-only] :as cfg}]
(l/info :hint "initialize connection pool"
:name (d/name name)
:uri (:uri cfg)
:read-only read-only
:with-credentials (and (contains? cfg :username)
(contains? cfg :password))
:min-size (:min-size cfg)
:max-size (:max-size cfg))
(let [pool (create-pool cfg)]
(some->> (seq migrations) (apply-migrations! pool))
(when-not read-only
(some->> (seq migrations) (apply-migrations! pool)))
pool))
(defmethod ig/halt-key! ::pool
[_ pool]
(.close ^HikariDataSource pool))
(defn- instrument-jdbc!
[registry]
(mtx/instrument-vars!
[#'next.jdbc/execute-one!
#'next.jdbc/execute!]
{:registry registry
:type :counter
:name "database_query_total"
:help "An absolute counter of database queries."}))
(defn- apply-migrations!
[pool migrations]
(with-open [conn ^AutoCloseable (open pool)]
@ -110,22 +120,19 @@
"SET idle_in_transaction_session_timeout = 300000;"))
(defn- create-datasource-config
[{:keys [metrics read-only] :or {read-only false} :as cfg}]
(let [dburi (:uri cfg)
username (:username cfg)
password (:password cfg)
config (HikariConfig.)]
[{:keys [metrics uri] :as cfg}]
(let [config (HikariConfig.)]
(doto config
(.setJdbcUrl (str "jdbc:" dburi))
(.setJdbcUrl (str "jdbc:" uri))
(.setPoolName (d/name (:name cfg)))
(.setAutoCommit true)
(.setReadOnly read-only)
(.setConnectionTimeout (:connection-timeout cfg 10000)) ;; 10seg
(.setValidationTimeout (:validation-timeout cfg 10000)) ;; 10seg
(.setIdleTimeout 120000) ;; 2min
(.setMaxLifetime 1800000) ;; 30min
(.setMinimumIdle (:min-pool-size cfg 0))
(.setMaximumPoolSize (:max-pool-size cfg 50))
(.setReadOnly (:read-only cfg))
(.setConnectionTimeout (:connection-timeout cfg))
(.setValidationTimeout (:validation-timeout cfg))
(.setIdleTimeout (:idle-timeout cfg))
(.setMaxLifetime (:max-lifetime cfg))
(.setMinimumIdle (:min-size cfg))
(.setMaximumPoolSize (:max-size cfg))
(.setConnectionInitSql initsql)
(.setInitializationFailTimeout -1))
@ -135,8 +142,8 @@
(PrometheusMetricsTrackerFactory.)
(.setMetricsTrackerFactory config)))
(when username (.setUsername config username))
(when password (.setPassword config password))
(some->> ^String (:username cfg) (.setUsername config))
(some->> ^String (:password cfg) (.setPassword config))
config))
@ -146,10 +153,14 @@
(s/def ::pool pool?)
(defn pool-closed?
(defn closed?
[pool]
(.isClosed ^HikariDataSource pool))
(defn read-only?
[pool]
(.isReadOnly ^HikariDataSource pool))
(defn create-pool
[cfg]
(let [dsc (create-datasource-config cfg)]

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

@ -10,6 +10,7 @@
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.config :as cf]
[app.http.doc :as doc]
[app.http.errors :as errors]
[app.http.middleware :as middleware]
@ -24,19 +25,30 @@
(declare wrap-router)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HTTP SERVER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::handler fn?)
(s/def ::router some?)
(s/def ::port ::us/integer)
(s/def ::host ::us/string)
(s/def ::name ::us/string)
(defmethod ig/pre-init-spec ::server [_]
(s/keys :req-un [::port]
:opt-un [::name ::mtx/metrics ::router ::handler ::host]))
(s/def ::max-threads ::cf/http-server-max-threads)
(s/def ::min-threads ::cf/http-server-min-threads)
(defmethod ig/prep-key ::server
[_ cfg]
(merge {:name "http"} (d/without-nils cfg)))
(merge {:name "http"
:min-threads 4
:max-threads 60
:port 6060
:host "0.0.0.0"}
(d/without-nils cfg)))
(defmethod ig/pre-init-spec ::server [_]
(s/keys :req-un [::port ::host ::name ::min-threads ::max-threads]
:opt-un [::mtx/metrics ::router ::handler]))
(defn- instrument-metrics
[^Server server metrics]
@ -48,15 +60,22 @@
(defmethod ig/init-key ::server
[_ {:keys [handler router port name metrics host] :as opts}]
(l/info :msg "starting http server" :port port :host host :name name)
(let [options {:http/port port :http/host host}
(l/info :hint "starting http server"
:port port :host host :name name
:min-threads (:min-threads opts)
:max-threads (:max-threads opts))
(let [options {:http/port port
:http/host host
:thread-pool/max-threads (:max-threads opts)
:thread-pool/min-threads (:min-threads opts)
:ring/async true}
handler (cond
(fn? handler) handler
(some? router) (wrap-router router)
:else (ex/raise :type :internal
:code :invalid-argument
:hint "Missing `handler` or `router` option."))
server (-> (yt/server handler options)
server (-> (yt/server handler (d/without-nils options))
(cond-> metrics (instrument-metrics metrics)))]
(assoc opts :server (yt/start! server))))
@ -70,20 +89,20 @@
(let [default (rr/routes
(rr/create-resource-handler {:path "/"})
(rr/create-default-handler))
options {:middleware [middleware/server-timing]}
options {:middleware [middleware/wrap-server-timing]
:inject-match? false
:inject-router? false}
handler (rr/ring-handler router default options)]
(fn [request]
(try
(handler request)
(catch Throwable e
(fn [request respond _]
(handler request respond (fn [cause]
(l/error :hint "unexpected error processing request"
::l/context (errors/get-error-context request e)
::l/context (errors/get-error-context request cause)
:query-string (:query-string request)
:cause e)
{:status 500 :body "internal server error"})))))
:cause cause)
(respond {:status 500 :body "internal server error"}))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Http Router
;; HTTP ROUTER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::rpc map?)
@ -145,7 +164,6 @@
[middleware/multipart-params]
[middleware/keyword-params]
[middleware/format-response-body]
[middleware/etag]
[middleware/parse-request-body]
[middleware/errors errors/handle]
[middleware/cookies]]}

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

@ -13,9 +13,12 @@
[app.db :as db]
[app.metrics :as mtx]
[app.storage :as sto]
[app.util.async :as async]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
[integrant.core :as ig]
[promesa.core :as p]))
(def ^:private cache-max-age
(dt/duration {:hours 24}))
@ -52,10 +55,10 @@
:body (sto/get-object-bytes storage obj)}
:s3
(let [url (sto/get-object-url storage obj {:max-age signature-max-age})]
(let [{:keys [host port] :as url} (sto/get-object-url storage obj {:max-age signature-max-age})]
{:status 307
:headers {"location" (str url)
"x-host" (:host url)
"x-host" (cond-> host port (str ":" port))
"cache-control" (str "max-age=" (inst-ms cache-max-age))}
:body ""})
@ -69,29 +72,38 @@
:body ""}))))
(defn- generic-handler
[{:keys [storage] :as cfg} _request id]
(let [obj (sto/get-object storage id)]
[{:keys [storage executor] :as cfg} request kf]
(async/with-dispatch executor
(let [id (get-in request [:path-params :id])
mobj (get-file-media-object storage id)
obj (sto/get-object storage (kf mobj))]
(if obj
(serve-object cfg obj)
{:status 404 :body ""}))))
(defn objects-handler
[{:keys [storage executor] :as cfg} request respond raise]
(-> (async/with-dispatch executor
(let [id (get-in request [:path-params :id])
id (coerce-id id)
obj (sto/get-object storage id)]
(if obj
(serve-object cfg obj)
{:status 404 :body ""})))
(defn objects-handler
[cfg request]
(let [id (get-in request [:path-params :id])]
(generic-handler cfg request (coerce-id id))))
(p/then respond)
(p/catch raise)))
(defn file-objects-handler
[{:keys [storage] :as cfg} request]
(let [id (get-in request [:path-params :id])
mobj (get-file-media-object storage id)]
(generic-handler cfg request (:media-id mobj))))
[cfg request respond raise]
(-> (generic-handler cfg request :media-id)
(p/then respond)
(p/catch raise)))
(defn file-thumbnails-handler
[{:keys [storage] :as cfg} request]
(let [id (get-in request [:path-params :id])
mobj (get-file-media-object storage id)]
(generic-handler cfg request (or (:thumbnail-id mobj) (:media-id mobj)))))
[cfg request respond raise]
(-> (generic-handler cfg request #(or (:thumbnail-id %) (:media-id %)))
(p/then respond)
(p/catch raise)))
;; --- Initialization
@ -101,10 +113,16 @@
(s/def ::signature-max-age ::dt/duration)
(defmethod ig/pre-init-spec ::handlers [_]
(s/keys :req-un [::storage ::mtx/metrics ::assets-path ::cache-max-age ::signature-max-age]))
(s/keys :req-un [::storage
::wrk/executor
::mtx/metrics
::assets-path
::cache-max-age
::signature-max-age]))
(defmethod ig/init-key ::handlers
[_ cfg]
{:objects-handler #(objects-handler cfg %)
:file-objects-handler #(file-objects-handler cfg %)
:file-thumbnails-handler #(file-thumbnails-handler cfg %)})
{:objects-handler (partial objects-handler cfg)
:file-objects-handler (partial file-objects-handler cfg)
:file-thumbnails-handler (partial file-thumbnails-handler cfg)})

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

@ -26,7 +26,8 @@
(defmethod ig/init-key ::handler
[_ cfg]
(fn [request]
(fn [request respond _]
(try
(let [body (parse-json (slurp (:body request)))
mtype (get body "Type")]
(cond
@ -43,8 +44,12 @@
:else
(l/warn :hint "unexpected data received"
:report (pr-str body)))
{:status 200 :body ""})))
:report (pr-str body))))
(catch Throwable cause
(l/error :hint "unexpected exception on awsns handler"
:cause cause)))
(respond {:status 200 :body ""})))
(defn- parse-bounce
[data]

31
backend/src/app/http/debug.clj
View file

@ -14,14 +14,18 @@
[app.db :as db]
[app.rpc.mutations.files :as m.files]
[app.rpc.queries.profile :as profile]
[app.util.async :as async]
[app.util.blob :as blob]
[app.util.template :as tmpl]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.core :as fs]
[fipp.edn :as fpp]
[integrant.core :as ig]))
[integrant.core :as ig]
[promesa.core :as p]))
;; (selmer.parser/cache-off!)
@ -201,12 +205,23 @@
(db/exec-one! conn ["select count(*) as count from server_prop;"])
{:status 200 :body "Ok"}))
(defn- wrap-async
[{:keys [executor] :as cfg} f]
(fn [request respond raise]
(-> (async/with-dispatch executor
(f cfg request))
(p/then respond)
(p/catch raise))))
(defmethod ig/pre-init-spec ::handlers [_]
(s/keys :req-un [::db/pool ::wrk/executor]))
(defmethod ig/init-key ::handlers
[_ cfg]
{:index (partial index cfg)
:health-check (partial health-check cfg)
:retrieve-file-data (partial retrieve-file-data cfg)
:retrieve-file-changes (partial retrieve-file-changes cfg)
:retrieve-error (partial retrieve-error cfg)
:retrieve-error-list (partial retrieve-error-list cfg)
:upload-file-data (partial upload-file-data cfg)})
{:index (wrap-async cfg index)
:health-check (wrap-async cfg health-check)
:retrieve-file-data (wrap-async cfg retrieve-file-data)
:retrieve-file-changes (wrap-async cfg retrieve-file-changes)
:retrieve-error (wrap-async cfg retrieve-error)
:retrieve-error-list (wrap-async cfg retrieve-error-list)
:upload-file-data (wrap-async cfg upload-file-data)})

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

@ -46,8 +46,9 @@
[rpc]
(let [context (prepare-context rpc)]
(if (contains? cf/flags :backend-api-doc)
(fn [_]
{:status 200
(fn [_ respond _]
(respond {:status 200
:body (-> (io/resource "api-doc.tmpl")
(tmpl/render context))})
(constantly {:status 404 :body ""}))))
(tmpl/render context))}))
(fn [_ respond _]
(respond {:status 404 :body ""})))))

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

@ -14,48 +14,55 @@
[app.db :as db]
[app.emails :as eml]
[app.rpc.queries.profile :as profile]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px]))
(declare send-feedback)
(declare ^:private send-feedback)
(declare ^:private handler)
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::db/pool]))
(s/keys :req-un [::db/pool ::wrk/executor]))
(defmethod ig/init-key ::handler
[_ {:keys [pool] :as scfg}]
[_ {:keys [executor] :as cfg}]
(let [enabled? (contains? cf/flags :user-feedback)]
(if enabled?
(fn [request respond raise]
(-> (px/submit! executor #(handler cfg request))
(p/then' respond)
(p/catch raise)))
(fn [_ _ raise]
(raise (ex/error :type :validation
:code :feedback-disabled
:hint "feedback module is disabled"))))))
(defn- handler
[{:keys [pool] :as cfg} {:keys [profile-id] :as request}]
(let [ftoken (cf/get :feedback-token ::no-token)
enabled (contains? cf/flags :user-feedback)]
(fn [{:keys [profile-id] :as request}]
(let [token (get-in request [:headers "x-feedback-token"])
token (get-in request [:headers "x-feedback-token"])
params (d/merge (:params request)
(:body-params request))]
(when-not enabled
(ex/raise :type :validation
:code :feedback-disabled
:hint "feedback module is disabled"))
(cond
(uuid? profile-id)
(let [profile (profile/retrieve-profile-data pool profile-id)
params (assoc params :from (:email profile))]
(when-not (:is-muted profile)
(send-feedback pool profile params)))
(send-feedback pool profile params))
(= token ftoken)
(send-feedback scfg nil params))
(send-feedback cfg nil params))
{:status 204 :body ""}))))
{:status 204 :body ""}))
(s/def ::content ::us/string)
(s/def ::from ::us/email)
(s/def ::subject ::us/string)
(s/def ::feedback
(s/keys :req-un [::from ::subject ::content]))
(defn send-feedback
(defn- send-feedback
[pool profile params]
(let [params (us/conform ::feedback params)
destination (cf/get :feedback-destination)]

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

@ -10,8 +10,6 @@
[app.common.transit :as t]
[app.config :as cf]
[app.util.json :as json]
[buddy.core.codecs :as bc]
[buddy.core.hash :as bh]
[ring.core.protocols :as rp]
[ring.middleware.cookies :refer [wrap-cookies]]
[ring.middleware.keyword-params :refer [wrap-keyword-params]]
@ -21,13 +19,15 @@
(defn wrap-server-timing
[handler]
(let [seconds-from #(float (/ (- (System/nanoTime) %) 1000000000))]
(fn [request]
(let [start (System/nanoTime)
response (handler request)]
(update response :headers
(fn [headers]
(assoc headers "Server-Timing" (str "total;dur=" (seconds-from start)))))))))
(letfn [(get-age [start]
(float (/ (- (System/nanoTime) start) 1000000000)))
(update-headers [headers start]
(assoc headers "Server-Timing" (str "total;dur=" (get-age start))))]
(fn [request respond raise]
(let [start (System/nanoTime)]
(handler request #(respond (update % :headers update-headers start)) raise)))))
(defn wrap-parse-request-body
[handler]
@ -36,11 +36,11 @@
(t/read! reader)))
(parse-json [body]
(json/read body))]
(fn [{:keys [headers body] :as request}]
(try
(json/read body))
(handle-request [{:keys [headers body] :as request}]
(let [ctype (get headers "content-type")]
(handler (case ctype
(case ctype
"application/transit+json"
(let [params (parse-transit body)]
(-> request
@ -54,14 +54,22 @@
(update :params merge params)))
request)))
(catch Exception e
(handle-exception [cause]
(let [data {:type :validation
:code :unable-to-parse-request-body
:hint "malformed params"}]
(l/error :hint (ex-message e) :cause e)
(l/error :hint (ex-message cause) :cause cause)
{:status 400
:headers {"content-type" "application/transit+json"}
:body (t/encode-str data {:type :json-verbose})}))))))
:body (t/encode-str data {:type :json-verbose})}))]
(fn [request respond raise]
(try
(let [request (handle-request request)]
(handler request respond raise))
(catch Exception cause
(respond (handle-exception cause)))))))
(def parse-request-body
{:name ::parse-request-body
@ -81,8 +89,9 @@
(def ^:const buffer-size (:http/output-buffer-size yt/base-defaults))
(defn- transit-streamable-body
[data opts]
(defn wrap-format-response-body
[handler]
(letfn [(transit-streamable-body [data opts]
(reify rp/StreamableResponseBody
(write-body-to-stream [_ _ output-stream]
;; Use the same buffer as jetty output buffer size
@ -97,11 +106,9 @@
(l/warn :hint "unexpected error on encoding response"
:cause cause))))))
(defn- impl-format-response-body
[response {:keys [query-params] :as request}]
(impl-format-response-body [response {:keys [query-params] :as request}]
(let [body (:body response)
opts {:type (if (contains? query-params "transit_verbose") :json-verbose :json)}]
(cond
(:ws response)
response
@ -117,12 +124,15 @@
:else
response)))
(defn- wrap-format-response-body
[handler]
(fn [request]
(let [response (handler request)]
(handle-response [response request]
(cond-> response
(map? response) (impl-format-response-body request)))))
(map? response) (impl-format-response-body request)))]
(fn [request respond raise]
(handler request
(fn [response]
(respond (handle-response response request)))
raise))))
(def format-response-body
{:name ::format-response-body
@ -130,11 +140,9 @@
(defn wrap-errors
[handler on-error]
(fn [request]
(try
(handler request)
(catch Throwable e
(on-error e request)))))
(fn [request respond _]
(handler request respond (fn [cause]
(-> cause (on-error request) respond)))))
(def errors
{:name ::errors
@ -160,41 +168,7 @@
{:name ::server-timing
:compile (constantly wrap-server-timing)})
(defn wrap-etag
[handler]
(letfn [(encode [data]
(when (string? data)
(str "W/\"" (-> data bh/blake2b-128 bc/bytes->hex) "\"")))]
(fn [{method :request-method headers :headers :as request}]
(cond-> (handler request)
(= :get method)
(as-> $ (if-let [etag (-> $ :body meta :etag encode)]
(cond-> (update $ :headers assoc "etag" etag)
(= etag (get headers "if-none-match"))
(-> (assoc :body "")
(assoc :status 304)))
$))))))
(def etag
{:name ::etag
:compile (constantly wrap-etag)})
(defn activity-logger
[handler]
(let [logger "penpot.profile-activity"]
(fn [{:keys [headers] :as request}]
(let [ip-addr (get headers "x-forwarded-for")
profile-id (:profile-id request)
qstring (:query-string request)]
(l/info ::l/async true
::l/logger logger
:ip-addr ip-addr
:profile-id profile-id
:uri (str (:uri request) (when qstring (str "?" qstring)))
:method (name (:request-method request)))
(handler request)))))
(defn- wrap-cors
(defn wrap-cors
[handler]
(if-not (contains? cf/flags :cors)
handler
@ -209,12 +183,15 @@
(assoc "access-control-allow-credentials" "true")
(assoc "access-control-expose-headers" "x-requested-with, content-type, cookie")
(assoc "access-control-allow-headers" "x-frontend-version, content-type, accept, x-requested-width"))))))]
(fn [request]
(fn [request respond raise]
(if (= (:request-method request) :options)
(-> {:status 200 :body ""}
(add-cors-headers request))
(let [response (handler request)]
(add-cors-headers response request)))))))
(add-cors-headers request)
(respond))
(handler request
(fn [response]
(respond (add-cors-headers response request)))
raise))))))
(def cors
{:name ::cors

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

@ -21,7 +21,10 @@
[clojure.set :as set]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[integrant.core :as ig]))
[integrant.core :as ig]
[promesa.exec :as px]))
;; TODO: make it fully async (?)
(defn- build-redirect-uri
[{:keys [provider] :as cfg}]
@ -213,7 +216,10 @@
(redirect-response uri))))
(defn- auth-handler
[{:keys [tokens] :as cfg} {:keys [params] :as request}]
[{:keys [tokens executor] :as cfg} {:keys [params] :as request} respond _]
(px/run!
executor
(fn []
(let [invitation (:invitation-token params)
props (extract-utm-props params)
state (tokens :generate
@ -222,19 +228,23 @@
:props props
:exp (dt/in-future "15m")})
uri (build-auth-uri cfg state)]
(respond
{:status 200
:body {:redirect-uri uri}}))
:body {:redirect-uri uri}})))))
(defn- callback-handler
[cfg request]
[{:keys [executor] :as cfg} request respond _]
(px/run!
executor
(fn []
(try
(let [info (retrieve-info cfg request)
profile (retrieve-profile cfg info)]
(generate-redirect cfg request info profile))
(catch Exception e
(l/warn :hint "error on oauth process"
:cause e)
(generate-error-redirect cfg e))))
(respond (generate-redirect cfg request info profile)))
(catch Exception cause
(l/warn :hint "error on oauth process" :cause cause)
(respond (generate-error-redirect cfg cause)))))))
;; --- INIT
@ -250,15 +260,19 @@
(defn wrap-handler
[cfg handler]
(fn [request]
(fn [request respond raise]
(let [provider (get-in request [:path-params :provider])
provider (get-in @cfg [:providers provider])]
(when-not provider
(ex/raise :type :not-found
:context {:provider provider}
:hint "provider not configured"))
(-> (assoc @cfg :provider provider)
(handler request)))))
(if provider
(handler (assoc @cfg :provider provider)
request
respond
raise)
(raise
(ex/error
:type :not-found
:provider provider
:hint "provider not configured"))))))
(defmethod ig/init-key ::handler
[_ cfg]

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

@ -11,97 +11,167 @@
[app.common.logging :as l]
[app.config :as cfg]
[app.db :as db]
[app.db.sql :as sql]
[app.metrics :as mtx]
[app.util.async :as aa]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.core.async :as a]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
[integrant.core :as ig]
[ring.middleware.session.store :as rss]))
;; A default cookie name for storing the session. We don't allow
;; configure it.
(def cookie-name "auth-token")
;; A default cookie name for storing the session. We don't allow to configure it.
(def token-cookie-name "auth-token")
;; --- IMPL
;; A cookie that we can use to check from other sites of the same domain if a user
;; is registered. Is not intended for on premise installations, although nothing
;; prevents using it if some one wants to.
(def authenticated-cookie-name "authenticated")
(defn- create-session
[{:keys [conn tokens] :as cfg} {:keys [profile-id headers] :as request}]
(let [token (tokens :generate {:iss "authentication"
(deftype DatabaseStore [pool tokens]
rss/SessionStore
(read-session [_ token]
(db/exec-one! pool (sql/select :http-session {:id token})))
(write-session [_ _ data]
(let [profile-id (:profile-id data)
user-agent (:user-agent data)
token (tokens :generate {:iss "authentication"
:iat (dt/now)
:uid profile-id})
now (dt/now)
params {:user-agent (get headers "user-agent")
params {:user-agent user-agent
:profile-id profile-id
:created-at now
:updated-at now
:id token}]
(db/insert! conn :http-session params)))
(db/insert! pool :http-session params)
token))
(delete-session [_ token]
(db/delete! pool :http-session {:id token})
nil))
(deftype MemoryStore [cache tokens]
rss/SessionStore
(read-session [_ token]
(get @cache token))
(write-session [_ _ data]
(let [profile-id (:profile-id data)
user-agent (:user-agent data)
token (tokens :generate {:iss "authentication"
:iat (dt/now)
:uid profile-id})
params {:user-agent user-agent
:profile-id profile-id
:id token}]
(swap! cache assoc token params)
token))
(delete-session [_ token]
(swap! cache dissoc token)
nil))
;; --- IMPL
(defn- create-session
[store request profile-id]
(let [params {:user-agent (get-in request [:headers "user-agent"])
:profile-id profile-id}]
(rss/write-session store nil params)))
(defn- delete-session
[{:keys [conn] :as cfg} {:keys [cookies] :as request}]
(when-let [token (get-in cookies [cookie-name :value])]
(db/delete! conn :http-session {:id token}))
nil)
[store {:keys [cookies] :as request}]
(when-let [token (get-in cookies [token-cookie-name :value])]
(rss/delete-session store token)))
(defn- retrieve-session
[{:keys [conn] :as cfg} id]
(when id
(db/exec-one! conn ["select id, profile_id from http_session where id = ?" id])))
[store token]
(when token
(rss/read-session store token)))
(defn- retrieve-from-request
[cfg {:keys [cookies] :as request}]
(->> (get-in cookies [cookie-name :value])
(retrieve-session cfg)))
[store {:keys [cookies] :as request}]
(->> (get-in cookies [token-cookie-name :value])
(retrieve-session store)))
(defn- add-cookies
[response {:keys [id] :as session}]
[response token]
(let [cors? (contains? cfg/flags :cors)
secure? (contains? cfg/flags :secure-session-cookies)]
(assoc response :cookies {cookie-name {:path "/"
secure? (contains? cfg/flags :secure-session-cookies)
authenticated-cookie-domain (cfg/get :authenticated-cookie-domain)]
(update response :cookies
(fn [cookies]
(cond-> cookies
:always
(assoc token-cookie-name {:path "/"
:http-only true
:value id
:value token
:same-site (if cors? :none :lax)
:secure secure?}})))
:secure secure?})
(some? authenticated-cookie-domain)
(assoc authenticated-cookie-name {:domain authenticated-cookie-domain
:path "/"
:value true
:same-site :strict
:secure secure?}))))))
(defn- clear-cookies
[response]
(assoc response :cookies {cookie-name {:value "" :max-age -1}}))
(let [authenticated-cookie-domain (cfg/get :authenticated-cookie-domain)]
(assoc response :cookies {token-cookie-name {:path "/"
:value ""
:max-age -1}
authenticated-cookie-name {:domain authenticated-cookie-domain
:path "/"
:value ""
:max-age -1}})))
(defn- middleware
[cfg handler]
(fn [request]
(if-let [{:keys [id profile-id] :as session} (retrieve-from-request cfg request)]
[events-ch store handler]
(fn [request respond raise]
(if-let [{:keys [id profile-id] :as session} (retrieve-from-request store request)]
(do
(a/>!! (::events-ch cfg) id)
(a/>!! events-ch id)
(l/set-context! {:profile-id profile-id})
(handler (assoc request :profile-id profile-id :session-id id)))
(handler request))))
(handler (assoc request :profile-id profile-id :session-id id) respond raise))
(handler request respond raise))))
;; --- STATE INIT: SESSION
(s/def ::tokens fn?)
(defmethod ig/pre-init-spec ::session [_]
(s/keys :req-un [::db/pool]))
(s/keys :req-un [::db/pool ::tokens]))
(defmethod ig/prep-key ::session
[_ cfg]
(d/merge {:buffer-size 128} (d/without-nils cfg)))
(d/merge {:buffer-size 128}
(d/without-nils cfg)))
(defmethod ig/init-key ::session
[_ {:keys [pool] :as cfg}]
(let [events (a/chan (a/dropping-buffer (:buffer-size cfg)))
cfg (-> cfg
(assoc :conn pool)
(assoc ::events-ch events))]
[_ {:keys [pool tokens] :as cfg}]
(let [events-ch (a/chan (a/dropping-buffer (:buffer-size cfg)))
store (if (db/read-only? pool)
(->MemoryStore (atom {}) tokens)
(->DatabaseStore pool tokens))]
(when (db/read-only? pool)
(l/warn :hint "sessions module initialized with in-memory store"))
(-> cfg
(assoc :middleware #(middleware cfg %))
(assoc ::events-ch events-ch)
(assoc :middleware (partial middleware events-ch store))
(assoc :create (fn [profile-id]
(fn [request response]
(let [request (assoc request :profile-id profile-id)
session (create-session cfg request)]
(add-cookies response session)))))
(let [token (create-session store request profile-id)]
(add-cookies response token)))))
(assoc :delete (fn [request response]
(delete-session cfg request)
(delete-session store request)
(-> response
(assoc :status 204)
(assoc :body "")
@ -138,16 +208,11 @@
:max-batch-size (str (:max-batch-size cfg)))
(let [input (aa/batch (::events-ch session)
{:max-batch-size (:max-batch-size cfg)
:max-batch-age (inst-ms (:max-batch-age cfg))})
mcnt (mtx/create
{:name "http_session_update_total"
:help "A counter of session update batch events."
:registry (:registry metrics)
:type :counter})]
:max-batch-age (inst-ms (:max-batch-age cfg))})]
(a/go-loop []
(when-let [[reason batch] (a/<! input)]
(let [result (a/<! (update-sessions cfg batch))]
(mcnt :inc)
(mtx/run! metrics {:id :session-update-total :inc 1})
(cond
(ex/exception? result)
(l/error :task "updater"
@ -159,6 +224,7 @@
:hint "update sessions"
:reason (name reason)
:count result))
(recur))))))
(defn- update-sessions

31
backend/src/app/http/websocket.clj
View file

@ -13,7 +13,6 @@
[app.db :as db]
[app.metrics :as mtx]
[app.util.websocket :as ws]
[app.worker :as wrk]
[clojure.core.async :as a]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
@ -100,36 +99,36 @@
(s/keys :req-un [::file-id ::session-id]))
(defmethod ig/pre-init-spec ::handler [_]
(s/keys :req-un [::msgbus ::db/pool ::mtx/metrics ::wrk/executor]))
(s/keys :req-un [::msgbus ::db/pool ::mtx/metrics]))
(defmethod ig/init-key ::handler
[_ {:keys [metrics pool] :as cfg}]
(let [metrics {:connections (get-in metrics [:definitions :websocket-active-connections])
:messages (get-in metrics [:definitions :websocket-messages-total])
:sessions (get-in metrics [:definitions :websocket-session-timing])}]
(fn [{:keys [profile-id params] :as req}]
[_ {:keys [pool] :as cfg}]
(fn [{:keys [profile-id params] :as req} respond raise]
(let [params (us/conform ::handler-params params)
file (retrieve-file pool (:file-id params))
cfg (-> (merge cfg params)
(assoc :profile-id profile-id)
(assoc :team-id (:team-id file))
(assoc ::ws/metrics metrics))]
(assoc :team-id (:team-id file)))]
(when-not profile-id
(ex/raise :type :authentication
(cond
(not profile-id)
(raise (ex/error :type :authentication
:hint "Authentication required."))
(when-not file
(ex/raise :type :not-found
(not file)
(raise (ex/error :type :not-found
:code :object-not-found))
(when-not (yws/upgrade-request? req)
(ex/raise :type :validation
(not (yws/upgrade-request? req))
(raise (ex/error :type :validation
:code :websocket-request-expected
:hint "this endpoint only accepts websocket connections"))
:else
(->> (ws/handler handle-message cfg)
(yws/upgrade req))))))
(yws/upgrade req)
(respond))))))
(def ^:private
sql:retrieve-file

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

@ -24,6 +24,7 @@
[cuerdas.core :as str]
[integrant.core :as ig]
[lambdaisland.uri :as u]
[promesa.core :as p]
[promesa.exec :as px]))
(defn parse-client-ip
@ -41,33 +42,26 @@
(defn clean-props
[{:keys [profile-id] :as event}]
(letfn [(clean-common [props]
(-> props
(dissoc :session-id)
(dissoc :password)
(dissoc :old-password)
(dissoc :token)))
(clean-profile-id [props]
(cond-> props
(= profile-id (:profile-id props))
(dissoc :profile-id)))
(clean-complex-data [props]
(reduce-kv (fn [props k v]
(cond-> props
(let [invalid-keys #{:session-id
:password
:old-password
:token}
xform (comp
(remove (fn [kv]
(qualified-keyword? (first kv))))
(remove (fn [kv]
(contains? invalid-keys (first kv))))
(remove (fn [[k v]]
(and (= k :profile-id)
(= v profile-id))))
(filter (fn [[_ v]]
(or (string? v)
(keyword? v)
(uuid? v)
(boolean? v)
(number? v))
(assoc k v)
(number? v)))))]
(keyword? v)
(assoc k (name v))))
{}
props))]
(update event :props #(-> % clean-common clean-profile-id clean-complex-data))))
(update event :props #(into {} xform %))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HTTP Handler
@ -82,30 +76,48 @@
(s/def ::timestamp dt/instant?)
(s/def ::context (s/map-of ::us/keyword any?))
(s/def ::event
(s/def ::frontend-event
(s/keys :req-un [::type ::name ::props ::timestamp ::profile-id]
:opt-un [::context]))
(s/def ::events (s/every ::event))
(s/def ::frontend-events (s/every ::frontend-event))
(defmethod ig/init-key ::http-handler
[_ {:keys [executor] :as cfg}]
(fn [{:keys [params profile-id] :as request}]
(when (contains? cf/flags :audit-log)
[_ {:keys [executor pool] :as cfg}]
(if (or (db/read-only? pool) (not (contains? cf/flags :audit-log)))
(do
(l/warn :hint "audit log http handler disabled or db is read-only")
(fn [_ respond _]
(respond {:status 204 :body ""})))
(letfn [(handler [{:keys [params profile-id] :as request}]
(let [events (->> (:events params)
(remove #(not= profile-id (:profile-id %)))
(us/conform ::events))
(us/conform ::frontend-events))
ip-addr (parse-client-ip request)
cfg (-> cfg
(assoc :source "frontend")
(assoc :events events)
(assoc :ip-addr ip-addr))]
(px/run! executor #(persist-http-events cfg))))
{:status 204 :body ""}))
(persist-http-events cfg)))
(handle-error [cause]
(let [xdata (ex-data cause)]
(if (= :spec-validation (:code xdata))
(l/error ::l/raw (str "spec validation on persist-events:\n" (us/pretty-explain xdata)))
(l/error :hint "error on persist-events" :cause cause))))]
(fn [request respond _]
;; Fire and forget, log error in case of errro
(-> (px/submit! executor #(handler request))
(p/catch handle-error))
(respond {:status 204 :body ""})))))
(defn- persist-http-events
[{:keys [pool events ip-addr source] :as cfg}]
(try
(let [columns [:id :name :source :type :tracked-at :profile-id :ip-addr :props :context]
prepare-xf (map (fn [event]
[(uuid/next)
@ -116,18 +128,10 @@
(:profile-id event)
(db/inet ip-addr)
(db/tjson (:props event))
(db/tjson (d/without-nils (:context event)))]))
events (us/conform ::events events)]
(db/tjson (d/without-nils (:context event)))]))]
(when (seq events)
(->> (into [] prepare-xf events)
(db/insert-multi! pool :audit-log columns))))
(catch Throwable e
(let [xdata (ex-data e)]
(if (= :spec-validation (:code xdata))
(l/error ::l/raw (str "spec validation on persist-events:\n"
(:explain xdata)))
(l/error :hint "error on persist-events"
:cause e))))))
(db/insert-multi! pool :audit-log columns)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Collector
@ -142,41 +146,57 @@
(defmethod ig/pre-init-spec ::collector [_]
(s/keys :req-un [::db/pool ::wrk/executor]))
(def event-xform
(s/def ::ip-addr string?)
(s/def ::backend-event
(s/keys :req-un [::type ::name ::profile-id]
:opt-un [::ip-addr ::props]))
(def ^:private backend-event-xform
(comp
(filter :profile-id)
(filter #(us/valid? ::backend-event %))
(map clean-props)))
(defmethod ig/init-key ::collector
[_ cfg]
(when (contains? cf/flags :audit-log)
(l/info :msg "initializing audit log collector")
(let [input (a/chan 512 event-xform)
[_ {:keys [pool] :as cfg}]
(cond
(not (contains? cf/flags :audit-log))
(do
(l/info :hint "audit log collection disabled")
(constantly nil))
(db/read-only? pool)
(do
(l/warn :hint "audit log collection disabled, db is read-only")
(constantly nil))
:else
(let [input (a/chan 512 backend-event-xform)
buffer (aa/batch input {:max-batch-size 100
:max-batch-age (* 10 1000) ; 10s
:init []})]
(l/info :hint "audit log collector initialized")
(a/go-loop []
(when-let [[_type events] (a/<! buffer)]
(let [res (a/<! (persist-events cfg events))]
(when (ex/exception? res)
(l/error :hint "error on persisting events"
:cause res)))
(recur)))
(l/error :hint "error on persisting events" :cause res))
(recur))))
(fn [& {:keys [cmd] :as params}]
(case cmd
:stop
(a/close! input)
:submit
(let [params (-> params
(dissoc :cmd)
(assoc :tracked-at (dt/now)))]
(case cmd
:stop (a/close! input)
:submit (when-not (a/offer! input params)
(l/warn :msg "activity channel is full"))))))))
(when-not (a/offer! input params)
(l/warn :hint "activity channel is full"))))))))
(defn- persist-events
[{:keys [pool executor] :as cfg} events]
(letfn [(event->row [event]
(when (:profile-id event)
[(uuid/next)
(:name event)
(:type event)
@ -184,7 +204,7 @@
(:tracked-at event)
(some-> (:ip-addr event) db/inet)
(db/tjson (:props event))
"backend"]))]
"backend"])]
(aa/with-thread executor
(when (seq events)
(db/with-atomic [conn pool]
@ -217,6 +237,7 @@
(:enabled props false))
uri (or uri (:uri props))
cfg (assoc cfg :uri uri)]
(when (and enabled (not uri))
(ex/raise :type :internal
:code :task-not-configured

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

@ -27,8 +27,9 @@
(defonce enabled (atom true))
(defn- persist-on-database!
[{:keys [pool]} {:keys [id] :as event}]
(db/insert! pool :server-error-report {:id id :content (db/tjson event)}))
[{:keys [pool] :as cfg} {:keys [id] :as event}]
(when-not (db/read-only? pool)
(db/insert! pool :server-error-report {:id id :content (db/tjson event)})))
(defn- parse-event-data
[event]

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

@ -17,11 +17,37 @@
{:uri (cf/get :database-uri)
:username (cf/get :database-username)
:password (cf/get :database-password)
:read-only (cf/get :database-readonly false)
:metrics (ig/ref :app.metrics/metrics)
:migrations (ig/ref :app.migrations/all)
:name :main
:min-pool-size 0
:max-pool-size 60}
:min-size (cf/get :database-min-pool-size 0)
:max-size (cf/get :database-max-pool-size 30)}
;; Default thread pool for IO operations
[::default :app.worker/executor]
{:parallelism (cf/get :default-executor-parallelism 60)
:prefix :default}
;; Constrained thread pool. Should only be used from high demand
;; RPC methods.
[::blocking :app.worker/executor]
{:parallelism (cf/get :blocking-executor-parallelism 20)
:prefix :blocking}
;; Dedicated thread pool for backround tasks execution.
[::worker :app.worker/executor]
{:parallelism (cf/get :worker-executor-parallelism 10)
:prefix :worker}
:app.worker/executors
{:default (ig/ref [::default :app.worker/executor])
:worker (ig/ref [::worker :app.worker/executor])
:blocking (ig/ref [::blocking :app.worker/executor])}
:app.worker/executors-monitor
{:metrics (ig/ref :app.metrics/metrics)
:executors (ig/ref :app.worker/executors)}
:app.migrations/migrations
{}
@ -32,7 +58,6 @@
:app.migrations/all
{:main (ig/ref :app.migrations/migrations)}
:app.msgbus/msgbus
{:backend (cf/get :msgbus-backend :redis)
:redis-uri (cf/get :redis-uri)}
@ -48,10 +73,6 @@
:app.storage/gc-touched-task
{:pool (ig/ref :app.db/pool)}
:app.storage/recheck-task
{:pool (ig/ref :app.db/pool)
:storage (ig/ref :app.storage/storage)}
:app.http.session/session
{:pool (ig/ref :app.db/pool)
:tokens (ig/ref :app.tokens/tokens)}
@ -63,7 +84,7 @@
:app.http.session/updater
{:pool (ig/ref :app.db/pool)
:metrics (ig/ref :app.metrics/metrics)
:executor (ig/ref :app.worker/executor)
:executor (ig/ref [::worker :app.worker/executor])
:session (ig/ref :app.http.session/session)
:max-batch-age (cf/get :http-session-updater-batch-max-age)
:max-batch-size (cf/get :http-session-updater-batch-max-size)}
@ -76,7 +97,10 @@
{:port (cf/get :http-server-port)
:host (cf/get :http-server-host)
:router (ig/ref :app.http/router)
:metrics (ig/ref :app.metrics/metrics)}
:metrics (ig/ref :app.metrics/metrics)
:max-threads (cf/get :http-server-max-threads)
:min-threads (cf/get :http-server-min-threads)}
:app.http/router
{:assets (ig/ref :app.http.assets/handlers)
@ -94,11 +118,11 @@
:rpc (ig/ref :app.rpc/rpc)}
:app.http.debug/handlers
{:pool (ig/ref :app.db/pool)}
{:pool (ig/ref :app.db/pool)
:executor (ig/ref [::default :app.worker/executor])}
:app.http.websocket/handler
{:pool (ig/ref :app.db/pool)
:executor (ig/ref :app.worker/executor)
:metrics (ig/ref :app.metrics/metrics)
:msgbus (ig/ref :app.msgbus/msgbus)}
@ -106,11 +130,13 @@
{:metrics (ig/ref :app.metrics/metrics)
:assets-path (cf/get :assets-path)
:storage (ig/ref :app.storage/storage)
:executor (ig/ref [::default :app.worker/executor])
:cache-max-age (dt/duration {:hours 24})
:signature-max-age (dt/duration {:hours 24 :minutes 5})}
:app.http.feedback/handler
{:pool (ig/ref :app.db/pool)}
{:pool (ig/ref :app.db/pool)
:executor (ig/ref [::default :app.worker/executor])}
:app.http.oauth/handler
{:rpc (ig/ref :app.rpc/rpc)
@ -118,6 +144,7 @@
:pool (ig/ref :app.db/pool)
:tokens (ig/ref :app.tokens/tokens)
:audit (ig/ref :app.loggers.audit/collector)
:executor (ig/ref [::default :app.worker/executor])
:public-uri (cf/get :public-uri)}
:app.rpc/rpc
@ -128,22 +155,17 @@
:storage (ig/ref :app.storage/storage)
:msgbus (ig/ref :app.msgbus/msgbus)
:public-uri (cf/get :public-uri)
:audit (ig/ref :app.loggers.audit/collector)}
:app.worker/executor
{:min-threads 0
:max-threads 256
:idle-timeout 60000
:name :worker}
:audit (ig/ref :app.loggers.audit/collector)
:executors (ig/ref :app.worker/executors)}
:app.worker/worker
{:executor (ig/ref :app.worker/executor)
{:executor (ig/ref [::worker :app.worker/executor])
:tasks (ig/ref :app.worker/registry)
:metrics (ig/ref :app.metrics/metrics)
:pool (ig/ref :app.db/pool)}
:app.worker/scheduler
{:executor (ig/ref :app.worker/executor)
{:executor (ig/ref [::worker :app.worker/executor])
:tasks (ig/ref :app.worker/registry)
:pool (ig/ref :app.db/pool)
:schedule
@ -162,9 +184,6 @@
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :session-gc}
{:cron #app/cron "0 0 * * * ?" ;; hourly
:task :storage-recheck}
{:cron #app/cron "0 0 0 * * ?" ;; daily
:task :objects-gc}
@ -197,7 +216,6 @@
:file-xlog-gc (ig/ref :app.tasks.file-xlog-gc/handler)
:storage-deleted-gc (ig/ref :app.storage/gc-deleted-task)
:storage-touched-gc (ig/ref :app.storage/gc-touched-task)
:storage-recheck (ig/ref :app.storage/recheck-task)
:tasks-gc (ig/ref :app.tasks.tasks-gc/handler)
:telemetry (ig/ref :app.tasks.telemetry/handler)
:session-gc (ig/ref :app.http.session/gc-task)
@ -261,11 +279,11 @@
:app.loggers.audit/http-handler
{:pool (ig/ref :app.db/pool)
:executor (ig/ref :app.worker/executor)}
:executor (ig/ref [::worker :app.worker/executor])}
:app.loggers.audit/collector
{:pool (ig/ref :app.db/pool)
:executor (ig/ref :app.worker/executor)}
:executor (ig/ref [::worker :app.worker/executor])}
:app.loggers.audit/archive-task
{:uri (cf/get :audit-log-archive-uri)
@ -279,36 +297,26 @@
:app.loggers.loki/reporter
{:uri (cf/get :loggers-loki-uri)
:receiver (ig/ref :app.loggers.zmq/receiver)
:executor (ig/ref :app.worker/executor)}
:executor (ig/ref [::worker :app.worker/executor])}
:app.loggers.mattermost/reporter
{:uri (cf/get :error-report-webhook)
:receiver (ig/ref :app.loggers.zmq/receiver)
:pool (ig/ref :app.db/pool)
:executor (ig/ref :app.worker/executor)}
:executor (ig/ref [::worker :app.worker/executor])}
:app.loggers.database/reporter
{:receiver (ig/ref :app.loggers.zmq/receiver)
:pool (ig/ref :app.db/pool)
:executor (ig/ref :app.worker/executor)}
:app.loggers.sentry/reporter
{:dsn (cf/get :sentry-dsn)
:trace-sample-rate (cf/get :sentry-trace-sample-rate 1.0)
:attach-stack-trace (cf/get :sentry-attach-stack-trace false)
:debug (cf/get :sentry-debug false)
:receiver (ig/ref :app.loggers.zmq/receiver)
:pool (ig/ref :app.db/pool)
:executor (ig/ref :app.worker/executor)}
:executor (ig/ref [::worker :app.worker/executor])}
:app.storage/storage
{:pool (ig/ref :app.db/pool)
:executor (ig/ref :app.worker/executor)
:backends {
:assets-s3 (ig/ref [::assets :app.storage.s3/backend])
:backends
{:assets-s3 (ig/ref [::assets :app.storage.s3/backend])
:assets-db (ig/ref [::assets :app.storage.db/backend])
:assets-fs (ig/ref [::assets :app.storage.fs/backend])
:tmp (ig/ref [::tmp :app.storage.fs/backend])
:fdata-s3 (ig/ref [::fdata :app.storage.s3/backend])
@ -319,10 +327,12 @@
[::fdata :app.storage.s3/backend]
{:region (cf/get :storage-fdata-s3-region)
:bucket (cf/get :storage-fdata-s3-bucket)
:endpoint (cf/get :storage-fdata-s3-endpoint)
:prefix (cf/get :storage-fdata-s3-prefix)}
[::assets :app.storage.s3/backend]
{:region (cf/get :storage-assets-s3-region)
:endpoint (cf/get :storage-assets-s3-endpoint)
:bucket (cf/get :storage-assets-s3-bucket)}
[::assets :app.storage.fs/backend]

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

@ -326,8 +326,10 @@
(defn configure-assets-storage
"Given storage map, returns a storage configured with the appropriate
backend for assets."
[storage conn]
([storage]
(assoc storage :backend (cf/get :assets-storage-backend :assets-fs)))
([storage conn]
(-> storage
(assoc :conn conn)
(assoc :backend (cf/get :assets-storage-backend :assets-fs))))
(assoc :backend (cf/get :assets-storage-backend :assets-fs)))))

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

@ -5,46 +5,40 @@
;; Copyright (c) UXBOX Labs SL
(ns app.metrics
(:refer-clojure :exclude [run!])
(:require
[app.common.exceptions :as ex]
[app.common.logging :as l]
[clojure.spec.alpha :as s]
[integrant.core :as ig])
(:import
io.prometheus.client.CollectorRegistry
io.prometheus.client.Counter
io.prometheus.client.Counter$Child
io.prometheus.client.Gauge
io.prometheus.client.Gauge$Child
io.prometheus.client.Summary
io.prometheus.client.Summary$Child
io.prometheus.client.Summary$Builder
io.prometheus.client.Histogram
io.prometheus.client.Histogram$Child
io.prometheus.client.exporter.common.TextFormat
io.prometheus.client.hotspot.DefaultExports
io.prometheus.client.jetty.JettyStatisticsCollector
org.eclipse.jetty.server.handler.StatisticsHandler
java.io.StringWriter))
(declare instrument-vars!)
(declare instrument)
(set! *warn-on-reflection* true)
(declare create-registry)
(declare create)
(declare handler)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Defaults
;; METRICS SERVICE PROVIDER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def default-metrics
{:profile-register
{:name "actions_profile_register_count"
:help "A global counter of user registrations."
:type :counter}
:profile-activation
{:name "actions_profile_activation_count"
:help "A global counter of profile activations"
:type :counter}
:update-file-changes
{:update-file-changes
{:name "rpc_update_file_changes_total"
:help "A total number of changes submitted to update-file."
:type :counter}
@ -54,6 +48,18 @@
:help "A total number of bytes processed by update-file."
:type :counter}
:rpc-mutation-timing
{:name "rpc_mutation_timing"
:help "RPC mutation method call timming."
:labels ["name"]
:type :histogram}
:rpc-query-timing
{:name "rpc_query_timing"
:help "RPC query method call timing."
:labels ["name"]
:type :histogram}
:websocket-active-connections
{:name "websocket_active_connections"
:help "Active websocket connections gauge"
@ -68,12 +74,60 @@
:websocket-session-timing
{:name "websocket_session_timing"
:help "Websocket session timing (seconds)."
:quantiles []
:type :summary}})
:type :summary}
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Entry Point
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
:session-update-total
{:name "http_session_update_total"
:help "A counter of session update batch events."
:type :counter}
:tasks-timing
{:name "penpot_tasks_timing"
:help "Background tasks timing (milliseconds)."
:labels ["name"]
:type :summary}
:rlimit-queued-submissions
{:name "penpot_rlimit_queued_submissions"
:help "Current number of queued submissions on RLIMIT."
:labels ["name"]
:type :gauge}
:rlimit-used-permits
{:name "penpot_rlimit_used_permits"
:help "Current number of used permits on RLIMIT."
:labels ["name"]
:type :gauge}
:rlimit-acquires-total
{:name "penpot_rlimit_acquires_total"
:help "Total number of acquire operations on RLIMIT."
:labels ["name"]
:type :counter}
:executors-active-threads
{:name "penpot_executors_active_threads"
:help "Current number of threads available in the executor service."
:labels ["name"]
:type :gauge}
:executors-completed-tasks
{:name "penpot_executors_completed_tasks_total"
:help "Aproximate number of completed tasks by the executor."
:labels ["name"]
:type :counter}
:executors-running-threads
{:name "penpot_executors_running_threads"
:help "Current number of threads with state RUNNING."
:labels ["name"]
:type :gauge}
:executors-queued-submissions
{:name "penpot_executors_queued_submissions"
:help "Current number of queued submissions."
:labels ["name"]
:type :gauge}})
(defmethod ig/init-key ::metrics
[_ _]
@ -95,31 +149,44 @@
(s/keys :req-un [::registry ::handler]))
(defn- handler
[registry _request]
[registry _ respond _]
(let [samples (.metricFamilySamples ^CollectorRegistry registry)
writer (StringWriter.)]
(TextFormat/write004 writer samples)
{:headers {"content-type" TextFormat/CONTENT_TYPE_004}
:body (.toString writer)}))
(respond {:headers {"content-type" TextFormat/CONTENT_TYPE_004}
:body (.toString writer)})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def default-empty-labels (into-array String []))
(def default-quantiles
[[0.5 0.01]
[0.90 0.01]
[0.99 0.001]])
(def default-histogram-buckets
[1 5 10 25 50 75 100 250 500 750 1000 2500 5000 7500])
(defn run!
[{:keys [definitions]} {:keys [id] :as params}]
(when-let [mobj (get definitions id)]
((::fn mobj) params)
true))
(defn create-registry
[]
(let [registry (CollectorRegistry.)]
(DefaultExports/register registry)
registry))
(defmacro with-measure
[& {:keys [expr cb]}]
`(let [start# (System/nanoTime)
tdown# ~cb]
(try
~expr
(finally
(tdown# (/ (- (System/nanoTime) start#) 1000000))))))
(defn- is-array?
[o]
(let [oc (class o)]
(and (.isArray ^Class oc)
(= (.getComponentType oc) String))))
(defn make-counter
[{:keys [name help registry reg labels] :as props}]
@ -132,12 +199,9 @@
instance (.register instance registry)]
{::instance instance
::fn (fn [{:keys [by labels] :or {by 1}}]
(if labels
(.. ^Counter instance
(labels (into-array String labels))
(inc by))
(.inc ^Counter instance by)))}))
::fn (fn [{:keys [inc labels] :or {inc 1 labels default-empty-labels}}]
(let [instance (.labels instance (if (is-array? labels) labels (into-array String labels)))]
(.inc ^Counter$Child instance (double inc))))}))
(defn make-gauge
[{:keys [name help registry reg labels] :as props}]
@ -148,48 +212,33 @@
_ (when (seq labels)
(.labelNames instance (into-array String labels)))
instance (.register instance registry)]
{::instance instance
::fn (fn [{:keys [cmd by labels] :or {by 1}}]
(if labels
(let [labels (into-array String [labels])]
(case cmd
:inc (.. ^Gauge instance (labels labels) (inc by))
:dec (.. ^Gauge instance (labels labels) (dec by))))
(case cmd
:inc (.inc ^Gauge instance by)
:dec (.dec ^Gauge instance by))))}))
(def default-quantiles
[[0.75 0.02]
[0.99 0.001]])
::fn (fn [{:keys [inc dec labels val] :or {labels default-empty-labels}}]
(let [instance (.labels ^Gauge instance (if (is-array? labels) labels (into-array String labels)))]
(cond (number? inc) (.inc ^Gauge$Child instance (double inc))
(number? dec) (.dec ^Gauge$Child instance (double dec))
(number? val) (.set ^Gauge$Child instance (double val)))))}))
(defn make-summary
[{:keys [name help registry reg labels max-age quantiles buckets]
:or {max-age 3600 buckets 6 quantiles default-quantiles} :as props}]
:or {max-age 3600 buckets 12 quantiles default-quantiles} :as props}]
(let [registry (or registry reg)
instance (doto (Summary/build)
builder (doto (Summary/build)
(.name name)
(.help help))
_ (when (seq quantiles)
(.maxAgeSeconds ^Summary instance max-age)
(.ageBuckets ^Summary instance buckets))
(.maxAgeSeconds ^Summary$Builder builder ^long max-age)
(.ageBuckets ^Summary$Builder builder buckets))
_ (doseq [[q e] quantiles]
(.quantile ^Summary instance q e))
(.quantile ^Summary$Builder builder q e))
_ (when (seq labels)
(.labelNames instance (into-array String labels)))
instance (.register instance registry)]
(.labelNames ^Summary$Builder builder (into-array String labels)))
instance (.register ^Summary$Builder builder registry)]
{::instance instance
::fn (fn [{:keys [val labels]}]
(if labels
(.. ^Summary instance
(labels (into-array String labels))
(observe val))
(.observe ^Summary instance val)))}))
(def default-histogram-buckets
[1 5 10 25 50 75 100 250 500 750 1000 2500 5000 7500])
::fn (fn [{:keys [val labels] :or {labels default-empty-labels}}]
(let [instance (.labels ^Summary instance (if (is-array? labels) labels (into-array String labels)))]
(.observe ^Summary$Child instance val)))}))
(defn make-histogram
[{:keys [name help registry reg labels buckets]
@ -204,12 +253,9 @@
instance (.register instance registry)]
{::instance instance
::fn (fn [{:keys [val labels]}]
(if labels
(.. ^Histogram instance
(labels (into-array String labels))
(observe val))
(.observe ^Histogram instance val)))}))
::fn (fn [{:keys [val labels] :or {labels default-empty-labels}}]
(let [instance (.labels ^Histogram instance (if (is-array? labels) labels (into-array String labels)))]
(.observe ^Histogram$Child instance val)))}))
(defn create
[{:keys [type] :as props}]
@ -219,114 +265,6 @@
:summary (make-summary props)
:histogram (make-histogram props)))
(defn wrap-counter
([rootf mobj]
(let [mdata (meta rootf)
origf (::original mdata rootf)]
(with-meta
(fn
([a]
((::fn mobj) nil)
(origf a))
([a b]
((::fn mobj) nil)
(origf a b))
([a b c]
((::fn mobj) nil)
(origf a b c))
([a b c d]
((::fn mobj) nil)
(origf a b c d))
([a b c d & more]
((::fn mobj) nil)
(apply origf a b c d more)))
(assoc mdata ::original origf))))
([rootf mobj labels]
(let [mdata (meta rootf)
origf (::original mdata rootf)]
(with-meta
(fn
([a]
((::fn mobj) {:labels labels})
(origf a))
([a b]
((::fn mobj) {:labels labels})
(origf a b))
([a b & more]
((::fn mobj) {:labels labels})
(apply origf a b more)))
(assoc mdata ::original origf)))))
(defn wrap-summary
([rootf mobj]
(let [mdata (meta rootf)
origf (::original mdata rootf)]
(with-meta
(fn
([a]
(with-measure
:expr (origf a)
:cb #((::fn mobj) {:val %})))
([a b]
(with-measure
:expr (origf a b)
:cb #((::fn mobj) {:val %})))
([a b & more]
(with-measure
:expr (apply origf a b more)
:cb #((::fn mobj) {:val %}))))
(assoc mdata ::original origf))))
([rootf mobj labels]
(let [mdata (meta rootf)
origf (::original mdata rootf)]
(with-meta
(fn
([a]
(with-measure
:expr (origf a)
:cb #((::fn mobj) {:val % :labels labels})))
([a b]
(with-measure
:expr (origf a b)
:cb #((::fn mobj) {:val % :labels labels})))
([a b & more]
(with-measure
:expr (apply origf a b more)
:cb #((::fn mobj) {:val % :labels labels}))))
(assoc mdata ::original origf)))))
(defn instrument-vars!
[vars {:keys [wrap] :as props}]
(let [obj (create props)]
(cond
(instance? Counter (::instance obj))
(doseq [var vars]
(alter-var-root var (or wrap wrap-counter) obj))
(instance? Summary (::instance obj))
(doseq [var vars]
(alter-var-root var (or wrap wrap-summary) obj))
:else
(ex/raise :type :not-implemented))))
(defn instrument
[f {:keys [wrap] :as props}]
(let [obj (create props)]
(cond
(instance? Counter (::instance obj))
((or wrap wrap-counter) f obj)
(instance? Summary (::instance obj))
((or wrap wrap-summary) f obj)
(instance? Histogram (::instance obj))
((or wrap wrap-summary) f obj)
:else
(ex/raise :type :not-implemented))))
(defn instrument-jetty!
[^CollectorRegistry registry ^StatisticsHandler handler]
(doto (JettyStatisticsCollector. handler)

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

@ -205,6 +205,9 @@
{:name "0065-add-trivial-spelling-fixes"
:fn (mg/resource "app/migrations/sql/0065-add-trivial-spelling-fixes.sql")}
{:name "0066-add-frame-thumbnail-table"
:fn (mg/resource "app/migrations/sql/0066-add-frame-thumbnail-table.sql")}
])

10
backend/src/app/migrations/sql/0066-add-frame-thumbnail-table.sql Normal file
View file

@ -0,0 +1,10 @@
CREATE TABLE file_frame_thumbnail (
file_id uuid NOT NULL REFERENCES file(id) ON DELETE CASCADE,
frame_id uuid NOT NULL,
created_at timestamptz NOT NULL DEFAULT now(),
updated_at timestamptz NOT NULL DEFAULT clock_timestamp(),
data text NULL,
PRIMARY KEY(file_id, frame_id)
);

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

@ -18,7 +18,6 @@
[integrant.core :as ig]
[promesa.core :as p])
(:import
java.time.Duration
io.lettuce.core.RedisClient
io.lettuce.core.RedisURI
io.lettuce.core.api.StatefulConnection
@ -29,7 +28,10 @@
io.lettuce.core.codec.StringCodec
io.lettuce.core.pubsub.RedisPubSubListener
io.lettuce.core.pubsub.StatefulRedisPubSubConnection
io.lettuce.core.pubsub.api.async.RedisPubSubAsyncCommands))
io.lettuce.core.pubsub.api.async.RedisPubSubAsyncCommands
io.lettuce.core.resource.ClientResources
io.lettuce.core.resource.DefaultClientResources
java.time.Duration))
(def ^:private prefix (cfg/get :tenant))
@ -136,12 +138,18 @@
(declare impl-redis-sub)
(declare impl-redis-unsub)
(defmethod init-backend :redis
[{:keys [redis-uri] :as cfg}]
(let [codec (RedisCodec/of StringCodec/UTF8 ByteArrayCodec/INSTANCE)
resources (.. (DefaultClientResources/builder)
(ioThreadPoolSize 4)
(computationThreadPoolSize 4)
(build))
uri (RedisURI/create redis-uri)
rclient (RedisClient/create ^RedisURI uri)
rclient (RedisClient/create ^ClientResources resources ^RedisURI uri)
pub-conn (.connect ^RedisClient rclient ^RedisCodec codec)
sub-conn (.connectPubSub ^RedisClient rclient ^RedisCodec codec)]
@ -150,13 +158,15 @@
(.setTimeout ^StatefulRedisPubSubConnection sub-conn ^Duration (dt/duration {:seconds 10}))
(-> cfg
(assoc ::resources resources)
(assoc ::pub-conn pub-conn)
(assoc ::sub-conn sub-conn))))
(defmethod stop-backend :redis
[{:keys [::pub-conn ::sub-conn] :as cfg}]
[{:keys [::pub-conn ::sub-conn ::resources] :as cfg}]
(.close ^StatefulRedisConnection pub-conn)
(.close ^StatefulRedisPubSubConnection sub-conn))
(.close ^StatefulRedisPubSubConnection sub-conn)
(.shutdown ^ClientResources resources))
(defmethod init-pub-loop :redis
[{:keys [::pub-conn ::pub-ch]}]

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

@ -13,25 +13,42 @@
[app.db :as db]
[app.loggers.audit :as audit]
[app.metrics :as mtx]
[app.util.retry :as retry]
[app.util.rlimit :as rlimit]
[app.rpc.retry :as retry]
[app.rpc.rlimit :as rlimit]
[app.util.async :as async]
[app.util.services :as sv]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px]))
(defn- default-handler
[_]
(ex/raise :type :not-found))
(p/rejected (ex/error :type :not-found)))
(defn- run-hook
[hook-fn response]
(ex/ignoring (hook-fn))
(defn- handle-response-transformation
[response request mdata]
(if-let [transform-fn (:transform-response mdata)]
(transform-fn request response)
response))
(defn- handle-before-comple-hook
[response mdata]
(when-let [hook-fn (:before-complete mdata)]
(ex/ignoring (hook-fn)))
response)
(defn- rpc-query-handler
[methods {:keys [profile-id session-id] :as request}]
(let [type (keyword (get-in request [:path-params :type]))
"Ring handler that dispatches query requests and convert between
internal async flow into ring async flow."
[methods {:keys [profile-id session-id] :as request} respond raise]
(letfn [(handle-response [result]
(let [mdata (meta result)]
(-> {:status 200 :body result}
(handle-response-transformation request mdata))))]
(let [type (keyword (get-in request [:path-params :type]))
data (merge (:params request)
(:body-params request)
(:uploads request)
@ -41,15 +58,24 @@
(assoc data :profile-id profile-id ::session-id session-id)
(dissoc data :profile-id))
result ((get methods type default-handler) data)
mdata (meta result)]
;; Get the method from methods registry and if method does
;; not exists asigns it to the default handler.
method (get methods type default-handler)]
(cond->> {:status 200 :body result}
(fn? (:transform-response mdata))
((:transform-response mdata) request))))
(-> (method data)
(p/then #(respond (handle-response %)))
(p/catch raise)))))
(defn- rpc-mutation-handler
[methods {:keys [profile-id session-id] :as request}]
"Ring handler that dispatches mutation requests and convert between
internal async flow into ring async flow."
[methods {:keys [profile-id session-id] :as request} respond raise]
(letfn [(handle-response [result]
(let [mdata (meta result)]
(-> {:status 200 :body result}
(handle-response-transformation request mdata)
(handle-before-comple-hook mdata))))]
(let [type (keyword (get-in request [:path-params :type]))
data (merge (:params request)
(:body-params request)
@ -60,51 +86,61 @@
(assoc data :profile-id profile-id ::session-id session-id)
(dissoc data :profile-id))
result ((get methods type default-handler) data)
mdata (meta result)]
(cond->> {:status 200 :body result}
(fn? (:transform-response mdata))
((:transform-response mdata) request)
method (get methods type default-handler)]
(fn? (:before-complete mdata))
(run-hook (:before-complete mdata)))))
(-> (method data)
(p/then #(respond (handle-response %)))
(p/catch raise)))))
(defn- wrap-with-metrics
[cfg f mdata]
(mtx/wrap-summary f (::mobj cfg) [(::sv/name mdata)]))
(defn- wrap-metrics
"Wrap service method with metrics measurement."
[{:keys [metrics ::metrics-id]} f mdata]
(let [labels (into-array String [(::sv/name mdata)])]
(fn [cfg params]
(let [start (System/nanoTime)]
(p/finally
(f cfg params)
(fn [_ _]
(mtx/run! metrics
{:id metrics-id
:val (/ (- (System/nanoTime) start) 1000000)
:labels labels})))))))
(defn- wrap-impl
[{:keys [audit] :as cfg} f mdata]
(let [f (as-> f $
(rlimit/wrap-rlimit cfg $ mdata)
(retry/wrap-retry cfg $ mdata)
(wrap-with-metrics cfg $ mdata))
spec (or (::sv/spec mdata) (s/spec any?))
auth? (:auth mdata true)]
(l/trace :action "register" :name (::sv/name mdata))
(defn- wrap-dispatch
"Wraps service method into async flow, with the ability to dispatching
it to a preconfigured executor service."
[{:keys [executors] :as cfg} f mdata]
(let [dname (::async/dispatch mdata :none)]
(if (= :none dname)
(with-meta
(fn [params]
;; Raise authentication error when rpc method requires auth but
;; no profile-id is found in the request.
(when (and auth? (not (uuid? (:profile-id params))))
(ex/raise :type :authentication
:code :authentication-required
:hint "authentication required for this endpoint"))
(fn [cfg params]
(p/do! (f cfg params)))
mdata)
(let [params' (dissoc params ::request)
params' (us/conform spec params')
result (f cfg params')]
(let [executor (get executors dname)]
(when-not executor
(ex/raise :type :internal
:code :executor-not-configured
:hint (format "executor %s not configured" dname)))
(with-meta
(fn [cfg params]
(-> (px/submit! executor #(f cfg params))
(p/bind p/wrap)))
mdata)))))
;; When audit log is enabled (default false).
(when (fn? audit)
(defn- wrap-audit
[{:keys [audit] :as cfg} f mdata]
(if audit
(with-meta
(fn [cfg {:keys [::request] :as params}]
(p/finally (f cfg params)
(fn [result _]
(when result
(let [resultm (meta result)
request (::request params)
profile-id (or (:profile-id params')
profile-id (or (:profile-id params)
(:profile-id result)
(::audit/profile-id resultm))
props (d/merge params' (::audit/props resultm))]
props (d/merge params (::audit/props resultm))]
(audit :cmd :submit
:type (or (::audit/type resultm)
(::type cfg))
@ -112,26 +148,47 @@
(::sv/name mdata))
:profile-id profile-id
:ip-addr (audit/parse-client-ip request)
:props props)))
:props (dissoc props ::request)))))))
mdata)
f))
(defn- wrap
[cfg f mdata]
(let [f (as-> f $
(wrap-dispatch cfg $ mdata)
(rlimit/wrap-rlimit cfg $ mdata)
(retry/wrap-retry cfg $ mdata)
(wrap-audit cfg $ mdata)
(wrap-metrics cfg $ mdata)
)
spec (or (::sv/spec mdata) (s/spec any?))
auth? (:auth mdata true)]
(l/trace :action "register" :name (::sv/name mdata))
(with-meta
(fn [{:keys [::request] :as params}]
;; Raise authentication error when rpc method requires auth but
;; no profile-id is found in the request.
(p/do!
(if (and auth? (not (uuid? (:profile-id params))))
(ex/raise :type :authentication
:code :authentication-required
:hint "authentication required for this endpoint")
(let [params (us/conform spec (dissoc params ::request))]
(f cfg (assoc params ::request request))))))
result))
mdata)))
(defn- process-method
[cfg vfn]
(let [mdata (meta vfn)]
[(keyword (::sv/name mdata))
(wrap-impl cfg (deref vfn) mdata)]))
(wrap cfg (deref vfn) mdata)]))
(defn- resolve-query-methods
[cfg]
(let [mobj (mtx/create
{:name "rpc_query_timing"
:labels ["name"]
:registry (get-in cfg [:metrics :registry])
:type :histogram
:help "Timing of query services."})
cfg (assoc cfg ::mobj mobj ::type "query")]
(let [cfg (assoc cfg ::type "query" ::metrics-id :rpc-query-timing)]
(->> (sv/scan-ns 'app.rpc.queries.projects
'app.rpc.queries.files
'app.rpc.queries.teams
@ -144,13 +201,7 @@
(defn- resolve-mutation-methods
[cfg]
(let [mobj (mtx/create
{:name "rpc_mutation_timing"
:labels ["name"]
:registry (get-in cfg [:metrics :registry])
:type :histogram
:help "Timing of mutation services."})
cfg (assoc cfg ::mobj mobj ::type "mutation")]
(let [cfg (assoc cfg ::type "mutation" ::metrics-id :rpc-mutation-timing)]
(->> (sv/scan-ns 'app.rpc.mutations.demo
'app.rpc.mutations.media
'app.rpc.mutations.profile
@ -170,15 +221,16 @@
(s/def ::session map?)
(s/def ::tokens fn?)
(s/def ::audit (s/nilable fn?))
(s/def ::executors (s/map-of keyword? ::wrk/executor))
(defmethod ig/pre-init-spec ::rpc [_]
(s/keys :req-un [::storage ::session ::tokens ::audit
::mtx/metrics ::db/pool]))
::executors ::mtx/metrics ::db/pool]))
(defmethod ig/init-key ::rpc
[_ cfg]
(let [mq (resolve-query-methods cfg)
mm (resolve-mutation-methods cfg)]
{:methods {:query mq :mutation mm}
:query-handler #(rpc-query-handler mq %)
:mutation-handler #(rpc-mutation-handler mm %)}))
:query-handler (partial rpc-query-handler mq)
:mutation-handler (partial rpc-mutation-handler mm)}))

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

@ -7,12 +7,13 @@
(ns app.rpc.mutations.comments
(:require
[app.common.exceptions :as ex]
[app.common.geom.point :as gpt]
[app.common.spec :as us]
[app.db :as db]
[app.rpc.queries.comments :as comments]
[app.rpc.queries.files :as files]
[app.rpc.retry :as retry]
[app.util.blob :as blob]
[app.util.retry :as retry]
[app.util.services :as sv]
[app.util.time :as dt]
[clojure.spec.alpha :as s]))
@ -26,15 +27,14 @@
(s/def ::page-id ::us/uuid)
(s/def ::file-id ::us/uuid)
(s/def ::profile-id ::us/uuid)
(s/def ::position ::us/point)
(s/def ::position ::gpt/point)
(s/def ::content ::us/string)
(s/def ::create-comment-thread
(s/keys :req-un [::profile-id ::file-id ::position ::content ::page-id]))
(sv/defmethod ::create-comment-thread
{::retry/enabled true
::retry/max-retries 3
{::retry/max-retries 3
::retry/matches retry/conflict-db-insert?}
[{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
(db/with-atomic [conn pool]

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

@ -18,6 +18,7 @@
[app.rpc.queries.files :as files]
[app.rpc.queries.projects :as proj]
[app.storage.impl :as simpl]
[app.util.async :as async]
[app.util.blob :as blob]
[app.util.services :as sv]
[app.util.time :as dt]
@ -27,6 +28,8 @@
;; --- Helpers & Specs
(s/def ::frame-id ::us/uuid)
(s/def ::file-id ::us/uuid)
(s/def ::id ::us/uuid)
(s/def ::name ::us/string)
(s/def ::profile-id ::us/uuid)
@ -270,6 +273,7 @@
(contains? o :changes-with-metadata)))))
(sv/defmethod ::update-file
{::async/dispatch :blocking}
[{:keys [pool] :as cfg} {:keys [id profile-id] :as params}]
(db/with-atomic [conn pool]
(db/xact-lock! conn id)
@ -305,24 +309,21 @@
:context {:incoming-revn (:revn params)
:stored-revn (:revn file)}))
(let [mtx1 (get-in metrics [:definitions :update-file-changes])
mtx2 (get-in metrics [:definitions :update-file-bytes-processed])
changes (if changes-with-metadata
(let [changes (if changes-with-metadata
(mapcat :changes changes-with-metadata)
changes)
changes (vec changes)
;; Trace the number of changes processed
_ ((::mtx/fn mtx1) {:by (count changes)})
_ (mtx/run! metrics {:id :update-file-changes :inc (count changes)})
ts (dt/now)
file (-> (files/retrieve-data cfg file)
(update :revn inc)
(update :data (fn [data]
;; Trace the length of bytes of processed data
((::mtx/fn mtx2) {:by (alength data)})
(mtx/run! metrics {:id :update-file-bytes-processed :inc (alength data)})
(-> data
(blob/decode)
(assoc :id (:id file))
@ -472,3 +473,25 @@
{:id id})))
nil)))
;; --- Mutation: Upsert frame thumbnail
(def sql:upsert-frame-thumbnail
"insert into file_frame_thumbnail(file_id, frame_id, data)
values (?, ?, ?)
on conflict(file_id, frame_id) do
update set data = ?;")
(s/def ::data ::us/string)
(s/def ::upsert-frame-thumbnail
(s/keys :req-un [::profile-id ::file-id ::frame-id ::data]))
(sv/defmethod ::upsert-frame-thumbnail
[{:keys [pool] :as cfg} {:keys [profile-id file-id frame-id data]}]
(db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id file-id)
(db/exec-one! conn [sql:upsert-frame-thumbnail file-id frame-id data data])
nil))

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

@ -9,12 +9,10 @@
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.media :as media]
[app.rpc.queries.teams :as teams]
[app.storage :as sto]
[app.util.rlimit :as rlimit]
[app.util.services :as sv]
[app.util.time :as dt]
[clojure.spec.alpha :as s]))
@ -39,42 +37,47 @@
::font-id ::font-family ::font-weight ::font-style]))
(sv/defmethod ::create-font-variant
{::rlimit/permits (cf/get :rlimit-font)}
[{:keys [pool] :as cfg} {:keys [team-id profile-id] :as params}]
(db/with-atomic [conn pool]
(let [cfg (assoc cfg :conn conn)]
(teams/check-edition-permissions! conn profile-id team-id)
(create-font-variant cfg params))))
(teams/check-edition-permissions! pool profile-id team-id)
(create-font-variant cfg params))
(defn create-font-variant
[{:keys [conn storage] :as cfg} {:keys [data] :as params}]
[{:keys [storage pool] :as cfg} {:keys [data] :as params}]
(let [data (media/run {:cmd :generate-fonts :input data})
storage (media/configure-assets-storage storage conn)
storage (media/configure-assets-storage storage)]
otf (when-let [fdata (get data "font/otf")]
(sto/put-object storage {:content (sto/content fdata)
:content-type "font/otf"}))
ttf (when-let [fdata (get data "font/ttf")]
(sto/put-object storage {:content (sto/content fdata)
:content-type "font/ttf"}))
woff1 (when-let [fdata (get data "font/woff")]
(sto/put-object storage {:content (sto/content fdata)
:content-type "font/woff"}))
woff2 (when-let [fdata (get data "font/woff2")]
(sto/put-object storage {:content (sto/content fdata)
:content-type "font/woff2"}))]
(when (and (nil? otf)
(nil? ttf)
(nil? woff1)
(nil? woff2))
(when (and (not (contains? data "font/otf"))
(not (contains? data "font/ttf"))
(not (contains? data "font/woff"))
(not (contains? data "font/woff2")))
(ex/raise :type :validation
:code :invalid-font-upload))
(db/insert! conn :team-font-variant
(let [otf (when-let [fdata (get data "font/otf")]
(sto/put-object storage {:content (sto/content fdata)
:content-type "font/otf"
:reference :team-font-variant
:touched-at (dt/now)}))
ttf (when-let [fdata (get data "font/ttf")]
(sto/put-object storage {:content (sto/content fdata)
:content-type "font/ttf"
:touched-at (dt/now)
:reference :team-font-variant}))
woff1 (when-let [fdata (get data "font/woff")]
(sto/put-object storage {:content (sto/content fdata)
:content-type "font/woff"
:touched-at (dt/now)
:reference :team-font-variant}))
woff2 (when-let [fdata (get data "font/woff2")]
(sto/put-object storage {:content (sto/content fdata)
:content-type "font/woff2"
:touched-at (dt/now)
:reference :team-font-variant}))]
(db/insert! pool :team-font-variant
{:id (uuid/next)
:team-id (:team-id params)
:font-id (:font-id params)
@ -84,7 +87,7 @@
:woff1-file-id (:id woff1)
:woff2-file-id (:id woff2)
:otf-file-id (:id otf)
:ttf-file-id (:id ttf)})))
:ttf-file-id (:id ttf)}))))
;; --- UPDATE FONT FAMILY

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

@ -56,7 +56,7 @@
(s/keys :req-un [::email ::password]
:opt-un [::invitation-token]))
(sv/defmethod ::login-with-ldap {:auth false :rlimit :password}
(sv/defmethod ::login-with-ldap {:auth false}
[{:keys [pool session tokens] :as cfg} params]
(db/with-atomic [conn pool]
(let [info (authenticate params)

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

@ -14,9 +14,10 @@
[app.db :as db]
[app.media :as media]
[app.rpc.queries.teams :as teams]
[app.rpc.rlimit :as rlimit]
[app.storage :as sto]
[app.util.async :as async]
[app.util.http :as http]
[app.util.rlimit :as rlimit]
[app.util.services :as sv]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
@ -49,13 +50,12 @@
:opt-un [::id]))
(sv/defmethod ::upload-file-media-object
{::rlimit/permits (cf/get :rlimit-image)}
{::rlimit/permits (cf/get :rlimit-image)
::async/dispatch :default}
[{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
(db/with-atomic [conn pool]
(let [file (select-file conn file-id)]
(teams/check-edition-permissions! conn profile-id (:team-id file))
(-> (assoc cfg :conn conn)
(create-file-media-object params)))))
(let [file (select-file pool file-id)]
(teams/check-edition-permissions! pool profile-id (:team-id file))
(create-file-media-object cfg params)))
(defn- big-enough-for-thumbnail?
"Checks if the provided image info is big enough for
@ -77,6 +77,9 @@
:code :unable-to-access-to-url
:cause e))))
;; TODO: we need to check the size before fetch resource, if not we
;; can start downloading very big object and cause OOM errors.
(defn- download-media
[{:keys [storage] :as cfg} url]
(let [result (fetch-url url)
@ -90,6 +93,7 @@
(-> (assoc storage :backend :tmp)
(sto/put-object {:content (sto/content data)
:content-type mtype
:reference :file-media-object
:expired-at (dt/in-future {:minutes 30})}))))
;; NOTE: we use the `on conflict do update` instead of `do nothing`
@ -102,13 +106,27 @@
on conflict (id) do update set created_at=file_media_object.created_at
returning *")
;; NOTE: the following function executes without a transaction, this
;; means that if something fails in the middle of this function, it
;; will probably leave leaked/unreferenced objects in the database and
;; probably in the storage layer. For handle possible object leakage,
;; we create all media objects marked as touched, this ensures that if
;; something fails, all leaked (already created storage objects) will
;; be eventually marked as deleted by the touched-gc task.
;;
;; The touched-gc task, performs periodic analisis of all touched
;; storage objects and check references of it. This is the reason why
;; `reference` metadata exists: it indicates the name of the table
;; witch holds the reference to storage object (it some kind of
;; inverse, soft referential integrity).
(defn create-file-media-object
[{:keys [conn storage] :as cfg} {:keys [id file-id is-local name content] :as params}]
[{:keys [storage pool] :as cfg} {:keys [id file-id is-local name content] :as params}]
(media/validate-media-type (:content-type content))
(let [storage (media/configure-assets-storage storage conn)
source-path (fs/path (:tempfile content))
(let [source-path (fs/path (:tempfile content))
source-mtype (:content-type content)
source-info (media/run {:cmd :info :input {:path source-path :mtype source-mtype}})
storage (media/configure-assets-storage storage)
thumb (when (and (not (svg-image? source-info))
(big-enough-for-thumbnail? source-info))
@ -119,16 +137,25 @@
image (if (= (:mtype source-info) "image/svg+xml")
(let [data (slurp source-path)]
(sto/put-object storage {:content (sto/content data)
:content-type (:mtype source-info)}))
(sto/put-object storage {:content (sto/content source-path)
:content-type (:mtype source-info)}))
(sto/put-object storage
{:content (sto/content data)
:content-type (:mtype source-info)
:reference :file-media-object
:touched-at (dt/now)}))
(sto/put-object storage
{:content (sto/content source-path)
:content-type (:mtype source-info)
:reference :file-media-object
:touched-at (dt/now)}))
thumb (when thumb
(sto/put-object storage {:content (sto/content (:data thumb) (:size thumb))
:content-type (:mtype thumb)}))]
(sto/put-object storage
{:content (sto/content (:data thumb) (:size thumb))
:content-type (:mtype thumb)
:reference :file-media-object
:touched-at (dt/now)}))]
(db/exec-one! conn [sql:create-file-media-object
(db/exec-one! pool [sql:create-file-media-object
(or id (uuid/next))
file-id is-local name
(:id image)
@ -144,20 +171,19 @@
:opt-un [::id ::name]))
(sv/defmethod ::create-file-media-object-from-url
{::rlimit/permits (cf/get :rlimit-image)
::async/dispatch :default}
[{:keys [pool storage] :as cfg} {:keys [profile-id file-id url name] :as params}]
(db/with-atomic [conn pool]
(let [file (select-file conn file-id)]
(teams/check-edition-permissions! conn profile-id (:team-id file))
(let [file (select-file pool file-id)]
(teams/check-edition-permissions! pool profile-id (:team-id file))
(let [mobj (download-media cfg url)
content {:filename "tempfile"
:size (:size mobj)
:tempfile (sto/get-object-path storage mobj)
:content-type (:content-type (meta mobj))}
params' (merge params {:content content
:name (or name (:filename content))})]
(-> (assoc cfg :conn conn)
(create-file-media-object params'))))))
:content-type (:content-type (meta mobj))}]
(->> (merge params {:content content :name (or name (:filename content))})
(create-file-media-object cfg)))))
;; --- Clone File Media object (Upload and create from url)
@ -189,7 +215,6 @@
:height (:height mobj)
:mtype (:mtype mobj)})))
;; --- HELPERS
(def ^:private

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

@ -15,11 +15,11 @@
[app.http.oauth :refer [extract-utm-props]]
[app.loggers.audit :as audit]
[app.media :as media]
[app.metrics :as mtx]
[app.rpc.mutations.teams :as teams]
[app.rpc.queries.profile :as profile]
[app.rpc.rlimit :as rlimit]
[app.storage :as sto]
[app.util.rlimit :as rlimit]
[app.util.async :as async]
[app.util.services :as sv]
[app.util.time :as dt]
[buddy.hashers :as hashers]
@ -38,7 +38,6 @@
(s/def ::theme ::us/string)
(s/def ::invitation-token ::us/not-empty-string)
(declare annotate-profile-register)
(declare check-profile-existence!)
(declare create-profile)
(declare create-profile-relations)
@ -102,6 +101,7 @@
(when-not (contains? cf/flags :registration)
(ex/raise :type :restriction
:code :registration-disabled))
(when-let [domains (cf/get :registration-domain-whitelist)]
(when-not (email-domain-in-whitelist? domains (:email params))
(ex/raise :type :validation
@ -116,10 +116,17 @@
(check-profile-existence! pool params)
(let [params (assoc params
(when (= (str/lower (:email params))
(str/lower (:password params)))
(ex/raise :type :validation
:code :email-as-password
:hint "you can't use your email as password"))
(let [params {:email (:email params)
:invitation-token (:invitation-token params)
:backend "penpot"
:iss :prepared-register
:exp (dt/in-future "48h"))
:exp (dt/in-future "48h")}
token (tokens :generate params)]
{:token token}))
@ -136,16 +143,8 @@
(-> (assoc cfg :conn conn)
(register-profile params))))
(defn- annotate-profile-register
"A helper for properly increase the profile-register metric once the
transaction is completed."
[metrics]
(fn []
(let [mobj (get-in metrics [:definitions :profile-register])]
((::mtx/fn mobj) {:by 1}))))
(defn register-profile
[{:keys [conn tokens session metrics] :as cfg} {:keys [token] :as params}]
[{:keys [conn tokens session] :as cfg} {:keys [token] :as params}]
(let [claims (tokens :verify {:token token :iss :prepared-register})
params (merge params claims)]
@ -156,23 +155,21 @@
profile (->> (assoc params :is-active is-active)
(create-profile conn)
(create-profile-relations conn)
(decode-profile-row))]
(decode-profile-row))
invitation (when-let [token (:invitation-token params)]
(tokens :verify {:token token :iss :team-invitation}))]
(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))
;; 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). This happens only if the invitation email matches with the register email.
(and (some? invitation) (= (:email profile) (:member-email invitation)))
(let [claims (assoc invitation :member-id (:id 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)}))
@ -182,7 +179,6 @@
(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)})
@ -191,7 +187,6 @@
(true? is-active)
(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)})
@ -214,8 +209,7 @@
:extra-data ptoken})
(with-meta profile
{:before-complete (annotate-profile-register metrics)
::audit/props (audit/profile->props profile)
{::audit/props (audit/profile->props profile)
::audit/profile-id (:id profile)}))))))
(defn create-profile
@ -284,7 +278,9 @@
:opt-un [::scope ::invitation-token]))
(sv/defmethod ::login
{:auth false ::rlimit/permits (cf/get :rlimit-password)}
{:auth false
::async/dispatch :default
::rlimit/permits (cf/get :rlimit-password)}
[{:keys [pool session tokens] :as cfg} {:keys [email password] :as params}]
(letfn [(check-password [profile password]
(when (= (:password profile) "!")
@ -309,28 +305,22 @@
(validate-profile)
(profile/strip-private-attrs)
(profile/populate-additional-data conn)
(decode-profile-row))]
(if-let [token (:invitation-token params)]
;; If the request comes with an invitation token, this means
;; that user wants to accept it with different user. A very
;; strange case but still can happen. In this case, we
;; proceed in the same way as in register: regenerate the
;; invitation token and return it to the user for proper
;; invitation acceptation.
(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 (audit/profile->props profile)
::audit/profile-id (:id profile)}))
(decode-profile-row))
(with-meta profile
invitation (when-let [token (:invitation-token params)]
(tokens :verify {:token token :iss :team-invitation}))
;; If invitation member-id does not matches the profile-id, we just proceed to ignore the
;; invitation because invitations matches exactly; and user can't loging with other email and
;; accept invitation with other email
response (if (and (some? invitation) (= (:id profile) (:member-id invitation)))
{:invitation-token (:invitation-token params)}
profile)]
(with-meta response
{:transform-response ((:create session) (:id profile))
::audit/props (audit/profile->props profile)
::audit/profile-id (:id profile)}))))))
::audit/profile-id (:id profile)})))))
;; --- MUTATION: Logout
@ -360,6 +350,7 @@
:opt-un [::lang ::theme]))
(sv/defmethod ::update-profile
{::async/dispatch :default}
[{:keys [pool] :as cfg} params]
(db/with-atomic [conn pool]
(let [profile (update-profile conn params)]
@ -381,6 +372,11 @@
(db/with-atomic [conn pool]
(let [profile (validate-password! conn params)
session-id (:app.rpc/session-id params)]
(when (= (str/lower (:email profile))
(str/lower (:password params)))
(ex/raise :type :validation
:code :email-as-password
:hint "you can't use your email as password"))
(update-profile-password! conn (assoc profile :password password))
(invalidate-profile-session! conn (:id profile) session-id)
nil)))

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

@ -18,8 +18,8 @@
[app.rpc.permissions :as perms]
[app.rpc.queries.profile :as profile]
[app.rpc.queries.teams :as teams]
[app.rpc.rlimit :as rlimit]
[app.storage :as sto]
[app.util.rlimit :as rlimit]
[app.util.services :as sv]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
@ -379,8 +379,7 @@
:code :member-is-muted
:hint "looks like the profile has reported repeatedly as spam or has permanent bounces"))
;; Secondly check if the invited member email is part of the
;; global spam/bounce report.
;; Secondly check if the invited member email is part of the global spam/bounce report.
(when (eml/has-bounce-reports? conn email)
(ex/raise :type :validation
:code :email-has-permanent-bounces
@ -403,13 +402,21 @@
(s/and ::create-team (s/keys :req-un [::emails ::role])))
(sv/defmethod ::create-team-and-invite-members
[{:keys [pool] :as cfg} {:keys [profile-id emails role] :as params}]
[{:keys [pool audit] :as cfg} {:keys [profile-id emails role] :as params}]
(db/with-atomic [conn pool]
(let [team (create-team conn params)
profile (db/get-by-id conn :profile profile-id)]
;; Create invitations for all provided emails.
(doseq [email emails]
(audit :cmd :submit
:type "mutation"
:name "create-team-invitation"
:profile-id profile-id
:props {:email email
:role role
:profile-id profile-id})
(create-team-invitation
(assoc cfg
:conn conn

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

@ -10,7 +10,6 @@
[app.common.spec :as us]
[app.db :as db]
[app.loggers.audit :as audit]
[app.metrics :as mtx]
[app.rpc.mutations.teams :as teams]
[app.rpc.queries.profile :as profile]
[app.util.services :as sv]
@ -44,16 +43,8 @@
::audit/props {:email email}
::audit/profile-id profile-id}))
(defn- annotate-profile-activation
"A helper for properly increase the profile-activation metric once the
transaction is completed."
[metrics]
(fn []
(let [mobj (get-in metrics [:definitions :profile-activation])]
((::mtx/fn mobj) {:by 1}))))
(defmethod process-token :verify-email
[{:keys [conn session metrics] :as cfg} _ {:keys [profile-id] :as claims}]
[{:keys [conn session] :as cfg} _ {:keys [profile-id] :as claims}]
(let [profile (profile/retrieve-profile conn profile-id)
claims (assoc claims :profile profile)]
@ -69,7 +60,6 @@
(with-meta claims
{:transform-response ((:create session) profile-id)
:before-complete (annotate-profile-activation metrics)
::audit/name "verify-profile-email"
::audit/props (audit/profile->props profile)
::audit/profile-id (:id profile)})))
@ -118,77 +108,39 @@
(assoc member :is-active true)))
(defmethod process-token :team-invitation
[{:keys [session] :as cfg} {:keys [profile-id token]} {:keys [member-id] :as claims}]
[cfg {:keys [profile-id token]} {:keys [member-id] :as claims}]
(us/assert ::team-invitation-claims claims)
(cond
;; This happens when token is filled with member-id and current
;; user is already logged in with some account.
(and (uuid? profile-id)
(uuid? member-id))
;; user is already logged in with exactly invited account.
(and (uuid? profile-id) (uuid? member-id) (= member-id profile-id))
(let [profile (accept-invitation cfg claims)]
(if (= member-id profile-id)
;; If the current session is already matches the invited
;; member, then just return the token and leave the frontend
;; app redirect to correct team.
(assoc claims :state :created)
;; If the session does not matches the invited member, replace
;; the session with a new one matching the invited member.
;; This technique should be considered secure because the
;; user clicking the link he already has access to the email
;; account.
(with-meta
(assoc claims :state :created)
{:transform-response ((:create session) member-id)
::audit/name "accept-team-invitation"
::audit/props (merge
(audit/profile->props profile)
{:team-id (:team-id claims)
:role (:role claims)})
::audit/profile-id profile-id})))
;; This happens when member-id is not filled in the invitation but
;; the user already has an account (probably with other mail) and
;; is already logged-in.
(and (uuid? profile-id)
(nil? member-id))
(let [profile (accept-invitation cfg (assoc claims :member-id profile-id))]
(with-meta
(assoc claims :state :created)
{::audit/name "accept-team-invitation"
::audit/props (merge
(audit/profile->props profile)
{:team-id (:team-id claims)
:role (:role claims)})
::audit/profile-id profile-id}))
;; This happens when member-id is filled but the accessing user is
;; not logged-in. In this case we proceed to accept invitation and
;; leave the user logged-in.
(and (nil? profile-id)
(uuid? member-id))
(let [profile (accept-invitation cfg claims)]
(with-meta
(assoc claims :state :created)
{:transform-response ((:create session) member-id)
::audit/name "accept-team-invitation"
::audit/props (merge
(audit/profile->props profile)
{:team-id (:team-id claims)
:role (:role claims)})
::audit/profile-id member-id}))
;; In this case, we wait until frontend app redirect user to
;; registration page, the user is correctly registered and the
;; register mutation call us again with the same token to finally
;; create the corresponding team-profile relation from the first
;; condition of this if.
;; This case means that invitation token does not match with
;; registred user, so we need to indicate to frontend to redirect
;; it to register page.
(nil? member-id)
{:invitation-token token
:iss :team-invitation
:redirect-to :auth-register
:state :pending}
;; In all other cases, just tell to fontend to redirect the user
;; to the login page.
:else
{:invitation-token token
:iss :team-invitation
:redirect-to :auth-login
:state :pending}))
;; --- Default
(defmethod process-token :default

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

@ -7,7 +7,7 @@
(ns app.rpc.queries.files
(:require
[app.common.data :as d]
[app.common.pages :as cp]
[app.common.pages.helpers :as cph]
[app.common.pages.migrations :as pmg]
[app.common.spec :as us]
[app.common.uuid :as uuid]
@ -26,6 +26,7 @@
;; --- Helpers & Specs
(s/def ::frame-id ::us/uuid)
(s/def ::id ::us/uuid)
(s/def ::name ::us/string)
(s/def ::project-id ::us/uuid)
@ -242,13 +243,10 @@
(defn- trim-file-data
[file {:keys [page-id object-id]}]
(let [page (get-in file [:data :pages-index page-id])
objects (->> (:objects page)
(cp/get-object-with-children object-id)
(map #(dissoc % :thumbnail)))
objects (d/index-by :id objects)
objects (->> (cph/get-children-with-self (:objects page) object-id)
(map #(dissoc % :thumbnail))
(d/index-by :id))
page (assoc page :objects objects)]
(-> file
(update :data assoc :pages-index {page-id page})
(update :data assoc :pages [page-id]))))
@ -395,6 +393,7 @@
)
select * from recent_files where row_num <= 10;")
(s/def ::team-recent-files
(s/keys :req-un [::profile-id ::team-id]))
@ -404,6 +403,25 @@
(teams/check-read-permissions! conn profile-id team-id)
(db/exec! conn [sql:team-recent-files team-id])))
;; --- QUERY: get the thumbnail for an frame
(def ^:private sql:file-frame-thumbnail
"select data
from file_frame_thumbnail
where file_id = ?
and frame_id = ?")
(s/def ::file-frame-thumbnail
(s/keys :req-un [::profile-id ::file-id ::frame-id]))
(sv/defmethod ::file-frame-thumbnail
[{:keys [pool]} {:keys [profile-id file-id frame-id]}]
(with-open [conn (db/open pool)]
(check-read-permissions! conn profile-id file-id)
(db/exec-one! conn [sql:file-frame-thumbnail file-id frame-id])))
;; --- Helpers
(defn decode-row

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

@ -35,7 +35,8 @@
(s/def ::profile
(s/keys :opt-un [::profile-id]))
(sv/defmethod ::profile {:auth false}
(sv/defmethod ::profile
{:auth false}
[{:keys [pool] :as cfg} {:keys [profile-id] :as params}]
;; We need to return the anonymous profile object in two cases, when
;; no profile-id is in session, and when db call raises not found. In all other

45
backend/src/app/rpc/retry.clj Normal file
View file

@ -0,0 +1,45 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) UXBOX Labs SL
(ns app.rpc.retry
"A fault tolerance helpers. Allow retry some operations that we know
we can retry."
(:require
[app.common.logging :as l]
[app.util.services :as sv]
[promesa.core :as p]))
(defn conflict-db-insert?
"Check if exception matches a insertion conflict on postgresql."
[e]
(and (instance? org.postgresql.util.PSQLException e)
(= "23505" (.getSQLState e))))
(defn wrap-retry
[_ f {:keys [::matches ::sv/name]
:or {matches (constantly false)}
:as mdata}]
(when (::enabled mdata)
(l/debug :hint "wrapping retry" :name name))
(if-let [max-retries (::max-retries mdata)]
(fn [cfg params]
(letfn [(run [retry]
(-> (f cfg params)
(p/catch (partial handle-error retry))))
(handle-error [retry cause]
(if (matches cause)
(let [current-retry (inc retry)]
(l/trace :hint "running retry algorithm" :retry current-retry)
(if (<= current-retry max-retries)
(run current-retry)
(throw cause)))
(throw cause)))]
(run 0)))
f))

67
backend/src/app/rpc/rlimit.clj Normal file
View file

@ -0,0 +1,67 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) UXBOX Labs SL
(ns app.rpc.rlimit
"Resource usage limits (in other words: semaphores)."
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.metrics :as mtx]
[app.util.services :as sv]
[promesa.core :as p]))
(defprotocol IAsyncSemaphore
(acquire! [_])
(release! [_]))
(defn semaphore
[{:keys [permits metrics name]}]
(let [name (d/name name)
used (volatile! 0)
queue (volatile! (d/queue))
labels (into-array String [name])]
(reify IAsyncSemaphore
(acquire! [this]
(let [d (p/deferred)]
(locking this
(if (< @used permits)
(do
(vswap! used inc)
(p/resolve! d))
(vswap! queue conj d)))
(mtx/run! metrics {:id :rlimit-used-permits :val @used :labels labels })
(mtx/run! metrics {:id :rlimit-queued-submissions :val (count @queue) :labels labels})
(mtx/run! metrics {:id :rlimit-acquires-total :inc 1 :labels labels})
d))
(release! [this]
(locking this
(if-let [item (peek @queue)]
(do
(vswap! queue pop)
(p/resolve! item))
(when (pos? @used)
(vswap! used dec))))
(mtx/run! metrics {:id :rlimit-used-permits :val @used :labels labels})
(mtx/run! metrics {:id :rlimit-queued-submissions :val (count @queue) :labels labels})
))))
(defn wrap-rlimit
[{:keys [metrics] :as cfg} f mdata]
(if-let [permits (::permits mdata)]
(let [sem (semaphore {:permits permits
:metrics metrics
:name (::sv/name mdata)})]
(l/debug :hint "wrapping rlimit" :handler (::sv/name mdata) :permits permits)
(fn [cfg params]
(-> (acquire! sem)
(p/then (fn [_] (f cfg params)))
(p/finally (fn [_ _] (release! sem))))))
f))

85
backend/src/app/setup.clj
View file

@ -7,6 +7,7 @@
(ns app.setup
"Initial data setup of instance."
(:require
[app.common.logging :as l]
[app.common.uuid :as uuid]
[app.db :as db]
[buddy.core.codecs :as bc]
@ -14,55 +15,49 @@
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
(declare initialize-instance-id!)
(declare initialize-secret-key!)
(declare retrieve-all)
(defn- generate-random-key
[]
(-> (bn/random-bytes 64)
(bc/bytes->b64u)
(bc/bytes->str)))
(defn- retrieve-all
[conn]
(->> (db/query conn :server-prop {:preload true})
(filter #(not= "secret-key" (:id %)))
(map (fn [row]
[(keyword (:id row))
(db/decode-transit-pgobject (:content row))]))
(into {})))
(defn- handle-instance-id
[instance-id conn read-only?]
(or instance-id
(let [instance-id (uuid/random)]
(when-not read-only?
(try
(db/insert! conn :server-prop
{:id "instance-id"
:preload true
:content (db/tjson instance-id)})
(catch Throwable cause
(l/warn :hint "unable to persist instance-id"
:instance-id instance-id
:cause cause))))
instance-id)))
(defmethod ig/pre-init-spec ::props [_]
(s/keys :req-un [::db/pool]))
(defmethod ig/init-key ::props
[_ {:keys [pool] :as cfg}]
[_ {:keys [pool key] :as cfg}]
(db/with-atomic [conn pool]
(let [cfg (assoc cfg :conn conn)]
(initialize-secret-key! cfg)
(initialize-instance-id! cfg)
(retrieve-all cfg))))
(db/xact-lock! conn 0)
(when-not key
(l/warn :hint (str "using autogenerated secret-key, it will change on each restart and will invalidate "
"all sessions on each restart, it is hightly recommeded setting up the "
"PENPOT_SECRET_KEY environment variable")))
(def sql:upsert-secret-key
"insert into server_prop (id, preload, content)
values ('secret-key', true, ?::jsonb)
on conflict (id) do update set content = ?::jsonb")
(def sql:insert-secret-key
"insert into server_prop (id, preload, content)
values ('secret-key', true, ?::jsonb)
on conflict (id) do nothing")
(defn- initialize-secret-key!
[{:keys [conn key] :as cfg}]
(if key
(let [key (db/tjson key)]
(db/exec-one! conn [sql:upsert-secret-key key key]))
(let [key (-> (bn/random-bytes 64)
(bc/bytes->b64u)
(bc/bytes->str))
key (db/tjson key)]
(db/exec-one! conn [sql:insert-secret-key key]))))
(defn- initialize-instance-id!
[{:keys [conn] :as cfg}]
(let [iid (uuid/random)]
(db/insert! conn :server-prop
{:id "instance-id"
:preload true
:content (db/tjson iid)}
{:on-conflict-do-nothing true})))
(defn- retrieve-all
[{:keys [conn] :as cfg}]
(reduce (fn [acc row]
(assoc acc (keyword (:id row)) (db/decode-transit-pgobject (:content row))))
{}
(db/query conn :server-prop {:preload true})))
(let [stored (-> (retrieve-all conn)
(assoc :secret-key (or key (generate-random-key))))]
(update stored :instance-id handle-instance-id conn (db/read-only? pool)))))

6
backend/src/app/srepl/main.clj
View file

@ -7,7 +7,7 @@
[app.common.logging :as l]
[app.common.pages :as cp]
[app.common.pages.migrations :as pmg]
[app.common.pages.spec :as spec]
[app.common.spec.file :as spec.file]
[app.common.uuid :as uuid]
[app.config :as cfg]
[app.db :as db]
@ -86,7 +86,7 @@
(validate-item [{:keys [id data modified-at] :as file}]
(let [data (blob/decode data)
valid? (s/valid? ::spec/data data)]
valid? (s/valid? ::spec.file/data data)]
(l/debug :hint "validated file"
:file-id id
@ -98,7 +98,7 @@
:valid valid?)
(when (and (not valid?) verbose?)
(let [edata (-> (s/explain-data ::spec/data data)
(let [edata (-> (s/explain-data ::spec.file/data data)
(update ::s/problems #(take 5 %)))]
(binding [s/*explain-out* expound/printer]
(l/warn ::l/raw (with-out-str (s/explain-out edata))))))

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

@ -18,11 +18,9 @@
[app.storage.impl :as impl]
[app.storage.s3 :as ss3]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[datoteka.core :as fs]
[integrant.core :as ig]
[promesa.exec :as px]))
[integrant.core :as ig]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Storage Module State
@ -40,7 +38,7 @@
:db ::sdb/backend))))
(defmethod ig/pre-init-spec ::storage [_]
(s/keys :req-un [::wrk/executor ::db/pool ::backends]))
(s/keys :req-un [::db/pool ::backends]))
(defmethod ig/prep-key ::storage
[_ {:keys [backends] :as cfg}]
@ -53,78 +51,74 @@
(assoc :backends (d/without-nils backends))))
(s/def ::storage
(s/keys :req-un [::backends ::wrk/executor ::db/pool]))
(s/keys :req-un [::backends ::db/pool]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Database Objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defrecord StorageObject [id size created-at expired-at backend])
(defrecord StorageObject [id size created-at expired-at touched-at backend])
(defn storage-object?
[v]
(instance? StorageObject v))
(def ^:private
sql:insert-storage-object
"insert into storage_object (id, size, backend, metadata)
values (?, ?, ?, ?::jsonb)
returning *")
(s/def ::storage-object storage-object?)
(s/def ::storage-content impl/content?)
(def ^:private
sql:insert-storage-object-with-expiration
"insert into storage_object (id, size, backend, metadata, deleted_at)
values (?, ?, ?, ?::jsonb, ?)
returning *")
(defn- insert-object
[conn id size backend mdata expiration]
(if expiration
(db/exec-one! conn [sql:insert-storage-object-with-expiration id size backend mdata expiration])
(db/exec-one! conn [sql:insert-storage-object id size backend mdata])))
(defn- create-database-object
[{:keys [conn backend]} {:keys [content] :as object}]
(if (instance? StorageObject object)
(defn- clone-database-object
;; If we in this condition branch, this means we come from the
;; clone-object, so we just need to clone it with a new backend.
[{:keys [conn backend]} object]
(let [id (uuid/random)
mdata (meta object)
result (insert-object conn
id
(:size object)
(name backend)
(db/tjson mdata)
(:expired-at object))]
result (db/insert! conn :storage-object
{:id id
:size (:size object)
:backend (name backend)
:metadata (db/tjson mdata)
:deleted-at (:expired-at object)
:touched-at (:touched-at object)})]
(assoc object
:id (:id result)
:backend backend
:created-at (:created-at result)))
:created-at (:created-at result)
:touched-at (:touched-at result))))
(defn- create-database-object
[{:keys [conn backend]} {:keys [content] :as object}]
(us/assert ::storage-content content)
(let [id (uuid/random)
mdata (dissoc object :content :expired-at)
result (insert-object conn
id
(count content)
(name backend)
(db/tjson mdata)
(:expired-at object))]
mdata (dissoc object :content :expired-at :touched-at)
result (db/insert! conn :storage-object
{:id id
:size (count content)
:backend (name backend)
:metadata (db/tjson mdata)
:deleted-at (:expired-at object)
:touched-at (:touched-at object)})]
(StorageObject. (:id result)
(:size result)
(:created-at result)
(:deleted-at result)
(:touched-at result)
backend
mdata
nil))))
nil)))
(def ^:private sql:retrieve-storage-object
"select * from storage_object where id = ? and (deleted_at is null or deleted_at > now())")
(defn row->storage-object [res]
(let [mdata (some-> (:metadata res) (db/decode-transit-pgobject))]
(let [mdata (or (some-> (:metadata res) (db/decode-transit-pgobject)) {})]
(StorageObject. (:id res)
(:size res)
(:created-at res)
(:deleted-at res)
(:touched-at res)
(keyword (:backend res))
mdata
nil)))
@ -142,10 +136,6 @@
(let [result (db/exec-one! conn [sql:delete-storage-object id])]
(pos? (:next.jdbc/update-count result))))
(defn- register-recheck
[{:keys [pool] :as storage} backend id]
(db/insert! pool :storage-pending {:id id :backend (name backend)}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -170,17 +160,13 @@
(defn put-object
"Creates a new object with the provided content."
[{:keys [pool conn backend executor] :as storage} {:keys [content] :as params}]
[{:keys [pool conn backend] :as storage} {:keys [content] :as params}]
(us/assert ::storage storage)
(us/assert impl/content? content)
(us/assert ::storage-content content)
(us/assert ::us/keyword backend)
(let [storage (assoc storage :conn (or conn pool))
object (create-database-object storage params)]
;; Schedule to execute in background; in an other transaction and
;; register the currently created storage object id for a later
;; recheck.
(px/run! executor #(register-recheck storage backend (:id object)))
;; Store the data finally on the underlying storage subsystem.
(-> (impl/resolve-backend storage backend)
(impl/put-object object content))
@ -190,10 +176,12 @@
(defn clone-object
"Creates a clone of the provided object using backend based efficient
method. Always clones objects to the configured default."
[{:keys [pool conn] :as storage} object]
[{:keys [pool conn backend] :as storage} object]
(us/assert ::storage storage)
(us/assert ::storage-object object)
(us/assert ::us/keyword backend)
(let [storage (assoc storage :conn (or conn pool))
object* (create-database-object storage object)]
object* (clone-database-object storage object)]
(if (= (:backend object) (:backend storage))
;; if the source and destination backends are the same, we
;; proceed to use the fast path with specific copy
@ -269,7 +257,7 @@
;; A task responsible to permanently delete already marked as deleted
;; storage files.
(declare sql:retrieve-deleted-objects)
(declare sql:retrieve-deleted-objects-chunk)
(s/def ::min-age ::dt/duration)
@ -278,44 +266,46 @@
(defmethod ig/init-key ::gc-deleted-task
[_ {:keys [pool storage min-age] :as cfg}]
(letfn [(group-by-backend [rows]
(let [conj (fnil conj [])]
[(reduce (fn [acc {:keys [id backend]}]
(update acc (keyword backend) conj id))
{}
rows)
(count rows)]))
(letfn [(retrieve-deleted-objects-chunk [conn cursor]
(let [min-age (db/interval min-age)
rows (db/exec! conn [sql:retrieve-deleted-objects-chunk min-age cursor])]
[(some-> rows peek :created-at)
(some->> (seq rows) (d/group-by' #(-> % :backend keyword) :id) seq)]))
(retrieve-deleted-objects [conn]
(let [min-age (db/interval min-age)
rows (db/exec! conn [sql:retrieve-deleted-objects min-age])]
(some-> (seq rows) (group-by-backend))))
(->> (d/iteration (fn [cursor]
(retrieve-deleted-objects-chunk conn cursor))
:initk (dt/now)
:vf second
:kf first)
(sequence cat)))
(delete-in-bulk [conn [backend ids]]
(delete-in-bulk [conn backend ids]
(let [backend (impl/resolve-backend storage backend)
backend (assoc backend :conn conn)]
(impl/del-objects-in-bulk backend ids)))]
(fn [_]
(db/with-atomic [conn pool]
(loop [n 0]
(if-let [[groups total] (retrieve-deleted-objects conn)]
(loop [total 0
groups (retrieve-deleted-objects conn)]
(if-let [[backend ids] (first groups)]
(do
(run! (partial delete-in-bulk conn) groups)
(recur (+ n ^long total)))
(delete-in-bulk conn backend ids)
(recur (+ total (count ids))
(rest groups)))
(do
(l/info :task "gc-deleted"
:hint "permanently delete items"
:count n)
{:deleted n})))))))
(l/info :task "gc-deleted" :count total)
{:deleted total})))))))
(def sql:retrieve-deleted-objects
(def sql:retrieve-deleted-objects-chunk
"with items_part as (
select s.id
from storage_object as s
where s.deleted_at is not null
and s.deleted_at < (now() - ?::interval)
order by s.deleted_at
and s.created_at < ?
order by s.created_at desc
limit 100
)
delete from storage_object
@ -326,157 +316,105 @@
;; Garbage Collection: Analyze touched objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This task is part of the garbage collection of storage objects and
;; is responsible on analyzing the touched objects and mark them for deletion
;; if corresponds.
;; This task is part of the garbage collection of storage objects and is responsible on analyzing the touched
;; objects and mark them for deletion if corresponds.
;;
;; When file_media_object is deleted, the depending storage_object are
;; marked as touched. This means that some files that depend on a
;; concrete storage_object are no longer exists and maybe this
;; storage_object is no longer necessary and can be eligible for
;; elimination. This task periodically analyzes touched objects and
;; mark them as freeze (means that has other references and the object
;; is still valid) or deleted (no more references to this object so is
;; ready to be deleted).
;; For example: when file_media_object is deleted, the depending storage_object are marked as touched. This
;; means that some files that depend on a concrete storage_object are no longer exists and maybe this
;; storage_object is no longer necessary and can be eligible for elimination. This task periodically analyzes
;; touched objects and mark them as freeze (means that has other references and the object is still valid) or
;; deleted (no more references to this object so is ready to be deleted).
(declare sql:retrieve-touched-objects)
(declare sql:retrieve-touched-objects-chunk)
(declare sql:retrieve-file-media-object-nrefs)
(declare sql:retrieve-team-font-variant-nrefs)
(defmethod ig/pre-init-spec ::gc-touched-task [_]
(s/keys :req-un [::db/pool]))
(defmethod ig/init-key ::gc-touched-task
[_ {:keys [pool] :as cfg}]
(letfn [(group-results [rows]
(let [conj (fnil conj [])]
(reduce (fn [acc {:keys [id nrefs]}]
(if (pos? nrefs)
(update acc :to-freeze conj id)
(update acc :to-delete conj id)))
{}
rows)))
(letfn [(has-team-font-variant-nrefs? [conn id]
(-> (db/exec-one! conn [sql:retrieve-team-font-variant-nrefs id id id id]) :nrefs pos?))
(retrieve-touched [conn]
(let [rows (db/exec! conn [sql:retrieve-touched-objects])]
(some-> (seq rows) (group-results))))
(mark-delete-in-bulk [conn ids]
(db/exec-one! conn ["update storage_object set deleted_at=now(), touched_at=null where id = ANY(?)"
(db/create-array conn "uuid" (into-array java.util.UUID ids))]))
(has-file-media-object-nrefs? [conn id]
(-> (db/exec-one! conn [sql:retrieve-file-media-object-nrefs id id]) :nrefs pos?))
(mark-freeze-in-bulk [conn ids]
(db/exec-one! conn ["update storage_object set touched_at=null where id = ANY(?)"
(db/create-array conn "uuid" (into-array java.util.UUID ids))]))]
(db/create-array conn "uuid" ids)]))
(mark-delete-in-bulk [conn ids]
(db/exec-one! conn ["update storage_object set deleted_at=now(), touched_at=null where id = ANY(?)"
(db/create-array conn "uuid" ids)]))
(retrieve-touched-chunk [conn cursor]
(let [rows (->> (db/exec! conn [sql:retrieve-touched-objects-chunk cursor])
(mapv #(d/update-when % :metadata db/decode-transit-pgobject)))
kw (fn [o] (if (keyword? o) o (keyword o)))]
(when (seq rows)
[(-> rows peek :created-at)
;; NOTE: we use the :file-media-object as default value for backward compatibility because when we
;; deploy it we can have old backend instances running in the same time as the new one and we can
;; still have storage-objects created without reference value. And we know that if it does not
;; have value, it means :file-media-object.
(d/group-by' #(or (some-> % :metadata :reference kw) :file-media-object) :id rows)])))
(retrieve-touched [conn]
(->> (d/iteration (fn [cursor]
(retrieve-touched-chunk conn cursor))
:initk (dt/now)
:vf second
:kf first)
(sequence cat)))
(process-objects! [conn pred-fn ids]
(loop [to-freeze #{}
to-delete #{}
ids (seq ids)]
(if-let [id (first ids)]
(if (pred-fn conn id)
(recur (conj to-freeze id) to-delete (rest ids))
(recur to-freeze (conj to-delete id) (rest ids)))
(do
(some->> (seq to-freeze) (mark-freeze-in-bulk conn))
(some->> (seq to-delete) (mark-delete-in-bulk conn))
[(count to-freeze) (count to-delete)]))))
]
(fn [_]
(db/with-atomic [conn pool]
(loop [cntf 0
cntd 0]
(if-let [{:keys [to-delete to-freeze]} (retrieve-touched conn)]
(loop [to-freeze 0
to-delete 0
groups (retrieve-touched conn)]
(if-let [[reference ids] (first groups)]
(let [[f d] (case reference
:file-media-object (process-objects! conn has-file-media-object-nrefs? ids)
:team-font-variant (process-objects! conn has-team-font-variant-nrefs? ids)
(ex/raise :type :internal
:code :unexpected-unknown-reference
:hint (format "unknown reference %s" (pr-str reference))))]
(recur (+ to-freeze f)
(+ to-delete d)
(rest groups)))
(do
(when (seq to-delete) (mark-delete-in-bulk conn to-delete))
(when (seq to-freeze) (mark-freeze-in-bulk conn to-freeze))
(recur (+ cntf (count to-freeze))
(+ cntd (count to-delete))))
(do
(l/info :task "gc-touched"
:hint "mark freeze"
:count cntf)
(l/info :task "gc-touched"
:hint "mark for deletion"
:count cntd)
{:freeze cntf :delete cntd})))))))
(l/info :task "gc-touched" :to-freeze to-freeze :to-delete to-delete)
{:freeze to-freeze :delete to-delete})))))))
(def sql:retrieve-touched-objects
"select so.id,
((select count(*) from file_media_object where media_id = so.id) +
(select count(*) from file_media_object where thumbnail_id = so.id)) as nrefs
from storage_object as so
(def sql:retrieve-touched-objects-chunk
"select so.* from storage_object as so
where so.touched_at is not null
order by so.touched_at
limit 100;")
and so.created_at < ?
order by so.created_at desc
limit 500;")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Recheck Stalled Task
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def sql:retrieve-file-media-object-nrefs
"select ((select count(*) from file_media_object where media_id = ?) +
(select count(*) from file_media_object where thumbnail_id = ?)) as nrefs")
;; Because the physical storage (filesystem, s3, ... except db) is not
;; transactional, in some situations we can found physical object
;; leakage. That situations happens when the transaction that writes
;; the file aborts, leaving the file written to the underlying storage
;; but the reference on the database is lost with the rollback.
;;
;; For this situations we need to write a "log" of inserted files that
;; are checked in some time in future. If physical file exists but the
;; database refence does not exists means that leaked file is found
;; and is immediately deleted. The responsibility of this task is
;; check that write log for possible leaked files.
(def recheck-min-age (dt/duration {:hours 1}))
(declare sql:retrieve-pending-to-recheck)
(declare sql:exists-storage-object)
(defmethod ig/pre-init-spec ::recheck-task [_]
(s/keys :req-un [::storage ::db/pool]))
(defmethod ig/init-key ::recheck-task
[_ {:keys [pool storage] :as cfg}]
(letfn [(group-results [rows]
(let [conj (fnil conj [])]
(reduce (fn [acc {:keys [id exist] :as row}]
(cond-> (update acc :all conj id)
(false? exist)
(update :to-delete conj (dissoc row :exist))))
{}
rows)))
(group-by-backend [rows]
(let [conj (fnil conj [])]
(reduce (fn [acc {:keys [id backend]}]
(update acc (keyword backend) conj id))
{}
rows)))
(retrieve-pending [conn]
(let [rows (db/exec! conn [sql:retrieve-pending-to-recheck (db/interval recheck-min-age)])]
(some-> (seq rows) (group-results))))
(delete-group [conn [backend ids]]
(let [backend (impl/resolve-backend storage backend)
backend (assoc backend :conn conn)]
(impl/del-objects-in-bulk backend ids)))
(delete-all [conn ids]
(let [ids (db/create-array conn "uuid" (into-array java.util.UUID ids))]
(db/exec-one! conn ["delete from storage_pending where id = ANY(?)" ids])))]
(fn [_]
(db/with-atomic [conn pool]
(loop [n 0 d 0]
(if-let [{:keys [all to-delete]} (retrieve-pending conn)]
(let [groups (group-by-backend to-delete)]
(run! (partial delete-group conn) groups)
(delete-all conn all)
(recur (+ n (count all))
(+ d (count to-delete))))
(do
(l/info :task "recheck"
:hint "recheck items"
:processed n
:deleted d)
{:processed n :deleted d})))))))
(def sql:retrieve-pending-to-recheck
"select sp.id,
sp.backend,
sp.created_at,
(case when count(so.id) > 0 then true
else false
end) as exist
from storage_pending as sp
left join storage_object as so
on (so.id = sp.id)
where sp.created_at < now() - ?::interval
group by 1,2,3
order by sp.created_at asc
limit 100")
(def sql:retrieve-team-font-variant-nrefs
"select ((select count(*) from team_font_variant where woff1_file_id = ?) +
(select count(*) from team_font_variant where woff2_file_id = ?) +
(select count(*) from team_font_variant where otf_file_id = ?) +
(select count(*) from team_font_variant where ttf_file_id = ?)) as nrefs")

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

@ -56,9 +56,10 @@
(s/def ::region #{:eu-central-1})
(s/def ::bucket ::us/string)
(s/def ::prefix ::us/string)
(s/def ::endpoint ::us/string)
(defmethod ig/pre-init-spec ::backend [_]
(s/keys :opt-un [::region ::bucket ::prefix]))
(s/keys :opt-un [::region ::bucket ::prefix ::endpoint]))
(defmethod ig/prep-key ::backend
[_ {:keys [prefix] :as cfg}]
@ -119,20 +120,31 @@
(defn- ^Region lookup-region
[region]
(case region
:eu-central-1 Region/EU_CENTRAL_1))
(Region/of (name region)))
(defn build-s3-client
[{:keys [region]}]
[{:keys [region endpoint]}]
(if (string? endpoint)
(let [uri (java.net.URI. endpoint)]
(.. (S3Client/builder)
(endpointOverride uri)
(region (lookup-region region))
(build)))
(.. (S3Client/builder)
(region (lookup-region region))
(build)))
(build))))
(defn build-s3-presigner
[{:keys [region]}]
[{:keys [region endpoint]}]
(if (string? endpoint)
(let [uri (java.net.URI. endpoint)]
(.. (S3Presigner/builder)
(endpointOverride uri)
(region (lookup-region region))
(build)))
(.. (S3Presigner/builder)
(region (lookup-region region))
(build))))
(defn put-object
[{:keys [client bucket prefix]} {:keys [id] :as object} content]

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

@ -10,6 +10,7 @@
after some period of inactivity (the default threshold is 72h)."
(:require
[app.common.logging :as l]
[app.common.pages.helpers :as cph]
[app.common.pages.migrations :as pmg]
[app.db :as db]
[app.util.blob :as blob]
@ -52,6 +53,7 @@
limit 10
for update skip locked")
(defn- retrieve-candidates
[{:keys [conn max-age] :as cfg}]
(let [interval (db/interval max-age)]
@ -64,12 +66,11 @@
(comp
(map :objects)
(mapcat vals)
(map (fn [{:keys [type] :as obj}]
(keep (fn [{:keys [type] :as obj}]
(case type
:path (get-in obj [:fill-image :id])
:image (get-in obj [:metadata :id])
nil)))
(filter uuid?)))
nil)))))
(defn- collect-used-media
[data]
@ -80,13 +81,28 @@
(into collect-media-xf pages)
(into (keys (:media data))))))
(def ^:private
collect-frames-xf
(comp
(map :objects)
(mapcat vals)
(filter cph/frame-shape?)
(keep :id)))
(defn- collect-frames
[data]
(let [pages (concat
(vals (:pages-index data))
(vals (:components data)))]
(into #{} collect-frames-xf pages)))
(defn- process-file
[{:keys [conn] :as cfg} {:keys [id data age] :as file}]
(let [data (-> (blob/decode data)
(assoc :id id)
(pmg/migrate-data))
(pmg/migrate-data))]
used (collect-used-media data)
(let [used (collect-used-media data)
unused (->> (db/query conn :file-media-object {:file-id id})
(remove #(contains? used (:id %))))]
@ -111,6 +127,13 @@
;; objects. The touch mechanism is needed because many files can
;; point to the same storage objects and we can't just delete
;; them.
(db/delete! conn :file-media-object {:id (:id mobj)}))
(db/delete! conn :file-media-object {:id (:id mobj)})))
(let [sql (str "delete from file_frame_thumbnail "
" where file_id = ? and not (frame_id = ANY(?))")
ids (->> (collect-frames data)
(db/create-array conn "uuid"))]
;; delete the unused frame thumbnails
(db/exec! conn [sql (:id file) ids]))
nil))

36
backend/src/app/tasks/telemetry.clj
View file

@ -38,14 +38,17 @@
(defmethod ig/init-key ::handler
[_ {:keys [pool sprops version] :as cfg}]
(fn [_]
(fn [{:keys [send?] :or {send? true}}]
;; Sleep randomly between 0 to 10s
(thread-sleep (rand-int 10000))
(when send?
(thread-sleep (rand-int 10000)))
(let [instance-id (:instance-id sprops)]
(-> (get-stats pool version)
(assoc :instance-id instance-id)
(send! cfg)))))
(let [instance-id (:instance-id sprops)
stats (-> (get-stats pool version)
(assoc :instance-id instance-id))]
(when send?
(send! stats cfg))
stats)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; IMPL
@ -137,12 +140,28 @@
(->> [sql:team-averages]
(db/exec-one! conn)))
(defn- retrieve-enabled-auth-providers
[conn]
(let [sql (str "select auth_backend as backend, count(*) as total "
" from profile group by 1")
rows (db/exec! conn [sql])]
(->> rows
(map (fn [{:keys [backend total]}]
(let [backend (or backend "penpot")]
[(keyword (str "auth-backend-" backend))
total])))
(into {}))))
(defn- retrieve-jvm-stats
[]
(let [^Runtime runtime (Runtime/getRuntime)]
{:jvm-heap-current (.totalMemory runtime)
:jvm-heap-max (.maxMemory runtime)
:jvm-cpus (.availableProcessors runtime)}))
:jvm-cpus (.availableProcessors runtime)
:os-arch (System/getProperty "os.arch")
:os-name (System/getProperty "os.name")
:os-version (System/getProperty "os.version")
:user-tz (System/getProperty "user.timezone")}))
(defn get-stats
[conn version]
@ -161,6 +180,7 @@
:total-touched-files (retrieve-num-touched-files conn)}
(d/merge
(retrieve-team-averages conn)
(retrieve-jvm-stats))
(retrieve-jvm-stats)
(retrieve-enabled-auth-providers conn))
(d/without-nils))))

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

@ -7,6 +7,7 @@
(ns app.tokens
"Tokens generation service."
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.transit :as t]
@ -17,7 +18,7 @@
(defn- generate
[cfg claims]
(let [payload (t/encode claims)]
(let [payload (-> claims d/without-nils t/encode)]
(jwe/encrypt payload (::secret cfg) {:alg :a256kw :enc :a256gcm})))
(defn- verify

8
backend/src/app/util/async.clj
View file

@ -7,7 +7,8 @@
(ns app.util.async
(:require
[clojure.core.async :as a]
[clojure.spec.alpha :as s])
[clojure.spec.alpha :as s]
[promesa.exec :as px])
(:import
java.util.concurrent.Executor))
@ -54,13 +55,16 @@
(a/close! c)
c))))
(defmacro with-thread
[executor & body]
(if (= executor ::default)
`(a/thread-call (^:once fn* [] (try ~@body (catch Exception e# e#))))
`(thread-call ~executor (^:once fn* [] ~@body))))
(defmacro with-dispatch
[executor & body]
`(px/submit! ~executor (^:once fn* [] ~@body)))
(defn batch
[in {:keys [max-batch-size
max-batch-age

43
backend/src/app/util/retry.clj
View file

@ -1,43 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) UXBOX Labs SL
(ns app.util.retry
"A fault tolerance helpers. Allow retry some operations that we know
we can retry."
(:require
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.util.async :as aa]
[app.util.services :as sv]))
(defn conflict-db-insert?
"Check if exception matches a insertion conflict on postgresql."
[e]
(and (instance? org.postgresql.util.PSQLException e)
(= "23505" (.getSQLState e))))
(defn wrap-retry
[_ f {:keys [::max-retries ::matches ::sv/name]
:or {max-retries 3
matches (constantly false)}
:as mdata}]
(when (::enabled mdata)
(l/debug :hint "wrapping retry" :name name))
(if (::enabled mdata)
(fn [cfg params]
(loop [retry 1]
(when (> retry 1)
(l/debug :hint "retrying controlled function" :retry retry :name name))
(let [res (ex/try (f cfg params))]
(if (ex/exception? res)
(if (and (matches res) (< retry max-retries))
(do
(aa/thread-sleep (* 100 retry))
(recur (inc retry)))
(throw res))
res))))
f))

36
backend/src/app/util/rlimit.clj
View file

@ -1,36 +0,0 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) UXBOX Labs SL
(ns app.util.rlimit
"Resource usage limits (in other words: semaphores)."
(:require
[app.common.logging :as l]
[app.util.services :as sv])
(:import
java.util.concurrent.Semaphore))
(defn acquire!
[sem]
(.acquire ^Semaphore sem))
(defn release!
[sem]
(.release ^Semaphore sem))
(defn wrap-rlimit
[_cfg f mdata]
(if-let [permits (::permits mdata)]
(let [sem (Semaphore. permits)]
(l/debug :hint "wrapping rlimit" :handler (::sv/name mdata) :permits permits)
(fn [cfg params]
(try
(acquire! sem)
(f cfg params)
(finally
(release! sem)))))
f))

17
backend/src/app/util/websocket.clj
View file

@ -27,11 +27,6 @@
(declare ws-ping!)
(declare ws-send!)
(defmacro call-mtx
[definitions name & args]
`(when-let [mtx-fn# (some-> ~definitions ~name ::mtx/fn)]
(mtx-fn# ~@args)))
(def noop (constantly nil))
(defn handler
@ -49,7 +44,7 @@
([handle-message {:keys [::input-buff-size
::output-buff-size
::idle-timeout
::metrics]
metrics]
:or {input-buff-size 64
output-buff-size 64
idle-timeout 30000}
@ -71,8 +66,8 @@
on-terminate
(fn [& _args]
(when (compare-and-set! terminated false true)
(call-mtx metrics :connections {:cmd :dec :by 1})
(call-mtx metrics :sessions {:val (/ (inst-ms (dt/diff created-at (dt/now))) 1000.0)})
(mtx/run! metrics {:id :websocket-active-connections :dec 1})
(mtx/run! metrics {:id :websocket-session-timing :val (/ (inst-ms (dt/diff created-at (dt/now))) 1000.0)})
(a/close! close-ch)
(a/close! pong-ch)
@ -88,7 +83,7 @@
on-connect
(fn [conn]
(call-mtx metrics :connections {:cmd :inc :by 1})
(mtx/run! metrics {:id :websocket-active-connections :inc 1})
(let [wsp (atom (assoc options ::conn conn))]
;; Handle heartbeat
@ -102,7 +97,7 @@
;; connection
(a/go-loop []
(when-let [val (a/<! output-ch)]
(call-mtx metrics :messages {:labels ["send"]})
(mtx/run! metrics {:id :websocket-messages-total :labels ["send"] :inc 1})
(a/<! (ws-send! conn (t/encode-str val)))
(recur)))
@ -111,7 +106,7 @@
on-message
(fn [_ message]
(call-mtx metrics :messages {:labels ["recv"]})
(mtx/run! metrics {:id :websocket-messages-total :labels ["send"] :inc 1})
(try
(let [message (t/decode-str message)]
(a/offer! input-ch message))

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

@ -22,44 +22,100 @@
[integrant.core :as ig]
[promesa.exec :as px])
(:import
org.eclipse.jetty.util.thread.QueuedThreadPool
java.util.concurrent.ExecutorService
java.util.concurrent.Executors
java.util.concurrent.Executor))
java.util.concurrent.ForkJoinPool
java.util.concurrent.ForkJoinWorkerThread
java.util.concurrent.ForkJoinPool$ForkJoinWorkerThreadFactory
java.util.concurrent.atomic.AtomicLong
java.util.concurrent.Executors))
(s/def ::executor #(instance? Executor %))
(set! *warn-on-reflection* true)
(s/def ::executor #(instance? ExecutorService %))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Executor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::name keyword?)
(s/def ::prefix keyword?)
(s/def ::parallelism ::us/integer)
(s/def ::min-threads ::us/integer)
(s/def ::max-threads ::us/integer)
(s/def ::idle-timeout ::us/integer)
(defmethod ig/pre-init-spec ::executor [_]
(s/keys :req-un [::min-threads ::max-threads ::idle-timeout ::name]))
(s/keys :req-un [::prefix ::parallelism]))
(defn- get-thread-factory
^ForkJoinPool$ForkJoinWorkerThreadFactory
[prefix counter]
(reify ForkJoinPool$ForkJoinWorkerThreadFactory
(newThread [_ pool]
(let [^ForkJoinWorkerThread thread (.newThread ForkJoinPool/defaultForkJoinWorkerThreadFactory pool)
^String thread-name (str (name prefix) "-" (.getAndIncrement ^AtomicLong counter))]
(.setName thread thread-name)
thread))))
(defmethod ig/init-key ::executor
[_ {:keys [min-threads max-threads idle-timeout name]}]
(doto (QueuedThreadPool. (int max-threads)
(int min-threads)
(int idle-timeout))
(.setStopTimeout 500)
(.setName (d/name name))
(.start)))
[_ {:keys [parallelism prefix]}]
(let [counter (AtomicLong. 0)]
(ForkJoinPool. (int parallelism) (get-thread-factory prefix counter) nil false)))
(defmethod ig/halt-key! ::executor
[_ instance]
(.stop ^QueuedThreadPool instance))
(.shutdown ^ForkJoinPool instance))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Executor Monitor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::executors (s/map-of keyword? ::executor))
(defmethod ig/pre-init-spec ::executors-monitor [_]
(s/keys :req-un [::executors ::mtx/metrics]))
(defmethod ig/init-key ::executors-monitor
[_ {:keys [executors metrics interval] :or {interval 3000}}]
(letfn [(log-stats [scheduler state]
(doseq [[key ^ForkJoinPool executor] executors]
(let [labels (into-array String [(name key)])
active (.getActiveThreadCount executor)
running (.getRunningThreadCount executor)
queued (.getQueuedSubmissionCount executor)
steals (.getStealCount executor)
steals-increment (- steals (or (get-in @state [key :steals]) 0))
steals-increment (if (neg? steals-increment) 0 steals-increment)]
(mtx/run! metrics {:id :executors-active-threads :labels labels :val active})
(mtx/run! metrics {:id :executors-running-threads :labels labels :val running})
(mtx/run! metrics {:id :executors-queued-submissions :labels labels :val queued})
(mtx/run! metrics {:id :executors-completed-tasks :labels labels :inc steals-increment})
(swap! state update key assoc
:running running
:active active
:queued queued
:steals steals)))
(when-not (.isShutdown scheduler)
(px/schedule! scheduler interval (partial log-stats scheduler state))))]
(let [scheduler (px/scheduled-pool 1)
state (atom {})]
(px/schedule! scheduler interval (partial log-stats scheduler state))
{::scheduler scheduler
::state state})))
(defmethod ig/halt-key! ::executors-monitor
[_ {:keys [::scheduler]}]
(.shutdown ^ExecutorService scheduler))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Worker
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare event-loop-fn)
(declare instrument-tasks)
(declare event-loop)
(s/def ::queue keyword?)
(s/def ::parallelism ::us/integer)
@ -85,13 +141,10 @@
:queue :default}
(d/without-nils cfg)))
(defmethod ig/init-key ::worker
[_ {:keys [pool poll-interval name queue] :as cfg}]
(l/info :action "start worker"
:name (d/name name)
:queue (d/name queue))
(let [close-ch (a/chan 1)
poll-ms (inst-ms poll-interval)]
(defn- event-loop
"Main, worker eventloop"
[{:keys [pool poll-interval close-ch] :as cfg}]
(let [poll-ms (inst-ms poll-interval)]
(a/go-loop []
(let [[val port] (a/alts! [close-ch (event-loop-fn cfg)] :priority true)]
(cond
@ -100,7 +153,7 @@
(or (= port close-ch) (nil? val))
(l/debug :hint "stop condition found")
(db/pool-closed? pool)
(db/closed? pool)
(do
(l/debug :hint "eventloop aborted because pool is closed")
(a/close! close-ch))
@ -132,14 +185,27 @@
(= ::empty val)
(do
(a/<! (a/timeout poll-ms))
(recur)))))
(recur)))))))
(defmethod ig/init-key ::worker
[_ {:keys [pool name queue] :as cfg}]
(let [close-ch (a/chan 1)
cfg (assoc cfg :close-ch close-ch)]
(if (db/read-only? pool)
(l/warn :hint "worker not started, db is read-only"
:name (d/name name)
:queue (d/name queue))
(do
(l/info :hint "worker started"
:name (d/name name)
:queue (d/name queue))
(event-loop cfg)))
(reify
java.lang.AutoCloseable
(close [_]
(a/close! close-ch)))))
(defmethod ig/halt-key! ::worker
[_ instance]
(.close ^java.lang.AutoCloseable instance))
@ -350,9 +416,11 @@
(s/keys :req-un [::executor ::db/pool ::schedule ::tasks]))
(defmethod ig/init-key ::scheduler
[_ {:keys [schedule tasks] :as cfg}]
(let [scheduler (Executors/newScheduledThreadPool (int 1))
schedule (->> schedule
[_ {:keys [schedule tasks pool] :as cfg}]
(let [scheduler (Executors/newScheduledThreadPool (int 1))]
(if (db/read-only? pool)
(l/warn :hint "scheduler not started, db is read-only")
(let [schedule (->> schedule
(filter some?)
;; If id is not defined, use the task as id.
(map (fn [{:keys [id task] :as item}]
@ -371,10 +439,12 @@
cfg (assoc cfg
:scheduler scheduler
:schedule schedule)]
(l/info :hint "scheduler started"
:registred-tasks (count schedule))
(synchronize-schedule cfg)
(run! (partial schedule-task cfg)
(filter some? schedule))
(filter some? schedule))))
(reify
java.lang.AutoCloseable
@ -405,11 +475,6 @@
(def sql:lock-scheduled-task
"select id from scheduled_task where id=? for update skip locked")
(defn exception->string
[error]
(with-out-str
(.printStackTrace ^Throwable error (java.io.PrintWriter. *out*))))
(defn- execute-scheduled-task
[{:keys [executor pool] :as cfg} {:keys [id] :as task}]
(letfn [(run-task [conn]
@ -445,59 +510,27 @@
;; --- INSTRUMENTATION
(defn instrument!
[registry]
(mtx/instrument-vars!
[#'submit!]
{:registry registry
:type :counter
:labels ["name"]
:name "tasks_submit_total"
:help "A counter of task submissions."
:wrap (fn [rootf mobj]
(let [mdata (meta rootf)
origf (::original mdata rootf)]
(with-meta
(fn [conn params]
(let [tname (:name params)]
(mobj :inc [tname])
(origf conn params)))
{::original origf})))})
(mtx/instrument-vars!
[#'app.worker/run-task]
{:registry registry
:type :summary
:quantiles []
:name "tasks_checkout_timing"
:help "Latency measured between scheduled_at and execution time."
:wrap (fn [rootf mobj]
(let [mdata (meta rootf)
origf (::original mdata rootf)]
(with-meta
(fn [tasks item]
(let [now (inst-ms (dt/now))
sat (inst-ms (:scheduled-at item))]
(mobj :observe (- now sat))
(origf tasks item)))
{::original origf})))}))
(defn- wrap-task-handler
[metrics tname f]
(let [labels (into-array String [tname])]
(fn [params]
(let [start (System/nanoTime)]
(try
(f params)
(finally
(mtx/run! metrics
{:id :tasks-timing
:val (/ (- (System/nanoTime) start) 1000000)
:labels labels})))))))
(defmethod ig/pre-init-spec ::registry [_]
(s/keys :req-un [::mtx/metrics ::tasks]))
(defmethod ig/init-key ::registry
[_ {:keys [metrics tasks]}]
(let [mobj (mtx/create
{:registry (:registry metrics)
:type :summary
:labels ["name"]
:quantiles []
:name "tasks_timing"
:help "Background task execution timing."})]
(reduce-kv (fn [res k v]
(let [tname (name k)]
(l/debug :action "register task" :name tname)
(assoc res k (mtx/wrap-summary v mobj [tname]))))
(l/debug :hint "register task" :name tname)
(assoc res k (wrap-task-handler metrics tname v))))
{}
tasks)))
tasks))

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

@ -174,6 +174,14 @@
:type :image
:metadata {:id (:id fmo1)}}}]})]
;; If we launch gc-touched-task, we should have 4 items to freeze.
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {})]
(t/is (= 4 (:freeze res)))
(t/is (= 0 (:delete res))))
;; run the task immediately
(let [task (:app.tasks.file-media-gc/handler th/*system*)
res (task {})]
@ -202,16 +210,22 @@
(t/is (some? (sto/get-object storage (:media-id fmo1))))
(t/is (some? (sto/get-object storage (:thumbnail-id fmo1))))
;; but if we pass the touched gc task two of them should disappear
;; now, we have deleted the unused file-media-object, if we
;; execute the touched-gc task, we should see that two of them
;; are marked to be deleted.
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {})]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:delete res)))
(t/is (= 2 (:delete res))))
;; Finally, check that some of the objects that are marked as
;; deleted we are unable to retrieve them using standard storage
;; public api.
(t/is (nil? (sto/get-object storage (:media-id fmo2))))
(t/is (nil? (sto/get-object storage (:thumbnail-id fmo2))))
(t/is (some? (sto/get-object storage (:media-id fmo1))))
(t/is (some? (sto/get-object storage (:thumbnail-id fmo1)))))
(t/is (some? (sto/get-object storage (:thumbnail-id fmo1))))
)))
@ -389,3 +403,73 @@
(t/is (th/ex-info? error))
(t/is (= (:type error-data) :not-found))))
))
(t/deftest query-frame-thumbnails
(let [prof (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
:is-shared false})
data {::th/type :file-frame-thumbnail
:profile-id (:id prof)
:file-id (:id file)
:frame-id (uuid/next)}]
;;insert an entry on the database with a test value for the thumbnail of this frame
(db/exec-one! th/*pool*
["insert into file_frame_thumbnail(file_id, frame_id, data) values (?, ?, ?)"
(:file-id data) (:frame-id data) "testvalue"])
(let [out (th/query! data)]
(t/is (nil? (:error out)))
(let [result (:result out)]
(t/is (= 1 (count result)))
(t/is (= "testvalue" (:data result)))))))
(t/deftest insert-frame-thumbnails
(let [prof (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
:is-shared false})
data {::th/type :upsert-frame-thumbnail
:profile-id (:id prof)
:file-id (:id file)
:frame-id (uuid/next)
:data "test insert new value"}
out (th/mutation! data)]
(t/is (nil? (:error out)))
(t/is (nil? (:result out)))
;;retrieve the value from the database and check its content
(let [result (db/exec-one!
th/*pool*
["select data from file_frame_thumbnail where file_id = ? and frame_id = ?"
(:file-id data) (:frame-id data)])]
(t/is (= "test insert new value" (:data result))))))
(t/deftest frame-thumbnails
(let [prof (th/create-profile* 1 {:is-active true})
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
:is-shared false})
data {::th/type :upsert-frame-thumbnail
:profile-id (:id prof)
:file-id (:id file)
:frame-id (uuid/next)
:data "updated value"}]
;;insert an entry on the database with and old value for the thumbnail of this frame
(db/exec-one! th/*pool*
["insert into file_frame_thumbnail(file_id, frame_id, data) values (?, ?, ?)"
(:file-id data) (:frame-id data) "old value"])
(let [out (th/mutation! data)]
(t/is (nil? (:error out)))
(t/is (nil? (:result out)))
;;retrieve the value from the database and check its content
(let [result (db/exec-one!
th/*pool*
["select data from file_frame_thumbnail where file_id = ? and frame_id = ?"
(:file-id data) (:frame-id data)])]
(t/is (= "updated value" (:data result)))))))

15
backend/test/app/services_management_test.clj
View file

@ -11,6 +11,7 @@
[app.http :as http]
[app.storage :as sto]
[app.test-helpers :as th]
[app.storage-test :refer [configure-storage-backend]]
[clojure.test :as t]
[buddy.core.bytes :as b]
[datoteka.core :as fs]))
@ -19,7 +20,9 @@
(t/use-fixtures :each th/database-reset)
(t/deftest duplicate-file
(let [storage (:app.storage/storage th/*system*)
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
sobject (sto/put-object storage {:content (sto/content "content")
:content-type "text/plain"
:other "data"})
@ -90,7 +93,8 @@
))))
(t/deftest duplicate-file-with-deleted-rels
(let [storage (:app.storage/storage th/*system*)
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
sobject (sto/put-object storage {:content (sto/content "content")
:content-type "text/plain"
:other "data"})
@ -151,7 +155,9 @@
))))
(t/deftest duplicate-project
(let [storage (:app.storage/storage th/*system*)
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
sobject (sto/put-object storage {:content (sto/content "content")
:content-type "text/plain"
:other "data"})
@ -221,7 +227,8 @@
)))))
(t/deftest duplicate-project-with-deleted-files
(let [storage (:app.storage/storage th/*system*)
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
sobject (sto/put-object storage {:content (sto/content "content")
:content-type "text/plain"
:other "data"})

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

@ -240,6 +240,16 @@
(t/is (nil? error))
(t/is (string? (:token result))))))
(t/deftest test-register-profile-with-email-as-password
(let [data {::th/type :prepare-register-profile
:email "user@example.com"
:password "USER@example.com"}]
(let [{:keys [result error] :as out} (th/mutation! data)]
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :email-as-password)))))
(t/deftest test-email-change-request
(with-mocks [email-send-mock {:target 'app.emails/send! :return nil}
cfg-get-mock {:target 'app.config/get
@ -345,3 +355,39 @@
(t/is (th/ex-of-code? error :email-has-permanent-bounces)))
)))
(t/deftest update-profile-password
(let [profile (th/create-profile* 1)
data {::th/type :update-profile-password
:profile-id (:id profile)
:old-password "123123"
:password "foobarfoobar"}
out (th/mutation! data)]
(t/is (nil? (:error out)))
(t/is (nil? (:result out)))
))
(t/deftest update-profile-password-bad-old-password
(let [profile (th/create-profile* 1)
data {::th/type :update-profile-password
:profile-id (:id profile)
:old-password "badpassword"
:password "foobarfoobar"}
{:keys [result error] :as out} (th/mutation! data)]
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :old-password-not-match))))
(t/deftest update-profile-password-email-as-password
(let [profile (th/create-profile* 1)
data {::th/type :update-profile-password
:profile-id (:id profile)
:old-password "123123"
:password "profile1.test@nodomain.com"}
{:keys [result error] :as out} (th/mutation! data)]
(t/is (th/ex-info? error))
(t/is (th/ex-of-type? error :validation))
(t/is (th/ex-of-code? error :email-as-password))))

182
backend/test/app/storage_test.clj
View file

@ -7,6 +7,7 @@
(ns app.storage-test
(:require
[app.common.exceptions :as ex]
[app.common.uuid :as uuid]
[app.db :as db]
[app.storage :as sto]
[app.test-helpers :as th]
@ -22,9 +23,19 @@
th/database-reset
th/clean-storage))
(defn configure-storage-backend
"Given storage map, returns a storage configured with the appropriate
backend for assets."
([storage]
(assoc storage :backend :tmp))
([storage conn]
(-> storage
(assoc :conn conn)
(assoc :backend :tmp))))
(t/deftest put-and-retrieve-object
(let [storage (:app.storage/storage th/*system*)
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
content (sto/content "content")
object (sto/put-object storage {:content content
:content-type "text/plain"
@ -39,9 +50,9 @@
(t/is (= "content" (slurp (sto/get-object-path storage object))))
))
(t/deftest put-and-retrieve-expired-object
(let [storage (:app.storage/storage th/*system*)
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
content (sto/content "content")
object (sto/put-object storage {:content content
:content-type "text/plain"
@ -59,7 +70,8 @@
))
(t/deftest put-and-delete-object
(let [storage (:app.storage/storage th/*system*)
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
content (sto/content "content")
object (sto/put-object storage {:content content
:content-type "text/plain"
@ -79,7 +91,8 @@
))
(t/deftest test-deleted-gc-task
(let [storage (:app.storage/storage th/*system*)
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
content (sto/content "content")
object1 (sto/put-object storage {:content content
:content-type "text/plain"
@ -96,14 +109,17 @@
(let [res (db/exec-one! th/*pool* ["select count(*) from storage_object;"])]
(t/is (= 1 (:count res))))))
(t/deftest test-touched-gc-task
(let [storage (:app.storage/storage th/*system*)
(t/deftest test-touched-gc-task-1
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
prof (th/create-profile* 1)
proj (th/create-project* 1 {:profile-id (:id prof)
:team-id (:default-team-id prof)})
file (th/create-file* 1 {:profile-id (:id prof)
:project-id (:default-project-id prof)
:is-shared false})
mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg"
@ -140,12 +156,12 @@
;; now check if the storage objects are touched
(let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where touched_at is not null"])]
(t/is (= 2 (:count res))))
(t/is (= 4 (:count res))))
;; run the touched gc task
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {})]
(t/is (= 0 (:freeze res)))
(t/is (= 2 (:freeze res)))
(t/is (= 2 (:delete res))))
;; now check that there are no touched objects
@ -157,8 +173,85 @@
(t/is (= 2 (:count res))))
)))
(t/deftest test-touched-gc-task-2
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
prof (th/create-profile* 1 {:is-active true})
team-id (:default-team-id prof)
proj-id (:default-project-id prof)
font-id (uuid/custom 10 1)
proj (th/create-project* 1 {:profile-id (:id prof)
:team-id team-id})
file (th/create-file* 1 {:profile-id (:id prof)
:project-id proj-id
:is-shared false})
ttfdata (-> (io/resource "app/test_files/font-1.ttf")
(fs/slurp-bytes))
mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg"
:size 312043}
params1 {::th/type :upload-file-media-object
:profile-id (:id prof)
:file-id (:id file)
:is-local true
:name "testfile"
:content mfile}
params2 {::th/type :create-font-variant
:profile-id (:id prof)
:team-id team-id
:font-id font-id
:font-family "somefont"
:font-weight 400
:font-style "normal"
:data {"font/ttf" ttfdata}}
out1 (th/mutation! params1)
out2 (th/mutation! params2)]
;; (th/print-result! out)
(t/is (nil? (:error out1)))
(t/is (nil? (:error out2)))
;; run the touched gc task
(let [task (:app.storage/gc-touched-task th/*system*)
res (task {})]
(t/is (= 6 (:freeze res)))
(t/is (= 0 (:delete res)))
(let [result-1 (:result out1)
result-2 (:result out2)]
;; now we proceed to manually delete one team-font-variant
(db/exec-one! th/*pool* ["delete from team_font_variant where id = ?" (:id result-2)])
;; revert touched state to all storage objects
(db/exec-one! th/*pool* ["update storage_object set touched_at=now()"])
;; Run the task again
(let [res (task {})]
(t/is (= 2 (:freeze res)))
(t/is (= 4 (:delete res))))
;; now check that there are no touched objects
(let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where touched_at is not null"])]
(t/is (= 0 (:count res))))
;; now check that all objects are marked to be deleted
(let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where deleted_at is not null"])]
(t/is (= 4 (:count res))))))))
(t/deftest test-touched-gc-task-without-delete
(let [storage (:app.storage/storage th/*system*)
(let [storage (-> (:app.storage/storage th/*system*)
(configure-storage-backend))
prof (th/create-profile* 1)
proj (th/create-project* 1 {:profile-id (:id prof)
:team-id (:default-team-id prof)})
@ -198,72 +291,3 @@
;; check that we have all object in the db
(let [res (db/exec-one! th/*pool* ["select count(*) from storage_object where deleted_at is null"])]
(t/is (= 4 (:count res)))))))
;; Recheck is the mechanism for delete leaked resources on
;; transaction failure.
(t/deftest test-recheck
(let [storage (:app.storage/storage th/*system*)
content (sto/content "content")
object (sto/put-object storage {:content content
:content-type "text/plain"})]
;; Sleep fo 50ms
(th/sleep 50)
(let [rows (db/exec! th/*pool* ["select * from storage_pending"])]
(t/is (= 1 (count rows)))
(t/is (= (:id object) (:id (first rows)))))
;; Artificially make all storage_pending object 1 hour older.
(db/exec-one! th/*pool* ["update storage_pending set created_at = created_at - '1 hour'::interval"])
;; Sleep fo 50ms
(th/sleep 50)
;; Run recheck task
(let [task (:app.storage/recheck-task th/*system*)
res (task {})]
(t/is (= 1 (:processed res)))
(t/is (= 0 (:deleted res))))
;; After recheck task, storage-pending table should be empty
(let [rows (db/exec! th/*pool* ["select * from storage_pending"])]
(t/is (= 0 (count rows))))))
(t/deftest test-recheck-with-rollback
(let [storage (:app.storage/storage th/*system*)
content (sto/content "content")]
;; check with aborted transaction
(ex/ignoring
(db/with-atomic [conn th/*pool*]
(let [storage (assoc storage :conn conn)] ; make participate storage in the transaction
(sto/put-object storage {:content content
:content-type "text/plain"})
(throw (ex-info "expected" {})))))
;; let a 200ms window for recheck registration thread
;; completion before proceed.
(th/sleep 200)
;; storage_pending table should have the object
;; registered independently of the aborted transaction.
(let [rows (db/exec! th/*pool* ["select * from storage_pending"])]
(t/is (= 1 (count rows))))
;; Artificially make all storage_pending object 1 hour older.
(db/exec-one! th/*pool* ["update storage_pending set created_at = created_at - '1 hour'::interval"])
;; Sleep fo 50ms
(th/sleep 50)
;; Run recheck task
(let [task (:app.storage/recheck-task th/*system*)
res (task {})]
(t/is (= 1 (:processed res)))
(t/is (= 1 (:deleted res))))
;; After recheck task, storage-pending table should be empty
(let [rows (db/exec! th/*pool* ["select * from storage_pending"])]
(t/is (= 0 (count rows))))))

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

@ -52,7 +52,6 @@
(assoc-in [:app.db/pool :uri] (:database-uri config))
(assoc-in [:app.db/pool :username] (:database-username config))
(assoc-in [:app.db/pool :password] (:database-password config))
(assoc-in [[:app.main/main :app.storage.fs/backend] :directory] "/tmp/app/storage")
(dissoc :app.srepl/server
:app.http/server
:app.http/router
@ -65,8 +64,7 @@
:app.worker/scheduler
:app.worker/worker)
(d/deep-merge
{:app.storage/storage {:backend :tmp}
:app.tasks.file-media-gc/handler {:max-age (dt/duration 300)}}))
{:app.tasks.file-media-gc/handler {:max-age (dt/duration 300)}}))
_ (ig/load-namespaces config)
system (-> (ig/prep config)
(ig/init))]
@ -250,7 +248,7 @@
[expr]
`(try
{:error nil
:result ~expr}
:result (deref ~expr)}
(catch Exception e#
{:error (handle-error e#)
:result nil})))

9
common/deps.edn
View file

@ -13,7 +13,7 @@
org.apache.logging.log4j/log4j-slf4j18-impl {:mvn/version "2.17.1"}
org.slf4j/slf4j-api {:mvn/version "2.0.0-alpha1"}
selmer/selmer {:mvn/version "1.12.49"}
selmer/selmer {:mvn/version "1.12.50"}
criterium/criterium {:mvn/version "0.4.6"}
expound/expound {:mvn/version "0.9.0"}
@ -21,10 +21,10 @@
com.cognitect/transit-cljs {:mvn/version "0.8.269"}
java-http-clj/java-http-clj {:mvn/version "0.4.3"}
funcool/promesa {:mvn/version "6.0.2"}
funcool/promesa {:mvn/version "7.0.444"}
funcool/cuerdas {:mvn/version "2022.01.14-391"}
lambdaisland/uri {:mvn/version "1.12.89"
lambdaisland/uri {:mvn/version "1.13.95"
:exclusions [org.clojure/data.json]}
frankiesardo/linked {:mvn/version "1.3.0"}
@ -42,9 +42,8 @@
{: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.17.3"}
com.bhauman/rebel-readline {:mvn/version "RELEASE"}
thheller/shadow-cljs {:mvn/version "2.16.12"}
criterium/criterium {:mvn/version "RELEASE"}
mockery/mockery {:mvn/version "RELEASE"}}
:extra-paths ["test" "dev"]}

2
common/package.json
View file

@ -13,7 +13,7 @@
"test": "yarn run compile-test && yarn run run-test"
},
"devDependencies": {
"shadow-cljs": "2.16.12",
"shadow-cljs": "2.17.3",
"source-map-support": "^0.5.19",
"ws": "^7.4.6"
}

1
common/src/app/common/colors.cljc
View file

@ -15,4 +15,5 @@
(def info "#59B9E2")
(def test "#fabada")
(def white "#FFFFFF")
(def primary "#31EFB8")

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

@ -6,7 +6,7 @@
(ns app.common.data
"Data manipulation and query helper functions."
(:refer-clojure :exclude [read-string hash-map merge name parse-double])
(:refer-clojure :exclude [read-string hash-map merge name parse-double group-by iteration])
#?(:cljs
(:require-macros [app.common.data]))
(:require
@ -37,6 +37,22 @@
#?(:cljs (instance? lks/LinkedSet o)
:clj (instance? LinkedSet o)))
#?(:clj
(defmethod print-method clojure.lang.PersistentQueue [q, w]
;; Overload the printer for queues so they look like fish
(print-method '<- w)
(print-method (seq q) w)
(print-method '-< w)))
(defn queue
([] #?(:clj clojure.lang.PersistentQueue/EMPTY :cljs #queue []))
([a] (into (queue) [a]))
([a & more] (into (queue) (cons a more))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data Structures Manipulation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn deep-merge
([a b]
(if (map? a)
@ -45,10 +61,6 @@
([a b & rest]
(reduce deep-merge a (cons b rest))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data Structures Manipulation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn dissoc-in
[m [k & ks]]
(if ks
@ -151,7 +163,11 @@
"Given a map, return a map removing key-value
pairs when value is `nil`."
[data]
(into {} (remove (comp nil? second) data)))
(into {} (remove (comp nil? second)) data))
(defn without-qualified
[data]
(into {} (remove (comp qualified-keyword? first)) data))
(defn without-keys
"Return a map without the keys provided
@ -609,3 +625,71 @@
(if (or (keyword? k) (string? k))
[(keyword (str/kebab (name k))) v]
[k v])))))
(defn group-by
([kf coll] (group-by kf identity coll))
([kf vf coll]
(let [conj (fnil conj [])]
(reduce (fn [result item]
(update result (kf item) conj (vf item)))
{}
coll))))
(defn group-by'
"A variant of group-by that uses a set for collecting results."
([kf coll] (group-by kf identity coll))
([kf vf coll]
(let [conj (fnil conj #{})]
(reduce (fn [result item]
(update result (kf item) conj (vf item)))
{}
coll))))
;; TEMPORAL COPY of clojure-1.11 iteration function, should be
;; replaced with the builtin on when stable version is released.
#?(:clj
(defn iteration
"Creates a seqable/reducible via repeated calls to step,
a function of some (continuation token) 'k'. The first call to step
will be passed initk, returning 'ret'. Iff (somef ret) is true,
(vf ret) will be included in the iteration, else iteration will
terminate and vf/kf will not be called. If (kf ret) is non-nil it
will be passed to the next step call, else iteration will terminate.
This can be used e.g. to consume APIs that return paginated or batched data.
step - (possibly impure) fn of 'k' -> 'ret'
:somef - fn of 'ret' -> logical true/false, default 'some?'
:vf - fn of 'ret' -> 'v', a value produced by the iteration, default 'identity'
:kf - fn of 'ret' -> 'next-k' or nil (signaling 'do not continue'), default 'identity'
:initk - the first value passed to step, default 'nil'
It is presumed that step with non-initk is unreproducible/non-idempotent.
If step with initk is unreproducible it is on the consumer to not consume twice."
{:added "1.11"}
[step & {:keys [somef vf kf initk]
:or {vf identity
kf identity
somef some?
initk nil}}]
(reify
clojure.lang.Seqable
(seq [_]
((fn next [ret]
(when (somef ret)
(cons (vf ret)
(when-some [k (kf ret)]
(lazy-seq (next (step k)))))))
(step initk)))
clojure.lang.IReduceInit
(reduce [_ rf init]
(loop [acc init
ret (step initk)]
(if (somef ret)
(let [acc (rf acc (vf ret))]
(if (reduced? acc)
@acc
(if-some [k (kf ret)]
(recur acc (step k))
acc)))
acc))))))

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

@ -13,6 +13,7 @@
[app.common.pages.changes :as ch]
[app.common.pages.init :as init]
[app.common.spec :as us]
[app.common.spec.change :as spec.change]
[app.common.uuid :as uuid]
[cuerdas.core :as str]))
@ -38,9 +39,9 @@
:frame-id (:current-frame-id file)))]
(when fail-on-spec?
(us/verify :app.common.pages.spec/change change))
(us/verify ::spec.change/change change))
(let [valid? (us/valid? :app.common.pages.spec/change change)]
(let [valid? (us/valid? ::spec.change/change change)]
#?(:cljs
(when-not valid? (.warn js/console "Invalid shape" (clj->js change))))
@ -568,4 +569,78 @@
(dissoc :current-component-id)
(update :parent-stack pop))))
(defn delete-object
[file id]
(let [page-id (:current-page-id file)]
(commit-change
file
{:type :del-obj
:page-id page-id
:id id})))
(defn update-object
[file old-obj new-obj]
(let [page-id (:current-page-id file)
new-obj (setup-selrect new-obj)
attrs (d/concat-set (keys old-obj) (keys new-obj))
generate-operation
(fn [changes attr]
(let [old-val (get old-obj attr)
new-val (get new-obj attr)]
(if (= old-val new-val)
changes
(conj changes {:type :set :attr attr :val new-val}))))]
(-> file
(commit-change
{:type :mod-obj
:operations (reduce generate-operation [] attrs)
:page-id page-id
:id (:id old-obj)}))))
(defn get-current-page
[file]
(let [page-id (:current-page-id file)]
(-> file (get-in [:data :pages-index page-id]))))
(defn add-guide
[file guide]
(let [guide (cond-> guide
(nil? (:id guide))
(assoc :id (uuid/next)))
page-id (:current-page-id file)
old-guides (or (get-in file [:data :pages-index page-id :options :guides]) {})
new-guides (assoc old-guides (:id guide) guide)]
(-> file
(commit-change
{:type :set-option
:page-id page-id
:option :guides
:value new-guides})
(assoc :last-id (:id guide)))))
(defn delete-guide
[file id]
(let [page-id (:current-page-id file)
old-guides (or (get-in file [:data :pages-index page-id :options :guides]) {})
new-guides (dissoc old-guides id)]
(-> file
(commit-change
{:type :set-option
:page-id page-id
:option :guides
:value new-guides}))))
(defn update-guide
[file guide]
(let [page-id (:current-page-id file)
old-guides (or (get-in file [:data :pages-index page-id :options :guides]) {})
new-guides (assoc old-guides (:id guide) guide)]
(-> file
(commit-change
{:type :set-option
:page-id page-id
:option :guides
:value new-guides}))))

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

@ -6,7 +6,6 @@
(ns app.common.geom.align
(:require
[app.common.data :as d]
[app.common.geom.shapes :as gsh]
[app.common.pages.helpers :refer [get-children]]
[clojure.spec.alpha :as s]))
@ -20,8 +19,7 @@
(defn- recursive-move
"Move the shape and all its recursive children."
[shape dpoint objects]
(->> (get-children (:id shape) objects)
(map (d/getf objects))
(->> (get-children objects (:id shape))
(cons shape)
(map #(gsh/move % dpoint))))

24
common/src/app/common/geom/matrix.cljc
View file

@ -10,7 +10,9 @@
:clj [clojure.pprint :as pp])
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.common.math :as mth]))
[app.common.math :as mth]
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
;; --- Matrix Impl
@ -24,6 +26,21 @@
(toString [_]
(str "matrix(" a "," b "," c "," d "," e "," f ")")))
(defn ^boolean matrix?
"Return true if `v` is Matrix instance."
[v]
(instance? Matrix v))
(s/def ::a ::us/safe-number)
(s/def ::b ::us/safe-number)
(s/def ::c ::us/safe-number)
(s/def ::d ::us/safe-number)
(s/def ::e ::us/safe-number)
(s/def ::f ::us/safe-number)
(s/def ::matrix
(s/and (s/keys :req-un [::a ::b ::c ::d ::e ::f]) matrix?))
(defn matrix
"Create a new matrix instance."
([]
@ -84,11 +101,6 @@
(- m1a m2a) (- m1b m2b) (- m1c m2c)
(- m1d m2d) (- m1e m2e) (- m1f m2f)))
(defn ^boolean matrix?
"Return true if `v` is Matrix instance."
[v]
(instance? Matrix v))
(def base (matrix))
(defn base?

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

@ -11,7 +11,9 @@
:clj [clojure.pprint :as pp])
#?(:cljs [cljs.core :as c]
:clj [clojure.core :as c])
[app.common.math :as mth]))
[app.common.math :as mth]
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
;; --- Point Impl
@ -25,6 +27,13 @@
(or (instance? Point v)
(and (map? v) (contains? v :x) (contains? v :y))))
(s/def ::x ::us/safe-number)
(s/def ::y ::us/safe-number)
(s/def ::point
(s/and (s/keys :req-un [::x ::y]) point?))
(defn ^boolean point-like?
[{:keys [x y] :as v}]
(and (map? v)

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

@ -185,3 +185,7 @@
;; Bool
(d/export gsb/update-bool-selrect)
(d/export gsb/calc-bool-content)
;; Constraints
(d/export gct/default-constraints-h)
(d/export gct/default-constraints-v)

22
common/src/app/common/geom/shapes/constraints.cljc
View file

@ -11,7 +11,7 @@
[app.common.geom.shapes.common :as gco]
[app.common.geom.shapes.transforms :as gtr]
[app.common.math :as mth]
[app.common.pages.spec :as spec]))
[app.common.uuid :as uuid]))
;; Auxiliary methods to work in an specifica axis
(defn get-delta-start [axis rect tr-rect]
@ -138,16 +138,32 @@
:center :center
:scale :scale})
(defn default-constraints-h
[shape]
(if (= (:parent-id shape) uuid/zero)
nil
(if (= (:parent-id shape) (:frame-id shape))
:left
:scale)))
(defn default-constraints-v
[shape]
(if (= (:parent-id shape) uuid/zero)
nil
(if (= (:parent-id shape) (:frame-id shape))
:top
:scale)))
(defn calc-child-modifiers
[parent child modifiers ignore-constraints transformed-parent-rect]
(let [constraints-h
(if-not ignore-constraints
(:constraints-h child (spec/default-constraints-h child))
(:constraints-h child (default-constraints-h child))
:scale)
constraints-v
(if-not ignore-constraints
(:constraints-v child (spec/default-constraints-v child))
(:constraints-v child (default-constraints-v child))
:scale)
modifiers-h (constraint-modifier (constraints-h const->type+axis) :x parent child modifiers transformed-parent-rect)

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

@ -545,7 +545,6 @@
(defn transform-selrect
[selrect {:keys [displacement resize-transform-inverse resize-vector resize-origin resize-vector-2 resize-origin-2]}]
;; FIXME: Improve Performance
(let [resize-transform-inverse (or resize-transform-inverse (gmt/matrix))

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

@ -6,6 +6,7 @@
(ns app.common.math
"A collection of math utils."
(:refer-clojure :exclude [abs])
#?(:cljs
(:require [goog.math :as math])))

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

@ -10,11 +10,8 @@
[app.common.data :as d]
[app.common.pages.changes :as changes]
[app.common.pages.common :as common]
[app.common.pages.helpers :as helpers]
[app.common.pages.indices :as indices]
[app.common.pages.init :as init]
[app.common.pages.spec :as spec]
[clojure.spec.alpha :as s]))
[app.common.pages.init :as init]))
;; Common
(d/export common/root)
@ -22,55 +19,6 @@
(d/export common/default-color)
(d/export common/component-sync-attrs)
;; Helpers
(d/export helpers/walk-pages)
(d/export helpers/select-objects)
(d/export helpers/update-object-list)
(d/export helpers/get-component-shape)
(d/export helpers/get-root-shape)
(d/export helpers/make-container)
(d/export helpers/page?)
(d/export helpers/component?)
(d/export helpers/get-container)
(d/export helpers/get-shape)
(d/export helpers/get-component)
(d/export helpers/is-main-of)
(d/export helpers/get-component-root)
(d/export helpers/get-children)
(d/export helpers/get-children-objects)
(d/export helpers/get-object-with-children)
(d/export helpers/select-children)
(d/export helpers/is-shape-grouped)
(d/export helpers/get-parent)
(d/export helpers/get-parents)
(d/export helpers/get-frame)
(d/export helpers/clean-loops)
(d/export helpers/calculate-invalid-targets)
(d/export helpers/valid-frame-target)
(d/export helpers/position-on-parent)
(d/export helpers/insert-at-index)
(d/export helpers/append-at-the-end)
(d/export helpers/select-toplevel-shapes)
(d/export helpers/select-frames)
(d/export helpers/clone-object)
(d/export helpers/indexed-shapes)
(d/export helpers/expand-region-selection)
(d/export helpers/frame-id-by-position)
(d/export helpers/set-touched-group)
(d/export helpers/touched-group?)
(d/export helpers/get-base-shape)
(d/export helpers/is-parent?)
(d/export helpers/get-index-in-parent)
(d/export helpers/split-path)
(d/export helpers/join-path)
(d/export helpers/parse-path-name)
(d/export helpers/merge-path-item)
(d/export helpers/compact-path)
(d/export helpers/compact-name)
(d/export helpers/unframed-shape?)
(d/export helpers/children-seq)
;; Indices
(d/export indices/calculate-z-index)
(d/export indices/update-z-index)
@ -88,15 +36,3 @@
(d/export init/make-minimal-shape)
(d/export init/make-minimal-group)
(d/export init/empty-file-data)
;; Specs
(s/def ::changes ::spec/changes)
(s/def ::color ::spec/color)
(s/def ::data ::spec/data)
(s/def ::media-object ::spec/media-object)
(s/def ::page ::spec/page)
(s/def ::recent-color ::spec/recent-color)
(s/def ::shape-attrs ::spec/shape-attrs)
(s/def ::typography ::spec/typography)

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

@ -5,6 +5,7 @@
;; Copyright (c) UXBOX Labs SL
(ns app.common.pages.changes
#_:clj-kondo/ignore
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
@ -13,9 +14,9 @@
[app.common.pages.common :refer [component-sync-attrs]]
[app.common.pages.helpers :as cph]
[app.common.pages.init :as init]
[app.common.pages.spec :as spec]
[app.common.spec :as us]))
[app.common.spec :as us]
[app.common.spec.change :as spec.change]
[app.common.spec.shape :as spec.shape]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Specific helpers
@ -47,7 +48,7 @@
;; When verify? false we spec the schema validation. Currently used to make just
;; 1 validation even if the changes are applied twice
(when verify?
(us/assert ::spec/changes items))
(us/assert ::spec.change/changes items))
(let [result (reduce #(or (process-change %1 %2) %1) data items)]
;; Validate result shapes (only on the backend)
@ -57,7 +58,7 @@
(doseq [[id shape] (:objects page)]
(when-not (= shape (get-in data [:pages-index page-id :objects id]))
;; If object has change verify is correct
(us/verify ::spec/shape shape))))))
(us/verify ::spec.shape/shape shape))))))
result)))
@ -159,10 +160,8 @@
(let [lookup (d/getf objects)
update-fn #(d/update-when %1 %2 update-group %1)
xform (comp
(mapcat #(cons % (cph/get-parents % objects)))
(map lookup)
(filter #(contains? #{:group :bool} (:type %)))
(map :id)
(mapcat #(cons % (cph/get-parent-ids objects %)))
(filter #(contains? #{:group :bool} (-> % lookup :type)))
(distinct))]
(->> (sequence xform shapes)
@ -203,11 +202,16 @@
(defmethod process-change :mov-objects
[data {:keys [parent-id shapes index page-id component-id ignore-touched]}]
(letfn [(is-valid-move? [objects shape-id]
(let [invalid-targets (cph/calculate-invalid-targets shape-id objects)]
(letfn [(calculate-invalid-targets [objects shape-id]
(let [reduce-fn #(into %1 (calculate-invalid-targets objects %2))]
(->> (get-in objects [shape-id :shapes])
(reduce reduce-fn #{shape-id}))))
(is-valid-move? [objects shape-id]
(let [invalid-targets (calculate-invalid-targets objects shape-id)]
(and (contains? objects shape-id)
(not (invalid-targets parent-id))
(cph/valid-frame-target shape-id parent-id objects))))
(cph/valid-frame-target? objects parent-id shape-id))))
(insert-items [prev-shapes index shapes]
(let [prev-shapes (or prev-shapes [])]

41
common/src/app/common/pages/changes_builder.cljc
View file

@ -7,19 +7,27 @@
(ns app.common.pages.changes-builder
(:require
[app.common.data :as d]
[app.common.pages :as cp]
[app.common.pages.helpers :as h]))
[app.common.pages.helpers :as cph]))
;; Auxiliary functions to help create a set of changes (undo + redo)
(defn empty-changes
[origin page-id]
(let [changes {:redo-changes []
:undo-changes []
:origin origin}]
([origin page-id]
(let [changes (empty-changes origin)]
(with-meta changes
{::page-id page-id})))
([origin]
{:redo-changes []
:undo-changes []
:origin origin}))
(defn with-page [changes page]
(vary-meta changes assoc
::page page
::page-id (:id page)
::objects (:objects page)))
(defn with-objects [changes objects]
(vary-meta changes assoc ::objects objects))
@ -69,7 +77,7 @@
:page-id (::page-id (meta changes))
:parent-id (:parent-id shape)
:shapes [(:id shape)]
:index (cp/position-on-parent (:id shape) objects)}))]
:index (cph/get-position-on-parent objects (:id shape))}))]
(-> changes
(update :redo-changes conj set-parent-change)
@ -162,7 +170,7 @@
:page-id page-id
:parent-id (:parent-id shape)
:shapes [id]
:index (h/position-on-parent id objects)
:index (cph/get-position-on-parent objects id)
:ignore-touched true})))]
(-> changes
@ -171,10 +179,25 @@
(reduce add-undo-change-parent $ ids)
(reduce add-undo-change-shape $ ids))))))
(defn move-page
[chdata index prev-index]
(let [page-id (::page-id (meta chdata))]
(-> chdata
(update :redo-changes conj {:type :mov-page :id page-id :index index})
(update :undo-changes conj {:type :mov-page :id page-id :index prev-index}))))
(defn set-page-option
[chdata option-key option-val]
(let [page-id (::page-id (meta chdata))
page (::page (meta chdata))
old-val (get-in page [:options option-key])]
(-> chdata
(update :redo-changes conj {:type :set-option
:page-id page-id
:option option-key
:value option-val})
(update :undo-changes conj {:type :set-option
:page-id page-id
:option option-key
:value old-val}))))

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

@ -9,7 +9,7 @@
[app.common.colors :as clr]
[app.common.uuid :as uuid]))
(def file-version 12)
(def file-version 13)
(def default-color clr/gray-20)
(def root uuid/zero)

170
common/src/app/common/pages/diff.cljc Normal file
View file

@ -0,0 +1,170 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.pages.diff
"Given a page in its old version and the new will retrieve a map with
the differences that will have an impact in the snap data"
(:require
[app.common.data :as d]
[clojure.set :as set]))
(defn calculate-page-diff
[old-page page check-attrs]
(let [old-objects (get old-page :objects)
old-guides (or (get-in old-page [:options :guides]) [])
new-objects (get page :objects)
new-guides (or (get-in page [:options :guides]) [])
changed-object?
(fn [id]
(let [oldv (get old-objects id)
newv (get new-objects id)]
;; Check first without select-keys because is faster if they are
;; the same reference
(and (not= oldv newv)
(not= (select-keys oldv check-attrs)
(select-keys newv check-attrs)))))
frame?
(fn [id]
(or (= :frame (get-in new-objects [id :type]))
(= :frame (get-in old-objects [id :type]))))
changed-guide?
(fn [id]
(not= (get old-guides id)
(get new-guides id)))
deleted-object?
#(and (contains? old-objects %)
(not (contains? new-objects %)))
deleted-guide?
#(and (contains? old-guides %)
(not (contains? new-guides %)))
new-object?
#(and (not (contains? old-objects %))
(contains? new-objects %))
new-guide?
#(and (not (contains? old-guides %))
(contains? new-guides %))
changed-frame-object?
#(and (contains? new-objects %)
(contains? old-objects %)
(not= (get-in old-objects [% :frame-id])
(get-in new-objects [% :frame-id])))
changed-frame-guide?
#(and (contains? new-guides %)
(contains? old-guides %)
(not= (get-in old-objects [% :frame-id])
(get-in new-objects [% :frame-id])))
changed-attrs-object?
#(and (contains? new-objects %)
(contains? old-objects %)
(= (get-in old-objects [% :frame-id])
(get-in new-objects [% :frame-id])))
changed-attrs-guide?
#(and (contains? new-guides %)
(contains? old-guides %)
(= (get-in old-objects [% :frame-id])
(get-in new-objects [% :frame-id])))
changed-object-ids
(into #{}
(filter changed-object?)
(set/union (set (keys old-objects))
(set (keys new-objects))))
changed-guides-ids
(into #{}
(filter changed-guide?)
(set/union (set (keys old-guides))
(set (keys new-guides))))
get-diff-object (fn [id] [(get old-objects id) (get new-objects id)])
get-diff-guide (fn [id] [(get old-guides id) (get new-guides id)])
;; Shapes with different frame owner
change-frame-shapes
(->> changed-object-ids
(into [] (comp (filter changed-frame-object?)
(map get-diff-object))))
;; Guides that changed frames
change-frame-guides
(->> changed-guides-ids
(into [] (comp (filter changed-frame-guide?)
(map get-diff-guide))))
removed-frames
(->> changed-object-ids
(into [] (comp (filter frame?)
(filter deleted-object?)
(map (d/getf old-objects)))))
removed-shapes
(->> changed-object-ids
(into [] (comp (remove frame?)
(filter deleted-object?)
(map (d/getf old-objects)))))
removed-guides
(->> changed-guides-ids
(into [] (comp (filter deleted-guide?)
(map (d/getf old-guides)))))
updated-frames
(->> changed-object-ids
(into [] (comp (filter frame?)
(filter changed-attrs-object?)
(map get-diff-object))))
updated-shapes
(->> changed-object-ids
(into [] (comp (remove frame?)
(filter changed-attrs-object?)
(map get-diff-object))))
updated-guides
(->> changed-guides-ids
(into [] (comp (filter changed-attrs-guide?)
(map get-diff-guide))))
new-frames
(->> changed-object-ids
(into [] (comp (filter frame?)
(filter new-object?)
(map (d/getf new-objects)))))
new-shapes
(->> changed-object-ids
(into [] (comp (remove frame?)
(filter new-object?)
(map (d/getf new-objects)))))
new-guides
(->> changed-guides-ids
(into [] (comp (filter new-guide?)
(map (d/getf new-guides)))))]
{:change-frame-shapes change-frame-shapes
:change-frame-guides change-frame-guides
:removed-frames removed-frames
:removed-shapes removed-shapes
:removed-guides removed-guides
:updated-frames updated-frames
:updated-shapes updated-shapes
:updated-guides updated-guides
:new-frames new-frames
:new-shapes new-shapes
:new-guides new-guides}))

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

@ -9,87 +9,211 @@
[app.common.data :as d]
[app.common.geom.shapes :as gsh]
[app.common.spec :as us]
[app.common.types.interactions :as cti]
[app.common.spec.page :as spec.page]
[app.common.uuid :as uuid]
[cuerdas.core :as str]))
(defn walk-pages
"Go through all pages of a file and apply a function to each one"
;; The function receives two parameters (page-id and page), and
;; returns the updated page.
[f data]
(update data :pages-index #(d/mapm f %)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GENERIC SHAPE SELECTORS AND PREDICATES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn select-objects
"Get a list of all objects in a container (a page or a component) that
satisfy a condition"
[f container]
(filter f (vals (get container :objects))))
(defn ^boolean root-frame?
[{:keys [id type]}]
(and (= type :frame)
(= id uuid/zero)))
(defn update-object-list
"Update multiple objects in a page at once"
[page objects-list]
(update page :objects
#(into % (d/index-by :id objects-list))))
(defn ^boolean frame-shape?
[{:keys [type]}]
(= type :frame))
(defn get-component-shape
"Get the parent shape linked to a component for this shape, if any"
[shape objects]
(if-not (:shape-ref shape)
nil
(if (:component-id shape)
shape
(if-let [parent-id (:parent-id shape)]
(get-component-shape (get objects parent-id) objects)
nil))))
(defn ^boolean group-shape?
[{:keys [type]}]
(= type :group))
(defn get-root-shape
"Get the root shape linked to a component for this shape, if any"
[shape objects]
(defn ^boolean text-shape?
[{:keys [type]}]
(= type :text))
(cond
(some? (:component-root? shape))
shape
(some? (:shape-ref shape))
(recur (get objects (:parent-id shape))
objects)))
(defn make-container
[page-or-component type]
(assoc page-or-component
:type type))
(defn page?
[container]
(us/assert some? (:type container))
(= (:type container) :page))
(defn component?
[container]
(= (:type container) :component))
(defn get-container
[id type local-file]
(assert (some? type))
(-> (if (= type :page)
(get-in local-file [:pages-index id])
(get-in local-file [:components id]))
(assoc :type type)))
(defn ^boolean unframed-shape?
"Checks if it's a non-frame shape in the top level."
[shape]
(and (not (frame-shape? shape))
(= (:frame-id shape) uuid/zero)))
(defn get-shape
[container shape-id]
(get-in container [:objects shape-id]))
(us/assert ::spec.page/container container)
(us/assert ::us/uuid shape-id)
(-> container
(get :objects)
(get shape-id)))
(defn get-children-ids
[objects id]
(if-let [shapes (-> (get objects id) :shapes (some-> vec))]
(into shapes (mapcat #(get-children-ids objects %)) shapes)
[]))
(defn get-children
[objects id]
(mapv (d/getf objects) (get-children-ids objects id)))
(defn get-children-with-self
[objects id]
(let [lookup (d/getf objects)]
(into [(lookup id)] (map lookup) (get-children-ids objects id))))
(defn get-parent
"Retrieve the id of the parent for the shape-id (if exists)"
[objects id]
(let [lookup (d/getf objects)]
(-> id lookup :parent-id lookup)))
(defn get-parent-id
"Retrieve the id of the parent for the shape-id (if exists)"
[objects id]
(-> objects (get id) :parent-id))
(defn get-parent-ids
"Returns a vector of parents of the specified shape."
[objects shape-id]
(loop [result [] id shape-id]
(if-let [parent-id (->> id (get objects) :parent-id)]
(recur (conj result parent-id) parent-id)
result)))
(defn get-frame
"Get the frame that contains the shape. If the shape is already a
frame, get itself. If no shape is provided, returns the root frame."
([objects]
(get objects uuid/zero))
([objects shape-or-id]
(cond
(map? shape-or-id)
(if (frame-shape? shape-or-id)
shape-or-id
(get objects (:frame-id shape-or-id)))
(= uuid/zero shape-or-id)
(get objects uuid/zero)
:else
(some->> shape-or-id
(get objects)
(get-frame objects)))))
(defn valid-frame-target?
[objects parent-id shape-id]
(let [shape (get objects shape-id)]
(or (not (frame-shape? shape))
(= parent-id uuid/zero))))
(defn get-position-on-parent
[objects id]
(let [obj (get objects id)
pid (:parent-id obj)
prt (get objects pid)]
(d/index-of (:shapes prt) id)))
(defn get-immediate-children
"Retrieve resolved shape objects that are immediate children
of the specified shape-id"
([objects] (get-immediate-children objects uuid/zero))
([objects shape-id]
(let [lookup (d/getf objects)]
(->> (lookup shape-id)
(:shapes)
(keep lookup)))))
(defn get-frames
"Retrieves all frame objects as vector. It is not implemented in
function of `get-immediate-children` for performance reasons. This
function is executed in the render hot path."
[objects]
(let [lookup (d/getf objects)
xform (comp (keep lookup)
(filter frame-shape?))]
(->> (:shapes (lookup uuid/zero))
(into [] xform))))
(defn frame-id-by-position
[objects position]
(let [frames (get-frames objects)]
(or
(->> frames
(reverse)
(d/seek #(and position (gsh/has-point? % position)))
:id)
uuid/zero)))
(declare indexed-shapes)
(defn get-base-shape
"Selects the shape that will be the base to add the shapes over"
[objects selected]
(let [;; Gets the tree-index for all the shapes
indexed-shapes (indexed-shapes objects)
;; Filters the selected and retrieve a list of ids
sorted-ids (->> indexed-shapes
(filter (comp selected second))
(map second))]
;; The first id will be the top-most
(get objects (first sorted-ids))))
(defn is-parent?
"Check if `parent-candidate` is parent of `shape-id`"
[objects shape-id parent-candidate]
(loop [current (get objects parent-candidate)
done #{}
pending (:shapes current)]
(cond
(contains? done (:id current))
(recur (get objects (first pending))
done
(rest pending))
(empty? pending) false
(and current (contains? (set (:shapes current)) shape-id)) true
:else
(recur (get objects (first pending))
(conj done (:id current))
(concat (rest pending) (:shapes current))))))
(defn get-index-in-parent
"Retrieves the index in the parent"
[objects shape-id]
(let [shape (get objects shape-id)
parent (get objects (:parent-id shape))
[parent-idx _] (d/seek (fn [[_idx child-id]] (= child-id shape-id))
(d/enumerate (:shapes parent)))]
parent-idx))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; COMPONENTS HELPERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn set-touched-group
[touched group]
(conj (or touched #{}) group))
(defn touched-group?
[shape group]
((or (:touched shape) #{}) group))
(defn get-component
[component-id library-id local-library libraries]
(assert (some? (:id local-library)))
(let [file (if (= library-id (:id local-library))
local-library
(get-in libraries [library-id :data]))]
(get-in file [:components component-id])))
"Retrieve a component from libraries, if no library-id is provided, we
iterate over all libraries and find the component on it."
([libraries component-id]
(some #(-> % :data :components (get component-id)) (vals libraries)))
([libraries library-id component-id]
(get-in libraries [library-id :data :components component-id])))
(defn is-main-of
(defn ^boolean is-main-of?
[shape-main shape-inst]
(and (:shape-ref shape-inst)
(or (= (:shape-ref shape-inst) (:id shape-main))
@ -99,92 +223,67 @@
[component]
(get-in component [:objects (:id component)]))
(defn get-children [id objects]
(if-let [shapes (-> (get objects id) :shapes (some-> vec))]
(into shapes (mapcat #(get-children % objects)) shapes)
[]))
(defn get-children-objects
"Retrieve all children objects recursively for a given object"
[id objects]
(mapv #(get objects %) (get-children id objects)))
(defn get-object-with-children
"Retrieve a vector with an object and all of its children"
[id objects]
(mapv #(get objects %) (cons id (get-children id objects))))
(defn select-children [id objects]
(->> (get-children id objects)
(select-keys objects)))
(defn is-shape-grouped
"Checks if a shape is inside a group"
[shape-id objects]
(let [contains-shape-fn (fn [{:keys [shapes]}] ((set shapes) shape-id))
shapes (remove #(= (:type %) :frame) (vals objects))]
(some contains-shape-fn shapes)))
(defn get-top-frame
[objects]
(get objects uuid/zero))
(defn get-parent
"Retrieve the id of the parent for the shape-id (if exists)"
[shape-id objects]
(let [obj (get objects shape-id)]
(:parent-id obj)))
(defn get-parents
[shape-id objects]
(let [{:keys [parent-id]} (get objects shape-id)]
(when parent-id
(lazy-seq (cons parent-id (get-parents parent-id objects))))))
(defn get-frame
"Get the frame that contains the shape. If the shape is already a frame, get itself."
[shape objects]
(if (= (:type shape) :frame)
(defn get-component-shape
"Get the parent shape linked to a component for this shape, if any"
[objects shape]
(if-not (:shape-ref shape)
nil
(if (:component-id shape)
shape
(get objects (:frame-id shape))))
(if-let [parent-id (:parent-id shape)]
(get-component-shape objects (get objects parent-id))
nil))))
(defn clean-loops
"Clean a list of ids from circular references."
[objects ids]
(defn get-root-shape
"Get the root shape linked to a component for this shape, if any."
[objects shape]
(let [parent-selected?
(fn [id]
(let [parents (get-parents id objects)]
(some ids parents)))
(cond
(some? (:component-root? shape))
shape
add-element
(fn [result id]
(cond-> result
(not (parent-selected? id))
(conj id)))]
(some? (:shape-ref shape))
(recur objects (get objects (:parent-id shape)))))
(reduce add-element (d/ordered-set) ids)))
(defn make-container
[page-or-component type]
(assoc page-or-component :type type))
(defn calculate-invalid-targets
[shape-id objects]
(let [result #{shape-id}
children (get-in objects [shape-id :shapes])
reduce-fn (fn [result child-id]
(into result (calculate-invalid-targets child-id objects)))]
(reduce reduce-fn result children)))
(defn page?
[container]
(= (:type container) :page))
(defn valid-frame-target
[shape-id parent-id objects]
(let [shape (get objects shape-id)]
(or (not= (:type shape) :frame)
(= parent-id uuid/zero))))
(defn component?
[container]
(= (:type container) :component))
(defn position-on-parent
[id objects]
(let [obj (get objects id)
pid (:parent-id obj)
prt (get objects pid)]
(d/index-of (:shapes prt) id)))
(defn get-container
[file type id]
(us/assert map? file)
(us/assert keyword? type)
(us/assert uuid? id)
(-> (if (= type :page)
(get-in file [:pages-index id])
(get-in file [:components id]))
(assoc :type type)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ALGORITHMS & TRANSFORMATIONS FOR SHAPES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn walk-pages
"Go through all pages of a file and apply a function to each one"
;; The function receives two parameters (page-id and page), and
;; returns the updated page.
[f data]
(update data :pages-index #(d/mapm f %)))
(defn update-object-list
"Update multiple objects in a page at once"
[page objects-list]
(update page :objects
#(into % (d/index-by :id objects-list))))
(defn insert-at-index
[objects index ids]
@ -204,41 +303,22 @@
(vec prev-ids)
ids))
(defn select-toplevel-shapes
([objects] (select-toplevel-shapes objects nil))
([objects {:keys [include-frames? include-frame-children?]
:or {include-frames? false
include-frame-children? true}}]
(defn clean-loops
"Clean a list of ids from circular references."
[objects ids]
(let [lookup #(get objects %)
root (lookup uuid/zero)
root-children (:shapes root)
(let [parent-selected?
(fn [id]
(let [parents (get-parent-ids objects id)]
(some ids parents)))
lookup-shapes
add-element
(fn [result id]
(if (nil? id)
result
(let [obj (lookup id)
typ (:type obj)
children (:shapes obj)]
(cond-> result
(or (not= :frame typ) include-frames?)
(conj obj)
(not (parent-selected? id))
(conj id)))]
(and (= :frame typ) include-frame-children?)
(into (map lookup) children)))))]
(reduce lookup-shapes [] root-children))))
(defn select-frames
[objects]
(let [lookup #(get objects %)
frame? #(= :frame (:type %))
xform (comp (map lookup)
(filter frame?))]
(->> (:shapes (lookup uuid/zero))
(into [] xform))))
(reduce add-element (d/ordered-set) ids)))
(defn clone-object
"Gets a copy of the object and all its children, with new ids
@ -305,8 +385,6 @@
(reduce red-fn cur-idx (reverse (:shapes object)))))]
(into {} (rec-index '() uuid/zero))))
(defn expand-region-selection
"Given a selection selects all the shapes between the first and last in
an indexed manner (shift selection)"
@ -323,67 +401,9 @@
(map second)
(into #{}))))
(defn frame-id-by-position [objects position]
(let [frames (select-frames objects)]
(or
(->> frames
(reverse)
(d/seek #(and position (gsh/has-point? % position)))
:id)
uuid/zero)))
(defn set-touched-group
[touched group]
(conj (or touched #{}) group))
(defn touched-group?
[shape group]
((or (:touched shape) #{}) group))
(defn get-base-shape
"Selects the shape that will be the base to add the shapes over"
[objects selected]
(let [;; Gets the tree-index for all the shapes
indexed-shapes (indexed-shapes objects)
;; Filters the selected and retrieve a list of ids
sorted-ids (->> indexed-shapes
(filter (comp selected second))
(map second))]
;; The first id will be the top-most
(get objects (first sorted-ids))))
(defn is-parent?
"Check if `parent-candidate` is parent of `shape-id`"
[objects shape-id parent-candidate]
(loop [current (get objects parent-candidate)
done #{}
pending (:shapes current)]
(cond
(contains? done (:id current))
(recur (get objects (first pending))
done
(rest pending))
(empty? pending) false
(and current (contains? (set (:shapes current)) shape-id)) true
:else
(recur (get objects (first pending))
(conj done (:id current))
(concat (rest pending) (:shapes current))))))
(defn get-index-in-parent
"Retrieves the index in the parent"
[objects shape-id]
(let [shape (get objects shape-id)
parent (get objects (:parent-id shape))
[parent-idx _] (d/seek (fn [[_idx child-id]] (= child-id shape-id))
(d/enumerate (:shapes parent)))]
parent-idx))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SHAPES ORGANIZATION (PATH MANAGEMENT)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn split-path
"Decompose a string in the form 'one / two / three' into
@ -443,25 +463,3 @@
[path name]
(let [path-split (split-path path)]
(merge-path-item (first path-split) name)))
(defn connected-frame?
"Check if some frame is origin or destination of any navigate interaction
in the page"
[frame-id objects]
(let [children (get-object-with-children frame-id objects)]
(or (some cti/flow-origin? (map :interactions children))
(some #(cti/flow-to? % frame-id) (map :interactions (vals objects))))))
(defn unframed-shape?
"Checks if it's a non-frame shape in the top level."
[shape]
(and (not= (:type shape) :frame)
(= (:frame-id shape) uuid/zero)))
(defn children-seq
"Creates a sequence of shapes through the objects tree"
[shape objects]
(let [getter (partial get objects)]
(tree-seq #(d/not-empty? (get shape :shapes))
#(->> (get % :shapes) (map getter))
shape)))

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

@ -7,7 +7,7 @@
(ns app.common.pages.indices
(:require
[app.common.data :as d]
[app.common.pages.helpers :as helpers]
[app.common.pages.helpers :as cph]
[app.common.uuid :as uuid]
[clojure.set :as set]))
@ -45,7 +45,7 @@
means is displayed over other shapes with less index."
[objects]
(let [frames (helpers/select-frames objects)
(let [frames (cph/get-frames objects)
z-index (calculate-frame-z-index {} uuid/zero objects)]
(->> frames
(map :id)
@ -61,7 +61,7 @@
changed-frames (set/union old-frames new-frames)
frames (->> (helpers/select-frames new-objects)
frames (->> (cph/get-frames new-objects)
(map :id)
(filter #(contains? changed-frames %)))
@ -84,13 +84,10 @@
(generate-child-all-parents-index objects (vals objects)))
([objects shapes]
(let [shape->parents
(fn [shape]
(->> (helpers/get-parents (:id shape) objects)
(into [])))]
(->> shapes
(map #(vector (:id %) (shape->parents %)))
(into {})))))
(let [xf-parents (comp
(map :id)
(map #(vector % (cph/get-parent-ids objects %))))]
(into {} xf-parents shapes))))
(defn create-clip-index
"Retrieves the mask information for an object"

4
common/src/app/common/pages/init.cljc
View file

@ -51,7 +51,9 @@
:rx 0
:ry 0}
{:type :image}
{:type :image
:rx 0
:ry 0}
{:type :circle
:name "Circle-1"

19
common/src/app/common/pages/migrations.cljc
View file

@ -281,3 +281,22 @@
(d/update-in-when page [:options :saved-grids] #(d/mapm update-grid %)))]
(update data :pages-index #(d/mapm update-page %))))
;; Add rx and ry to images
(defmethod migrate 13
[data]
(letfn [(fix-radius [shape]
(if-not (or (contains? shape :rx) (contains? shape :r1))
(-> shape
(assoc :rx 0)
(assoc :ry 0))
shape))
(update-object [_ object]
(cond-> object
(= :image (:type object))
(fix-radius)))
(update-page [_ page]
(update page :objects #(d/mapm update-object %)))]
(update data :pages-index #(d/mapm update-page %))))

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

@ -1,623 +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.pages.spec
(:require
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.spec :as us]
[app.common.types.interactions :as cti]
[app.common.types.page-options :as cto]
[app.common.types.radius :as ctr]
[app.common.uuid :as uuid]
[clojure.set :as set]
[clojure.spec.alpha :as s]))
;; --- Specs
(s/def ::frame-id uuid?)
(s/def ::id uuid?)
(s/def ::name string?)
(s/def ::path (s/nilable string?))
(s/def ::page-id uuid?)
(s/def ::parent-id uuid?)
(s/def ::string string?)
(s/def ::type keyword?)
(s/def ::uuid uuid?)
(s/def ::component-id uuid?)
(s/def ::component-file uuid?)
(s/def ::component-root? boolean?)
(s/def ::shape-ref uuid?)
(s/def :internal.matrix/a ::us/safe-number)
(s/def :internal.matrix/b ::us/safe-number)
(s/def :internal.matrix/c ::us/safe-number)
(s/def :internal.matrix/d ::us/safe-number)
(s/def :internal.matrix/e ::us/safe-number)
(s/def :internal.matrix/f ::us/safe-number)
(s/def ::matrix
(s/and (s/keys :req-un [:internal.matrix/a
:internal.matrix/b
:internal.matrix/c
:internal.matrix/d
:internal.matrix/e
:internal.matrix/f])
gmt/matrix?))
(s/def :internal.point/x ::us/safe-number)
(s/def :internal.point/y ::us/safe-number)
(s/def ::point
(s/and (s/keys :req-un [:internal.point/x
:internal.point/y])
gpt/point?))
;; GRADIENTS
(s/def :internal.gradient.stop/color ::string)
(s/def :internal.gradient.stop/opacity ::us/safe-number)
(s/def :internal.gradient.stop/offset ::us/safe-number)
(s/def :internal.gradient/type #{:linear :radial})
(s/def :internal.gradient/start-x ::us/safe-number)
(s/def :internal.gradient/start-y ::us/safe-number)
(s/def :internal.gradient/end-x ::us/safe-number)
(s/def :internal.gradient/end-y ::us/safe-number)
(s/def :internal.gradient/width ::us/safe-number)
(s/def :internal.gradient/stop
(s/keys :req-un [:internal.gradient.stop/color
:internal.gradient.stop/opacity
:internal.gradient.stop/offset]))
(s/def :internal.gradient/stops
(s/coll-of :internal.gradient/stop :kind vector?))
(s/def ::gradient
(s/keys :req-un [:internal.gradient/type
:internal.gradient/start-x
:internal.gradient/start-y
:internal.gradient/end-x
:internal.gradient/end-y
:internal.gradient/width
:internal.gradient/stops]))
;;; COLORS
(s/def :internal.color/name ::string)
(s/def :internal.color/path (s/nilable ::string))
(s/def :internal.color/value (s/nilable ::string))
(s/def :internal.color/color (s/nilable ::string))
(s/def :internal.color/opacity (s/nilable ::us/safe-number))
(s/def :internal.color/gradient (s/nilable ::gradient))
(s/def ::color
(s/keys :opt-un [::id
:internal.color/name
:internal.color/path
:internal.color/value
:internal.color/color
:internal.color/opacity
:internal.color/gradient]))
;;; SHADOW EFFECT
(s/def :internal.shadow/id uuid?)
(s/def :internal.shadow/style #{:drop-shadow :inner-shadow})
(s/def :internal.shadow/color ::color)
(s/def :internal.shadow/offset-x ::us/safe-number)
(s/def :internal.shadow/offset-y ::us/safe-number)
(s/def :internal.shadow/blur ::us/safe-number)
(s/def :internal.shadow/spread ::us/safe-number)
(s/def :internal.shadow/hidden boolean?)
(s/def :internal.shadow/shadow
(s/keys :req-un [:internal.shadow/id
:internal.shadow/style
:internal.shadow/color
:internal.shadow/offset-x
:internal.shadow/offset-y
:internal.shadow/blur
:internal.shadow/spread
:internal.shadow/hidden]))
(s/def ::shadow
(s/coll-of :internal.shadow/shadow :kind vector?))
;;; BLUR EFFECT
(s/def :internal.blur/id uuid?)
(s/def :internal.blur/type #{:layer-blur})
(s/def :internal.blur/value ::us/safe-number)
(s/def :internal.blur/hidden boolean?)
(s/def ::blur
(s/keys :req-un [:internal.blur/id
:internal.blur/type
:internal.blur/value
:internal.blur/hidden]))
;; Size constraints
(s/def :internal.shape/constraints-h #{:left :right :leftright :center :scale})
(s/def :internal.shape/constraints-v #{:top :bottom :topbottom :center :scale})
(s/def :internal.shape/fixed-scroll boolean?)
; Shapes in the top frame have no constraints. Shapes directly below some
; frame are left-top constrained. Else (shapes in a group) are scaled.
(defn default-constraints-h
[shape]
(if (= (:parent-id shape) uuid/zero)
nil
(if (= (:parent-id shape) (:frame-id shape))
:left
:scale)))
(defn default-constraints-v
[shape]
(if (= (:parent-id shape) uuid/zero)
nil
(if (= (:parent-id shape) (:frame-id shape))
:top
:scale)))
;; Page Data related
(s/def :internal.shape/blocked boolean?)
(s/def :internal.shape/collapsed boolean?)
(s/def :internal.shape/fill-color string?)
(s/def :internal.shape/fill-opacity ::us/safe-number)
(s/def :internal.shape/fill-color-gradient (s/nilable ::gradient))
(s/def :internal.shape/fill-color-ref-file (s/nilable uuid?))
(s/def :internal.shape/fill-color-ref-id (s/nilable uuid?))
(s/def :internal.shape/hide-fill-on-export boolean?)
(s/def :internal.shape/font-family string?)
(s/def :internal.shape/font-size ::us/safe-integer)
(s/def :internal.shape/font-style string?)
(s/def :internal.shape/font-weight string?)
(s/def :internal.shape/hidden boolean?)
(s/def :internal.shape/letter-spacing ::us/safe-number)
(s/def :internal.shape/line-height ::us/safe-number)
(s/def :internal.shape/locked boolean?)
(s/def :internal.shape/page-id uuid?)
(s/def :internal.shape/proportion ::us/safe-number)
(s/def :internal.shape/proportion-lock boolean?)
(s/def :internal.shape/stroke-color string?)
(s/def :internal.shape/stroke-color-gradient (s/nilable ::gradient))
(s/def :internal.shape/stroke-color-ref-file (s/nilable uuid?))
(s/def :internal.shape/stroke-color-ref-id (s/nilable uuid?))
(s/def :internal.shape/stroke-opacity ::us/safe-number)
(s/def :internal.shape/stroke-style #{:solid :dotted :dashed :mixed :none :svg})
(def stroke-caps-line #{:round :square})
(def stroke-caps-marker #{:line-arrow :triangle-arrow :square-marker :circle-marker :diamond-marker})
(def stroke-caps (set/union stroke-caps-line stroke-caps-marker))
(s/def :internal.shape/stroke-cap-start stroke-caps)
(s/def :internal.shape/stroke-cap-end stroke-caps)
(defn has-caps?
[shape]
(= (:type shape) :path))
(s/def :internal.shape/stroke-width ::us/safe-number)
(s/def :internal.shape/stroke-alignment #{:center :inner :outer})
(s/def :internal.shape/text-align #{"left" "right" "center" "justify"})
(s/def :internal.shape/x ::us/safe-number)
(s/def :internal.shape/y ::us/safe-number)
(s/def :internal.shape/cx ::us/safe-number)
(s/def :internal.shape/cy ::us/safe-number)
(s/def :internal.shape/width ::us/safe-number)
(s/def :internal.shape/height ::us/safe-number)
(s/def :internal.shape/index integer?)
(s/def :internal.shape/shadow ::shadow)
(s/def :internal.shape/blur ::blur)
(s/def :internal.shape/x1 ::us/safe-number)
(s/def :internal.shape/y1 ::us/safe-number)
(s/def :internal.shape/x2 ::us/safe-number)
(s/def :internal.shape/y2 ::us/safe-number)
(s/def :internal.shape.export/suffix string?)
(s/def :internal.shape.export/scale ::us/safe-number)
(s/def :internal.shape/export
(s/keys :req-un [::type
:internal.shape.export/suffix
:internal.shape.export/scale]))
(s/def :internal.shape/exports
(s/coll-of :internal.shape/export :kind vector?))
(s/def :internal.shape/selrect
(s/keys :req-un [:internal.shape/x
:internal.shape/y
:internal.shape/x1
:internal.shape/y1
:internal.shape/x2
:internal.shape/y2
:internal.shape/width
:internal.shape/height]))
(s/def :internal.shape/points
(s/every ::point :kind vector?))
(s/def :internal.shape/shapes
(s/every uuid? :kind vector?))
(s/def :internal.shape/transform ::matrix)
(s/def :internal.shape/transform-inverse ::matrix)
(s/def :internal.shape/opacity ::us/safe-number)
(s/def :internal.shape/blend-mode
#{:normal
:darken
:multiply
:color-burn
:lighten
:screen
:color-dodge
:overlay
:soft-light
:hard-light
:difference
:exclusion
:hue
:saturation
:color
:luminosity})
(s/def ::shape-attrs
(s/keys :opt-un [::id
::type
::name
::component-id
::component-file
::component-root?
::shape-ref
:internal.shape/selrect
:internal.shape/points
:internal.shape/blocked
:internal.shape/collapsed
:internal.shape/fill-color
:internal.shape/fill-opacity
:internal.shape/fill-color-gradient
:internal.shape/fill-color-ref-file
:internal.shape/fill-color-ref-id
:internal.shape/font-family
:internal.shape/font-size
:internal.shape/font-style
:internal.shape/font-weight
:internal.shape/hidden
:internal.shape/letter-spacing
:internal.shape/line-height
:internal.shape/locked
:internal.shape/proportion
:internal.shape/proportion-lock
:internal.shape/constraints-h
:internal.shape/constraints-v
:internal.shape/fixed-scroll
::ctr/rx
::ctr/ry
::ctr/r1
::ctr/r2
::ctr/r3
::ctr/r4
:internal.shape/x
:internal.shape/y
:internal.shape/exports
:internal.shape/shapes
:internal.shape/stroke-color
:internal.shape/stroke-color-ref-file
:internal.shape/stroke-color-ref-id
:internal.shape/stroke-opacity
:internal.shape/stroke-style
:internal.shape/stroke-width
:internal.shape/stroke-alignment
:internal.shape/stroke-cap-start
:internal.shape/stroke-cap-end
:internal.shape/text-align
:internal.shape/transform
:internal.shape/transform-inverse
:internal.shape/width
:internal.shape/height
::cti/interactions
:internal.shape/masked-group?
:internal.shape/shadow
:internal.shape/blur
:internal.shape/opacity
:internal.shape/blend-mode]))
(s/def :internal.shape.text/type #{"root" "paragraph-set" "paragraph"})
(s/def :internal.shape.text/children
(s/coll-of :internal.shape.text/content
:kind vector?
:min-count 1))
(s/def :internal.shape.text/text string?)
(s/def :internal.shape.text/key string?)
(s/def :internal.shape.text/content
(s/nilable
(s/or :text-container
(s/keys :req-un [:internal.shape.text/type
:internal.shape.text/children]
:opt-un [:internal.shape.text/key])
:text-content
(s/keys :req-un [:internal.shape.text/text]))))
(s/def :internal.shape.path/command keyword?)
(s/def :internal.shape.path/params
(s/nilable (s/map-of keyword? any?)))
(s/def :internal.shape.path/command-item
(s/keys :req-un [:internal.shape.path/command]
:opt-un [:internal.shape.path/params]))
(s/def :internal.shape.path/content
(s/coll-of :internal.shape.path/command-item :kind vector?))
(defmulti shape-spec :type)
(defmethod shape-spec :default [_]
(s/spec ::shape-attrs))
(defmethod shape-spec :text [_]
(s/and ::shape-attrs
(s/keys :opt-un [:internal.shape.text/content])))
(defmethod shape-spec :path [_]
(s/and ::shape-attrs
(s/keys :opt-un [:internal.shape.path/content])))
(defmethod shape-spec :frame [_]
(s/and ::shape-attrs
(s/keys :opt-un [:internal.shape/hide-fill-on-export])))
(s/def ::shape
(s/and (s/multi-spec shape-spec :type)
#(contains? % :name)
#(contains? % :type)))
(s/def :internal.page/objects (s/map-of uuid? ::shape))
(s/def ::page
(s/keys :req-un [::id
::name
::cto/options
:internal.page/objects]))
(s/def ::recent-color
(s/keys :opt-un [:internal.color/value
:internal.color/color
:internal.color/opacity
:internal.color/gradient]))
(s/def :internal.media-object/name ::string)
(s/def :internal.media-object/width ::us/safe-integer)
(s/def :internal.media-object/height ::us/safe-integer)
(s/def :internal.media-object/mtype ::string)
(s/def ::media-object
(s/keys :req-un [::id
::name
:internal.media-object/width
:internal.media-object/height
:internal.media-object/mtype]))
(s/def ::media-object-update
(s/keys :req-un [::id]
:opt-un [::name
:internal.media-object/width
:internal.media-object/height
:internal.media-object/mtype]))
(s/def :internal.file/colors
(s/map-of ::uuid ::color))
(s/def :internal.file/recent-colors
(s/coll-of ::recent-color :kind vector?))
(s/def :internal.typography/id ::id)
(s/def :internal.typography/name ::string)
(s/def :internal.typography/path (s/nilable ::string))
(s/def :internal.typography/font-id ::string)
(s/def :internal.typography/font-family ::string)
(s/def :internal.typography/font-variant-id ::string)
(s/def :internal.typography/font-size ::string)
(s/def :internal.typography/font-weight ::string)
(s/def :internal.typography/font-style ::string)
(s/def :internal.typography/line-height ::string)
(s/def :internal.typography/letter-spacing ::string)
(s/def :internal.typography/text-transform ::string)
(s/def ::typography
(s/keys :req-un [:internal.typography/id
:internal.typography/name
:internal.typography/font-id
:internal.typography/font-family
:internal.typography/font-variant-id
:internal.typography/font-size
:internal.typography/font-weight
:internal.typography/font-style
:internal.typography/line-height
:internal.typography/letter-spacing
:internal.typography/text-transform]
:opt-un [:internal.typography/path]))
(s/def :internal.file/pages
(s/coll-of ::uuid :kind vector?))
(s/def :internal.file/media
(s/map-of ::uuid ::media-object))
(s/def :internal.file/pages-index
(s/map-of ::uuid ::page))
(s/def ::data
(s/keys :req-un [:internal.file/pages-index
:internal.file/pages]
:opt-un [:internal.file/colors
:internal.file/recent-colors
:internal.file/media]))
(s/def :internal.container/type #{:page :component})
(s/def ::container
(s/keys :req-un [:internal.container/type
::id
::name
:internal.page/objects]))
(defmulti operation-spec :type)
(s/def :internal.operations.set/attr keyword?)
(s/def :internal.operations.set/val any?)
(s/def :internal.operations.set/touched
(s/nilable (s/every keyword? :kind set?)))
(s/def :internal.operations.set/remote-synced?
(s/nilable boolean?))
(defmethod operation-spec :set [_]
(s/keys :req-un [:internal.operations.set/attr
:internal.operations.set/val]))
(defmethod operation-spec :set-touched [_]
(s/keys :req-un [:internal.operations.set/touched]))
(defmethod operation-spec :set-remote-synced [_]
(s/keys :req-un [:internal.operations.set/remote-synced?]))
(defmulti change-spec :type)
(s/def :internal.changes.set-option/option any?)
(s/def :internal.changes.set-option/value any?)
(defmethod change-spec :set-option [_]
(s/keys :req-un [:internal.changes.set-option/option
:internal.changes.set-option/value]))
(s/def :internal.changes.add-obj/obj ::shape)
(defn- valid-container-id-frame?
[o]
(or (and (contains? o :page-id)
(not (contains? o :component-id))
(some? (:frame-id o)))
(and (contains? o :component-id)
(not (contains? o :page-id))
(nil? (:frame-id o)))))
(defn- valid-container-id?
[o]
(or (and (contains? o :page-id)
(not (contains? o :component-id)))
(and (contains? o :component-id)
(not (contains? o :page-id)))))
(defmethod change-spec :add-obj [_]
(s/and (s/keys :req-un [::id :internal.changes.add-obj/obj]
:opt-un [::page-id ::component-id ::parent-id ::frame-id])
valid-container-id-frame?))
(s/def ::operation (s/multi-spec operation-spec :type))
(s/def ::operations (s/coll-of ::operation))
(defmethod change-spec :mod-obj [_]
(s/and (s/keys :req-un [::id ::operations]
:opt-un [::page-id ::component-id])
valid-container-id?))
(defmethod change-spec :del-obj [_]
(s/and (s/keys :req-un [::id]
:opt-un [::page-id ::component-id])
valid-container-id?))
(s/def :internal.changes.reg-objects/shapes
(s/coll-of uuid? :kind vector?))
(defmethod change-spec :reg-objects [_]
(s/and (s/keys :req-un [:internal.changes.reg-objects/shapes]
:opt-un [::page-id ::component-id])
valid-container-id?))
(defmethod change-spec :mov-objects [_]
(s/and (s/keys :req-un [::parent-id :internal.shape/shapes]
:opt-un [::page-id ::component-id ::index])
valid-container-id?))
(defmethod change-spec :add-page [_]
(s/or :empty (s/keys :req-un [::id ::name])
:complete (s/keys :req-un [::page])))
(defmethod change-spec :mod-page [_]
(s/keys :req-un [::id ::name]))
(defmethod change-spec :del-page [_]
(s/keys :req-un [::id]))
(defmethod change-spec :mov-page [_]
(s/keys :req-un [::id ::index]))
(defmethod change-spec :add-color [_]
(s/keys :req-un [::color]))
(defmethod change-spec :mod-color [_]
(s/keys :req-un [::color]))
(defmethod change-spec :del-color [_]
(s/keys :req-un [::id]))
(s/def :internal.changes.add-recent-color/color ::recent-color)
(defmethod change-spec :add-recent-color [_]
(s/keys :req-un [:internal.changes.add-recent-color/color]))
(s/def :internal.changes.media/object ::media-object)
(defmethod change-spec :add-media [_]
(s/keys :req-un [:internal.changes.media/object]))
(s/def :internal.changes.media.mod/object ::media-object-update)
(defmethod change-spec :mod-media [_]
(s/keys :req-un [:internal.changes.media.mod/object]))
(defmethod change-spec :del-media [_]
(s/keys :req-un [::id]))
(s/def :internal.changes.add-component/shapes
(s/coll-of ::shape))
(defmethod change-spec :add-component [_]
(s/keys :req-un [::id ::name :internal.changes.add-component/shapes]
:opt-un [::path]))
(defmethod change-spec :mod-component [_]
(s/keys :req-un [::id]
:opt-un [::name :internal.changes.add-component/shapes]))
(defmethod change-spec :del-component [_]
(s/keys :req-un [::id]))
(s/def :internal.changes.typography/typography ::typography)
(defmethod change-spec :add-typography [_]
(s/keys :req-un [:internal.changes.typography/typography]))
(defmethod change-spec :mod-typography [_]
(s/keys :req-un [:internal.changes.typography/typography]))
(defmethod change-spec :del-typography [_]
(s/keys :req-un [:internal.typography/id]))
(s/def ::change (s/multi-spec change-spec :type))
(s/def ::changes (s/coll-of ::change))

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

@ -16,7 +16,6 @@
;; because of some strange interaction with cljs.spec.alpha and
;; modules splitting.
[app.common.exceptions :as ex]
[app.common.geom.point :as gpt]
[app.common.uuid :as uuid]
[cuerdas.core :as str]
[expound.alpha :as expound]))
@ -110,7 +109,6 @@
(s/def ::not-empty-string (s/and string? #(not (str/empty? %))))
(s/def ::url string?)
(s/def ::fn fn?)
(s/def ::point gpt/point?)
(s/def ::id ::uuid)
(defn bytes?
@ -279,5 +277,3 @@
(binding [s/*explain-out* expound/printer]
(with-out-str
(s/explain-out (update data ::s/problems #(take max-problems %))))))))

19
common/src/app/common/spec/blur.cljc Normal file
View file

@ -0,0 +1,19 @@
;; 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.spec.blur
(:require
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
(s/def ::id uuid?)
(s/def ::type #{:layer-blur})
(s/def ::value ::us/safe-number)
(s/def ::hidden boolean?)
(s/def ::blur
(s/keys :req-un [::id ::type ::value ::hidden]))

165
common/src/app/common/spec/change.cljc Normal file
View file

@ -0,0 +1,165 @@
;; 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.spec.change
(:require
[app.common.spec.color :as color]
[app.common.spec.file :as file]
[app.common.spec.page :as page]
[app.common.spec.shape :as shape]
[app.common.spec.typography :as typg]
[clojure.spec.alpha :as s]))
(s/def ::index integer?)
(s/def ::id uuid?)
(s/def ::parent-id uuid?)
(s/def ::frame-id uuid?)
(s/def ::page-id uuid?)
(s/def ::component-id uuid?)
(s/def ::name string?)
(defmulti operation-spec :type)
(s/def :internal.operations.set/attr keyword?)
(s/def :internal.operations.set/val any?)
(s/def :internal.operations.set/touched
(s/nilable (s/every keyword? :kind set?)))
(s/def :internal.operations.set/remote-synced?
(s/nilable boolean?))
(defmethod operation-spec :set [_]
(s/keys :req-un [:internal.operations.set/attr
:internal.operations.set/val]))
(defmethod operation-spec :set-touched [_]
(s/keys :req-un [:internal.operations.set/touched]))
(defmethod operation-spec :set-remote-synced [_]
(s/keys :req-un [:internal.operations.set/remote-synced?]))
(defmulti change-spec :type)
(s/def :internal.changes.set-option/option any?)
(s/def :internal.changes.set-option/value any?)
(defmethod change-spec :set-option [_]
(s/keys :req-un [:internal.changes.set-option/option
:internal.changes.set-option/value]))
(s/def :internal.changes.add-obj/obj ::shape/shape)
(defn- valid-container-id-frame?
[o]
(or (and (contains? o :page-id)
(not (contains? o :component-id))
(some? (:frame-id o)))
(and (contains? o :component-id)
(not (contains? o :page-id))
(nil? (:frame-id o)))))
(defn- valid-container-id?
[o]
(or (and (contains? o :page-id)
(not (contains? o :component-id)))
(and (contains? o :component-id)
(not (contains? o :page-id)))))
(defmethod change-spec :add-obj [_]
(s/and (s/keys :req-un [::id :internal.changes.add-obj/obj]
:opt-un [::page-id ::component-id ::parent-id ::frame-id])
valid-container-id-frame?))
(s/def ::operation (s/multi-spec operation-spec :type))
(s/def ::operations (s/coll-of ::operation))
(defmethod change-spec :mod-obj [_]
(s/and (s/keys :req-un [::id ::operations]
:opt-un [::page-id ::component-id])
valid-container-id?))
(defmethod change-spec :del-obj [_]
(s/and (s/keys :req-un [::id]
:opt-un [::page-id ::component-id])
valid-container-id?))
(defmethod change-spec :reg-objects [_]
(s/and (s/keys :req-un [::shape/shapes]
:opt-un [::page-id ::component-id])
valid-container-id?))
(defmethod change-spec :mov-objects [_]
(s/and (s/keys :req-un [::parent-id ::shape/shapes]
:opt-un [::page-id ::component-id ::index])
valid-container-id?))
(defmethod change-spec :add-page [_]
(s/or :empty (s/keys :req-un [::id ::name])
:complete (s/keys :req-un [::page/page])))
(defmethod change-spec :mod-page [_]
(s/keys :req-un [::id ::name]))
(defmethod change-spec :del-page [_]
(s/keys :req-un [::id]))
(defmethod change-spec :mov-page [_]
(s/keys :req-un [::id ::index]))
(defmethod change-spec :add-color [_]
(s/keys :req-un [::color/color]))
(defmethod change-spec :mod-color [_]
(s/keys :req-un [::color/color]))
(defmethod change-spec :del-color [_]
(s/keys :req-un [::id]))
(s/def :internal.changes.add-recent-color/color ::color/recent-color)
(defmethod change-spec :add-recent-color [_]
(s/keys :req-un [:internal.changes.add-recent-color/color]))
(s/def :internal.changes.media/object ::file/media-object)
(defmethod change-spec :add-media [_]
(s/keys :req-un [:internal.changes.media/object]))
(s/def :internal.changes.media.mod/object
(s/and ::file/media-object #(contains? % :id)))
(defmethod change-spec :mod-media [_]
(s/keys :req-un [:internal.changes.media.mod/object]))
(defmethod change-spec :del-media [_]
(s/keys :req-un [::id]))
(s/def :internal.changes.add-component/shapes
(s/coll-of ::shape/shape))
(defmethod change-spec :add-component [_]
(s/keys :req-un [::id ::name :internal.changes.add-component/shapes]
:opt-un [::path]))
(defmethod change-spec :mod-component [_]
(s/keys :req-un [::id]
:opt-un [::name :internal.changes.add-component/shapes]))
(defmethod change-spec :del-component [_]
(s/keys :req-un [::id]))
(defmethod change-spec :add-typography [_]
(s/keys :req-un [::typg/typography]))
(defmethod change-spec :mod-typography [_]
(s/keys :req-un [::typg/typography]))
(defmethod change-spec :del-typography [_]
(s/keys :req-un [::typg/id]))
(s/def ::change (s/multi-spec change-spec :type))
(s/def ::changes (s/coll-of ::change))

75
common/src/app/common/spec/color.cljc Normal file
View file

@ -0,0 +1,75 @@
;; 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.spec.color
(:require
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
;; TODO: waiting clojure 1.11 to rename this all :internal.stuff to a
;; more consistent name.
;; TODO: maybe define ::color-hex-string with proper hex color spec?
;; --- GRADIENTS
(s/def ::id uuid?)
(s/def :internal.gradient.stop/color string?)
(s/def :internal.gradient.stop/opacity ::us/safe-number)
(s/def :internal.gradient.stop/offset ::us/safe-number)
(s/def :internal.gradient/type #{:linear :radial})
(s/def :internal.gradient/start-x ::us/safe-number)
(s/def :internal.gradient/start-y ::us/safe-number)
(s/def :internal.gradient/end-x ::us/safe-number)
(s/def :internal.gradient/end-y ::us/safe-number)
(s/def :internal.gradient/width ::us/safe-number)
(s/def :internal.gradient/stop
(s/keys :req-un [:internal.gradient.stop/color
:internal.gradient.stop/opacity
:internal.gradient.stop/offset]))
(s/def :internal.gradient/stops
(s/coll-of :internal.gradient/stop :kind vector?))
(s/def ::gradient
(s/keys :req-un [:internal.gradient/type
:internal.gradient/start-x
:internal.gradient/start-y
:internal.gradient/end-x
:internal.gradient/end-y
:internal.gradient/width
:internal.gradient/stops]))
;;; --- COLORS
(s/def :internal.color/name string?)
(s/def :internal.color/path (s/nilable string?))
(s/def :internal.color/value (s/nilable string?))
(s/def :internal.color/color (s/nilable string?))
(s/def :internal.color/opacity (s/nilable ::us/safe-number))
(s/def :internal.color/gradient (s/nilable ::gradient))
(s/def ::color
(s/keys :opt-un [::id
:internal.color/name
:internal.color/path
:internal.color/value
:internal.color/color
:internal.color/opacity
:internal.color/gradient]))
(s/def ::recent-color
(s/keys :opt-un [:internal.color/value
:internal.color/color
:internal.color/opacity
:internal.color/gradient]))

22
common/src/app/common/spec/export.cljc Normal file
View file

@ -0,0 +1,22 @@
;; 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.spec.export
(:require
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
(s/def ::suffix string?)
(s/def ::scale ::us/safe-number)
(s/def ::type keyword?)
(s/def ::export
(s/keys :req-un [::type
::suffix
::scale]))

54
common/src/app/common/spec/file.cljc Normal file
View file

@ -0,0 +1,54 @@
;; 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.spec.file
(:require
[app.common.spec :as us]
[app.common.spec.color :as color]
[app.common.spec.page :as page]
[app.common.spec.typography]
[clojure.spec.alpha :as s]))
(s/def :internal.media-object/name string?)
(s/def :internal.media-object/width ::us/safe-integer)
(s/def :internal.media-object/height ::us/safe-integer)
(s/def :internal.media-object/mtype string?)
(s/def ::media-object
(s/keys :req-un [::id
::name
:internal.media-object/width
:internal.media-object/height
:internal.media-object/mtype]))
(s/def ::colors
(s/map-of uuid? ::color/color))
(s/def ::recent-colors
(s/coll-of ::color/recent-color :kind vector?))
(s/def ::typographies
(s/map-of uuid? :app.common.spec.typography/typography))
(s/def ::pages
(s/coll-of uuid? :kind vector?))
(s/def ::media
(s/map-of uuid? ::media-object))
(s/def ::pages-index
(s/map-of uuid? ::page/page))
(s/def ::components
(s/map-of uuid? ::page/container))
(s/def ::data
(s/keys :req-un [::pages-index
::pages]
:opt-un [::colors
::recent-colors
::typographies
::media]))

4
common/src/app/common/types/interactions.cljc → common/src/app/common/spec/interactions.cljc
View file

@ -4,7 +4,7 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.types.interactions
(ns app.common.spec.interactions
(:require
[app.common.data :as d]
[app.common.geom.point :as gpt]
@ -100,7 +100,7 @@
:bottom-left
:bottom-right
:bottom-center})
(s/def ::overlay-position ::us/point)
(s/def ::overlay-position ::gpt/point)
(s/def ::url ::us/string)
(s/def ::close-click-outside ::us/boolean)
(s/def ::background-overlay ::us/boolean)

128
common/src/app/common/spec/page.cljc Normal file
View file

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

2
common/src/app/common/types/radius.cljc → common/src/app/common/spec/radius.cljc
View file

@ -4,7 +4,7 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.types.radius
(ns app.common.spec.radius
(:require
[app.common.spec :as us]
[clojure.spec.alpha :as s]))

37
common/src/app/common/spec/shadow.cljc Normal file
View file

@ -0,0 +1,37 @@
;; 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.spec.shadow
(:require
[app.common.spec :as us]
[app.common.spec.color :as color]
[clojure.spec.alpha :as s]))
;;; SHADOW EFFECT
(s/def ::id uuid?)
(s/def ::style #{:drop-shadow :inner-shadow})
(s/def ::color ::color/color)
(s/def ::offset-x ::us/safe-number)
(s/def ::offset-y ::us/safe-number)
(s/def ::blur ::us/safe-number)
(s/def ::spread ::us/safe-number)
(s/def ::hidden boolean?)
(s/def ::shadow-props
(s/keys :req-un [:internal.shadow/id
:internal.shadow/style
:internal.shadow/color
:internal.shadow/offset-x
:internal.shadow/offset-y
:internal.shadow/blur
:internal.shadow/spread
:internal.shadow/hidden]))
(s/def ::shadow
(s/coll-of ::shadow-props :kind vector?))

242
common/src/app/common/spec/shape.cljc Normal file
View file

@ -0,0 +1,242 @@
;; 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.spec.shape
(:require
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]
[app.common.spec :as us]
[app.common.spec.blur :as blur]
[app.common.spec.color :as color]
[app.common.spec.export :as export]
[app.common.spec.interactions :as cti]
[app.common.spec.radius :as radius]
[app.common.spec.shadow :as shadow]
[clojure.set :as set]
[clojure.spec.alpha :as s]))
;; --- Specs
(s/def ::frame-id uuid?)
(s/def ::id uuid?)
(s/def ::name string?)
(s/def ::path (s/nilable string?))
(s/def ::page-id uuid?)
(s/def ::parent-id uuid?)
(s/def ::string string?)
(s/def ::type keyword?)
(s/def ::uuid uuid?)
(s/def ::component-id uuid?)
(s/def ::component-file uuid?)
(s/def ::component-root? boolean?)
(s/def ::shape-ref uuid?)
;; Size constraints
(s/def ::constraints-h #{:left :right :leftright :center :scale})
(s/def ::constraints-v #{:top :bottom :topbottom :center :scale})
(s/def ::fixed-scroll boolean?)
;; Page Data related
(s/def ::blocked boolean?)
(s/def ::collapsed boolean?)
(s/def ::fill-color string?)
(s/def ::fill-opacity ::us/safe-number)
(s/def ::fill-color-gradient (s/nilable ::color/gradient))
(s/def ::fill-color-ref-file (s/nilable uuid?))
(s/def ::fill-color-ref-id (s/nilable uuid?))
(s/def ::hide-fill-on-export boolean?)
(s/def ::masked-group? boolean?)
(s/def ::font-family string?)
(s/def ::font-size ::us/safe-integer)
(s/def ::font-style string?)
(s/def ::font-weight string?)
(s/def ::hidden boolean?)
(s/def ::letter-spacing ::us/safe-number)
(s/def ::line-height ::us/safe-number)
(s/def ::locked boolean?)
(s/def ::page-id uuid?)
(s/def ::proportion ::us/safe-number)
(s/def ::proportion-lock boolean?)
(s/def ::stroke-color string?)
(s/def ::stroke-color-gradient (s/nilable ::color/gradient))
(s/def ::stroke-color-ref-file (s/nilable uuid?))
(s/def ::stroke-color-ref-id (s/nilable uuid?))
(s/def ::stroke-opacity ::us/safe-number)
(s/def ::stroke-style #{:solid :dotted :dashed :mixed :none :svg})
(def stroke-caps-line #{:round :square})
(def stroke-caps-marker #{:line-arrow :triangle-arrow :square-marker :circle-marker :diamond-marker})
(def stroke-caps (set/union stroke-caps-line stroke-caps-marker))
(s/def ::stroke-cap-start stroke-caps)
(s/def ::stroke-cap-end stroke-caps)
(s/def ::stroke-width ::us/safe-number)
(s/def ::stroke-alignment #{:center :inner :outer})
(s/def ::text-align #{"left" "right" "center" "justify"})
(s/def ::x ::us/safe-number)
(s/def ::y ::us/safe-number)
(s/def ::cx ::us/safe-number)
(s/def ::cy ::us/safe-number)
(s/def ::width ::us/safe-number)
(s/def ::height ::us/safe-number)
(s/def ::index integer?)
(s/def ::x1 ::us/safe-number)
(s/def ::y1 ::us/safe-number)
(s/def ::x2 ::us/safe-number)
(s/def ::y2 ::us/safe-number)
(s/def ::selrect
(s/keys :req-un [::x ::y ::x1 ::y1 ::x2 ::y2 ::width ::height]))
(s/def ::exports
(s/coll-of ::export/export :kind vector?))
(s/def ::points
(s/every ::gpt/point :kind vector?))
(s/def ::shapes
(s/every uuid? :kind vector?))
(s/def ::transform ::gmt/matrix)
(s/def ::transform-inverse ::gmt/matrix)
(s/def ::opacity ::us/safe-number)
(s/def ::blend-mode
#{:normal
:darken
:multiply
:color-burn
:lighten
:screen
:color-dodge
:overlay
:soft-light
:hard-light
:difference
:exclusion
:hue
:saturation
:color
:luminosity})
(s/def ::shape-attrs
(s/keys :opt-un [::id
::type
::name
::component-id
::component-file
::component-root?
::shape-ref
::selrect
::points
::blocked
::collapsed
::fill-color
::fill-opacity
::fill-color-gradient
::fill-color-ref-file
::fill-color-ref-id
::hide-fill-on-export
::font-family
::font-size
::font-style
::font-weight
::hidden
::letter-spacing
::line-height
::locked
::proportion
::proportion-lock
::constraints-h
::constraints-v
::fixed-scroll
::radius/rx
::radius/ry
::radius/r1
::radius/r2
::radius/r3
::radius/r4
::x
::y
::exports
::shapes
::stroke-color
::stroke-color-ref-file
::stroke-color-ref-id
::stroke-opacity
::stroke-style
::stroke-width
::stroke-alignment
::stroke-cap-start
::stroke-cap-end
::text-align
::transform
::transform-inverse
::width
::height
::masked-group?
::cti/interactions
::shadow/shadow
::blur/blur
::opacity
::blend-mode]))
(s/def :internal.shape.text/type #{"root" "paragraph-set" "paragraph"})
(s/def :internal.shape.text/children
(s/coll-of :internal.shape.text/content
:kind vector?
:min-count 1))
(s/def :internal.shape.text/text string?)
(s/def :internal.shape.text/key string?)
(s/def :internal.shape.text/content
(s/nilable
(s/or :text-container
(s/keys :req-un [:internal.shape.text/type
:internal.shape.text/children]
:opt-un [:internal.shape.text/key])
:text-content
(s/keys :req-un [:internal.shape.text/text]))))
(s/def :internal.shape.path/command keyword?)
(s/def :internal.shape.path/params
(s/nilable (s/map-of keyword? any?)))
(s/def :internal.shape.path/command-item
(s/keys :req-un [:internal.shape.path/command]
:opt-un [:internal.shape.path/params]))
(s/def :internal.shape.path/content
(s/coll-of :internal.shape.path/command-item :kind vector?))
(defmulti shape-spec :type)
(defmethod shape-spec :default [_]
(s/spec ::shape-attrs))
(defmethod shape-spec :text [_]
(s/and ::shape-attrs
(s/keys :opt-un [:internal.shape.text/content])))
(defmethod shape-spec :path [_]
(s/and ::shape-attrs
(s/keys :opt-un [:internal.shape.path/content])))
(defmethod shape-spec :frame [_]
(s/and ::shape-attrs
(s/keys :opt-un [::hide-fill-on-export])))
(s/def ::shape
(s/and (s/multi-spec shape-spec :type)
#(contains? % :type)
#(contains? % :name)))

38
common/src/app/common/spec/typography.cljc Normal file
View file

@ -0,0 +1,38 @@
;; 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.spec.typography
(:require
[clojure.spec.alpha :as s]))
(s/def ::id uuid?)
(s/def ::name string?)
(s/def ::path (s/nilable string?))
(s/def ::font-id string?)
(s/def ::font-family string?)
(s/def ::font-variant-id string?)
(s/def ::font-size string?)
(s/def ::font-weight string?)
(s/def ::font-style string?)
(s/def ::line-height string?)
(s/def ::letter-spacing string?)
(s/def ::text-transform string?)
(s/def ::typography
(s/keys :req-un [::id
::name
::font-id
::font-family
::font-variant-id
::font-size
::font-weight
::font-style
::line-height
::letter-spacing
::text-transform]
:opt-un [::path]))

95
common/src/app/common/types/page_options.cljc
View file

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

292
common/test/app/common/types_interactions_test.cljc → common/test/app/common/spec_interactions_test.cljc
View file

@ -4,68 +4,68 @@
;;
;; Copyright (c) UXBOX Labs SL
(ns app.common.types-interactions-test
(ns app.common.spec-interactions-test
(:require
[clojure.test :as t]
[clojure.pprint :refer [pprint]]
[app.common.exceptions :as ex]
[app.common.pages.init :as cpi]
[app.common.types.interactions :as cti]
[app.common.spec.interactions :as csi]
[app.common.uuid :as uuid]
[app.common.geom.point :as gpt]))
(t/deftest set-event-type
(let [interaction cti/default-interaction
(let [interaction csi/default-interaction
shape (cpi/make-minimal-shape :rect)
frame (cpi/make-minimal-shape :frame)]
(t/testing "Set event type unchanged"
(let [new-interaction
(cti/set-event-type interaction :click shape)]
(csi/set-event-type interaction :click shape)]
(t/is (= :click (:event-type new-interaction)))))
(t/testing "Set event type changed"
(let [new-interaction
(cti/set-event-type interaction :mouse-press shape)]
(csi/set-event-type interaction :mouse-press shape)]
(t/is (= :mouse-press (:event-type new-interaction)))))
(t/testing "Set after delay on non-frame"
(let [result (ex/try
(cti/set-event-type interaction :after-delay shape))]
(csi/set-event-type interaction :after-delay shape))]
(t/is (ex/exception? result))))
(t/testing "Set after delay on frame"
(let [new-interaction
(cti/set-event-type interaction :after-delay frame)]
(csi/set-event-type interaction :after-delay frame)]
(t/is (= :after-delay (:event-type new-interaction)))
(t/is (= 600 (:delay new-interaction)))))
(t/testing "Set after delay with previous data"
(let [interaction (assoc interaction :delay 300)
new-interaction
(cti/set-event-type interaction :after-delay frame)]
(csi/set-event-type interaction :after-delay frame)]
(t/is (= :after-delay (:event-type new-interaction)))
(t/is (= 300 (:delay new-interaction)))))))
(t/deftest set-action-type
(let [interaction cti/default-interaction]
(let [interaction csi/default-interaction]
(t/testing "Set action type unchanged"
(let [new-interaction
(cti/set-action-type interaction :navigate)]
(csi/set-action-type interaction :navigate)]
(t/is (= :navigate (:action-type new-interaction)))))
(t/testing "Set action type changed"
(let [new-interaction
(cti/set-action-type interaction :prev-screen)]
(csi/set-action-type interaction :prev-screen)]
(t/is (= :prev-screen (:action-type new-interaction)))))
(t/testing "Set action type navigate"
(let [interaction {:event-type :click
:action-type :prev-screen}
new-interaction
(cti/set-action-type interaction :navigate)]
(csi/set-action-type interaction :navigate)]
(t/is (= :navigate (:action-type new-interaction)))
(t/is (nil? (:destination new-interaction)))
(t/is (= false (:preserve-scroll new-interaction)))))
@ -77,14 +77,14 @@
:destination destination
:preserve-scroll true}
new-interaction
(cti/set-action-type interaction :navigate)]
(csi/set-action-type interaction :navigate)]
(t/is (= :navigate (:action-type new-interaction)))
(t/is (= destination (:destination new-interaction)))
(t/is (= true (:preserve-scroll new-interaction)))))
(t/testing "Set action type open-overlay"
(let [new-interaction
(cti/set-action-type interaction :open-overlay)]
(csi/set-action-type interaction :open-overlay)]
(t/is (= :open-overlay (:action-type new-interaction)))
(t/is (= :center (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))
@ -93,14 +93,14 @@
(let [interaction (assoc interaction :overlay-pos-type :top-left
:overlay-position (gpt/point 100 200))
new-interaction
(cti/set-action-type interaction :open-overlay)]
(csi/set-action-type interaction :open-overlay)]
(t/is (= :open-overlay (:action-type new-interaction)))
(t/is (= :top-left (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 100 200) (:overlay-position new-interaction)))))
(t/testing "Set action type toggle-overlay"
(let [new-interaction
(cti/set-action-type interaction :toggle-overlay)]
(csi/set-action-type interaction :toggle-overlay)]
(t/is (= :toggle-overlay (:action-type new-interaction)))
(t/is (= :center (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))
@ -109,14 +109,14 @@
(let [interaction (assoc interaction :overlay-pos-type :top-left
:overlay-position (gpt/point 100 200))
new-interaction
(cti/set-action-type interaction :toggle-overlay)]
(csi/set-action-type interaction :toggle-overlay)]
(t/is (= :toggle-overlay (:action-type new-interaction)))
(t/is (= :top-left (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 100 200) (:overlay-position new-interaction)))))
(t/testing "Set action type close-overlay"
(let [new-interaction
(cti/set-action-type interaction :close-overlay)]
(csi/set-action-type interaction :close-overlay)]
(t/is (= :close-overlay (:action-type new-interaction)))
(t/is (nil? (:destination new-interaction)))))
@ -124,89 +124,89 @@
(let [destination (uuid/next)
interaction (assoc interaction :destination destination)
new-interaction
(cti/set-action-type interaction :close-overlay)]
(csi/set-action-type interaction :close-overlay)]
(t/is (= :close-overlay (:action-type new-interaction)))
(t/is (= destination (:destination new-interaction)))))
(t/testing "Set action type prev-screen"
(let [new-interaction
(cti/set-action-type interaction :prev-screen)]
(csi/set-action-type interaction :prev-screen)]
(t/is (= :prev-screen (:action-type new-interaction)))))
(t/testing "Set action type open-url"
(let [new-interaction
(cti/set-action-type interaction :open-url)]
(csi/set-action-type interaction :open-url)]
(t/is (= :open-url (:action-type new-interaction)))
(t/is (= "" (:url new-interaction)))))
(t/testing "Set action type open-url with previous data"
(let [interaction (assoc interaction :url "https://example.com")
new-interaction
(cti/set-action-type interaction :open-url)]
(csi/set-action-type interaction :open-url)]
(t/is (= :open-url (:action-type new-interaction)))
(t/is (= "https://example.com" (:url new-interaction)))))))
(t/deftest option-delay
(let [frame (cpi/make-minimal-shape :frame)
i1 cti/default-interaction
i2 (cti/set-event-type i1 :after-delay frame)]
i1 csi/default-interaction
i2 (csi/set-event-type i1 :after-delay frame)]
(t/testing "Has delay"
(t/is (not (cti/has-delay i1)))
(t/is (cti/has-delay i2)))
(t/is (not (csi/has-delay i1)))
(t/is (csi/has-delay i2)))
(t/testing "Set delay"
(let [new-interaction (cti/set-delay i2 1000)]
(let [new-interaction (csi/set-delay i2 1000)]
(t/is (= 1000 (:delay new-interaction)))))))
(t/deftest option-destination
(let [destination (uuid/next)
i1 cti/default-interaction
i2 (cti/set-action-type i1 :prev-screen)
i3 (cti/set-action-type i1 :open-overlay)]
i1 csi/default-interaction
i2 (csi/set-action-type i1 :prev-screen)
i3 (csi/set-action-type i1 :open-overlay)]
(t/testing "Has destination"
(t/is (cti/has-destination i1))
(t/is (not (cti/has-destination i2))))
(t/is (csi/has-destination i1))
(t/is (not (csi/has-destination i2))))
(t/testing "Set destination"
(let [new-interaction (cti/set-destination i1 destination)]
(let [new-interaction (csi/set-destination i1 destination)]
(t/is (= destination (:destination new-interaction)))
(t/is (nil? (:overlay-pos-type new-interaction)))
(t/is (nil? (:overlay-position new-interaction)))))
(t/testing "Set destination of overlay"
(let [new-interaction (cti/set-destination i3 destination)]
(let [new-interaction (csi/set-destination i3 destination)]
(t/is (= destination (:destination new-interaction)))
(t/is (= :center (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))))
(t/deftest option-preserve-scroll
(let [i1 cti/default-interaction
i2 (cti/set-action-type i1 :prev-screen)]
(let [i1 csi/default-interaction
i2 (csi/set-action-type i1 :prev-screen)]
(t/testing "Has preserve-scroll"
(t/is (cti/has-preserve-scroll i1))
(t/is (not (cti/has-preserve-scroll i2))))
(t/is (csi/has-preserve-scroll i1))
(t/is (not (csi/has-preserve-scroll i2))))
(t/testing "Set preserve-scroll"
(let [new-interaction (cti/set-preserve-scroll i1 true)]
(let [new-interaction (csi/set-preserve-scroll i1 true)]
(t/is (= true (:preserve-scroll new-interaction)))))))
(t/deftest option-url
(let [i1 cti/default-interaction
i2 (cti/set-action-type i1 :open-url)]
(let [i1 csi/default-interaction
i2 (csi/set-action-type i1 :open-url)]
(t/testing "Has url"
(t/is (not (cti/has-url i1)))
(t/is (cti/has-url i2)))
(t/is (not (csi/has-url i1)))
(t/is (csi/has-url i2)))
(t/testing "Set url"
(let [new-interaction (cti/set-url i2 "https://example.com")]
(let [new-interaction (csi/set-url i2 "https://example.com")]
(t/is (= "https://example.com" (:url new-interaction)))))))
@ -220,35 +220,35 @@
objects {(:id base-frame) base-frame
(:id overlay-frame) overlay-frame}
i1 cti/default-interaction
i2 (cti/set-action-type i1 :open-overlay)
i1 csi/default-interaction
i2 (csi/set-action-type i1 :open-overlay)
i3 (-> i1
(cti/set-action-type :open-overlay)
(cti/set-destination (:id overlay-frame)))]
(csi/set-action-type :open-overlay)
(csi/set-destination (:id overlay-frame)))]
(t/testing "Has overlay options"
(t/is (not (cti/has-overlay-opts i1)))
(t/is (cti/has-overlay-opts i2)))
(t/is (not (csi/has-overlay-opts i1)))
(t/is (csi/has-overlay-opts i2)))
(t/testing "Set overlay-pos-type without destination"
(let [new-interaction (cti/set-overlay-pos-type i2 :top-right base-frame objects)]
(let [new-interaction (csi/set-overlay-pos-type i2 :top-right base-frame objects)]
(t/is (= :top-right (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))
(t/testing "Set overlay-pos-type with destination and auto"
(let [new-interaction (cti/set-overlay-pos-type i3 :bottom-right base-frame objects)]
(let [new-interaction (csi/set-overlay-pos-type i3 :bottom-right base-frame objects)]
(t/is (= :bottom-right (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 0 0) (:overlay-position new-interaction)))))
(t/testing "Set overlay-pos-type with destination and manual"
(let [new-interaction (cti/set-overlay-pos-type i3 :manual base-frame objects)]
(let [new-interaction (csi/set-overlay-pos-type i3 :manual base-frame objects)]
(t/is (= :manual (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 35 40) (:overlay-position new-interaction)))))
(t/testing "Toggle overlay-pos-type"
(let [new-interaction (cti/toggle-overlay-pos-type i3 :center base-frame objects)
new-interaction-2 (cti/toggle-overlay-pos-type new-interaction :center base-frame objects)
new-interaction-3 (cti/toggle-overlay-pos-type new-interaction-2 :top-right base-frame objects)]
(let [new-interaction (csi/toggle-overlay-pos-type i3 :center base-frame objects)
new-interaction-2 (csi/toggle-overlay-pos-type new-interaction :center base-frame objects)
new-interaction-3 (csi/toggle-overlay-pos-type new-interaction-2 :top-right base-frame objects)]
(t/is (= :manual (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 35 40) (:overlay-position new-interaction)))
(t/is (= :center (:overlay-pos-type new-interaction-2)))
@ -257,73 +257,73 @@
(t/is (= (gpt/point 0 0) (:overlay-position new-interaction-3)))))
(t/testing "Set overlay-position"
(let [new-interaction (cti/set-overlay-position i3 (gpt/point 50 60))]
(let [new-interaction (csi/set-overlay-position i3 (gpt/point 50 60))]
(t/is (= :manual (:overlay-pos-type new-interaction)))
(t/is (= (gpt/point 50 60) (:overlay-position new-interaction)))))
(t/testing "Set close-click-outside"
(let [new-interaction (cti/set-close-click-outside i3 true)]
(let [new-interaction (csi/set-close-click-outside i3 true)]
(t/is (not (:close-click-outside i3)))
(t/is (:close-click-outside new-interaction))))
(t/testing "Set background-overlay"
(let [new-interaction (cti/set-background-overlay i3 true)]
(let [new-interaction (csi/set-background-overlay i3 true)]
(t/is (not (:background-overlay i3)))
(t/is (:background-overlay new-interaction))))))
(t/deftest animation-checks
(let [i1 cti/default-interaction
i2 (cti/set-action-type i1 :open-overlay)
i3 (cti/set-action-type i1 :toggle-overlay)
i4 (cti/set-action-type i1 :close-overlay)
i5 (cti/set-action-type i1 :prev-screen)
i6 (cti/set-action-type i1 :open-url)]
(let [i1 csi/default-interaction
i2 (csi/set-action-type i1 :open-overlay)
i3 (csi/set-action-type i1 :toggle-overlay)
i4 (csi/set-action-type i1 :close-overlay)
i5 (csi/set-action-type i1 :prev-screen)
i6 (csi/set-action-type i1 :open-url)]
(t/testing "Has animation?"
(t/is (cti/has-animation? i1))
(t/is (cti/has-animation? i2))
(t/is (cti/has-animation? i3))
(t/is (cti/has-animation? i4))
(t/is (not (cti/has-animation? i5)))
(t/is (not (cti/has-animation? i6))))
(t/is (csi/has-animation? i1))
(t/is (csi/has-animation? i2))
(t/is (csi/has-animation? i3))
(t/is (csi/has-animation? i4))
(t/is (not (csi/has-animation? i5)))
(t/is (not (csi/has-animation? i6))))
(t/testing "Valid push?"
(t/is (cti/allow-push? (:action-type i1)))
(t/is (not (cti/allow-push? (:action-type i2))))
(t/is (not (cti/allow-push? (:action-type i3))))
(t/is (not (cti/allow-push? (:action-type i4))))
(t/is (not (cti/allow-push? (:action-type i5))))
(t/is (not (cti/allow-push? (:action-type i6)))))))
(t/is (csi/allow-push? (:action-type i1)))
(t/is (not (csi/allow-push? (:action-type i2))))
(t/is (not (csi/allow-push? (:action-type i3))))
(t/is (not (csi/allow-push? (:action-type i4))))
(t/is (not (csi/allow-push? (:action-type i5))))
(t/is (not (csi/allow-push? (:action-type i6)))))))
(t/deftest set-animation-type
(let [i1 cti/default-interaction
i2 (cti/set-animation-type i1 :dissolve)]
(let [i1 csi/default-interaction
i2 (csi/set-animation-type i1 :dissolve)]
(t/testing "Set animation type nil"
(let [new-interaction
(cti/set-animation-type i1 nil)]
(csi/set-animation-type i1 nil)]
(t/is (nil? (-> new-interaction :animation :animation-type)))))
(t/testing "Set animation type unchanged"
(let [new-interaction
(cti/set-animation-type i2 :dissolve)]
(csi/set-animation-type i2 :dissolve)]
(t/is (= :dissolve (-> new-interaction :animation :animation-type)))))
(t/testing "Set animation type changed"
(let [new-interaction
(cti/set-animation-type i2 :slide)]
(csi/set-animation-type i2 :slide)]
(t/is (= :slide (-> new-interaction :animation :animation-type)))))
(t/testing "Set animation type reset"
(let [new-interaction
(cti/set-animation-type i2 nil)]
(csi/set-animation-type i2 nil)]
(t/is (nil? (-> new-interaction :animation)))))
(t/testing "Set animation type dissolve"
(let [new-interaction
(cti/set-animation-type i1 :dissolve)]
(csi/set-animation-type i1 :dissolve)]
(t/is (= :dissolve (-> new-interaction :animation :animation-type)))
(t/is (= 300 (-> new-interaction :animation :duration)))
(t/is (= :linear (-> new-interaction :animation :easing)))))
@ -336,14 +336,14 @@
:direction :left
:offset-effect true})
new-interaction
(cti/set-animation-type interaction :dissolve)]
(csi/set-animation-type interaction :dissolve)]
(t/is (= :dissolve (-> new-interaction :animation :animation-type)))
(t/is (= 1000 (-> new-interaction :animation :duration)))
(t/is (= :ease-out (-> new-interaction :animation :easing)))))
(t/testing "Set animation type slide"
(let [new-interaction
(cti/set-animation-type i1 :slide)]
(csi/set-animation-type i1 :slide)]
(t/is (= :slide (-> new-interaction :animation :animation-type)))
(t/is (= 300 (-> new-interaction :animation :duration)))
(t/is (= :linear (-> new-interaction :animation :easing)))
@ -359,7 +359,7 @@
:direction :left
:offset-effect true})
new-interaction
(cti/set-animation-type interaction :slide)]
(csi/set-animation-type interaction :slide)]
(t/is (= :slide (-> new-interaction :animation :animation-type)))
(t/is (= 1000 (-> new-interaction :animation :duration)))
(t/is (= :ease-out (-> new-interaction :animation :easing)))
@ -369,7 +369,7 @@
(t/testing "Set animation type push"
(let [new-interaction
(cti/set-animation-type i1 :push)]
(csi/set-animation-type i1 :push)]
(t/is (= :push (-> new-interaction :animation :animation-type)))
(t/is (= 300 (-> new-interaction :animation :duration)))
(t/is (= :linear (-> new-interaction :animation :easing)))
@ -383,7 +383,7 @@
:direction :left
:offset-effect true})
new-interaction
(cti/set-animation-type interaction :push)]
(csi/set-animation-type interaction :push)]
(t/is (= :push (-> new-interaction :animation :animation-type)))
(t/is (= 1000 (-> new-interaction :animation :duration)))
(t/is (= :ease-out (-> new-interaction :animation :easing)))
@ -391,9 +391,9 @@
(t/deftest allowed-animation
(let [i1 (cti/set-action-type cti/default-interaction :open-overlay)
i2 (cti/set-action-type cti/default-interaction :close-overlay)
i3 (cti/set-action-type cti/default-interaction :toggle-overlay)]
(let [i1 (csi/set-action-type csi/default-interaction :open-overlay)
i2 (csi/set-action-type csi/default-interaction :close-overlay)
i3 (csi/set-action-type csi/default-interaction :toggle-overlay)]
(t/testing "Cannot use animation push for an overlay action"
(let [bad-interaction-1 (assoc i1 :animation {:animation-type :push
@ -408,72 +408,72 @@
:duration 1000
:easing :ease-out
:direction :left})]
(t/is (not (cti/allowed-animation? (:action-type bad-interaction-1)
(t/is (not (csi/allowed-animation? (:action-type bad-interaction-1)
(-> bad-interaction-1 :animation :animation-type))))
(t/is (not (cti/allowed-animation? (:action-type bad-interaction-2)
(t/is (not (csi/allowed-animation? (:action-type bad-interaction-2)
(-> bad-interaction-1 :animation :animation-type))))
(t/is (not (cti/allowed-animation? (:action-type bad-interaction-3)
(t/is (not (csi/allowed-animation? (:action-type bad-interaction-3)
(-> bad-interaction-1 :animation :animation-type))))))
(t/testing "Remove animation if moving to an forbidden state"
(let [interaction (cti/set-animation-type cti/default-interaction :push)
new-interaction (cti/set-action-type interaction :open-overlay)]
(let [interaction (csi/set-animation-type csi/default-interaction :push)
new-interaction (csi/set-action-type interaction :open-overlay)]
(t/is (nil? (:animation new-interaction)))))))
(t/deftest option-duration
(let [i1 cti/default-interaction
i2 (cti/set-animation-type cti/default-interaction :dissolve)]
(let [i1 csi/default-interaction
i2 (csi/set-animation-type csi/default-interaction :dissolve)]
(t/testing "Has duration?"
(t/is (not (cti/has-duration? i1)))
(t/is (cti/has-duration? i2)))
(t/is (not (csi/has-duration? i1)))
(t/is (csi/has-duration? i2)))
(t/testing "Set duration"
(let [new-interaction (cti/set-duration i2 1000)]
(let [new-interaction (csi/set-duration i2 1000)]
(t/is (= 1000 (-> new-interaction :animation :duration)))))))
(t/deftest option-easing
(let [i1 cti/default-interaction
i2 (cti/set-animation-type cti/default-interaction :dissolve)]
(let [i1 csi/default-interaction
i2 (csi/set-animation-type csi/default-interaction :dissolve)]
(t/testing "Has easing?"
(t/is (not (cti/has-easing? i1)))
(t/is (cti/has-easing? i2)))
(t/is (not (csi/has-easing? i1)))
(t/is (csi/has-easing? i2)))
(t/testing "Set easing"
(let [new-interaction (cti/set-easing i2 :ease-in)]
(let [new-interaction (csi/set-easing i2 :ease-in)]
(t/is (= :ease-in (-> new-interaction :animation :easing)))))))
(t/deftest option-way
(let [i1 cti/default-interaction
i2 (cti/set-animation-type cti/default-interaction :slide)
i3 (cti/set-action-type i2 :open-overlay)]
(let [i1 csi/default-interaction
i2 (csi/set-animation-type csi/default-interaction :slide)
i3 (csi/set-action-type i2 :open-overlay)]
(t/testing "Has way?"
(t/is (not (cti/has-way? i1)))
(t/is (cti/has-way? i2))
(t/is (not (cti/has-way? i3)))
(t/is (not (csi/has-way? i1)))
(t/is (csi/has-way? i2))
(t/is (not (csi/has-way? i3)))
(t/is (some? (-> i3 :animation :way)))) ; <- it exists but is ignored
(t/testing "Set way"
(let [new-interaction (cti/set-way i2 :out)]
(let [new-interaction (csi/set-way i2 :out)]
(t/is (= :out (-> new-interaction :animation :way)))))))
(t/deftest option-direction
(let [i1 cti/default-interaction
i2 (cti/set-animation-type cti/default-interaction :push)
i3 (cti/set-animation-type cti/default-interaction :dissolve)]
(let [i1 csi/default-interaction
i2 (csi/set-animation-type csi/default-interaction :push)
i3 (csi/set-animation-type csi/default-interaction :dissolve)]
(t/testing "Has direction?"
(t/is (not (cti/has-direction? i1)))
(t/is (cti/has-direction? i2)))
(t/is (not (csi/has-direction? i1)))
(t/is (csi/has-direction? i2)))
(t/testing "Set direction"
(let [new-interaction (cti/set-direction i2 :left)]
(let [new-interaction (csi/set-direction i2 :left)]
(t/is (= :left (-> new-interaction :animation :direction)))))
(t/testing "Invert direction"
@ -483,12 +483,12 @@
a-up (assoc a-right :direction :up)
a-down (assoc a-right :direction :down)
a-nil' (cti/invert-direction nil)
a-none' (cti/invert-direction a-none)
a-right' (cti/invert-direction a-right)
a-left' (cti/invert-direction a-left)
a-up' (cti/invert-direction a-up)
a-down' (cti/invert-direction a-down)]
a-nil' (csi/invert-direction nil)
a-none' (csi/invert-direction a-none)
a-right' (csi/invert-direction a-right)
a-left' (csi/invert-direction a-left)
a-up' (csi/invert-direction a-up)
a-down' (csi/invert-direction a-down)]
(t/is (nil? a-nil'))
(t/is (nil? (:direction a-none')))
@ -499,44 +499,44 @@
(t/deftest option-offset-effect
(let [i1 cti/default-interaction
i2 (cti/set-animation-type cti/default-interaction :slide)
i3 (cti/set-action-type i2 :open-overlay)]
(let [i1 csi/default-interaction
i2 (csi/set-animation-type csi/default-interaction :slide)
i3 (csi/set-action-type i2 :open-overlay)]
(t/testing "Has offset-effect"
(t/is (not (cti/has-offset-effect? i1)))
(t/is (cti/has-offset-effect? i2))
(t/is (not (cti/has-offset-effect? i3)))
(t/is (not (csi/has-offset-effect? i1)))
(t/is (csi/has-offset-effect? i2))
(t/is (not (csi/has-offset-effect? i3)))
(t/is (some? (-> i3 :animation :offset-effect)))) ; <- it exists but is ignored
(t/testing "Set offset-effect"
(let [new-interaction (cti/set-offset-effect i2 true)]
(let [new-interaction (csi/set-offset-effect i2 true)]
(t/is (= true (-> new-interaction :animation :offset-effect)))))))
(t/deftest modify-interactions
(let [i1 (cti/set-action-type cti/default-interaction :open-overlay)
i2 (cti/set-action-type cti/default-interaction :close-overlay)
i3 (cti/set-action-type cti/default-interaction :prev-screen)
(let [i1 (csi/set-action-type csi/default-interaction :open-overlay)
i2 (csi/set-action-type csi/default-interaction :close-overlay)
i3 (csi/set-action-type csi/default-interaction :prev-screen)
interactions [i1 i2]]
(t/testing "Add interaction to nil"
(let [new-interactions (cti/add-interaction nil i3)]
(let [new-interactions (csi/add-interaction nil i3)]
(t/is (= (count new-interactions) 1))
(t/is (= (:action-type (last new-interactions)) :prev-screen))))
(t/testing "Add interaction to normal"
(let [new-interactions (cti/add-interaction interactions i3)]
(let [new-interactions (csi/add-interaction interactions i3)]
(t/is (= (count new-interactions) 3))
(t/is (= (:action-type (last new-interactions)) :prev-screen))))
(t/testing "Remove interaction"
(let [new-interactions (cti/remove-interaction interactions 0)]
(let [new-interactions (csi/remove-interaction interactions 0)]
(t/is (= (count new-interactions) 1))
(t/is (= (:action-type (last new-interactions)) :close-overlay))))
(t/testing "Update interaction"
(let [new-interactions (cti/update-interaction interactions 1 #(cti/set-action-type % :open-url))]
(let [new-interactions (csi/update-interaction interactions 1 #(csi/set-action-type % :open-url))]
(t/is (= (count new-interactions) 2))
(t/is (= (:action-type (last new-interactions)) :open-url))))))
@ -556,16 +556,16 @@
ids-map {(:id frame1) (:id frame4)
(:id frame2) (:id frame5)}
i1 (cti/set-destination cti/default-interaction (:id frame1))
i2 (cti/set-destination cti/default-interaction (:id frame2))
i3 (cti/set-destination cti/default-interaction (:id frame3))
i4 (cti/set-destination cti/default-interaction nil)
i5 (cti/set-destination cti/default-interaction (:id frame6))
i1 (csi/set-destination csi/default-interaction (:id frame1))
i2 (csi/set-destination csi/default-interaction (:id frame2))
i3 (csi/set-destination csi/default-interaction (:id frame3))
i4 (csi/set-destination csi/default-interaction nil)
i5 (csi/set-destination csi/default-interaction (:id frame6))
interactions [i1 i2 i3 i4 i5]]
(t/testing "Remap interactions"
(let [new-interactions (cti/remap-interactions interactions ids-map objects)]
(let [new-interactions (csi/remap-interactions interactions ids-map objects)]
(t/is (= (count new-interactions) 4))
(t/is (= (:id frame4) (:destination (get new-interactions 0))))
(t/is (= (:id frame5) (:destination (get new-interactions 1))))

8
common/yarn.lock
View file

@ -533,10 +533,10 @@ shadow-cljs-jar@1.3.2:
resolved "https://registry.yarnpkg.com/shadow-cljs-jar/-/shadow-cljs-jar-1.3.2.tgz#97273afe1747b6a2311917c1c88d9e243c81957b"
integrity sha512-XmeffAZHv8z7451kzeq9oKh8fh278Ak+UIOGGrapyqrFBB773xN8vMQ3O7J7TYLnb9BUwcqadKkmgaq7q6fhZg==
shadow-cljs@2.16.12:
version "2.16.12"
resolved "https://registry.yarnpkg.com/shadow-cljs/-/shadow-cljs-2.16.12.tgz#8757b3079dadfff15ca09192f81eb69b5d25266d"
integrity sha512-6JqOhN5X3n0IkxA/gSUcZ1lImwcW1LmpgzlaBDOC/u/pIysdNm0tiOxpOTEnExl9nKZBS/EYS7bXIIInywPJUA==
shadow-cljs@2.17.3:
version "2.17.3"
resolved "https://registry.yarnpkg.com/shadow-cljs/-/shadow-cljs-2.17.3.tgz#748e31f67cffdc401691c0cd1bf733a1da53ab5d"
integrity sha512-GxyczUuCtACq/uEOvdTc61wT/aDOZFy8G/AGc322uTX/oUiZaeTJrwpClXe+0+e7VKG9E9RCqP/cjuG3cAG0fw==
dependencies:
node-libs-browser "^2.2.1"
readline-sync "^1.4.7"

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

@ -10,6 +10,7 @@ networks:
volumes:
postgres_data:
user_data:
minio_data:
services:
main:
@ -66,6 +67,22 @@ services:
- PENPOT_LDAP_ATTRS_FULLNAME=cn
- PENPOT_LDAP_ATTRS_PHOTO=jpegPhoto
minio:
profiles: ["full"]
image: "minio/minio:latest"
command: minio server /mnt/data --console-address ":9001"
volumes:
- "minio_data:/mnt/data"
environment:
- MINIO_ROOT_USER=minioadmin
- MINIO_ROOT_PASSWORD=minioadmin
ports:
- 9000:9000
- 9001:9001
backend:
profiles: ["backend"]
privileged: true
@ -91,6 +108,7 @@ services:
environment:
- EXTERNAL_UID=${CURRENT_USER_ID}
- PENPOT_SECRET_KEY=super-secret-devenv-key
# SMTP setup
- PENPOT_SMTP_ENABLED=true
- PENPOT_SMTP_DEFAULT_FROM=no-reply@example.com

2
exporter/deps.edn
View file

@ -14,7 +14,7 @@
:dev
{:extra-deps
{thheller/shadow-cljs {:mvn/version "2.16.12"}}}
{thheller/shadow-cljs {:mvn/version "2.17.3"}}}
:shadow-cljs
{:main-opts ["-m" "shadow.cljs.devtools.cli"]}

2
exporter/package.json
View file

@ -22,7 +22,7 @@
"xregexp": "^5.0.2"
},
"devDependencies": {
"shadow-cljs": "^2.16.12",
"shadow-cljs": "^2.17.3",
"source-map-support": "^0.5.21"
}
}

8
exporter/yarn.lock
View file

@ -1010,10 +1010,10 @@ shadow-cljs-jar@1.3.2:
resolved "https://registry.yarnpkg.com/shadow-cljs-jar/-/shadow-cljs-jar-1.3.2.tgz#97273afe1747b6a2311917c1c88d9e243c81957b"
integrity sha512-XmeffAZHv8z7451kzeq9oKh8fh278Ak+UIOGGrapyqrFBB773xN8vMQ3O7J7TYLnb9BUwcqadKkmgaq7q6fhZg==
shadow-cljs@^2.16.12:
version "2.16.12"
resolved "https://registry.yarnpkg.com/shadow-cljs/-/shadow-cljs-2.16.12.tgz#8757b3079dadfff15ca09192f81eb69b5d25266d"
integrity sha512-6JqOhN5X3n0IkxA/gSUcZ1lImwcW1LmpgzlaBDOC/u/pIysdNm0tiOxpOTEnExl9nKZBS/EYS7bXIIInywPJUA==
shadow-cljs@^2.17.3:
version "2.17.3"
resolved "https://registry.yarnpkg.com/shadow-cljs/-/shadow-cljs-2.17.3.tgz#748e31f67cffdc401691c0cd1bf733a1da53ab5d"
integrity sha512-GxyczUuCtACq/uEOvdTc61wT/aDOZFy8G/AGc322uTX/oUiZaeTJrwpClXe+0+e7VKG9E9RCqP/cjuG3cAG0fw==
dependencies:
node-libs-browser "^2.2.1"
readline-sync "^1.4.7"

5
frontend/cypress.json
View file

@ -1 +1,4 @@
{}
{
"watchForFileChanges": false,
"video": false
}

BIN
frontend/cypress/fixtures/fonts/Viafont.otf Normal file
View file

Binary file not shown.

BIN
frontend/cypress/fixtures/fonts/blkchcry.ttf Normal file
View file

Binary file not shown.

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