Penpot/penpot
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-03-20 11:41:47 -05:00
Code Issues Activity

Merge branch 'niwinz-enhancements' into develop

Browse source
This commit is contained in:
Andrey Antukh 2022-11-07 16:57:35 +01:00
commit 67fc499001
60 changed files with 1150 additions and 919 deletions

2
.circleci/config.yml
View file

@ -94,7 +94,7 @@ jobs:
working_directory: "./common"
name: common tests (clj)
command: |
clojure -X:dev:test
clojure -X:dev:test :patterns '["common-tests.test-.*"]'
environment:
PATH: /usr/local/nodejs/bin/:/usr/local/bin:/bin:/usr/bin

12
backend/deps.edn
View file

@ -16,19 +16,18 @@
:exclusions [org.eclipse.jetty/jetty-server
org.eclipse.jetty/jetty-servlet]}
io.prometheus/simpleclient_httpserver {:mvn/version "0.16.0"}
io.lettuce/lettuce-core {:mvn/version "6.2.0.RELEASE"}
io.lettuce/lettuce-core {:mvn/version "6.2.1.RELEASE"}
java-http-clj/java-http-clj {:mvn/version "0.4.3"}
funcool/yetti
{:git/tag "v9.9"
:git/sha "f0a455d"
{:git/tag "v9.10"
:git/sha "9744349"
:git/url "https://github.com/funcool/yetti.git"
:exclusions [org.slf4j/slf4j-api]}
com.github.seancorfield/next.jdbc {:mvn/version "1.3.828"}
com.github.seancorfield/next.jdbc {:mvn/version "1.3.834"}
metosin/reitit-core {:mvn/version "0.5.18"}
org.postgresql/postgresql {:mvn/version "42.5.0"}
com.zaxxer/HikariCP {:mvn/version "5.0.1"}
@ -38,6 +37,8 @@
buddy/buddy-hashers {:mvn/version "1.8.158"}
buddy/buddy-sign {:mvn/version "3.4.333"}
com.github.ben-manes.caffeine/caffeine {:mvn/version "3.1.1"}
org.jsoup/jsoup {:mvn/version "1.15.1"}
org.im4java/im4java
{:git/tag "1.4.0-penpot-2"
@ -62,7 +63,6 @@
{:extra-deps
{com.bhauman/rebel-readline {:mvn/version "RELEASE"}
org.clojure/tools.namespace {:mvn/version "RELEASE"}
org.clojure/test.check {:mvn/version "RELEASE"}
clojure-humanize/clojure-humanize {:mvn/version "0.2.2"}
org.clojure/data.csv {:mvn/version "RELEASE"}
com.clojure-goes-fast/clj-async-profiler {:mvn/version "RELEASE"}

2
backend/dev/user.clj
View file

@ -29,8 +29,8 @@
[clojure.pprint :refer [pprint print-table]]
[clojure.repl :refer :all]
[clojure.spec.alpha :as s]
[clojure.spec.gen.alpha :as sgen]
[clojure.test :as test]
[clojure.test.check.generators :as gen]
[clojure.tools.namespace.repl :as repl]
[clojure.walk :refer [macroexpand-all]]
[criterium.core :as crit]

3
backend/resources/app/templates/error-list.tmpl
View file

@ -11,7 +11,8 @@ penpot - error list
<main class="horizontal-list">
<ul>
{% for item in items %}
<li><a href="/dbg/error/{{item.id}}">{{item.created-at}}</a></li>
<li><a class="date" href="/dbg/error/{{item.id}}">{{item.created-at}}</a>
<span class="title">{{item.hint|abbreviate:150}}</span></li>
{% endfor %}
</ul>
</main>

16
backend/resources/app/templates/styles.css
View file

@ -137,8 +137,6 @@ nav > div:not(:last-child) {
margin: 0px;
padding: 0px;
flex-direction: column;
flex-wrap: wrap;
height: calc(100vh - 75px);
justify-content: flex-start;
}
@ -151,19 +149,31 @@ nav > div:not(:last-child) {
margin: 0px 20px;
cursor: pointer;
display: flex;
justify-content: center;
border-radius: 3px;
}
.horizontal-list li:hover {
background-color: #e9e9e9;
}
.horizontal-list li > *:not(:last-child) {
margin-right: 10px;
}
.horizontal-list li > a {
text-decoration: none;
color: inherit;
}
.horizontal-list li > .date {
font-weight: 200;
color: #686868;
min-width: 210px;
}
form .row {
padding: 5px 0;
}

7
backend/resources/climit.edn Normal file
View file

@ -0,0 +1,7 @@
;; Example climit.edn file
;; Required: concurrency
;; Optional: queue-size, ommited means Integer/MAX_VALUE
{:update-file {:concurrency 1 :queue-size 3}
:auth {:concurrency 128}
:process-font {:concurrency 4 :queue-size 32}
:process-image {:concurrency 8 :queue-size 32}}

1
backend/resources/log4j2-devenv.xml
View file

@ -32,6 +32,7 @@
<Logger name="app.util.websocket" level="info" />
<Logger name="app.redis" level="info" />
<Logger name="app.rpc.rlimit" level="info" />
<Logger name="app.rpc.climit" level="info" />
<Logger name="app.rpc.mutations.files" level="info" />
<Logger name="app.cli" level="debug" additivity="false">

4
backend/resources/rlimit.edn
View file

@ -1,6 +1,10 @@
;; Example rlimit.edn file
^{:refresh "30s"}
{:default
[[:default :window "200000/h"]]
#{:query/teams}
[[:burst :bucket "5/1/5s"]]
#{:query/profile}
[[:burst :bucket "100/60/1m"]]}

6
backend/scripts/repl
View file

@ -2,7 +2,7 @@
export PENPOT_HOST=devenv
export PENPOT_TENANT=dev
export PENPOT_FLAGS="$PENPOT_FLAGS enable-backend-asserts enable-audit-log enable-transit-readable-response enable-demo-users disable-secure-session-cookies enable-rpc-rate-limit enable-warn-rpc-rate-limits enable-smtp"
export PENPOT_FLAGS="$PENPOT_FLAGS enable-backend-asserts enable-audit-log enable-transit-readable-response enable-demo-users disable-secure-session-cookies enable-smtp"
# export PENPOT_DATABASE_URI="postgresql://172.17.0.1:5432/penpot"
# export PENPOT_DATABASE_USERNAME="penpot"
@ -16,8 +16,6 @@ export PENPOT_FLAGS="$PENPOT_FLAGS enable-backend-asserts enable-audit-log enabl
# export PENPOT_LOGGERS_LOKI_URI="http://172.17.0.1:3100/loki/api/v1/push"
# export PENPOT_AUDIT_LOG_ARCHIVE_URI="http://localhost:6070/api/audit"
export PENPOT_DEFAULT_RATE_LIMIT="default,window,10000/h"
# Initialize MINIO config
mc alias set penpot-s3/ http://minio:9000 minioadmin minioadmin
mc admin user add penpot-s3 penpot-devenv penpot-devenv
@ -31,7 +29,7 @@ export PENPOT_STORAGE_ASSETS_S3_ENDPOINT=http://minio:9000
export PENPOT_STORAGE_ASSETS_S3_BUCKET=penpot
export OPTIONS="
-A:dev:jmx-remote \
-A:jmx-remote -A:dev \
-J-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager \
-J-Dlog4j2.configurationFile=log4j2-devenv.xml \
-J-XX:+UseG1GC \

6
backend/src/app/auth/oidc.clj
View file

@ -17,6 +17,7 @@
[app.db :as db]
[app.http.client :as http]
[app.http.middleware :as hmw]
[app.http.session :as session]
[app.loggers.audit :as audit]
[app.rpc.queries.profile :as profile]
[app.tokens :as tokens]
@ -423,7 +424,7 @@
(defn- generate-redirect
[{:keys [sprops session audit] :as cfg} request info profile]
(if profile
(let [sxf ((:create session) (:id profile))
(let [sxf (session/create-fn session (:id profile))
token (or (:invitation-token info)
(tokens/generate sprops {:iss :auth
:exp (dt/in-future "15m")
@ -502,14 +503,13 @@
(s/def ::public-uri ::us/not-empty-string)
(s/def ::http-client ::http/client)
(s/def ::session map?)
(s/def ::sprops map?)
(s/def ::providers map?)
(defmethod ig/pre-init-spec ::routes
[_]
(s/keys :req-un [::public-uri
::session
::session/session
::sprops
::http-client
::providers

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

@ -52,7 +52,9 @@
:default-blob-version 5
:loggers-zmq-uri "tcp://localhost:45556"
:rpc-rlimit-config (fs/path "resources/rlimit.edn")
:rpc-climit-config (fs/path "resources/climit.edn")
:file-change-snapshot-every 5
:file-change-snapshot-timeout "3h"
@ -90,6 +92,7 @@
(s/def ::default-rpc-rlimit ::us/vector-of-strings)
(s/def ::rpc-rlimit-config ::fs/path)
(s/def ::rpc-climit-config ::fs/path)
(s/def ::media-max-file-size ::us/integer)
@ -172,11 +175,6 @@
(s/def ::redis-uri ::us/string)
(s/def ::registration-domain-whitelist ::us/set-of-strings)
(s/def ::semaphore-process-font ::us/integer)
(s/def ::semaphore-process-image ::us/integer)
(s/def ::semaphore-update-file ::us/integer)
(s/def ::semaphore-auth ::us/integer)
(s/def ::smtp-default-from ::us/string)
(s/def ::smtp-default-reply-to ::us/string)
(s/def ::smtp-host ::us/string)

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

@ -11,6 +11,7 @@
[app.common.transit :as t]
[app.http.errors :as errors]
[app.http.middleware :as mw]
[app.http.session :as session]
[app.metrics :as mtx]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
@ -123,7 +124,7 @@
(s/def ::oauth map?)
(s/def ::oidc-routes (s/nilable vector?))
(s/def ::rpc-routes (s/nilable vector?))
(s/def ::session map?)
(s/def ::session ::session/session)
(s/def ::storage map?)
(s/def ::ws fn?)
@ -148,13 +149,14 @@
[mw/format-response]
[mw/params]
[mw/parse-request]
[session/middleware-1 session]
[mw/errors errors/handle]
[mw/restrict-methods]]}
["/metrics" {:handler (::mtx/handler metrics)
:allowed-methods #{:get}}]
["/assets" {:middleware [(:middleware session)]}
["/assets" {:middleware [[session/middleware-2 session]]}
["/by-id/:id" {:handler (:objects-handler assets)}]
["/by-file-media-id/:id" {:handler (:file-objects-handler assets)}]
["/by-file-media-id/:id/thumbnail" {:handler (:file-thumbnails-handler assets)}]]
@ -165,12 +167,12 @@
["/sns" {:handler (:awsns-handler cfg)
:allowed-methods #{:post}}]]
["/ws/notifications" {:middleware [(:middleware session)]
["/ws/notifications" {:middleware [[session/middleware-2 session]]
:handler ws
:allowed-methods #{:get}}]
["/api" {:middleware [[mw/cors]
[(:middleware session)]]}
[session/middleware-2 session]]}
["/audit/events" {:handler (:audit-handler cfg)
:allowed-methods #{:post}}]
["/feedback" {:handler feedback

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

@ -14,6 +14,7 @@
[app.config :as cf]
[app.db :as db]
[app.http.middleware :as mw]
[app.http.session :as session]
[app.rpc.commands.binfile :as binf]
[app.rpc.mutations.files :refer [create-file]]
[app.rpc.queries.profile :as profile]
@ -243,15 +244,19 @@
(yrs/response 404 "not found")))))
(def sql:error-reports
"select id, created_at from server_error_report order by created_at desc limit 100")
"SELECT id, created_at,
content->>'~:hint' AS hint
FROM server_error_report
ORDER BY created_at DESC
LIMIT 100")
(defn error-list-handler
[{:keys [pool]} request]
(when-not (authorized? pool request)
(ex/raise :type :authentication
:code :only-admins-allowed))
(let [items (db/exec! pool [sql:error-reports])
items (map #(update % :created-at dt/format-instant :rfc1123) items)]
(let [items (->> (db/exec! pool [sql:error-reports])
(map #(update % :created-at dt/format-instant :rfc1123)))]
(yrs/response :status 200
:body (-> (io/resource "app/templates/error-list.tmpl")
(tmpl/render {:items items}))
@ -377,17 +382,15 @@
:code :only-admins-allowed))))))})
(s/def ::session map?)
(defmethod ig/pre-init-spec ::routes [_]
(s/keys :req-un [::db/pool ::wrk/executor ::session]))
(s/keys :req-un [::db/pool ::wrk/executor ::session/session]))
(defmethod ig/init-key ::routes
[_ {:keys [session pool executor] :as cfg}]
[["/readyz" {:middleware [[mw/with-dispatch executor]
[mw/with-config cfg]]
:handler health-handler}]
["/dbg" {:middleware [[(:middleware session)]
["/dbg" {:middleware [[session/middleware-2 session]
[with-authorization pool]
[mw/with-dispatch executor]
[mw/with-config cfg]]}

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

@ -7,6 +7,7 @@
(ns app.http.errors
"A errors handling for the http server."
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
@ -26,16 +27,18 @@
(defn get-context
[request]
(merge
*context*
{:path (:path request)
:method (:method request)
:params (:params request)
:ip-addr (parse-client-ip request)
:profile-id (:profile-id request)}
(let [headers (:headers request)]
{:user-agent (get headers "user-agent")
:frontend-version (get headers "x-frontend-version" "unknown")})))
(let [claims (:session-token-claims request)]
(merge
*context*
{:path (:path request)
:method (:method request)
:params (:params request)
:ip-addr (parse-client-ip request)}
(d/without-nils
{:user-agent (yrq/get-header request "user-agent")
:frontend-version (or (yrq/get-header request "x-frontend-version")
"unknown")
:profile-id (:uid claims)}))))
(defmulti handle-exception
(fn [err & _rest]
@ -91,6 +94,23 @@
[err _]
(yrs/response 404 (ex-data err)))
(defmethod handle-exception :internal
[error request]
(let [{:keys [code] :as edata} (ex-data error)]
(cond
(= :concurrency-limit-reached code)
(yrs/response 429)
:else
(do
(l/error ::l/raw (ex-message error)
::l/context (get-context request)
:cause error)
(yrs/response 500 {:type :server-error
:code :unhandled
:hint (ex-message error)
:data edata})))))
(defmethod handle-exception org.postgresql.util.PSQLException
[error request]
(let [state (.getSQLState ^java.sql.SQLException error)]

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

@ -5,6 +5,7 @@
;; Copyright (c) KALEIDOS INC
(ns app.http.session
(:refer-clojure :exclude [read])
(:require
[app.common.data :as d]
[app.common.logging :as l]
@ -20,6 +21,10 @@
[promesa.exec :as px]
[yetti.request :as yrq]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DEFAULTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; A default cookie name for storing the session.
(def default-auth-token-cookie-name "auth-token")
@ -33,35 +38,55 @@
;; Default age for automatic session renewal
(def default-renewal-max-age (dt/duration {:hours 6}))
(defprotocol ISessionStore
(read-session [store key])
(write-session [store key data])
(update-session [store data])
(delete-session [store key]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PROTOCOLS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- make-database-store
(defprotocol ISessionManager
(read [_ key])
(decode [_ key])
(write! [_ key data])
(update! [_ data])
(delete! [_ key]))
(s/def ::session #(satisfies? ISessionManager %))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; STORAGE IMPL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- prepare-session-params
[sprops data]
(let [profile-id (:profile-id data)
user-agent (:user-agent data)
created-at (or (:created-at data) (dt/now))
token (tokens/generate sprops {:iss "authentication"
:iat created-at
:uid profile-id})]
{:user-agent user-agent
:profile-id profile-id
:created-at created-at
:updated-at created-at
:id token}))
(defn- database-manager
[{:keys [pool sprops executor]}]
(reify ISessionStore
(read-session [_ token]
(reify ISessionManager
(read [_ token]
(px/with-dispatch executor
(db/exec-one! pool (sql/select :http-session {:id token}))))
(write-session [_ _ data]
(decode [_ token]
(px/with-dispatch executor
(let [profile-id (:profile-id data)
user-agent (:user-agent data)
created-at (or (:created-at data) (dt/now))
token (tokens/generate sprops {:iss "authentication"
:iat created-at
:uid profile-id})
params {:user-agent user-agent
:profile-id profile-id
:created-at created-at
:updated-at created-at
:id token}]
(db/insert! pool :http-session params))))
(tokens/verify sprops {:token token :iss "authentication"})))
(update-session [_ data]
(write! [_ _ data]
(px/with-dispatch executor
(let [params (prepare-session-params sprops data)]
(db/insert! pool :http-session params)
params)))
(update! [_ data]
(let [updated-at (dt/now)]
(px/with-dispatch executor
(db/update! pool :http-session
@ -69,83 +94,154 @@
{:id (:id data)})
(assoc data :updated-at updated-at))))
(delete-session [_ token]
(delete! [_ token]
(px/with-dispatch executor
(db/delete! pool :http-session {:id token})
nil))))
(defn make-inmemory-store
[{:keys [sprops]}]
(defn inmemory-manager
[{:keys [sprops executor]}]
(let [cache (atom {})]
(reify ISessionStore
(read-session [_ token]
(reify ISessionManager
(read [_ token]
(p/do (get @cache token)))
(write-session [_ _ data]
(p/do
(let [profile-id (:profile-id data)
user-agent (:user-agent data)
created-at (or (:created-at data) (dt/now))
token (tokens/generate sprops {:iss "authentication"
:iat created-at
:uid profile-id})
params {:user-agent user-agent
:created-at created-at
:updated-at created-at
:profile-id profile-id
:id token}]
(decode [_ token]
(px/with-dispatch executor
(tokens/verify sprops {:token token :iss "authentication"})))
(write! [_ _ data]
(p/do
(let [{:keys [token] :as params} (prepare-session-params sprops data)]
(swap! cache assoc token params)
params)))
(update-session [_ data]
(let [updated-at (dt/now)]
(swap! cache update (:id data) assoc :updated-at updated-at)
(assoc data :updated-at updated-at)))
(update! [_ data]
(p/do
(let [updated-at (dt/now)]
(swap! cache update (:id data) assoc :updated-at updated-at)
(assoc data :updated-at updated-at))))
(delete-session [_ token]
(delete! [_ token]
(p/do
(swap! cache dissoc token)
nil)))))
(s/def ::sprops map?)
(defmethod ig/pre-init-spec ::store [_]
(defmethod ig/pre-init-spec ::manager [_]
(s/keys :req-un [::db/pool ::wrk/executor ::sprops]))
(defmethod ig/init-key ::store
(defmethod ig/init-key ::manager
[_ {:keys [pool] :as cfg}]
(if (db/read-only? pool)
(make-inmemory-store cfg)
(make-database-store cfg)))
(inmemory-manager cfg)
(database-manager cfg)))
(defmethod ig/halt-key! ::store
(defmethod ig/halt-key! ::manager
[_ _])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MANAGER IMPL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare assign-auth-token-cookie)
(declare assign-authenticated-cookie)
(declare clear-auth-token-cookie)
(declare clear-authenticated-cookie)
(defn create-fn
[manager profile-id]
(fn [request response]
(let [uagent (yrq/get-header request "user-agent")
params {:profile-id profile-id
:user-agent uagent}]
(-> (write! manager nil params)
(p/then (fn [session]
(l/trace :hint "create" :profile-id profile-id)
(-> response
(assign-auth-token-cookie session)
(assign-authenticated-cookie session))))))))
(defn delete-fn
[manager]
(letfn [(delete [{:keys [profile-id] :as request}]
(let [cname (cf/get :auth-token-cookie-name default-auth-token-cookie-name)
cookie (yrq/get-cookie request cname)]
(l/trace :hint "delete" :profile-id profile-id)
(some->> (:value cookie) (delete! manager))))]
(fn [request response]
(p/do
(delete request)
(-> response
(assoc :status 204)
(assoc :body nil)
(clear-auth-token-cookie)
(clear-authenticated-cookie))))))
(def middleware-1
(letfn [(wrap-handler [manager handler request respond raise]
(try
(let [claims (some->> (cf/get :auth-token-cookie-name default-auth-token-cookie-name)
(yrq/get-cookie request)
(decode manager))
request (cond-> request
(some? claims)
(assoc :session-token-claims claims))]
(handler request respond raise))
(catch Throwable _
(handler request respond raise))))]
{:name :session-1
:compile (fn [& _]
(fn [handler manager]
(partial wrap-handler manager handler)))}))
(def middleware-2
(letfn [(wrap-handler [manager handler request respond raise]
(-> (retrieve-session manager request)
(p/finally (fn [session cause]
(cond
(some? cause)
(raise cause)
(nil? session)
(handler request respond raise)
:else
(let [request (-> request
(assoc :profile-id (:profile-id session))
(assoc :session-id (:id session)))
respond (cond-> respond
(renew-session? session)
(wrap-respond manager session))]
(handler request respond raise)))))))
(retrieve-session [manager request]
(let [cname (cf/get :auth-token-cookie-name default-auth-token-cookie-name)
cookie (yrq/get-cookie request cname)]
(some->> (:value cookie) (read manager))))
(renew-session? [{:keys [updated-at] :as session}]
(and (dt/instant? updated-at)
(let [elapsed (dt/diff updated-at (dt/now))]
(neg? (compare default-renewal-max-age elapsed)))))
;; Wrap respond with session renewal code
(wrap-respond [respond manager session]
(fn [response]
(p/let [session (update! manager session)]
(-> response
(assign-auth-token-cookie session)
(assign-authenticated-cookie session)
(respond)))))]
{:name :session-2
:compile (fn [& _]
(fn [handler manager]
(partial wrap-handler manager handler)))}))
;; --- IMPL
(defn- create-session!
[store profile-id user-agent]
(let [params {:user-agent user-agent
:profile-id profile-id}]
(write-session store nil params)))
(defn- update-session!
[store session]
(update-session store session))
(defn- delete-session!
[store {:keys [cookies] :as request}]
(let [name (cf/get :auth-token-cookie-name default-auth-token-cookie-name)]
(when-let [token (get-in cookies [name :value])]
(delete-session store token))))
(defn- retrieve-session
[store request]
(let [cookie-name (cf/get :auth-token-cookie-name default-auth-token-cookie-name)]
(when-let [cookie (yrq/get-cookie request cookie-name)]
(read-session store (:value cookie)))))
(defn assign-auth-token-cookie
(defn- assign-auth-token-cookie
[response {token :id updated-at :updated-at}]
(let [max-age (cf/get :auth-token-cookie-max-age default-cookie-max-age)
created-at (or updated-at (dt/now))
@ -164,7 +260,7 @@
:secure secure?}]
(update response :cookies assoc name cookie)))
(defn assign-authenticated-cookie
(defn- assign-authenticated-cookie
[response {updated-at :updated-at}]
(let [max-age (cf/get :auth-token-cookie-max-age default-cookie-max-age)
created-at (or updated-at (dt/now))
@ -185,96 +281,23 @@
(string? domain)
(update :cookies assoc name cookie))))
(defn clear-auth-token-cookie
(defn- clear-auth-token-cookie
[response]
(let [name (cf/get :auth-token-cookie-name default-auth-token-cookie-name)]
(update response :cookies assoc name {:path "/" :value "" :max-age -1})))
(let [cname (cf/get :auth-token-cookie-name default-auth-token-cookie-name)]
(update response :cookies assoc cname {:path "/" :value "" :max-age -1})))
(defn- clear-authenticated-cookie
[response]
(let [name (cf/get :authenticated-cookie-name default-authenticated-cookie-name)
(let [cname (cf/get :authenticated-cookie-name default-authenticated-cookie-name)
domain (cf/get :authenticated-cookie-domain)]
(cond-> response
(string? domain)
(update :cookies assoc name {:domain domain :path "/" :value "" :max-age -1}))))
(defn- make-middleware
[{:keys [store] :as cfg}]
(letfn [;; Check if time reached for automatic session renewal
(renew-session? [{:keys [updated-at] :as session}]
(and (dt/instant? updated-at)
(let [elapsed (dt/diff updated-at (dt/now))]
(neg? (compare default-renewal-max-age elapsed)))))
;; Wrap respond with session renewal code
(wrap-respond [respond session]
(fn [response]
(p/let [session (update-session! store session)]
(-> response
(assign-auth-token-cookie session)
(assign-authenticated-cookie session)
(respond)))))]
{:name :session
:compile (fn [& _]
(fn [handler]
(fn [request respond raise]
(try
(-> (retrieve-session store request)
(p/finally (fn [session cause]
(cond
(some? cause)
(raise cause)
(nil? session)
(handler request respond raise)
:else
(let [request (-> request
(assoc :profile-id (:profile-id session))
(assoc :session-id (:id session)))
respond (cond-> respond
(renew-session? session)
(wrap-respond session))]
(handler request respond raise))))))
(catch Throwable cause
(raise cause))))))}))
(update :cookies assoc cname {:domain domain :path "/" :value "" :max-age -1}))))
;; --- STATE INIT: SESSION
(s/def ::store #(satisfies? ISessionStore %))
(defmethod ig/pre-init-spec :app.http/session [_]
(s/keys :req-un [::store]))
(defmethod ig/prep-key :app.http/session
[_ cfg]
(d/merge {:buffer-size 128}
(d/without-nils cfg)))
(defmethod ig/init-key :app.http/session
[_ {:keys [store] :as cfg}]
(-> cfg
(assoc :middleware (make-middleware cfg))
(assoc :create (fn [profile-id]
(fn [request response]
(p/let [uagent (yrq/get-header request "user-agent")
session (create-session! store profile-id uagent)]
(-> response
(assign-auth-token-cookie session)
(assign-authenticated-cookie session))))))
(assoc :delete (fn [request response]
(p/do
(delete-session! store request)
(-> response
(assoc :status 204)
(assoc :body nil)
(clear-auth-token-cookie)
(clear-authenticated-cookie)))))))
;; --- STATE INIT: SESSION GC
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TASK: SESSION GC
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare sql:delete-expired)

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

@ -9,11 +9,116 @@
[app.auth.oidc]
[app.common.logging :as l]
[app.config :as cf]
[app.metrics.definition :as-alias mdef]
[app.util.time :as dt]
[cuerdas.core :as str]
[integrant.core :as ig])
(:gen-class))
(def default-metrics
{:update-file-changes
{::mdef/name "penpot_rpc_update_file_changes_total"
::mdef/help "A total number of changes submitted to update-file."
::mdef/type :counter}
:update-file-bytes-processed
{::mdef/name "penpot_rpc_update_file_bytes_processed_total"
::mdef/help "A total number of bytes processed by update-file."
::mdef/type :counter}
:rpc-mutation-timing
{::mdef/name "penpot_rpc_mutation_timing"
::mdef/help "RPC mutation method call timing."
::mdef/labels ["name"]
::mdef/type :histogram}
:rpc-command-timing
{::mdef/name "penpot_rpc_command_timing"
::mdef/help "RPC command method call timing."
::mdef/labels ["name"]
::mdef/type :histogram}
:rpc-query-timing
{::mdef/name "penpot_rpc_query_timing"
::mdef/help "RPC query method call timing."
::mdef/labels ["name"]
::mdef/type :histogram}
:websocket-active-connections
{::mdef/name "penpot_websocket_active_connections"
::mdef/help "Active websocket connections gauge"
::mdef/type :gauge}
:websocket-messages-total
{::mdef/name "penpot_websocket_message_total"
::mdef/help "Counter of processed messages."
::mdef/labels ["op"]
::mdef/type :counter}
:websocket-session-timing
{::mdef/name "penpot_websocket_session_timing"
::mdef/help "Websocket session timing (seconds)."
::mdef/type :summary}
:session-update-total
{::mdef/name "penpot_http_session_update_total"
::mdef/help "A counter of session update batch events."
::mdef/type :counter}
:tasks-timing
{::mdef/name "penpot_tasks_timing"
::mdef/help "Background tasks timing (milliseconds)."
::mdef/labels ["name"]
::mdef/type :summary}
:redis-eval-timing
{::mdef/name "penpot_redis_eval_timing"
::mdef/help "Redis EVAL commands execution timings (ms)"
::mdef/labels ["name"]
::mdef/type :summary}
:rpc-climit-queue-size
{::mdef/name "penpot_rpc_climit_queue_size"
::mdef/help "Current number of queued submissions on the CLIMIT."
::mdef/labels ["name"]
::mdef/type :gauge}
:rpc-climit-concurrency
{::mdef/name "penpot_rpc_climit_concurrency"
::mdef/help "Current number of used concurrency capacity on the CLIMIT"
::mdef/labels ["name"]
::mdef/type :gauge}
:rpc-climit-timing
{::mdef/name "penpot_rpc_climit_timing"
::mdef/help "Summary of the time between queuing and executing on the CLIMIT"
::mdef/labels ["name"]
::mdef/type :summary}
:executors-active-threads
{::mdef/name "penpot_executors_active_threads"
::mdef/help "Current number of threads available in the executor service."
::mdef/labels ["name"]
::mdef/type :gauge}
:executors-completed-tasks
{::mdef/name "penpot_executors_completed_tasks_total"
::mdef/help "Approximate number of completed tasks by the executor."
::mdef/labels ["name"]
::mdef/type :counter}
:executors-running-threads
{::mdef/name "penpot_executors_running_threads"
::mdef/help "Current number of threads with state RUNNING."
::mdef/labels ["name"]
::mdef/type :gauge}
:executors-queued-submissions
{::mdef/name "penpot_executors_queued_submissions"
::mdef/help "Current number of queued submissions."
::mdef/labels ["name"]
::mdef/type :gauge}})
(def system-config
{:app.db/pool
{:uri (cf/get :database-uri)
@ -50,7 +155,7 @@
{}
:app.metrics/metrics
{}
{:default default-metrics}
:app.migrations/all
{:main (ig/ref :app.migrations/migrations)}
@ -79,10 +184,7 @@
:app.http/client
{:executor (ig/ref [::default :app.worker/executor])}
:app.http/session
{:store (ig/ref :app.http.session/store)}
:app.http.session/store
:app.http.session/manager
{:pool (ig/ref :app.db/pool)
:sprops (ig/ref :app.setup/props)
:executor (ig/ref [::default :app.worker/executor])}
@ -163,7 +265,7 @@
:sprops (ig/ref :app.setup/props)
:http-client (ig/ref :app.http/client)
:pool (ig/ref :app.db/pool)
:session (ig/ref :app.http/session)
:session (ig/ref :app.http.session/manager)
:public-uri (cf/get :public-uri)
:executor (ig/ref [::default :app.worker/executor])}
@ -171,7 +273,7 @@
:app.http/router
{:assets (ig/ref :app.http.assets/handlers)
:feedback (ig/ref :app.http.feedback/handler)
:session (ig/ref :app.http/session)
:session (ig/ref :app.http.session/manager)
:awsns-handler (ig/ref :app.http.awsns/handler)
:debug-routes (ig/ref :app.http.debug/routes)
:oidc-routes (ig/ref :app.auth.oidc/routes)
@ -188,7 +290,7 @@
{:pool (ig/ref :app.db/pool)
:executor (ig/ref [::worker :app.worker/executor])
:storage (ig/ref :app.storage/storage)
:session (ig/ref :app.http/session)}
:session (ig/ref :app.http.session/manager)}
:app.http.websocket/handler
{:pool (ig/ref :app.db/pool)
@ -207,8 +309,8 @@
{:pool (ig/ref :app.db/pool)
:executor (ig/ref [::default :app.worker/executor])}
:app.rpc/semaphores
{:metrics (ig/ref :app.metrics/metrics)
:app.rpc/climit
{:metrics (ig/ref :app.metrics/metrics)
:executor (ig/ref [::default :app.worker/executor])}
:app.rpc/rlimit
@ -217,7 +319,7 @@
:app.rpc/methods
{:pool (ig/ref :app.db/pool)
:session (ig/ref :app.http/session)
:session (ig/ref :app.http.session/manager)
:sprops (ig/ref :app.setup/props)
:metrics (ig/ref :app.metrics/metrics)
:storage (ig/ref :app.storage/storage)
@ -227,11 +329,11 @@
:audit (ig/ref :app.loggers.audit/collector)
:ldap (ig/ref :app.auth.ldap/provider)
:http-client (ig/ref :app.http/client)
:climit (ig/ref :app.rpc/climit)
:rlimit (ig/ref :app.rpc/rlimit)
:executors (ig/ref :app.worker/executors)
:executor (ig/ref [::default :app.worker/executor])
:templates (ig/ref :app.setup/builtin-templates)
:semaphores (ig/ref :app.rpc/semaphores)
}
:app.rpc.doc/routes

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

@ -38,110 +38,6 @@
;; METRICS SERVICE PROVIDER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def default-metrics
{:update-file-changes
{::mdef/name "penpot_rpc_update_file_changes_total"
::mdef/help "A total number of changes submitted to update-file."
::mdef/type :counter}
:update-file-bytes-processed
{::mdef/name "penpot_rpc_update_file_bytes_processed_total"
::mdef/help "A total number of bytes processed by update-file."
::mdef/type :counter}
:rpc-mutation-timing
{::mdef/name "penpot_rpc_mutation_timing"
::mdef/help "RPC mutation method call timing."
::mdef/labels ["name"]
::mdef/type :histogram}
:rpc-command-timing
{::mdef/name "penpot_rpc_command_timing"
::mdef/help "RPC command method call timing."
::mdef/labels ["name"]
::mdef/type :histogram}
:rpc-query-timing
{::mdef/name "penpot_rpc_query_timing"
::mdef/help "RPC query method call timing."
::mdef/labels ["name"]
::mdef/type :histogram}
:websocket-active-connections
{::mdef/name "penpot_websocket_active_connections"
::mdef/help "Active websocket connections gauge"
::mdef/type :gauge}
:websocket-messages-total
{::mdef/name "penpot_websocket_message_total"
::mdef/help "Counter of processed messages."
::mdef/labels ["op"]
::mdef/type :counter}
:websocket-session-timing
{::mdef/name "penpot_websocket_session_timing"
::mdef/help "Websocket session timing (seconds)."
::mdef/type :summary}
:session-update-total
{::mdef/name "penpot_http_session_update_total"
::mdef/help "A counter of session update batch events."
::mdef/type :counter}
:tasks-timing
{::mdef/name "penpot_tasks_timing"
::mdef/help "Background tasks timing (milliseconds)."
::mdef/labels ["name"]
::mdef/type :summary}
:redis-eval-timing
{::mdef/name "penpot_redis_eval_timing"
::mdef/help "Redis EVAL commands execution timings (ms)"
::mdef/labels ["name"]
::mdef/type :summary}
:semaphore-queued-submissions
{::mdef/name "penpot_semaphore_queued_submissions"
::mdef/help "Current number of queued submissions on SEMAPHORE."
::mdef/labels ["name"]
::mdef/type :gauge}
:semaphore-used-permits
{::mdef/name "penpot_semaphore_used_permits"
::mdef/help "Current number of used permits on SEMAPHORE."
::mdef/labels ["name"]
::mdef/type :gauge}
:semaphore-timing
{::mdef/name "penpot_semaphore_timing"
::mdef/help "Total timing of SEMAPHORE."
::mdef/labels ["name"]
::mdef/type :summary}
:executors-active-threads
{::mdef/name "penpot_executors_active_threads"
::mdef/help "Current number of threads available in the executor service."
::mdef/labels ["name"]
::mdef/type :gauge}
:executors-completed-tasks
{::mdef/name "penpot_executors_completed_tasks_total"
::mdef/help "Approximate number of completed tasks by the executor."
::mdef/labels ["name"]
::mdef/type :counter}
:executors-running-threads
{::mdef/name "penpot_executors_running_threads"
::mdef/help "Current number of threads with state RUNNING."
::mdef/labels ["name"]
::mdef/type :gauge}
:executors-queued-submissions
{::mdef/name "penpot_executors_queued_submissions"
::mdef/help "Current number of queued submissions."
::mdef/labels ["name"]
::mdef/type :gauge}})
(s/def ::mdef/name string?)
(s/def ::mdef/help string?)
(s/def ::mdef/labels (s/every string? :kind vector?))
@ -169,8 +65,13 @@
::handler
::definitions]))
(s/def ::default ::definitions)
(defmethod ig/pre-init-spec ::metrics [_]
(s/keys :req-un [::default]))
(defmethod ig/init-key ::metrics
[_ _]
[_ cfg]
(l/info :action "initialize metrics")
(let [registry (create-registry)
definitions (reduce-kv (fn [res k v]
@ -178,7 +79,7 @@
(create-collector)
(assoc res k)))
{}
default-metrics)]
(:default cfg))]
(us/verify! ::definitions definitions)

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

@ -11,12 +11,14 @@
[app.common.spec :as us]
[app.db :as db]
[app.http :as-alias http]
[app.http.session :as-alias session]
[app.loggers.audit :as audit]
[app.metrics :as mtx]
[app.msgbus :as-alias mbus]
[app.rpc.climit :as climit]
[app.rpc.retry :as retry]
[app.rpc.rlimit :as rlimit]
[app.rpc.semaphore :as-alias rsem]
[app.storage :as-alias sto]
[app.util.services :as sv]
[app.util.time :as ts]
[clojure.spec.alpha :as s]
@ -124,7 +126,8 @@
(with-meta
(fn [cfg params]
(-> (px/submit! executor #(f cfg params))
(p/bind p/wrap)))
(p/bind p/wrap)
(p/then' sv/wrap)))
mdata))
(defn- wrap-audit
@ -160,7 +163,7 @@
(wrap-dispatch cfg $ mdata)
(wrap-metrics cfg $ mdata)
(retry/wrap-retry cfg $ mdata)
(rsem/wrap cfg $ mdata)
(climit/wrap cfg $ mdata)
(rlimit/wrap cfg $ mdata)
(wrap-audit cfg $ mdata))
@ -172,6 +175,7 @@
(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
@ -179,7 +183,6 @@
:hint "authentication required for this endpoint")
(let [params (us/conform spec (dissoc params ::request))]
(f cfg (assoc params ::request request))))))
mdata)))
(defn- process-method
@ -235,21 +238,22 @@
(s/def ::http-client fn?)
(s/def ::ldap (s/nilable map?))
(s/def ::msgbus ::mbus/msgbus)
(s/def ::climit (s/nilable ::climit/climit))
(s/def ::rlimit (s/nilable ::rlimit/rlimit))
(s/def ::public-uri ::us/not-empty-string)
(s/def ::session map?)
(s/def ::storage some?)
(s/def ::sprops map?)
(defmethod ig/pre-init-spec ::methods [_]
(s/keys :req-un [::storage
::session
(s/keys :req-un [::sto/storage
::session/session
::sprops
::audit
::public-uri
::msgbus
::http-client
::rsem/semaphores
::rlimit/rlimit
::rlimit
::climit
::mtx/metrics
::db/pool
::ldap]))

205
backend/src/app/rpc/climit.clj Normal file
View file

@ -0,0 +1,205 @@
;; 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) KALEIDOS INC
(ns app.rpc.climit
"Concurrencly limiter for RPC."
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.config :as cf]
[app.metrics :as mtx]
[app.rpc :as-alias rpc]
[app.util.services :as-alias sv]
[app.util.time :as dt]
[app.worker :as-alias wrk]
[clojure.edn :as edn]
[clojure.spec.alpha :as s]
[datoteka.fs :as fs]
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px]
[promesa.exec.bulkhead :as pxb])
(:import
com.github.benmanes.caffeine.cache.Cache
com.github.benmanes.caffeine.cache.CacheLoader
com.github.benmanes.caffeine.cache.Caffeine
com.github.benmanes.caffeine.cache.RemovalListener))
(defn- capacity-exception?
[o]
(and (ex/ex-info? o)
(let [data (ex-data o)]
(and (= :bulkhead-error (:type data))
(= :capacity-limit-reached (:code data))))))
(defn invoke!
[limiter f]
(p/handle
(px/submit! limiter f)
(fn [result cause]
(cond
(capacity-exception? cause)
(p/rejected
(ex/error :type :internal
:code :concurrency-limit-reached
:queue (-> limiter meta :bkey name)
:cause cause))
(some? cause)
(p/rejected cause)
:else
(p/resolved result)))))
(defn- create-limiter
[{:keys [executor metrics concurrency queue-size bkey skey]}]
(let [labels (into-array String [(name bkey)])
on-queue (fn [instance]
(l/trace :hint "enqueued"
:key (name bkey)
:skey (str skey)
:queue-size (get instance :current-queue-size)
:concurrency (get instance :current-concurrency)
(mtx/run! metrics
:id :rpc-climit-queue-size
:val (get instance :current-queue-size)
:labels labels)
(mtx/run! metrics
:id :rpc-climit-concurrency
:val (get instance :current-concurrency)
:labels labels)))
on-run (fn [instance task]
(let [elapsed (- (inst-ms (dt/now))
(inst-ms task))]
(l/trace :hint "execute"
:key (name bkey)
:skey (str skey)
:elapsed (str elapsed "ms"))
(mtx/run! metrics
:id :rpc-climit-timing
:val elapsed
:labels labels)
(mtx/run! metrics
:id :rpc-climit-queue-size
:val (get instance :current-queue-size)
:labels labels)
(mtx/run! metrics
:id :rpc-climit-concurrency
:val (get instance :current-concurrency)
:labels labels)))
options {:executor executor
:concurrency concurrency
:queue-size (or queue-size Integer/MAX_VALUE)
:on-queue on-queue
:on-run on-run}]
(-> (pxb/create options)
(vary-meta assoc :bkey bkey :skey skey))))
(defn- create-cache
[{:keys [executor] :as params} config]
(let [listener (reify RemovalListener
(onRemoval [_ key _val cause]
(l/trace :hint "cache: remove" :key key :reason (str cause))))
loader (reify CacheLoader
(load [_ key]
(let [[bkey skey] key]
(when-let [config (get config bkey)]
(-> (merge params config)
(assoc :bkey bkey)
(assoc :skey skey)
(create-limiter))))))]
(.. (Caffeine/newBuilder)
(weakValues)
(executor executor)
(removalListener listener)
(build loader))))
(defprotocol IConcurrencyManager)
(s/def ::concurrency ::us/integer)
(s/def ::queue-size ::us/integer)
(s/def ::config
(s/map-of keyword?
(s/keys :req-un [::concurrency]
:opt-un [::queue-size])))
(defmethod ig/prep-key ::rpc/climit
[_ cfg]
(merge {:path (cf/get :rpc-climit-config)}
(d/without-nils cfg)))
(defmethod ig/pre-init-spec ::rpc/climit [_]
(s/keys :req-un [::wrk/executor ::mtx/metrics ::fs/path]))
(defmethod ig/init-key ::rpc/climit
[_ {:keys [path] :as params}]
(when (contains? cf/flags :rpc-climit)
(if-let [config (some->> path slurp edn/read-string)]
(do
(l/info :hint "initializing concurrency limit" :config (str path))
(us/verify! ::config config)
(let [cache (create-cache params config)]
^{::cache cache}
(reify
IConcurrencyManager
clojure.lang.IDeref
(deref [_] config)
clojure.lang.ILookup
(valAt [_ key]
(let [key (if (vector? key) key [key])]
(.get ^Cache cache key))))))
(l/warn :hint "unable to load configuration" :config (str path)))))
(s/def ::climit #(satisfies? IConcurrencyManager %))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro with-dispatch
[lim & body]
`(if ~lim
(invoke! ~lim (^:once fn [] (p/wrap (do ~@body))))
(p/wrap (do ~@body))))
(defn wrap
[{:keys [climit]} f {:keys [::queue ::key-fn] :as mdata}]
(if (and (some? climit)
(some? queue))
(if-let [config (get @climit queue)]
(do
(l/debug :hint "wrap: instrumenting method"
:limit-name (name queue)
:service-name (::sv/name mdata)
:queue-size (or (:queue-size config) Integer/MAX_VALUE)
:concurrency (:concurrency config)
:keyed? (some? key-fn))
(if (some? key-fn)
(fn [cfg params]
(let [key [queue (key-fn params)]
lim (get climit key)]
(invoke! lim (partial f cfg params))))
(let [lim (get climit queue)]
(fn [cfg params]
(invoke! lim (partial f cfg params))))))
(do
(l/warn :hint "wrap: no config found"
:queue (name queue)
:service (::sv/name mdata))
f))
f))

19
backend/src/app/rpc/commands/auth.clj
View file

@ -13,12 +13,13 @@
[app.config :as cf]
[app.db :as db]
[app.emails :as eml]
[app.http.session :as session]
[app.loggers.audit :as audit]
[app.rpc :as-alias rpc]
[app.rpc.climit :as climit]
[app.rpc.doc :as-alias doc]
[app.rpc.mutations.teams :as teams]
[app.rpc.queries.profile :as profile]
[app.rpc.semaphore :as rsem]
[app.tokens :as tokens]
[app.util.services :as sv]
[app.util.time :as dt]
@ -135,7 +136,7 @@
profile)]
(with-meta response
{::rpc/transform-response ((:create session) (:id profile))
{::rpc/transform-response (session/create-fn session (:id profile))
::audit/props (audit/profile->props profile)
::audit/profile-id (:id profile)})))))
@ -146,7 +147,7 @@
(sv/defmethod ::login-with-password
"Performs authentication using penpot password."
{:auth false
::rsem/queue :auth
::climit/queue :auth
::doc/added "1.15"}
[cfg params]
(login-with-password cfg params))
@ -162,7 +163,7 @@
::doc/added "1.15"}
[{:keys [session] :as cfg} _]
(with-meta {}
{::rpc/transform-response (:delete session)}))
{::rpc/transform-response (session/delete-fn session)}))
;; ---- COMMAND: Recover Profile
@ -187,7 +188,7 @@
(sv/defmethod ::recover-profile
{:auth false
::rsem/queue :auth
::climit/queue :auth
::doc/added "1.15"}
[cfg params]
(recover-profile cfg params))
@ -403,7 +404,7 @@
token (tokens/generate sprops claims)
resp {:invitation-token token}]
(with-meta resp
{::rpc/transform-response ((:create session) (:id profile))
{::rpc/transform-response (session/create-fn session (:id profile))
::audit/replace-props (audit/profile->props profile)
::audit/profile-id (:id profile)}))
@ -412,7 +413,7 @@
;; we need to mark this session as logged.
(not= "penpot" (:auth-backend profile))
(with-meta (profile/strip-private-attrs profile)
{::rpc/transform-response ((:create session) (:id profile))
{::rpc/transform-response (session/create-fn session (:id profile))
::audit/replace-props (audit/profile->props profile)
::audit/profile-id (:id profile)})
@ -420,7 +421,7 @@
;; to sign in the user directly, without email verification.
(true? is-active)
(with-meta (profile/strip-private-attrs profile)
{::rpc/transform-response ((:create session) (:id profile))
{::rpc/transform-response (session/create-fn session (:id profile))
::audit/replace-props (audit/profile->props profile)
::audit/profile-id (:id profile)})
@ -437,7 +438,7 @@
(sv/defmethod ::register-profile
{:auth false
::rsem/queue :auth
::climit/queue :auth
::doc/added "1.15"}
[{:keys [pool] :as cfg} params]
(db/with-atomic [conn pool]

5
backend/src/app/rpc/commands/ldap.clj
View file

@ -10,6 +10,7 @@
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.db :as db]
[app.http.session :as session]
[app.loggers.audit :as-alias audit]
[app.rpc :as-alias rpc]
[app.rpc.commands.auth :as cmd.auth]
@ -63,12 +64,12 @@
:member-email (:email profile))
token (tokens :generate claims)]
(with-meta {:invitation-token token}
{::rpc/transform-response ((:create session) (:id profile))
{::rpc/transform-response (session/create-fn session (:id profile))
::audit/props (:props profile)
::audit/profile-id (:id profile)}))
(with-meta profile
{::rpc/transform-response ((:create session) (:id profile))
{::rpc/transform-response (session/create-fn session (:id profile))
::audit/props (:props profile)
::audit/profile-id (:id profile)})))))

5
backend/src/app/rpc/commands/verify_token.clj
View file

@ -9,6 +9,7 @@
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.db :as db]
[app.http.session :as session]
[app.loggers.audit :as audit]
[app.rpc :as-alias rpc]
[app.rpc.doc :as-alias doc]
@ -68,7 +69,7 @@
{:id (:id profile)}))
(with-meta claims
{::rpc/transform-response ((:create session) profile-id)
{::rpc/transform-response (session/create-fn session profile-id)
::audit/name "verify-profile-email"
::audit/props (audit/profile->props profile)
::audit/profile-id (:id profile)})))
@ -172,7 +173,7 @@
(let [profile (accept-invitation cfg claims invitation member)]
(with-meta
(assoc claims :state :created)
{::rpc/transform-response ((:create session) (:id profile))
{::rpc/transform-response (session/create-fn session (:id profile))
::audit/name "accept-team-invitation"
::audit/props (merge
(audit/profile->props profile)

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

@ -21,11 +21,11 @@
[app.metrics :as mtx]
[app.msgbus :as mbus]
[app.rpc :as-alias rpc]
[app.rpc.climit :as-alias climit]
[app.rpc.doc :as-alias doc]
[app.rpc.permissions :as perms]
[app.rpc.queries.files :as files]
[app.rpc.queries.projects :as proj]
[app.rpc.semaphore :as rsem]
[app.storage.impl :as simpl]
[app.util.blob :as blob]
[app.util.objects-map :as omap]
@ -346,8 +346,8 @@
FOR KEY SHARE")
(sv/defmethod ::update-file
{::rsem/queue :update-file
::doc/added "1.0"}
{::climit/queue :update-file
::climit/key-fn :id}
[{:keys [pool] :as cfg} {:keys [id profile-id components-v2] :as params}]
(db/with-atomic [conn pool]
(db/xact-lock! conn id)

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

@ -12,14 +12,15 @@
[app.common.uuid :as uuid]
[app.db :as db]
[app.media :as media]
[app.rpc.climit :as-alias climit]
[app.rpc.doc :as-alias doc]
[app.rpc.queries.teams :as teams]
[app.rpc.semaphore :as rsem]
[app.storage :as sto]
[app.util.services :as sv]
[app.util.time :as dt]
[clojure.spec.alpha :as s]
[promesa.core :as p]))
[promesa.core :as p]
[promesa.exec :as px]))
(declare create-font-variant)
@ -46,15 +47,15 @@
(create-font-variant cfg params)))
(defn create-font-variant
[{:keys [storage pool executor semaphores] :as cfg} {:keys [data] :as params}]
[{:keys [storage pool executor climit] :as cfg} {:keys [data] :as params}]
(letfn [(generate-fonts [data]
(rsem/with-dispatch (:process-font semaphores)
(climit/with-dispatch (:process-font climit)
(media/run {:cmd :generate-fonts :input data})))
;; Function responsible of calculating cryptographyc hash of
;; the provided data.
(calculate-hash [data]
(rsem/with-dispatch (:process-font semaphores)
(px/with-dispatch executor
(sto/calculate-hash data)))
(validate-data [data]
@ -120,6 +121,7 @@
and font_id = ?")
(sv/defmethod ::update-font
{::climit/queue :process-font}
[{:keys [pool] :as cfg} {:keys [team-id profile-id id name] :as params}]
(db/with-atomic [conn pool]
(teams/check-edition-permissions! conn profile-id team-id)

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

@ -14,8 +14,8 @@
[app.config :as cf]
[app.db :as db]
[app.media :as media]
[app.rpc.climit :as climit]
[app.rpc.queries.teams :as teams]
[app.rpc.semaphore :as rsem]
[app.storage :as sto]
[app.storage.tmp :as tmp]
[app.util.services :as sv]
@ -23,7 +23,8 @@
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.io :as io]
[promesa.core :as p]))
[promesa.core :as p]
[promesa.exec :as px]))
(def default-max-file-size (* 1024 1024 10)) ; 10 MiB
@ -104,25 +105,25 @@
;; inverse, soft referential integrity).
(defn create-file-media-object
[{:keys [storage pool semaphores] :as cfg}
[{:keys [storage pool climit executor] :as cfg}
{:keys [id file-id is-local name content] :as params}]
(letfn [;; Function responsible to retrieve the file information, as
;; it is synchronous operation it should be wrapped into
;; with-dispatch macro.
(get-info [content]
(rsem/with-dispatch (:process-image semaphores)
(climit/with-dispatch (:process-image climit)
(media/run {:cmd :info :input content})))
;; Function responsible of calculating cryptographyc hash of
;; the provided data.
(calculate-hash [data]
(rsem/with-dispatch (:process-image semaphores)
(px/with-dispatch executor
(sto/calculate-hash data)))
;; Function responsible of generating thumnail. As it is synchronous
;; opetation, it should be wrapped into with-dispatch macro
(generate-thumbnail [info]
(rsem/with-dispatch (:process-image semaphores)
(climit/with-dispatch (:process-image climit)
(media/run (assoc thumbnail-options
:cmd :generic-thumbnail
:input info))))
@ -154,14 +155,15 @@
:bucket "file-media-object"})))
(insert-into-database [info image thumb]
(db/exec-one! pool [sql:create-file-media-object
(or id (uuid/next))
file-id is-local name
(:id image)
(:id thumb)
(:width info)
(:height info)
(:mtype info)]))]
(px/with-dispatch executor
(db/exec-one! pool [sql:create-file-media-object
(or id (uuid/next))
file-id is-local name
(:id image)
(:id thumb)
(:width info)
(:height info)
(:mtype info)])))]
(p/let [info (get-info content)
thumb (create-thumbnail info)

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

@ -12,14 +12,15 @@
[app.config :as cf]
[app.db :as db]
[app.emails :as eml]
[app.http.session :as session]
[app.loggers.audit :as audit]
[app.media :as media]
[app.rpc :as-alias rpc]
[app.rpc.climit :as-alias climit]
[app.rpc.commands.auth :as cmd.auth]
[app.rpc.doc :as-alias doc]
[app.rpc.mutations.teams :as teams]
[app.rpc.queries.profile :as profile]
[app.rpc.semaphore :as rsem]
[app.storage :as sto]
[app.tokens :as tokens]
[app.util.services :as sv]
@ -82,11 +83,11 @@
(s/keys :req-un [::profile-id ::password ::old-password]))
(sv/defmethod ::update-profile-password
{::rsem/queue :auth}
{::climit/queue :auth}
[{:keys [pool] :as cfg} {:keys [password] :as params}]
(db/with-atomic [conn pool]
(let [profile (validate-password! conn params)
session-id (:app.rpc/session-id params)]
session-id (::rpc/session-id params)]
(when (= (str/lower (:email profile))
(str/lower (:password params)))
(ex/raise :type :validation
@ -278,7 +279,7 @@
{:id profile-id})
(with-meta {}
{::rpc/transform-response (:delete session)}))))
{::rpc/transform-response (session/delete-fn session)}))))
(def sql:owned-teams
"with owner_teams as (
@ -308,7 +309,7 @@
(sv/defmethod ::login
{:auth false
::rsem/queue :auth
::climit/queue :auth
::doc/added "1.0"
::doc/deprecated "1.15"}
[cfg params]
@ -324,7 +325,7 @@
::doc/deprecated "1.15"}
[{:keys [session] :as cfg} _]
(with-meta {}
{::rpc/transform-response (:delete session)}))
{::rpc/transform-response (session/delete-fn session)}))
;; --- MUTATION: Recover Profile
@ -353,7 +354,7 @@
(sv/defmethod ::register-profile
{:auth false
::rsem/queue :auth
::climit/queue :auth
::doc/added "1.0"
::doc/deprecated "1.15"}
[{:keys [pool] :as cfg} params]

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

@ -17,11 +17,11 @@
[app.loggers.audit :as audit]
[app.media :as media]
[app.rpc :as-alias rpc]
[app.rpc.climit :as climit]
[app.rpc.mutations.projects :as projects]
[app.rpc.permissions :as perms]
[app.rpc.queries.profile :as profile]
[app.rpc.queries.teams :as teams]
[app.rpc.semaphore :as rsem]
[app.storage :as sto]
[app.tokens :as tokens]
[app.util.services :as sv]
@ -316,13 +316,13 @@
(assoc team :photo-id (:id photo))))
(defn upload-photo
[{:keys [storage semaphores] :as cfg} {:keys [file]}]
[{:keys [storage executor climit] :as cfg} {:keys [file]}]
(letfn [(get-info [content]
(rsem/with-dispatch (:process-image semaphores)
(climit/with-dispatch (:process-image climit)
(media/run {:cmd :info :input content})))
(generate-thumbnail [info]
(rsem/with-dispatch (:process-image semaphores)
(climit/with-dispatch (:process-image climit)
(media/run {:cmd :profile-thumbnail
:format :jpeg
:quality 85
@ -333,7 +333,7 @@
;; Function responsible of calculating cryptographyc hash of
;; the provided data.
(calculate-hash [data]
(rsem/with-dispatch (:process-image semaphores)
(px/with-dispatch executor
(sto/calculate-hash data)))]
(p/let [info (get-info file)
@ -341,11 +341,10 @@
hash (calculate-hash (:data thumb))
content (-> (sto/content (:data thumb) (:size thumb))
(sto/wrap-with-hash hash))]
(rsem/with-dispatch (:process-image semaphores)
(sto/put-object! storage {::sto/content content
::sto/deduplicate? true
:bucket "profile"
:content-type (:mtype thumb)})))))
(sto/put-object! storage {::sto/content content
::sto/deduplicate? true
:bucket "profile"
:content-type (:mtype thumb)}))))
;; --- Mutation: Invite Member

105
backend/src/app/rpc/rlimit.clj
View file

@ -44,7 +44,6 @@
"
(:require
[app.common.data :as d]
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
@ -111,7 +110,7 @@
"m" :minutes
"s" :seconds
"w" :weeks)
::key (dm/str "ratelimit.window." (d/name name))
::key (str "ratelimit.window." (d/name name))
::opts opts})
(ex/raise :type :validation
:code :invalid-window-limit-opts
@ -132,7 +131,7 @@
::interval interval
::opts opts
::params [(dt/->seconds interval) rate capacity]
::key (dm/str "ratelimit.bucket." (d/name name))})
::key (str "ratelimit.bucket." (d/name name))})
(ex/raise :type :validation
:code :invalid-bucket-limit-opts
:hint (str/ffmt "looks like '%' does not have a valid format" opts)))))
@ -140,7 +139,7 @@
(defmethod process-limit :bucket
[redis user-id now {:keys [::key ::params ::service ::capacity ::interval ::rate] :as limit}]
(let [script (-> bucket-rate-limit-script
(assoc ::rscript/keys [(dm/str key "." service "." user-id)])
(assoc ::rscript/keys [(str key "." service "." user-id)])
(assoc ::rscript/vals (conj params (dt/->seconds now))))]
(-> (redis/eval! redis script)
(p/then (fn [result]
@ -165,7 +164,7 @@
(let [ts (dt/truncate now unit)
ttl (dt/diff now (dt/plus ts {unit 1}))
script (-> window-rate-limit-script
(assoc ::rscript/keys [(dm/str key "." service "." user-id "." (dt/format-instant ts))])
(assoc ::rscript/keys [(str key "." service "." user-id "." (dt/format-instant ts))])
(assoc ::rscript/vals [nreq (dt/->seconds ttl)]))]
(-> (redis/eval! redis script)
(p/then (fn [result]
@ -197,67 +196,65 @@
(filter (complement ::lresult/allowed?))
(first))]
(when (and rejected (contains? cf/flags :warn-rpc-rate-limits))
(when rejected
(l/warn :hint "rejected rate limit"
:user-id (dm/str user-id)
:user-id (str user-id)
:limit-service (-> rejected ::service name)
:limit-name (-> rejected ::name name)
:limit-strategy (-> rejected ::strategy name)))
{:enabled? true
:allowed? (some? rejected)
:allowed? (not (some? rejected))
:headers {"x-rate-limit-remaining" remaining
"x-rate-limit-reset" reset}})))))
(defn- handle-response
[f cfg params rres]
(if (:enabled? rres)
(let [headers {"x-rate-limit-remaining" (:remaining rres)
"x-rate-limit-reset" (:reset rres)}]
(when-not (:allowed? rres)
[f cfg params result]
(if (:enabled? result)
(let [headers (:headers result)]
(when-not (:allowed? result)
(ex/raise :type :rate-limit
:code :request-blocked
:hint "rate limit reached"
::http/headers headers))
(-> (f cfg params)
(p/then (fn [response]
(with-meta response
{::http/headers headers})))))
(vary-meta response update ::http/headers merge headers)))))
(f cfg params)))
(defn wrap
[{:keys [rlimit redis] :as cfg} f mdata]
(let [skey (keyword (::rpc/type cfg) (->> mdata ::sv/spec name))
sname (dm/str (::rpc/type cfg) "." (->> mdata ::sv/spec name))
default-rresp (p/resolved {:enabled? false})]
(if (or (contains? cf/flags :rpc-rate-limit)
(contains? cf/flags :soft-rpc-rate-limit))
(if rlimit
(let [skey (keyword (::rpc/type cfg) (->> mdata ::sv/spec name))
sname (str (::rpc/type cfg) "." (->> mdata ::sv/spec name))]
(fn [cfg {:keys [::http/request] :as params}]
(let [user-id (or (:profile-id params)
(some-> request parse-client-ip)
uuid/zero)
(let [uid (or (:profile-id params)
(some-> request parse-client-ip)
uuid/zero)
rresp (when (and user-id @enabled?)
(when-let [limits (get-in @rlimit [::limits skey])]
(let [redis (redis/get-or-connect redis ::rlimit default-options)
limits (map #(assoc % ::service sname) limits)
rresp (-> (process-limits redis user-id limits (dt/now))
(p/catch (fn [cause]
;; If we have an error on processing the
;; rate-limit we just skip it for do not cause
;; service interruption because of redis downtime
;; or similar situation.
(l/error :hint "error on processing rate-limit" :cause cause)
{:enabled? false})))]
rsp (when (and uid @enabled?)
(when-let [limits (or (get-in @rlimit [::limits skey])
(get-in @rlimit [::limits :default]))]
(let [redis (redis/get-or-connect redis ::rlimit default-options)
limits (map #(assoc % ::service sname) limits)
resp (-> (process-limits redis uid limits (dt/now))
(p/catch (fn [cause]
;; If we have an error on processing the rate-limit we just skip
;; it for do not cause service interruption because of redis
;; downtime or similar situation.
(l/error :hint "error on processing rate-limit" :cause cause)
{:enabled? false})))]
;; If soft rate are enabled, we process the rate-limit but return
;; unprotected response.
(and (contains? cf/flags :soft-rpc-rate-limit) rresp))))]
;; If soft rate are enabled, we process the rate-limit but return unprotected
;; response.
(if (contains? cf/flags :soft-rpc-rlimit)
(p/resolved {:enabled? false})
resp))))
(p/then (or rresp default-rresp)
(partial handle-response f cfg params))))
f)))
rsp (or rsp (p/resolved {:enabled? false}))]
(p/then rsp (partial handle-response f cfg params)))))
f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CONFIG WATCHER
@ -376,20 +373,20 @@
(defmethod ig/pre-init-spec :app.rpc/rlimit [_]
(s/keys :req-un [::wrk/executor ::wrk/scheduler]))
(defmethod ig/init-key :app.rpc/rlimit
(defmethod ig/init-key ::rpc/rlimit
[_ {:keys [executor] :as params}]
(let [state (agent {})]
(when (contains? cf/flags :rpc-rlimit)
(let [state (agent {})]
(set-error-handler! state on-refresh-error)
(set-error-mode! state :continue)
(set-error-handler! state on-refresh-error)
(set-error-mode! state :continue)
(when-let [path (get-config-path)]
(l/info :hint "initializing rlimit config reader" :path (str path))
(when-let [path (get-config-path)]
(l/info :hint "initializing rlimit config reader" :path (str path))
;; Initialize the state with initial refresh value
(send-via executor state (constantly {::refresh (dt/duration "5s")}))
;; Initialize the state with initial refresh value
(send-via executor state (constantly {::refresh (dt/duration "5s")}))
;; Force a refresh
(refresh-config (assoc params :path path :state state)))
;; Force a refresh
(refresh-config (assoc params :path path :state state)))
state))
state)))

149
backend/src/app/rpc/semaphore.clj
View file

@ -1,149 +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) KALEIDOS INC
(ns app.rpc.semaphore
"Resource usage limits (in other words: semaphores)."
(:require
[app.common.data :as d]
[app.common.logging :as l]
[app.common.spec :as us]
[app.config :as cf]
[app.metrics :as mtx]
[app.rpc :as-alias rpc]
[app.util.locks :as locks]
[app.util.time :as ts]
[app.worker :as-alias wrk]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.core :as p]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ASYNC SEMAPHORE IMPL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defprotocol IAsyncSemaphore
(acquire! [_])
(release! [_ tp]))
(defn create
[& {:keys [permits metrics name executor]}]
(let [used (volatile! 0)
queue (volatile! (d/queue))
labels (into-array String [(d/name name)])
lock (locks/create)
permits (or permits Long/MAX_VALUE)]
(when (>= permits Long/MAX_VALUE)
(l/warn :hint "permits value too high" :permits permits :semaphore name))
^{::wrk/executor executor
::name name}
(reify IAsyncSemaphore
(acquire! [_]
(let [d (p/deferred)]
(locks/locking lock
(if (< @used permits)
(do
(vswap! used inc)
(p/resolve! d))
(vswap! queue conj d)))
(mtx/run! metrics
:id :semaphore-used-permits
:val @used
:labels labels)
(mtx/run! metrics
:id :semaphore-queued-submissions
:val (count @queue)
:labels labels)
d))
(release! [_ tp]
(locks/locking lock
(if-let [item (peek @queue)]
(do
(vswap! queue pop)
(p/resolve! item))
(when (pos? @used)
(vswap! used dec))))
(mtx/run! metrics
:id :semaphore-timing
:val (inst-ms (tp))
:labels labels)
(mtx/run! metrics
:id :semaphore-used-permits
:val @used
:labels labels)
(mtx/run! metrics
:id :semaphore-queued-submissions
:val (count @queue)
:labels labels)))))
(defn semaphore?
[v]
(satisfies? IAsyncSemaphore v))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PREDEFINED SEMAPHORES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::semaphore semaphore?)
(s/def ::semaphores
(s/map-of ::us/keyword ::semaphore))
(defmethod ig/pre-init-spec ::rpc/semaphores [_]
(s/keys :req-un [::mtx/metrics]))
(defn- create-default-semaphores
[metrics executor]
[(create :permits (cf/get :semaphore-process-font)
:metrics metrics
:name :process-font
:executor executor)
(create :permits (cf/get :semaphore-update-file)
:metrics metrics
:name :update-file
:executor executor)
(create :permits (cf/get :semaphore-process-image)
:metrics metrics
:name :process-image
:executor executor)
(create :permits (cf/get :semaphore-auth)
:metrics metrics
:name :auth
:executor executor)])
(defmethod ig/init-key ::rpc/semaphores
[_ {:keys [metrics executor]}]
(->> (create-default-semaphores metrics executor)
(d/index-by (comp ::name meta))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro with-dispatch
[queue & body]
`(let [tpoint# (ts/tpoint)
queue# ~queue
executor# (-> queue# meta ::wrk/executor)]
(-> (acquire! queue#)
(p/then (fn [_#] ~@body) executor#)
(p/finally (fn [_# _#]
(release! queue# tpoint#))))))
(defn wrap
[{:keys [semaphores]} f {:keys [::queue]}]
(let [queue' (get semaphores queue)]
(if (semaphore? queue')
(fn [cfg params]
(with-dispatch queue'
(f cfg params)))
(do
(when (some? queue)
(l/warn :hint "undefined semaphore" :name queue))
f))))

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

@ -11,19 +11,32 @@
[app.common.data :as d]
[cuerdas.core :as str]))
(defrecord WrappedValue [obj]
;; A utilty wrapper object for wrap service responses that does not
;; implements the IObj interface that make possible attach metadata to
;; it.
(deftype MetadataWrapper [obj ^:unsynchronized-mutable metadata]
clojure.lang.IDeref
(deref [_] obj))
(deref [_] obj)
clojure.lang.IObj
(withMeta [_ meta]
(MetadataWrapper. obj meta))
(meta [_] metadata))
(defn wrap
([]
(WrappedValue. nil))
"Conditionally wrap a value into MetadataWrapper instance. If the
object already implements IObj interface it will be returned as is."
([] (wrap nil))
([o]
(WrappedValue. o)))
(if (instance? clojure.lang.IObj o)
o
(MetadataWrapper. o {}))))
(defn wrapped?
[o]
(instance? WrappedValue o))
(instance? MetadataWrapper o))
(defmacro defmethod
[sname & body]

5
common/deps.edn
View file

@ -4,6 +4,7 @@
org.clojure/tools.cli {:mvn/version "1.0.206"}
metosin/jsonista {:mvn/version "0.3.6"}
org.clojure/clojurescript {:mvn/version "1.11.60"}
org.clojure/test.check {:mvn/version "1.1.1"}
;; Logging
org.apache.logging.log4j/log4j-api {:mvn/version "2.19.0"}
@ -16,12 +17,13 @@
selmer/selmer {:mvn/version "1.12.55"}
criterium/criterium {:mvn/version "0.4.6"}
expound/expound {:mvn/version "0.9.0"}
com.cognitect/transit-clj {:mvn/version "1.0.329"}
com.cognitect/transit-cljs {:mvn/version "0.8.280"}
java-http-clj/java-http-clj {:mvn/version "0.4.3"}
funcool/promesa {:mvn/version "8.0.450"}
funcool/promesa {:mvn/version "9.0.507"}
funcool/cuerdas {:mvn/version "2022.06.16-403"}
lambdaisland/uri {:mvn/version "1.13.95"
@ -41,7 +43,6 @@
{:dev
{:extra-deps
{org.clojure/tools.namespace {:mvn/version "RELEASE"}
org.clojure/test.check {:mvn/version "RELEASE"}
thheller/shadow-cljs {:mvn/version "2.20.2"}
com.bhauman/rebel-readline {:mvn/version "RELEASE"}
criterium/criterium {:mvn/version "RELEASE"}

15
common/dev/user.clj
View file

@ -2,7 +2,7 @@
;; 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
;; Copyright (c) KALEIDOS INC
(ns user
(:require
@ -12,32 +12,33 @@
[clojure.spec.alpha :as s]
[clojure.spec.gen.alpha :as sgen]
[clojure.test :as test]
[clojure.test.check.generators :as gen]
[clojure.tools.namespace.repl :as repl]
[clojure.walk :refer [macroexpand-all]]
[criterium.core :refer [quick-bench bench with-progress-reporting]]))
[criterium.core :as crit]))
;; --- Benchmarking Tools
(defmacro run-quick-bench
[& exprs]
`(with-progress-reporting (quick-bench (do ~@exprs) :verbose)))
`(crit/with-progress-reporting (crit/quick-bench (do ~@exprs) :verbose)))
(defmacro run-quick-bench'
[& exprs]
`(quick-bench (do ~@exprs)))
`(crit/quick-bench (do ~@exprs)))
(defmacro run-bench
[& exprs]
`(with-progress-reporting (bench (do ~@exprs) :verbose)))
`(crit/with-progress-reporting (crit/bench (do ~@exprs) :verbose)))
(defmacro run-bench'
[& exprs]
`(bench (do ~@exprs)))
`(crit/bench (do ~@exprs)))
;; --- Development Stuff
(defn- run-tests
([] (run-tests #"^app.common.*-test$"))
([] (run-tests #"^common-tests.test-.*$"))
([o]
(repl/refresh)
(cond

2
common/scripts/repl
View file

@ -1,7 +1,7 @@
#!/usr/bin/env bash
export PENPOT_FLAGS="enable-asserts enable-audit-log $PENPOT_FLAGS"
export OPTIONS="-A:dev -J-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager -J-XX:+UseG1GC -J-XX:-OmitStackTraceInFastThrow -J-Xms50m -J-Xmx512m";
export OPTIONS="-A:dev -J-Djava.util.logging.manager=org.apache.logging.log4j.jul.LogManager -J-XX:+UseG1GC -J-XX:-OmitStackTraceInFastThrow -J-Xms50m -J-Xmx1024m";
export OPTIONS_EVAL="nil"
# export OPTIONS_EVAL="(set! *warn-on-reflection* true)"

2
common/shadow-cljs.edn
View file

@ -8,7 +8,7 @@
{:target :node-test
:output-to "target/test.js"
:output-dir "target/test/"
:ns-regexp "^app.common.*-test$"
:ns-regexp "^common-tests.test-.*$"
:autorun true
:compiler-options

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

@ -12,7 +12,8 @@
[app.common.geom.point :as gpt]
[app.common.math :as mth]
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
[clojure.spec.alpha :as s]
[clojure.test.check.generators :as tgen]))
(def precision 6)
@ -39,16 +40,6 @@
[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."
([]
@ -56,6 +47,21 @@
([a b c d e f]
(Matrix. a b c d e f)))
(s/def ::a ::us/safe-float)
(s/def ::b ::us/safe-float)
(s/def ::c ::us/safe-float)
(s/def ::d ::us/safe-float)
(s/def ::e ::us/safe-float)
(s/def ::f ::us/safe-float)
(s/def ::matrix-attrs
(s/keys :req-un [::a ::b ::c ::d ::e ::f]))
(s/def ::matrix
(s/with-gen
(s/and ::matrix-attrs matrix?)
#(tgen/fmap map->Matrix (s/gen ::matrix-attrs))))
(def number-regex #"[+-]?\d*(\.\d+)?(e[+-]?\d+)?")
(defn str->matrix

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

@ -13,7 +13,8 @@
:clj [clojure.core :as c])
[app.common.math :as mth]
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
[clojure.spec.alpha :as s]
[clojure.test.check.generators :as tgen]))
;; --- Point Impl
@ -30,8 +31,11 @@
(s/def ::x ::us/safe-number)
(s/def ::y ::us/safe-number)
(s/def ::point-attrs (s/keys :req-un [::x ::y]))
(s/def ::point
(s/and (s/keys :req-un [::x ::y]) point?))
(s/with-gen (s/and ::point-attrs point?)
#(tgen/fmap map->Point (s/gen ::point-attrs))))
(defn point-like?
[{:keys [x y] :as v}]

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

@ -18,6 +18,7 @@
[app.common.exceptions :as ex]
[app.common.uri :as u]
[app.common.uuid :as uuid]
[clojure.test.check.generators :as tgen]
[cuerdas.core :as str]
[expound.alpha :as expound]))
@ -47,7 +48,9 @@
::s/invalid)))
(unformer [v]
(dm/str v))]
(s/def ::uuid (s/conformer conformer unformer)))
(s/def ::uuid
(s/with-gen (s/conformer conformer unformer)
#(tgen/fmap (fn [_] (uuid/random)) tgen/any))))
;; --- SPEC: boolean
@ -61,7 +64,9 @@
::s/invalid)))
(unformer [v]
(if v "true" "false"))]
(s/def ::boolean (s/conformer conformer unformer)))
(s/def ::boolean
(s/with-gen (s/conformer conformer unformer)
(constantly tgen/boolean))))
;; --- SPEC: number
@ -71,7 +76,9 @@
(str/numeric? v) #?(:cljs (js/parseFloat v)
:clj (Double/parseDouble v))
:else ::s/invalid))]
(s/def ::number (s/conformer conformer str)))
(s/def ::number
(s/with-gen (s/conformer conformer str)
#(s/gen ::safe-number))))
;; --- SPEC: integer
@ -84,7 +91,9 @@
:cljs (js/parseInt v 10))
::s/invalid)
:else ::s/invalid))]
(s/def ::integer (s/conformer conformer str)))
(s/def ::integer
(s/with-gen (s/conformer conformer str)
#(s/gen ::safe-integer))))
;; --- SPEC: keyword
@ -96,7 +105,10 @@
(unformer [v]
(name v))]
(s/def ::keyword (s/conformer conformer unformer)))
(s/def ::keyword
(s/with-gen (s/conformer conformer unformer)
#(->> (s/gen ::not-empty-string)
(tgen/fmap keyword)))))
;; --- SPEC: email
@ -110,7 +122,13 @@
(or (parse-email v) ::s/invalid))
(unformer [v]
(dm/str v))]
(s/def ::email (s/conformer conformer unformer)))
(s/def ::email
(s/with-gen (s/conformer conformer unformer)
#(as-> (tgen/let [p1 (s/gen ::not-empty-string)
p2 (s/gen ::not-empty-string)
p3 (tgen/elements ["com" "net"])]
(str p1 "@" p2 "." p3)) $
(tgen/such-that (partial re-matches email-re) $ 50)))))
;; -- SPEC: uri
@ -121,17 +139,34 @@
:else ::s/invalid))
(unformer [v]
(dm/str v))]
(s/def ::uri (s/conformer conformer unformer)))
(s/def ::uri
(s/with-gen (s/conformer conformer unformer)
#(tgen/let [scheme (tgen/elements ["http" "https"])
domain (as-> (s/gen ::not-empty-string) $
(tgen/such-that (fn [x] (> (count x) 5)) $ 100)
(tgen/fmap str/lower $))
ext (tgen/elements ["net" "com" "org" "app" "io"])]
(u/uri (str scheme "://" domain "." ext))))))
;; --- SPEC: color string
(def rgb-color-str-re
#"^#(?:[0-9a-fA-F]{3}){1,2}$")
(letfn [(conformer [v]
(if (and (string? v) (re-matches #"^#(?:[0-9a-fA-F]{3}){1,2}$" v))
(if (and (string? v) (re-matches rgb-color-str-re v))
v
::s/invalid))
(unformer [v]
(dm/str v))]
(s/def ::rgb-color-str (s/conformer conformer unformer)))
(s/def ::rgb-color-str
(s/with-gen (s/conformer conformer unformer)
#(->> tgen/any
(tgen/fmap (fn [_]
#?(:clj (format "%x" (rand-int 16rFFFFFF))
:cljs (.toString (rand-int 16rFFFFFF) 16))))
(tgen/fmap (fn [x]
(str "#" x)))))))
;; --- SPEC: set/vector of Keywords
@ -142,17 +177,19 @@
(keyword? s) s
:else nil)))]
(cond
(set? s) (into dest xform s)
(coll? s) (into dest xform s)
(string? s) (into dest xform (str/words s))
:else ::s/invalid)))
(unformer-fn [v]
(str/join " " (map name v)))]
(s/def ::set-of-keywords
(s/conformer (partial conformer-fn #{}) unformer-fn))
(s/with-gen (s/conformer (partial conformer-fn #{}) unformer-fn)
#(tgen/set (s/gen ::keyword))))
(s/def ::vector-of-keywords
(s/conformer (partial conformer-fn []) unformer-fn)))
(s/with-gen (s/conformer (partial conformer-fn []) unformer-fn)
#(tgen/vector (s/gen ::keyword)))))
;; --- SPEC: set/vector of strings
@ -164,18 +201,18 @@
(letfn [(conformer-fn [dest v]
(cond
(coll? v) (into dest non-empty-strings-xf v)
(string? v) (into dest non-empty-strings-xf (str/split v #"[\s,]+"))
(vector? v) (into dest non-empty-strings-xf v)
(set? v) (into dest non-empty-strings-xf v)
:else ::s/invalid))
(unformer-fn [v]
(str/join "," v))]
(s/def ::set-of-strings
(s/conformer (partial conformer-fn #{}) unformer-fn))
(s/with-gen (s/conformer (partial conformer-fn #{}) unformer-fn)
#(tgen/set (s/gen ::not-empty-string))))
(s/def ::vector-of-strings
(s/conformer (partial conformer-fn []) unformer-fn)))
(s/with-gen (s/conformer (partial conformer-fn []) unformer-fn)
#(tgen/vector (s/gen ::not-empty-string)))))
;; --- SPEC: set-of-valid-emails
@ -192,24 +229,27 @@
:else ::s/invalid))
(unformer [v]
(str/join " " v))]
(s/def ::set-of-valid-emails (s/conformer conformer unformer)))
;; --- SPEC: query-string
(letfn [(conformer [s]
(if (string? s)
(ex/try* #(u/query-string->map s) (constantly ::s/invalid))
s))
(unformer [s]
(u/map->query-string s))]
(s/def ::query-string (s/conformer conformer unformer)))
(s/def ::set-of-valid-emails
(s/with-gen (s/conformer conformer unformer)
#(tgen/set (s/gen ::email)))))
;; --- SPECS WITHOUT CONFORMER
(s/def ::inst inst?)
(s/def ::string string?)
(s/def ::not-empty-string (s/and string? #(not (str/empty? %))))
(s/def ::url string?)
(s/def ::string
(s/with-gen string?
(fn []
(tgen/such-that (fn [o]
(re-matches #"\w+" o))
tgen/string-alphanumeric
50))))
(s/def ::not-empty-string
(s/with-gen (s/and string? #(not (str/empty? %)))
#(tgen/such-that (complement str/empty?) (s/gen ::string))))
(s/def ::url ::string)
(s/def ::fn fn?)
(s/def ::id ::uuid)
@ -231,20 +271,34 @@
:cljs (or (instance? js/Uint8Array x)
(instance? js/ArrayBuffer x)))))
(s/def ::bytes bytes?)
(s/def ::bytes
#?(:clj (s/with-gen bytes? (constantly tgen/bytes))
:cljs bytes?))
(defn safe-number?
[x]
(and (number? x)
(>= x min-safe-int)
(<= x max-safe-int)))
(defn safe-int? [x]
(and (safe-number? x) (int? x)))
(defn safe-float? [x]
(and (safe-number? x) (float? x)))
(s/def ::safe-integer
#(and
(int? %)
(>= % min-safe-int)
(<= % max-safe-int)))
(s/with-gen safe-int? (constantly tgen/small-integer)))
(s/def ::safe-float
(s/with-gen safe-float? #(tgen/double* {:inifinite? false
:NaN? false
:min min-safe-int
:max max-safe-int})))
(s/def ::safe-number
#(and
(or (int? %)
(float? %))
(>= % min-safe-int)
(<= % max-safe-int)))
(s/with-gen safe-number? #(tgen/one-of [(s/gen ::safe-integer)
(s/gen ::safe-float)])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MACROS

20
common/src/app/common/types/color.cljc
View file

@ -27,7 +27,7 @@
(s/def ::color-gradient/end-y ::us/safe-number)
(s/def ::color-gradient/width ::us/safe-number)
(s/def ::color-gradient-stop/color string?)
(s/def ::color-gradient-stop/color ::us/rgb-color-str)
(s/def ::color-gradient-stop/opacity ::us/safe-number)
(s/def ::color-gradient-stop/offset ::us/safe-number)
@ -53,7 +53,7 @@
(s/def ::color-generic/name string?)
(s/def ::color-generic/path (s/nilable string?))
(s/def ::color-generic/value (s/nilable string?))
(s/def ::color-generic/color (s/nilable string?))
(s/def ::color-generic/color (s/nilable ::us/rgb-color-str))
(s/def ::color-generic/opacity (s/nilable ::us/safe-number))
(s/def ::color-generic/gradient (s/nilable ::gradient))
(s/def ::color-generic/ref-id uuid?)
@ -76,10 +76,14 @@
::color-generic/gradient]))
(s/def ::recent-color
(s/keys :opt-un [::color-generic/value
::color-generic/color
::color-generic/opacity
::color-generic/gradient]))
(s/and
(s/keys :opt-un [::color-generic/value
::color-generic/color
::color-generic/opacity
::color-generic/gradient])
(fn [o]
(or (contains? o :gradient)
(contains? o :color)))))
;; --- Helpers for color in different parts of a shape
@ -159,7 +163,7 @@
[shape position color opacity gradient]
(update-in shape [:shadow position :color]
(fn [shadow-color]
(d/without-nils (assoc shadow-color
(d/without-nils (assoc shadow-color
:color color
:opacity opacity
:gradient gradient)))))
@ -190,7 +194,7 @@
[shape position color opacity gradient]
(update-in shape [:grids position :params :color]
(fn [grid-color]
(d/without-nils (assoc grid-color
(d/without-nils (assoc grid-color
:color color
:opacity opacity
:gradient gradient)))))

7
common/src/app/common/types/container.cljc
View file

@ -15,13 +15,12 @@
(s/def ::type #{:page :component})
(s/def ::id uuid?)
(s/def ::name string?)
(s/def ::path (s/nilable string?))
(s/def ::name ::us/string)
(s/def ::path (s/nilable ::us/string))
(s/def ::container
;; (s/keys :req-un [::id ::name ::ctst/objects]
(s/keys :req-un [::id ::name]
:opt-un [::type ::path]))
:opt-un [::type ::path ::ctst/objects]))
(defn make-container
[page-or-component type]

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

@ -37,7 +37,7 @@
(s/coll-of ::ctc/recent-color :kind vector?))
(s/def ::typographies
(s/map-of uuid? :ctst/typography))
(s/map-of uuid? ::cty/typography))
(s/def ::pages
(s/coll-of uuid? :kind vector?))
@ -49,12 +49,13 @@
(s/map-of uuid? ::ctp/page))
(s/def ::components
(s/map-of uuid? ::ctp/container))
(s/map-of uuid? ::ctn/container))
(s/def ::data
(s/keys :req-un [::pages-index
::pages]
:opt-un [::colors
::components
::recent-colors
::typographies
::media]))

3
common/src/app/common/types/page.cljc
View file

@ -8,6 +8,7 @@
(:require
[app.common.data :as d]
[app.common.files.features :as ffeat]
[app.common.spec :as us]
[app.common.types.page.flow :as ctpf]
[app.common.types.page.grid :as ctpg]
[app.common.types.page.guide :as ctpu]
@ -17,7 +18,7 @@
;; --- Background color
(s/def ::background string?)
(s/def ::background ::us/rgb-color-str)
;; --- Page options

193
common/src/app/common/types/shape.cljc
View file

@ -25,18 +25,19 @@
[app.common.types.shape.text :as ctsx]
[app.common.uuid :as uuid]
[clojure.set :as set]
[clojure.spec.alpha :as s]))
[clojure.spec.alpha :as s]
[clojure.test.check.generators :as tgen]))
;; --- Specs
(s/def ::frame-id uuid?)
(s/def ::id uuid?)
(s/def ::name string?)
(s/def ::path (s/nilable string?))
(s/def ::name ::us/string)
(s/def ::path (s/nilable ::us/string))
(s/def ::page-id uuid?)
(s/def ::parent-id uuid?)
(s/def ::string string?)
(s/def ::type keyword?)
(s/def ::string ::us/string)
(s/def ::type #{:frame :text :rect :path :image :circle :group :bool :svg-raw})
(s/def ::uuid uuid?)
(s/def ::component-id uuid?)
@ -54,7 +55,7 @@
(s/def ::blocked boolean?)
(s/def ::collapsed boolean?)
(s/def ::fill-color string?)
(s/def ::fill-color ::us/rgb-color-str)
(s/def ::fill-opacity ::us/safe-number)
(s/def ::fill-color-gradient (s/nilable ::ctc/gradient))
(s/def ::fill-color-ref-file (s/nilable uuid?))
@ -66,10 +67,10 @@
(s/def ::file-thumbnail boolean?)
(s/def ::masked-group? boolean?)
(s/def ::font-family string?)
(s/def ::font-family ::us/string)
(s/def ::font-size ::us/safe-integer)
(s/def ::font-style string?)
(s/def ::font-weight string?)
(s/def ::font-style ::us/string)
(s/def ::font-weight ::us/string)
(s/def ::hidden boolean?)
(s/def ::letter-spacing ::us/safe-number)
(s/def ::line-height ::us/safe-number)
@ -77,7 +78,7 @@
(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 ::us/string)
(s/def ::stroke-color-gradient (s/nilable ::ctc/gradient))
(s/def ::stroke-color-ref-file (s/nilable uuid?))
(s/def ::stroke-color-ref-id (s/nilable uuid?))
@ -120,11 +121,12 @@
(s/every uuid? :kind vector?))
(s/def ::fill
(s/keys :opt-un [::fill-color
::fill-opacity
::fill-color-gradient
::fill-color-ref-file
::fill-color-ref-id]))
(s/and (s/keys :opt-un [::fill-color
::fill-opacity
::fill-color-gradient
::fill-color-ref-file
::fill-color-ref-id])
(comp boolean seq)))
(s/def ::fills
(s/coll-of ::fill :kind vector?))
@ -164,72 +166,70 @@
:color
:luminosity})
(s/def ::shape-base-attrs
(s/keys :opt-un [::id
::name
::component-id
::component-file
::component-root?
::shape-ref
::selrect
::points
::blocked
::collapsed
::fills
::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
::ctsr/rx
::ctsr/ry
::ctsr/r1
::ctsr/r2
::ctsr/r3
::ctsr/r4
::x
::y
::exports
::shapes
::strokes
::text-align
::transform
::transform-inverse
::width
::height
::masked-group?
::ctsi/interactions
::ctss/shadow
::ctsb/blur
::opacity
::blend-mode]))
(s/def ::shape-attrs
(s/and
::ctsl/layout-container-props
::ctsl/layout-child-props
(s/keys :opt-un [::id
::type
::name
::component-id
::component-file
::component-root?
::shape-ref
::selrect
::points
::blocked
::collapsed
::fills
::fill-color ;; TODO: remove these attributes
::fill-opacity ;; when backward compatibility
::fill-color-gradient ;; is no longer needed
::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
::ctsr/rx
::ctsr/ry
::ctsr/r1
::ctsr/r2
::ctsr/r3
::ctsr/r4
::x
::y
::exports
::shapes
::strokes
::stroke-color ;; TODO: same thing
::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?
::ctsi/interactions
::ctss/shadow
::ctsb/blur
::opacity
::blend-mode])))
(s/with-gen
(s/merge
::shape-base-attrs
::ctsl/layout-container-props
::ctsl/layout-child-props
;; For BACKWARD COMPATIBILITY we need to spec fill and stroke
;; attrs as shape toplevel attrs
::fill
::stroke)
#(tgen/let [attrs1 (s/gen ::shape-base-attrs)
attrs2 (s/gen ::ctsl/layout-container-props)
attrs3 (s/gen ::ctsl/layout-child-props)]
(merge attrs1 attrs2 attrs3))))
(defmulti shape-spec :type)
@ -237,26 +237,31 @@
(s/spec ::shape-attrs))
(defmethod shape-spec :text [_]
(s/and ::shape-attrs
(s/keys :opt-un [::ctsx/content
::ctsx/position-data])))
(s/merge ::shape-attrs
(s/keys :opt-un [::ctsx/content
::ctsx/position-data])))
(defmethod shape-spec :path [_]
(s/and ::shape-attrs
(s/keys :opt-un [::ctsp/content])))
(s/merge ::shape-attrs
(s/keys :opt-un [::ctsp/content])))
(defmethod shape-spec :frame [_]
(s/and ::shape-attrs
(s/keys :opt-un [::file-thumbnail
::hide-fill-on-export
::show-content
::hide-in-viewer])))
(s/merge ::shape-attrs
(s/keys :opt-un [::file-thumbnail
::hide-fill-on-export
::show-content
::hide-in-viewer])))
(s/def ::shape
(s/and (s/multi-spec shape-spec :type)
#(contains? % :type)
#(contains? % :name)))
(s/with-gen
(s/merge
(s/keys :req-un [::type ::name])
(s/multi-spec shape-spec :type))
(fn []
(tgen/let [type (s/gen ::type)
name (s/gen ::name)
attrs (s/gen ::shape-attrs)]
(assoc attrs :type type :name name)))))
;; --- Initialization

4
common/src/app/common/types/shape/export.cljc
View file

@ -9,9 +9,9 @@
[app.common.spec :as us]
[clojure.spec.alpha :as s]))
(s/def ::suffix string?)
(s/def ::suffix ::us/string)
(s/def ::scale ::us/safe-number)
(s/def ::type keyword?)
(s/def ::type ::us/keyword)
(s/def ::export
(s/keys :req-un [::type

74
common/src/app/common/types/shape/interactions.cljc
View file

@ -22,12 +22,13 @@
;; -- Options depending on event type
(s/def ::event-type #{:click
:mouse-press
:mouse-over
:mouse-enter
:mouse-leave
:after-delay})
(s/def ::event-type
#{:click
:mouse-press
:mouse-over
:mouse-enter
:mouse-leave
:after-delay})
(s/def ::delay ::us/safe-integer)
@ -40,26 +41,21 @@
(s/keys :req-un []))
(s/def ::event-opts
(s/multi-spec event-opts-spec ::event-type))
(s/multi-spec event-opts-spec :event-type))
;; -- Animation options
(s/def ::animation-type #{:dissolve
:slide
:push})
(s/def ::animation-type #{:dissolve :slide :push})
(s/def ::duration ::us/safe-integer)
(s/def ::easing #{:linear
:ease
:ease-in
:ease-out
:ease-in-out})
(s/def ::way #{:in
:out})
(s/def ::direction #{:right
:left
:up
:down})
(s/def ::way #{:in :out})
(s/def ::direction #{:right :left :up :down})
(s/def ::offset-effect ::us/boolean)
(s/def ::easing
#{:linear
:ease
:ease-in
:ease-out
:ease-in-out})
(defmulti animation-spec :animation-type)
@ -80,26 +76,29 @@
::direction]))
(s/def ::animation
(s/multi-spec animation-spec ::animation-type))
(s/multi-spec animation-spec :animation-type))
;; -- Options depending on action type
(s/def ::action-type #{:navigate
:open-overlay
:toggle-overlay
:close-overlay
:prev-screen
:open-url})
(s/def ::action-type
#{:navigate
:open-overlay
:toggle-overlay
:close-overlay
:prev-screen
:open-url})
(s/def ::overlay-pos-type
#{:manual
:center
:top-left
:top-right
:top-center
:bottom-left
:bottom-right
:bottom-center})
(s/def ::destination (s/nilable ::us/uuid))
(s/def ::overlay-pos-type #{:manual
:center
:top-left
:top-right
:top-center
:bottom-left
:bottom-right
:bottom-center})
(s/def ::overlay-position ::gpt/point)
(s/def ::url ::us/string)
(s/def ::close-click-outside ::us/boolean)
@ -140,7 +139,7 @@
(s/keys :req-un [::url]))
(s/def ::action-opts
(s/multi-spec action-opts-spec ::action-type))
(s/multi-spec action-opts-spec :action-type))
;; -- Interaction
@ -412,6 +411,7 @@
(us/verify (s/nilable ::animation-type) animation-type)
(assert (has-animation? interaction))
(assert (allowed-animation? (:action-type interaction) animation-type))
(if (= (-> interaction :animation :animation-type) animation-type)
interaction
(if (nil? animation-type)

1
common/src/app/common/types/shape/layout.cljc
View file

@ -30,6 +30,7 @@
(s/def ::row-gap ::us/safe-number)
(s/def ::column-gap ::us/safe-number)
(s/def ::layout-type #{:flex :grid})
(s/def ::layout-gap
(s/keys :req-un [::row-gap ::column-gap]))

58
common/test/app/common/data_test.clj
View file

@ -1,58 +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.data-test
(:require
[app.common.data :as d]
[clojure.test :as t]))
(t/deftest concat-vec
(t/is (= [1 2 3]
(d/concat-vec [1] #{2} [3])))
(t/is (= [1 2]
(d/concat-vec '(1) [2])))
(t/is (= [1]
(d/concat-vec [1])))
(t/is (= [] (d/concat-vec))))
(t/deftest concat-set
(t/is (= #{} (d/concat-set)))
(t/is (= #{1 2}
(d/concat-set [1] [2]))))
(t/deftest remove-at-index
(t/is (= [1 2 3 4]
(d/remove-at-index [1 2 3 4 5] 4)))
(t/is (= [1 2 3 4]
(d/remove-at-index [5 1 2 3 4] 0)))
(t/is (= [1 2 3 4]
(d/remove-at-index [1 5 2 3 4] 1)))
)
(t/deftest with-next
(t/is (= [[0 1] [1 2] [2 3] [3 4] [4 nil]]
(d/with-next (range 5)))))
(t/deftest with-prev
(t/is (= [[0 nil] [1 0] [2 1] [3 2] [4 3]]
(d/with-prev (range 5)))))
(t/deftest with-prev-next
(t/is (= [[0 nil 1] [1 0 2] [2 1 3] [3 2 4] [4 3 nil]]
(d/with-prev-next (range 5)))))
(t/deftest join
(t/is (= [[1 :a] [1 :b] [2 :a] [2 :b] [3 :a] [3 :b]]
(d/join [1 2 3] [:a :b])))
(t/is (= [1 10 100 2 20 200 3 30 300]
(d/join [1 2 3] [1 10 100] *))))

4
common/test/app/common/data_test.cljc → common/test/common_tests/test_data.cljc
View file

@ -2,9 +2,9 @@
;; 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
;; Copyright (c) KALEIDOS INC
(ns app.common.data-test
(ns common-tests.test-data
(:require
[app.common.data :as d]
[clojure.test :as t]))

4
common/test/app/common/geom_test.cljc → common/test/common_tests/test_geom.cljc
View file

@ -2,9 +2,9 @@
;; 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
;; Copyright (c) KALEIDOS INC
(ns app.common.geom-test
(ns common-tests.test-geom
(:require
[clojure.test :as t]
[app.common.math :as mth]

4
common/test/app/common/geom_shapes_test.cljc → common/test/common_tests/test_geom_shapes.cljc
View file

@ -2,9 +2,9 @@
;; 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
;; Copyright (c) KALEIDOS INC
(ns app.common.geom-shapes-test
(ns common-tests.test-geom-shapes
(:require
[app.common.geom.matrix :as gmt]
[app.common.geom.point :as gpt]

10
common/test/app/common/test_helpers/components.cljc → common/test/common_tests/test_helpers/components.cljc
View file

@ -1,4 +1,10 @@
(ns app.common.test-helpers.components
;; 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) KALEIDOS INC
(ns common-tests.test-helpers.components
(:require
[clojure.test :as t]
[app.common.pages.helpers :as cph]
@ -136,7 +142,7 @@
[shapes-inst shapes-main component]))
(defn resolve-component
"Get the component with the given id and all its shapes."
"Get the component with the given id and all its shapes."
[page component-id libraries]
(let [component (cph/get-component libraries component-id)
root-main (ctk/get-component-root component)

4
common/test/app/common/test_helpers/files.cljc → common/test/common_tests/test_helpers/files.cljc
View file

@ -2,9 +2,9 @@
;; 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
;; Copyright (c) KALEIDOS INC
(ns app.common.test-helpers.files
(ns common-tests.test-helpers.files
(:require
[app.common.files.features :as ffeat]
[app.common.geom.point :as gpt]

6
common/test/app/common/pages_test.cljc → common/test/common_tests/test_pages.cljc
View file

@ -2,9 +2,9 @@
;; 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
;; Copyright (c) KALEIDOS INC
(ns app.common.pages-test
(ns common-tests.test-pages
(:require
[app.common.files.features :as ffeat]
[app.common.pages :as cp]
@ -438,7 +438,7 @@
:frame-id frame-id
:parent-id frame-id
:id shape-1-id
:obj {:type :shape
:obj {:type :rect
:name "Shape 1"}}
{:type :add-obj
:page-id page-id

4
common/test/app/common/pages_helpers_test.cljc → common/test/common_tests/test_pages_helpers.cljc
View file

@ -2,9 +2,9 @@
;; 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
;; Copyright (c) KALEIDOS INC
(ns app.common.pages-helpers-test
(ns common-tests.test-pages-helpers
(:require
[clojure.test :as t]
[clojure.pprint :refer [pprint]]

4
common/test/app/common/pages_migrations_test.cljc → common/test/common_tests/test_pages_migrations.cljc
View file

@ -2,9 +2,9 @@
;; 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
;; Copyright (c) KALEIDOS INC
(ns app.common.pages-migrations-test
(ns common-tests.test-pages-migrations
(:require
[clojure.test :as t]
[clojure.pprint :refer [pprint]]

2
common/test/app/common/setup_test.cljc → common/test/common_tests/test_setup.cljc
View file

@ -1,4 +1,4 @@
(ns app.common.setup-test
(ns common-tests.test-setup
(:require
[clojure.test :as t]))

8
common/test/app/common/text_test.cljc → common/test/common_tests/test_text.cljc
View file

@ -1,4 +1,10 @@
(ns app.common.text-test
;; 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) KALEIDOS INC
(ns common-tests.test-text
(:require
[app.common.data :as d]
[app.common.text :as txt]

59
common/test/common_tests/test_types.cljc Normal file
View file

@ -0,0 +1,59 @@
;; 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) KALEIDOS INC
(ns common-tests.test-types
(:require
[clojure.spec.alpha :as s]
[clojure.test :as t]
[clojure.test.check.clojure-test :refer [defspec]]
[clojure.test.check.generators :as gen]
[clojure.test.check.properties :as props]
[app.common.spec :as us]
[app.common.transit :as transit]
[app.common.types.shape :as cts]
[app.common.types.page :as ctp]
[app.common.types.file :as ctf]))
(defspec transit-encode-decode-with-shape 30
(props/for-all
[fdata (s/gen ::cts/shape)]
(let [res (-> fdata transit/encode-str transit/decode-str)]
(t/is (= res fdata)))))
(defspec types-shape-spec 10
(props/for-all
[fdata (s/gen ::cts/shape)]
(t/is (us/valid? ::cts/shape fdata))))
(defspec types-page-spec 10
(props/for-all
[fdata (s/gen ::ctp/page)]
(t/is (us/valid? ::ctp/page fdata))))
(defspec types-file-colors-spec 30
(props/for-all
[fdata (s/gen ::ctf/colors)]
(t/is (us/valid? ::ctf/colors fdata))))
(defspec types-file-recent-colors-spec 30
(props/for-all
[fdata (s/gen ::ctf/recent-colors)]
(t/is (us/valid? ::ctf/recent-colors fdata))))
(defspec types-file-typographies-spec 30
(props/for-all
[fdata (s/gen ::ctf/typographies)]
(t/is (us/valid? ::ctf/typographies fdata))))
(defspec types-file-media-spec 30
(props/for-all
[fdata (s/gen ::ctf/media)]
(t/is (us/valid? ::ctf/media fdata))))
(defspec types-file-components-spec 10
(props/for-all
[fdata (s/gen ::ctf/components)]
(t/is (us/valid? ::ctf/components fdata))))

41
common/test/app/common/types/file_test.cljc → common/test/common_tests/test_types_file.cljc
View file

@ -2,29 +2,28 @@
;; 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
;; Copyright (c) KALEIDOS INC
(ns app.common.types.file-test
(ns common-tests.test-types-file
(:require
;; Uncomment to debug
;; [clojure.pprint :refer [pprint]]
;; [cuerdas.core :as str]
[clojure.test :as t]
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.common.text :as txt]
[app.common.types.colors-list :as ctcl]
[app.common.types.component :as ctk]
[app.common.types.components-list :as ctkl]
[app.common.types.container :as ctn]
[app.common.types.file :as ctf]
[app.common.types.pages-list :as ctpl]
[app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst]
[app.common.types.typographies-list :as ctyl]
[app.common.uuid :as uuid]
[app.common.test-helpers.files :as thf]
[app.common.test-helpers.components :as thk]))
[app.common.data :as d]
[app.common.geom.point :as gpt]
[app.common.text :as txt]
[app.common.types.colors-list :as ctcl]
[app.common.types.component :as ctk]
[app.common.types.components-list :as ctkl]
[app.common.types.container :as ctn]
[app.common.types.file :as ctf]
[app.common.types.pages-list :as ctpl]
[app.common.types.shape :as cts]
[app.common.types.shape-tree :as ctst]
[app.common.types.typographies-list :as ctyl]
[app.common.uuid :as uuid]
[clojure.pprint :refer [pprint]]
[clojure.test :as t]
[common-tests.test-helpers.components :as thk]
[common-tests.test-helpers.files :as thf]
[cuerdas.core :as str]))
(t/use-fixtures :each thf/reset-idmap!)

11
common/test/app/common/types/shape/spec_interactions_test.cljc → common/test/common_tests/test_types_shape_interactions.cljc
View file

@ -2,17 +2,17 @@
;; 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
;; Copyright (c) KALEIDOS INC
(ns app.common.types.shape.spec-interactions-test
(ns common-tests.test-types-shape-interactions
(:require
[clojure.test :as t]
[clojure.pprint :refer [pprint]]
[app.common.exceptions :as ex]
[app.common.geom.point :as gpt]
[app.common.types.shape :as cts]
[app.common.types.shape.interactions :as ctsi]
[app.common.uuid :as uuid]
[app.common.geom.point :as gpt]))
[clojure.pprint :refer [pprint]]
[clojure.test :as t]))
(t/deftest set-event-type
(let [interaction ctsi/default-interaction
@ -497,7 +497,6 @@
(t/is (= :down (:direction a-up')))
(t/is (= :up (:direction a-down')))))))
(t/deftest option-offset-effect
(let [i1 ctsi/default-interaction
i2 (ctsi/set-animation-type ctsi/default-interaction :slide)

22
common/test/app/common/uuid_test.cljc → common/test/common_tests/test_uuid.cljc
View file

@ -2,26 +2,22 @@
;; 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
;; Copyright (c) KALEIDOS INC
(ns app.common.uuid-test
(ns common-tests.test-uuid
(:require
[app.common.spec :as us]
[app.common.uuid :as uuid]
[clojure.spec.alpha :as s]
[clojure.test :as t]
[clojure.test.check.clojure-test :refer (defspec)]
[clojure.test.check.clojure-test :refer [defspec]]
[clojure.test.check.generators :as gen]
[clojure.test.check.properties :as props]))
(def uuid-gen
(->> gen/large-integer (gen/fmap (fn [_] (uuid/next)))))
(defspec non-repeating-uuid-next-1 100000
(defspec non-repeating-uuid-next-1 5000
(props/for-all
[uuid1 uuid-gen
uuid2 uuid-gen
uuid3 uuid-gen
uuid4 uuid-gen
uuid5 uuid-gen]
(t/is (not= uuid1 uuid2 uuid3 uuid4 uuid5))))
[uuid1 (s/gen ::us/uuid)
uuid2 (s/gen ::us/uuid)]
(t/is (not= uuid1 uuid2))))