0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-03-14 16:51:18 -05:00

♻️ Refactor general resource and concurrency model on backend

This commit is contained in:
Andrey Antukh 2022-02-18 18:01:21 +01:00 committed by Alonso Torres
parent d24f16563f
commit 7cf27ac86d
32 changed files with 917 additions and 797 deletions

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,6 +104,10 @@
(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)
@ -114,6 +116,9 @@
(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)
@ -136,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)
@ -207,8 +214,13 @@
::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
@ -231,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

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,19 +61,39 @@
(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 read-only] :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)]
(when-not read-only
@ -85,16 +104,6 @@
[_ 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)]
@ -111,22 +120,19 @@
"SET idle_in_transaction_session_timeout = 300000;"))
(defn- create-datasource-config
[{:keys [metrics read-only] :or {read-only false} :as cfg}]
(let [dburi (:uri cfg)
username (:username cfg)
password (:password cfg)
config (HikariConfig.)]
[{:keys [metrics uri] :as cfg}]
(let [config (HikariConfig.)]
(doto config
(.setJdbcUrl (str "jdbc:" dburi))
(.setJdbcUrl (str "jdbc:" uri))
(.setPoolName (d/name (:name cfg)))
(.setAutoCommit true)
(.setReadOnly read-only)
(.setConnectionTimeout (:connection-timeout cfg 10000)) ;; 10seg
(.setValidationTimeout (:validation-timeout cfg 10000)) ;; 10seg
(.setIdleTimeout 120000) ;; 2min
(.setMaxLifetime 1800000) ;; 30min
(.setMinimumIdle (:min-pool-size cfg 0))
(.setMaximumPoolSize (:max-pool-size cfg 50))
(.setReadOnly (:read-only cfg))
(.setConnectionTimeout (:connection-timeout cfg))
(.setValidationTimeout (:validation-timeout cfg))
(.setIdleTimeout (:idle-timeout cfg))
(.setMaxLifetime (:max-lifetime cfg))
(.setMinimumIdle (:min-size cfg))
(.setMaximumPoolSize (:max-size cfg))
(.setConnectionInitSql initsql)
(.setInitializationFailTimeout -1))
@ -136,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))

View file

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

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}))
@ -69,29 +72,38 @@
:body ""}))))
(defn- generic-handler
[{:keys [storage] :as cfg} _request id]
(let [obj (sto/get-object storage id)]
[{:keys [storage executor] :as cfg} request kf]
(async/with-dispatch executor
(let [id (get-in request [:path-params :id])
mobj (get-file-media-object storage id)
obj (sto/get-object storage (kf mobj))]
(if obj
(serve-object cfg obj)
{:status 404 :body ""}))))
(defn objects-handler
[{:keys [storage executor] :as cfg} request respond raise]
(-> (async/with-dispatch executor
(let [id (get-in request [:path-params :id])
id (coerce-id id)
obj (sto/get-object storage id)]
(if obj
(serve-object cfg obj)
{:status 404 :body ""})))
(defn objects-handler
[cfg request]
(let [id (get-in request [:path-params :id])]
(generic-handler cfg request (coerce-id id))))
(p/then respond)
(p/catch raise)))
(defn file-objects-handler
[{:keys [storage] :as cfg} request]
(let [id (get-in request [:path-params :id])
mobj (get-file-media-object storage id)]
(generic-handler cfg request (:media-id mobj))))
[cfg request respond raise]
(-> (generic-handler cfg request :media-id)
(p/then respond)
(p/catch raise)))
(defn file-thumbnails-handler
[{:keys [storage] :as cfg} request]
(let [id (get-in request [:path-params :id])
mobj (get-file-media-object storage id)]
(generic-handler cfg request (or (:thumbnail-id mobj) (:media-id mobj)))))
[cfg request respond raise]
(-> (generic-handler cfg request #(or (:thumbnail-id %) (:media-id %)))
(p/then respond)
(p/catch raise)))
;; --- Initialization
@ -101,10 +113,16 @@
(s/def ::signature-max-age ::dt/duration)
(defmethod ig/pre-init-spec ::handlers [_]
(s/keys :req-un [::storage ::mtx/metrics ::assets-path ::cache-max-age ::signature-max-age]))
(s/keys :req-un [::storage
::wrk/executor
::mtx/metrics
::assets-path
::cache-max-age
::signature-max-age]))
(defmethod ig/init-key ::handlers
[_ cfg]
{:objects-handler #(objects-handler cfg %)
:file-objects-handler #(file-objects-handler cfg %)
:file-thumbnails-handler #(file-thumbnails-handler cfg %)})
{:objects-handler (partial objects-handler cfg)
:file-objects-handler (partial file-objects-handler cfg)
:file-thumbnails-handler (partial file-thumbnails-handler cfg)})

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)})

