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

Merge branch 'staging'

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

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

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

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

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

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

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

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

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

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

@ -26,25 +26,30 @@
(defmethod ig/init-key ::handler
[_ cfg]
(fn [request]
(let [body (parse-json (slurp (:body request)))
mtype (get body "Type")]
(cond
(= mtype "SubscriptionConfirmation")
(let [surl (get body "SubscribeURL")
stopic (get body "TopicArn")]
(l/info :action "subscription received" :topic stopic :url surl)
(http/send! {:uri surl :method :post :timeout 10000}))
(fn [request respond _]
(try
(let [body (parse-json (slurp (:body request)))
mtype (get body "Type")]
(cond
(= mtype "SubscriptionConfirmation")
(let [surl (get body "SubscribeURL")
stopic (get body "TopicArn")]
(l/info :action "subscription received" :topic stopic :url surl)
(http/send! {:uri surl :method :post :timeout 10000}))
(= mtype "Notification")
(when-let [message (parse-json (get body "Message"))]
(let [notification (parse-notification cfg message)]
(process-report cfg notification)))
(= mtype "Notification")
(when-let [message (parse-json (get body "Message"))]
(let [notification (parse-notification cfg message)]
(process-report cfg notification)))
:else
(l/warn :hint "unexpected data received"
:report (pr-str body)))
{:status 200 :body ""})))
:else
(l/warn :hint "unexpected data received"
:report (pr-str body))))
(catch Throwable cause
(l/error :hint "unexpected exception on awsns handler"
:cause cause)))
(respond {:status 200 :body ""})))
(defn- parse-bounce
[data]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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