View file

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

View file

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

View file

@ -21,7 +21,8 @@
[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]))
(defn- build-redirect-uri
[{:keys [provider] :as cfg}]
@ -213,7 +214,10 @@
(redirect-response uri))))
(defn- auth-handler
[{:keys [tokens] :as cfg} {:keys [params] :as request}]
[{:keys [tokens executors] :as cfg} {:keys [params] :as request} respond _]
(px/run!
(:default executors)
(fn []
(let [invitation (:invitation-token params)
props (extract-utm-props params)
state (tokens :generate
@ -222,19 +226,23 @@
:props props
:exp (dt/in-future "15m")})
uri (build-auth-uri cfg state)]
(respond
{:status 200
:body {:redirect-uri uri}}))
:body {:redirect-uri uri}})))))
(defn- callback-handler
[cfg request]
[{:keys [executors] :as cfg} request respond _]
(px/run!
(:default executors)
(fn []
(try
(let [info (retrieve-info cfg request)
profile (retrieve-profile cfg info)]
(generate-redirect cfg request info profile))
(catch Exception e
(l/warn :hint "error on oauth process"
:cause e)
(generate-error-redirect cfg e))))
(respond (generate-redirect cfg request info profile)))
(catch Exception cause
(l/warn :hint "error on oauth process" :cause cause)
(respond (generate-error-redirect cfg cause)))))))
;; --- INIT
@ -250,15 +258,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]

View file

@ -134,13 +134,13 @@
(defn- middleware
[events-ch store handler]
(fn [request]
(fn [request respond raise]
(if-let [{:keys [id profile-id] :as session} (retrieve-from-request store request)]
(do
(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
@ -150,7 +150,8 @@
(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 tokens] :as cfg}]
@ -164,7 +165,7 @@
(-> cfg
(assoc ::events-ch events-ch)
(assoc :middleware #(middleware events-ch store %))
(assoc :middleware (partial middleware events-ch store))
(assoc :create (fn [profile-id]
(fn [request response]
(let [token (create-session store request profile-id)]
@ -207,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"
@ -228,6 +224,7 @@
:hint "update sessions"
:reason (name reason)
:count result))
(recur))))))
(defn- update-sessions

View file

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

View file

@ -21,8 +21,32 @@
: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 120)
: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-monitor
{:executors
{:default (ig/ref [::default :app.worker/executor])
:blocking (ig/ref [::blocking :app.worker/executor])
:worker (ig/ref [::worker :app.worker/executor])}
:metrics (ig/ref :app.metrics/metrics)}
:app.migrations/migrations
{}
@ -60,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,7 +97,10 @@
{:port (cf/get :http-server-port)
:host (cf/get :http-server-host)
:router (ig/ref :app.http/router)
:metrics (ig/ref :app.metrics/metrics)}
:metrics (ig/ref :app.metrics/metrics)
:max-threads (cf/get :http-server-max-threads)
:min-threads (cf/get :http-server-min-threads)}
:app.http/router
{:assets (ig/ref :app.http.assets/handlers)
@ -91,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)}
@ -103,6 +130,7 @@
{: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})}
@ -125,22 +153,19 @@
: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
{:default (ig/ref [::default :app.worker/executor])
:blocking (ig/ref [::blocking :app.worker/executor])}}
: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
@ -254,11 +279,11 @@
:app.loggers.audit/http-handler
{:pool (ig/ref :app.db/pool)
:executor (ig/ref :app.worker/executor)}
:executor (ig/ref [::default :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)
@ -272,27 +297,18 @@
: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)

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,54 @@
: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-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 +143,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 +193,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 +206,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 +247,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 +259,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)

View file

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

View file

@ -13,25 +13,42 @@
[app.db :as db]
[app.loggers.audit :as audit]
[app.metrics :as mtx]
[app.util.retry :as retry]
[app.util.rlimit :as rlimit]
[app.rpc.retry :as retry]
[app.rpc.rlimit :as rlimit]
[app.util.async :as async]
[app.util.services :as sv]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[integrant.core :as ig]))
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px]))
(defn- default-handler
[_]
(ex/raise :type :not-found))
(p/rejected (ex/error :type :not-found)))
(defn- run-hook
[hook-fn response]
(ex/ignoring (hook-fn))
(defn- handle-response-transformation
[response request mdata]
(if-let [transform-fn (:transform-response mdata)]
(transform-fn request response)
response))
(defn- handle-before-comple-hook
[response mdata]
(when-let [hook-fn (:before-complete mdata)]
(ex/ignoring (hook-fn)))
response)
(defn- rpc-query-handler
[methods {:keys [profile-id session-id] :as request}]
(let [type (keyword (get-in request [:path-params :type]))
"Ring handler that dispatches query requests and convert between
internal async flow into ring async flow."
[methods {:keys [profile-id session-id] :as request} respond raise]
(letfn [(handle-response [result]
(let [mdata (meta result)]
(-> {:status 200 :body result}
(handle-response-transformation request mdata))))]
(let [type (keyword (get-in request [:path-params :type]))
data (merge (:params request)
(:body-params request)
(:uploads request)
@ -41,15 +58,24 @@
(assoc data :profile-id profile-id ::session-id session-id)
(dissoc data :profile-id))
result ((get methods type default-handler) data)
mdata (meta result)]
;; Get the method from methods registry and if method does
;; not exists asigns it to the default handler.
method (get methods type default-handler)]
(cond->> {:status 200 :body result}
(fn? (:transform-response mdata))
((:transform-response mdata) request))))
(-> (method data)
(p/then #(respond (handle-response %)))
(p/catch raise)))))
(defn- rpc-mutation-handler
[methods {:keys [profile-id session-id] :as request}]
"Ring handler that dispatches mutation requests and convert between
internal async flow into ring async flow."
[methods {:keys [profile-id session-id] :as request} respond raise]
(letfn [(handle-response [result]
(let [mdata (meta result)]
(-> {:status 200 :body result}
(handle-response-transformation request mdata)
(handle-before-comple-hook mdata))))]
(let [type (keyword (get-in request [:path-params :type]))
data (merge (:params request)
(:body-params request)
@ -60,51 +86,64 @@
(assoc data :profile-id profile-id ::session-id session-id)
(dissoc data :profile-id))
result ((get methods type default-handler) data)
mdata (meta result)]
(cond->> {:status 200 :body result}
(fn? (:transform-response mdata))
((:transform-response mdata) request)
method (get methods type default-handler)]
(fn? (:before-complete mdata))
(run-hook (:before-complete mdata)))))
(-> (method data)
(p/then #(respond (handle-response %)))
(p/catch raise)))))
(defn- wrap-with-metrics
[cfg f mdata]
(mtx/wrap-summary f (::mobj cfg) [(::sv/name mdata)]))
(defn- wrap-metrics
"Wrap service method with metrics measurement."
[{:keys [metrics ::metrics-id]} f mdata]
(let [labels (into-array String [(::sv/name mdata)])]
(fn [cfg params]
(let [start (System/nanoTime)]
(p/finally
(f cfg params)
(fn [_ _]
(mtx/run! metrics
{:id metrics-id
:val (/ (- (System/nanoTime) start) 1000000)
:labels labels})))))))
(defn- wrap-impl
[{:keys [audit] :as cfg} f mdata]
(let [f (as-> f $
(rlimit/wrap-rlimit cfg $ mdata)
(retry/wrap-retry cfg $ mdata)
(wrap-with-metrics cfg $ mdata))
spec (or (::sv/spec mdata) (s/spec any?))
auth? (:auth mdata true)]
(l/trace :action "register" :name (::sv/name mdata))
(defn- wrap-dispatch
"Wraps service method into async flow, with the ability to dispatching
it to a preconfigured executor service."
[{:keys [executors] :as cfg} f mdata]
(let [dname (::async/dispatch mdata :none)]
(if (= :none dname)
(with-meta
(fn [params]
;; Raise authentication error when rpc method requires auth but
;; no profile-id is found in the request.
(when (and auth? (not (uuid? (:profile-id params))))
(ex/raise :type :authentication
:code :authentication-required
:hint "authentication required for this endpoint"))
(fn [cfg params]
(try
(p/wrap (f cfg params))
(catch Throwable cause
(p/rejected cause))))
mdata)
(let [params' (dissoc params ::request)
params' (us/conform spec params')
result (f cfg params')]
(let [executor (get executors dname)]
(when-not executor
(ex/raise :type :internal
:code :executor-not-configured
:hint (format "executor %s not configured" dname)))
(with-meta
(fn [cfg params]
(-> (px/submit! executor #(f cfg params))
(p/bind p/wrap)))
mdata)))))
;; When audit log is enabled (default false).
(when (fn? audit)
(defn- wrap-audit
[{:keys [audit] :as cfg} f mdata]
(if audit
(with-meta
(fn [cfg {:keys [::request] :as params}]
(p/finally (f cfg params)
(fn [result _]
(when result
(let [resultm (meta result)
request (::request params)
profile-id (or (:profile-id params')
profile-id (or (:profile-id params)
(:profile-id result)
(::audit/profile-id resultm))
props (d/merge params' (::audit/props resultm))]
props (d/merge params (::audit/props resultm))]
(audit :cmd :submit
:type (or (::audit/type resultm)
(::type cfg))
@ -112,25 +151,46 @@
(::sv/name mdata))
:profile-id profile-id
:ip-addr (audit/parse-client-ip request)
:props props)))
result))
:props (dissoc props ::request)))))))
mdata)
f))
(defn- wrap
[cfg f mdata]
(let [f (as-> f $
(wrap-dispatch cfg $ mdata)
(rlimit/wrap-rlimit cfg $ mdata)
(retry/wrap-retry cfg $ mdata)
(wrap-audit cfg $ mdata)
(wrap-metrics cfg $ mdata)
)
spec (or (::sv/spec mdata) (s/spec any?))
auth? (:auth mdata true)]
(l/trace :action "register" :name (::sv/name mdata))
(with-meta
(fn [{:keys [::request] :as params}]
;; Raise authentication error when rpc method requires auth but
;; no profile-id is found in the request.
(when (and auth? (not (uuid? (:profile-id params))))
(ex/raise :type :authentication
:code :authentication-required
:hint "authentication required for this endpoint"))
(let [params (us/conform spec (dissoc params ::request))]
(f cfg (assoc params ::request request))))
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
@ -143,13 +203,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
@ -169,15 +223,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)}))

View file

@ -12,8 +12,8 @@
[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]))
@ -34,8 +34,7 @@
(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]

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]
@ -272,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)
@ -307,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))

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)

View file

@ -10,10 +10,13 @@
[app.common.media :as cm]
[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.rpc.rlimit :as rlimit]
[app.storage :as sto]
[app.util.async :as async]
[app.util.http :as http]
[app.util.services :as sv]
[app.util.time :as dt]
@ -47,6 +50,8 @@
:opt-un [::id]))
(sv/defmethod ::upload-file-media-object
{::rlimit/permits (cf/get :rlimit-image)
::async/dispatch :default}
[{:keys [pool] :as cfg} {:keys [profile-id file-id] :as params}]
(let [file (select-file pool file-id)]
(teams/check-edition-permissions! pool profile-id (:team-id file))
@ -167,6 +172,8 @@
: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}]
(let [file (select-file pool file-id)]
(teams/check-edition-permissions! pool profile-id (:team-id file))

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
@ -122,10 +122,11 @@
:code :email-as-password
:hint "you can't use your email as password"))
(let [params (assoc params
(let [params {:email (:email params)
:invitation-token (:invitation-token params)
:backend "penpot"
:iss :prepared-register
:exp (dt/in-future "48h"))
:exp (dt/in-future "48h")}
token (tokens :generate params)]
{:token token}))
@ -142,16 +143,8 @@
(-> (assoc cfg :conn conn)
(register-profile params))))
(defn- annotate-profile-register
"A helper for properly increase the profile-register metric once the
transaction is completed."
[metrics]
(fn []
(let [mobj (get-in metrics [:definitions :profile-register])]
((::mtx/fn mobj) {:by 1}))))
(defn register-profile
[{:keys [conn tokens session metrics] :as cfg} {:keys [token] :as params}]
[{:keys [conn tokens session] :as cfg} {:keys [token] :as params}]
(let [claims (tokens :verify {:token token :iss :prepared-register})
params (merge params claims)]
@ -177,7 +170,6 @@
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)}))
@ -187,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)})
@ -196,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)})
@ -219,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
@ -359,6 +348,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)]

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]

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)})))

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

View file

@ -0,0 +1,52 @@
;; 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]
(prn "wrap-retry" "run" retry)
(try
(-> (f cfg params)
(p/catch (partial handle-error retry)))
(catch Throwable cause
(prn cause)
(throw cause))))
(handle-error [retry cause]
(prn "FOOFOFOF" retry (matches 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))

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))

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

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))

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))

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))

View file

@ -22,37 +22,83 @@
[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 2500}}]
(letfn [(log-stats [scheduler]
(doseq [[key ^ForkJoinPool executor] executors]
(let [labels (into-array String [(name key)])]
(mtx/run! metrics {:id :executors-active-threads
:labels labels
:val (.getPoolSize executor)})
(mtx/run! metrics {:id :executors-running-threads
:labels labels
:val (.getRunningThreadCount executor)})
(mtx/run! metrics {:id :executors-queued-submissions
:labels labels
:val (.getQueuedSubmissionCount executor)})))
(when-not (.isShutdown scheduler)
(px/schedule! scheduler interval (partial log-stats scheduler))))]
(let [scheduler (px/scheduled-pool 1)]
(px/schedule! scheduler interval (partial log-stats scheduler))
scheduler)))
(defmethod ig/halt-key! ::executors-monitor
[_ instance]
(.shutdown ^ExecutorService instance))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Worker
@ -60,7 +106,6 @@
(declare event-loop-fn)
(declare event-loop)
(declare instrument-tasks)
(s/def ::queue keyword?)
(s/def ::parallelism ::us/integer)
@ -420,11 +465,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]
@ -460,59 +500,27 @@
;; --- INSTRUMENTATION
(defn instrument!
[registry]
(mtx/instrument-vars!
[#'submit!]
{:registry registry
:type :counter
:labels ["name"]
:name "tasks_submit_total"
:help "A counter of task submissions."
:wrap (fn [rootf mobj]
(let [mdata (meta rootf)
origf (::original mdata rootf)]
(with-meta
(fn [conn params]
(let [tname (:name params)]
(mobj :inc [tname])
(origf conn params)))
{::original origf})))})
(mtx/instrument-vars!
[#'app.worker/run-task]
{:registry registry
:type :summary
:quantiles []
:name "tasks_checkout_timing"
:help "Latency measured between scheduled_at and execution time."
:wrap (fn [rootf mobj]
(let [mdata (meta rootf)
origf (::original mdata rootf)]
(with-meta
(fn [tasks item]
(let [now (inst-ms (dt/now))
sat (inst-ms (:scheduled-at item))]
(mobj :observe (- now sat))
(origf tasks item)))
{::original origf})))}))
(defn- wrap-task-handler
[metrics tname f]
(let [labels (into-array String [tname])]
(fn [params]
(let [start (System/nanoTime)]
(try
(f params)
(finally
(mtx/run! metrics
{:id :tasks-timing
:val (/ (- (System/nanoTime) start) 1000000)
:labels labels})))))))
(defmethod ig/pre-init-spec ::registry [_]
(s/keys :req-un [::mtx/metrics ::tasks]))
(defmethod ig/init-key ::registry
[_ {:keys [metrics tasks]}]
(let [mobj (mtx/create
{:registry (:registry metrics)
:type :summary
:labels ["name"]
:quantiles []
:name "tasks_timing"
:help "Background task execution timing."})]
(reduce-kv (fn [res k v]
(let [tname (name k)]
(l/debug :action "register task" :name tname)
(assoc res k (mtx/wrap-summary v mobj [tname]))))
(l/debug :hint "register task" :name tname)
(assoc res k (wrap-task-handler metrics tname v))))
{}
tasks)))
tasks))

View file

@ -248,7 +248,7 @@
[expr]
`(try
{:error nil
:result ~expr}
:result (deref ~expr)}
(catch Exception e#
{:error (handle-error e#)
:result nil})))

View file

@ -21,7 +21,7 @@
com.cognitect/transit-cljs {:mvn/version "0.8.269"}
java-http-clj/java-http-clj {:mvn/version "0.4.3"}
funcool/promesa {:mvn/version "6.1.431"}
funcool/promesa {:mvn/version "7.0.444"}
funcool/cuerdas {:mvn/version "2022.01.14-391"}
lambdaisland/uri {:mvn/version "1.13.95"

View file

@ -37,6 +37,22 @@
#?(:cljs (instance? lks/LinkedSet o)
:clj (instance? LinkedSet o)))
#?(:clj
(defmethod print-method clojure.lang.PersistentQueue [q, w]
;; Overload the printer for queues so they look like fish
(print-method '<- w)
(print-method (seq q) w)
(print-method '-< w)))
(defn queue
([] #?(:clj clojure.lang.PersistentQueue/EMPTY :cljs #queue []))
([a] (into (queue) [a]))
([a & more] (into (queue) (cons a more))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data Structures Manipulation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn deep-merge
([a b]
(if (map? a)
@ -45,10 +61,6 @@
([a b & rest]
(reduce deep-merge a (cons b rest))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data Structures Manipulation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn dissoc-in
[m [k & ks]]
(if ks
@ -151,7 +163,11 @@
"Given a map, return a map removing key-value
pairs when value is `nil`."
[data]
(into {} (remove (comp nil? second) data)))
(into {} (remove (comp nil? second)) data))
(defn without-qualified
[data]
(into {} (remove (comp qualified-keyword? first)) data))
(defn without-keys
"Return a map without the keys provided
@ -676,3 +692,4 @@
(recur acc (step k))
acc)))
acc))))))