Penpot/penpot
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2025-04-03 10:31:38 -05:00
Code Issues Activity

♻️ Refactor cocurrency model on backend

Browse source 
Mainly the followin changes:

- Pass majority of code to the old and plain synchronous style
  and start using virtual threads for the RPC (and partially some
  HTTP server middlewares).
- Make some improvements on how CLIMIT is handled, simplifying code
- Improve considerably performance reducing the reflection and
  unnecesary funcion calls on the whole stack-trace of an RPC call.
- Improve efficiency reducing considerably the total threads number.
This commit is contained in:
Andrey Antukh 2023-03-02 16:57:28 +01:00
parent 2e717882f1
commit aafbf6bc15
47 changed files with 1409 additions and 1477 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
backend/deps.edn
View file

@ -1,4 +1,7 @@
{:deps
{:mvn/repos
{"sonatype" {:url "https://oss.sonatype.org/content/repositories/snapshots/"}}
:deps
{penpot/common {:local/root "../common"}
org.clojure/clojure {:mvn/version "1.11.1"}
org.clojure/core.async {:mvn/version "1.6.673"}
@ -19,14 +22,16 @@
java-http-clj/java-http-clj {:mvn/version "0.4.3"}
funcool/yetti
{:git/tag "v9.13"
:git/sha "e2d25db"
{:git/tag "v9.15"
:git/sha "aa9b967"
:git/url "https://github.com/funcool/yetti.git"
:exclusions [org.slf4j/slf4j-api]}
com.github.seancorfield/next.jdbc {:mvn/version "1.3.847"}
metosin/reitit-core {:mvn/version "0.5.18"}
org.postgresql/postgresql {:mvn/version "42.5.2"}
org.postgresql/postgresql {:mvn/version "42.6.0-SNAPSHOT"}
com.zaxxer/HikariCP {:mvn/version "5.0.1"}
io.whitfin/siphash {:mvn/version "2.0.0"}

21
backend/resources/climit.edn
View file

@ -1,9 +1,14 @@
;; Example climit.edn file
;; Required: concurrency
;; Optional: queue-size, ommited means Integer/MAX_VALUE
{:update-file {:concurrency 1 :queue-size 3}
:auth {:concurrency 128}
:process-font {:concurrency 4 :queue-size 32}
:process-image {:concurrency 8 :queue-size 32}
:push-audit-events
{:concurrency 1 :queue-size 3}}
;; Required: permits
;; Optional: queue, ommited means Integer/MAX_VALUE
;; Optional: timeout, ommited means no timeout
;; Note: queue and timeout are excluding
{:update-file-by-id {:permits 1 :queue 3}
:update-file {:permits 20}
:derive-password {:permits 8}
:process-font {:permits 4 :queue 32}
:process-image {:permits 8 :queue 32}
:submit-audit-events-by-profile
{:permits 1 :queue 3}}

9
backend/resources/rlimit.edn
View file

@ -3,8 +3,9 @@
{:default
[[:default :window "200000/h"]]
#{:command/get-teams}
[[:burst :bucket "5/1/5s"]]
;; #{:command/get-teams}
;; [[:burst :bucket "5/5/5s"]]
#{:command/get-profile}
[[:burst :bucket "60/60/1m"]]}
;; #{:command/get-profile}
;; [[:burst :bucket "60/60/1m"]]
}

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

@ -17,7 +17,6 @@
[app.config :as cf]
[app.db :as db]
[app.http.client :as http]
[app.http.middleware :as hmw]
[app.http.session :as session]
[app.loggers.audit :as audit]
[app.main :as-alias main]
@ -25,14 +24,11 @@
[app.tokens :as tokens]
[app.util.json :as json]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.set :as set]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px]
[yetti.response :as yrs]))
[yetti.response :as-alias yrs]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HELPERS
@ -166,20 +162,22 @@
(defn- retrieve-github-email
[cfg tdata info]
(or (some-> info :email p/resolved)
(->> (http/req! cfg
{:uri "https://api.github.com/user/emails"
:headers {"Authorization" (dm/str (:type tdata) " " (:token tdata))}
:timeout 6000
:method :get})
(p/map (fn [{:keys [status body] :as response}]
(when-not (s/int-in-range? 200 300 status)
(ex/raise :type :internal
:code :unable-to-retrieve-github-emails
:hint "unable to retrieve github emails"
:http-status status
:http-body body))
(->> response :body json/decode (filter :primary) first :email))))))
(or (some-> info :email)
(let [params {:uri "https://api.github.com/user/emails"
:headers {"Authorization" (dm/str (:type tdata) " " (:token tdata))}
:timeout 6000
:method :get}
{:keys [status body]} (http/req! cfg params {:sync? true})]
(when-not (s/int-in-range? 200 300 status)
(ex/raise :type :internal
:code :unable-to-retrieve-github-emails
:hint "unable to retrieve github emails"
:http-status status
:http-body body))
(->> body json/decode (filter :primary) first :email))))
(defmethod ig/pre-init-spec ::providers/github [_]
(s/keys :req [::http/client]))
@ -290,80 +288,74 @@
:grant-type (:grant_type params)
:redirect-uri (:redirect_uri params))
(->> (http/req! cfg req)
(p/map (fn [{:keys [status body] :as res}]
(l/trace :hint "access token response"
:status status
:body body)
(if (= status 200)
(let [data (json/decode body)]
{:token (get data :access_token)
:type (get data :token_type)})
(ex/raise :type :internal
:code :unable-to-retrieve-token
:http-status status
:http-body body)))))))
(let [{:keys [status body]} (http/req! cfg req {:sync? true})]
(l/trace :hint "access token response" :status status :body body)
(if (= status 200)
(let [data (json/decode body)]
{:token (get data :access_token)
:type (get data :token_type)})
(ex/raise :type :internal
:code :unable-to-retrieve-token
:hint "unable to retrieve token"
:http-status status
:http-body body)))))
(defn- retrieve-user-info
[{:keys [provider] :as cfg} tdata]
(letfn [(retrieve []
(l/trace :hint "request user info"
:uri (:user-uri provider)
:token (obfuscate-string (:token tdata))
:token-type (:type tdata))
(http/req! cfg
{:uri (:user-uri provider)
:headers {"Authorization" (str (:type tdata) " " (:token tdata))}
:timeout 6000
:method :get}))
(validate-response [response]
(l/trace :hint "user info response"
:status (:status response)
:body (:body response))
(when-not (s/int-in-range? 200 300 (:status response))
(ex/raise :type :internal
:code :unable-to-retrieve-user-info
:hint "unable to retrieve user info"
:http-status (:status response)
:http-body (:body response)))
response)
(get-email [info]
(letfn [(get-email [info]
;; Allow providers hook into this for custom email
;; retrieval method.
(if-let [get-email-fn (:get-email-fn provider)]
(get-email-fn tdata info)
(let [attr-kw (cf/get :oidc-email-attr :email)]
(p/resolved (get info attr-kw)))))
(get info attr-kw))))
(get-name [info]
(let [attr-kw (cf/get :oidc-name-attr :name)]
(get info attr-kw)))
(process-response [response]
(p/let [info (-> response :body json/decode)
email (get-email info)]
(let [info (-> response :body json/decode)
email (get-email info)]
{:backend (:name provider)
:email email
:fullname (or (get-name info) email)
:props (->> (dissoc info :name :email)
(qualify-props provider))}))
(qualify-props provider))}))]
(validate-info [info]
(l/trace :hint "authentication info" :info info)
(when-not (s/valid? ::info info)
(l/warn :hint "received incomplete profile info object (please set correct scopes)"
:info (pr-str info))
(ex/raise :type :internal
:code :incomplete-user-info
:hint "inconmplete user info"
:info info))
info)]
(l/trace :hint "request user info"
:uri (:user-uri provider)
:token (obfuscate-string (:token tdata))
:token-type (:type tdata))
(->> (retrieve)
(p/fmap validate-response)
(p/mcat process-response)
(p/fmap validate-info))))
(let [request {:uri (:user-uri provider)
:headers {"Authorization" (str (:type tdata) " " (:token tdata))}
:timeout 6000
:method :get}
response (http/req! cfg request {:sync? true})]
(l/trace :hint "user info response"
:status (:status response)
:body (:body response))
(when-not (s/int-in-range? 200 300 (:status response))
(ex/raise :type :internal
:code :unable-to-retrieve-user-info
:hint "unable to retrieve user info"
:http-status (:status response)
:http-body (:body response)))
(let [info (process-response response)]
(l/trace :hint "authentication info" :info info)
(when-not (s/valid? ::info info)
(l/warn :hint "received incomplete profile info object (please set correct scopes)" :info info)
(ex/raise :type :internal
:code :incomplete-user-info
:hint "inconmplete user info"
:info info))
info))))
(s/def ::backend ::us/not-empty-string)
(s/def ::email ::us/not-empty-string)
@ -377,61 +369,55 @@
(defn get-info
[{:keys [provider] :as cfg} {:keys [params] :as request}]
(letfn [(validate-oidc [info]
;; If the provider is OIDC, we can proceed to check
;; roles if they are defined.
(when (and (= "oidc" (:name provider))
(seq (:roles provider)))
(let [provider-roles (into #{} (:roles provider))
profile-roles (let [attr (cf/get :oidc-roles-attr :roles)
roles (get info attr)]
(cond
(string? roles) (into #{} (str/words roles))
(vector? roles) (into #{} roles)
:else #{}))]
(when-let [error (get params :error)]
(ex/raise :type :internal
:code :error-on-retrieving-code
:error-id error
:error-desc (get params :error_description)))
;; check if profile has a configured set of roles
(when-not (set/subset? provider-roles profile-roles)
(ex/raise :type :internal
:code :unable-to-auth
:hint "not enough permissions"))))
info)
(let [state (get params :state)
code (get params :code)
state (tokens/verify (::main/props cfg) {:token state :iss :oauth})
token (retrieve-access-token cfg code)
info (retrieve-user-info cfg token)]
(post-process [state info]
(cond-> info
(some? (:invitation-token state))
(assoc :invitation-token (:invitation-token state))
;; If the provider is OIDC, we can proceed to check
;; roles if they are defined.
(when (and (= "oidc" (:name provider))
(seq (:roles provider)))
(let [provider-roles (into #{} (:roles provider))
profile-roles (let [attr (cf/get :oidc-roles-attr :roles)
roles (get info attr)]
(cond
(string? roles) (into #{} (str/words roles))
(vector? roles) (into #{} roles)
:else #{}))]
;; If state token comes with props, merge them. The state token
;; props can contain pm_ and utm_ prefixed query params.
(map? (:props state))
(update :props merge (:props state))))]
;; check if profile has a configured set of roles
(when-not (set/subset? provider-roles profile-roles)
(ex/raise :type :internal
:code :unable-to-auth
:hint "not enough permissions"))))
(when-let [error (get params :error)]
(ex/raise :type :internal
:code :error-on-retrieving-code
:error-id error
:error-desc (get params :error_description)))
(cond-> info
(some? (:invitation-token state))
(assoc :invitation-token (:invitation-token state))
(let [state (get params :state)
code (get params :code)
state (tokens/verify (::main/props cfg) {:token state :iss :oauth})]
(-> (p/resolved code)
(p/then #(retrieve-access-token cfg %))
(p/then #(retrieve-user-info cfg %))
(p/then' validate-oidc)
(p/then' (partial post-process state))))))
;; If state token comes with props, merge them. The state token
;; props can contain pm_ and utm_ prefixed query params.
(map? (:props state))
(update :props merge (:props state)))))
(defn- get-profile
[{:keys [::db/pool ::wrk/executor] :as cfg} info]
(px/with-dispatch executor
(with-open [conn (db/open pool)]
(some->> (:email info)
(profile/get-profile-by-email conn)))))
[{:keys [::db/pool] :as cfg} info]
(dm/with-open [conn (db/open pool)]
(some->> (:email info)
(profile/get-profile-by-email conn))))
(defn- redirect-response
[uri]
(yrs/response :status 302 :headers {"location" (str uri)}))
{::yrs/status 302
::yrs/headers {"location" (str uri)}})
(defn- generate-error-redirect
[_ error]
@ -458,11 +444,11 @@
(ex/raise :type :restriction
:code :profile-blocked))
(audit/submit! cfg {:type "command"
:name "login-with-password"
:profile-id (:id profile)
:ip-addr (audit/parse-client-ip request)
:props (audit/profile->props profile)})
(audit/submit! cfg {::audit/type "command"
::audit/name "login-with-oidc"
::audit/profile-id (:id profile)
::audit/ip-addr (audit/parse-client-ip request)
::audit/props (audit/profile->props profile)})
(->> (redirect-response uri)
(sxf request)))
@ -478,6 +464,7 @@
uri (-> (u/uri (cf/get :public-uri))
(assoc :path "/#/auth/register/validate")
(assoc :query (u/map->query-string params)))]
(redirect-response uri))))
(defn- auth-handler
@ -489,27 +476,24 @@
:props props
:exp (dt/in-future "4h")})
uri (build-auth-uri cfg state)]
(yrs/response 200 {:redirect-uri uri})))
{::yrs/status 200
::yrs/body {:redirect-uri uri}}))
(defn- callback-handler
[cfg request]
(letfn [(process-request []
(p/let [info (get-info cfg request)
profile (get-profile cfg info)]
(generate-redirect cfg request info profile)))
(handle-error [cause]
(l/error :hint "error on oauth process" :cause cause)
(generate-error-redirect cfg cause))]
(-> (process-request)
(p/catch handle-error))))
(try
(let [info (get-info cfg request)
profile (get-profile cfg info)]
(generate-redirect cfg request info profile))
(catch Throwable cause
(l/error :hint "error on oauth process" :cause cause)
(generate-error-redirect cfg cause))))
(def provider-lookup
{:compile
(fn [& _]
(fn [handler]
(fn [{:keys [::providers] :as cfg} request]
(fn [handler {:keys [::providers] :as cfg}]
(fn [request]
(let [provider (some-> request :path-params :provider keyword)]
(if-let [provider (get providers provider)]
(handler (assoc cfg :provider provider) request)
@ -553,18 +537,15 @@
[_]
(s/keys :req [::session/manager
::http/client
::wrk/executor
::main/props
::db/pool
::providers]))
(defmethod ig/init-key ::routes
[_ {:keys [::wrk/executor] :as cfg}]
[_ cfg]
(let [cfg (update cfg :provider d/without-nils)]
["" {:middleware [[session/authz cfg]
[hmw/with-dispatch executor]
[hmw/with-config cfg]
[provider-lookup]]}
[provider-lookup cfg]]}
["/auth/oauth"
["/:provider"
{:handler auth-handler

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

@ -19,19 +19,21 @@
[app.http.middleware :as mw]
[app.http.session :as session]
[app.http.websocket :as-alias ws]
[app.main :as-alias main]
[app.metrics :as mtx]
[app.rpc :as-alias rpc]
[app.rpc.doc :as-alias rpc.doc]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.exec :as px]
[reitit.core :as r]
[reitit.middleware :as rr]
[yetti.adapter :as yt]
[yetti.request :as yrq]
[yetti.response :as yrs]))
[yetti.response :as-alias yrs]))
(declare wrap-router)
(declare router-handler)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HTTP SERVER
@ -65,19 +67,22 @@
::wrk/executor]))
(defmethod ig/init-key ::server
[_ {:keys [::handler ::router ::host ::port ::wrk/executor] :as cfg}]
[_ {:keys [::handler ::router ::host ::port] :as cfg}]
(l/info :hint "starting http server" :port port :host host)
(let [options {:http/port port
:http/host host
:http/max-body-size (::max-body-size cfg)
:http/max-multipart-body-size (::max-multipart-body-size cfg)
:xnio/io-threads (::io-threads cfg)
:xnio/dispatch executor
:xnio/io-threads (or (::io-threads cfg)
(max 3 (px/get-available-processors)))
:xnio/worker-threads (or (::worker-threads cfg)
(max 6 (px/get-available-processors)))
:xnio/dispatch true
:ring/async true}
handler (cond
(some? router)
(wrap-router router)
(router-handler router)
(some? handler)
handler
@ -97,32 +102,35 @@
(defn- not-found-handler
[_ respond _]
(respond (yrs/response 404)))
(respond {::yrs/status 404}))
(defn- wrap-router
(defn- router-handler
[router]
(letfn [(handler [request respond raise]
(letfn [(resolve-handler [request]
(if-let [match (r/match-by-path router (yrq/path request))]
(let [params (:path-params match)
result (:result match)
handler (or (:handler result) not-found-handler)
request (assoc request :path-params params)]
(handler request respond raise))
(not-found-handler request respond raise)))
(partial handler request))
(partial not-found-handler request)))
(on-error [cause request respond]
(on-error [cause request]
(let [{:keys [body] :as response} (errors/handle cause request)]
(respond
(cond-> response
(map? body)
(-> (update :headers assoc "content-type" "application/transit+json")
(assoc :body (t/encode-str body {:type :json-verbose})))))))]
(cond-> response
(map? body)
(-> (update ::yrs/headers assoc "content-type" "application/transit+json")
(assoc ::yrs/body (t/encode-str body {:type :json-verbose}))))))]
(fn [request respond _]
(try
(handler request respond #(on-error % request respond))
(catch Throwable cause
(on-error cause request respond))))))
(let [handler (resolve-handler request)
exchange (yrq/exchange request)]
(handler
(fn [response]
(yt/dispatch! exchange (partial respond response)))
(fn [cause]
(let [response (on-error cause request)]
(yt/dispatch! exchange (partial respond response)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HTTP ROUTER
@ -130,11 +138,11 @@
(defmethod ig/pre-init-spec ::router [_]
(s/keys :req [::session/manager
::actoken/manager
::ws/routes
::rpc/routes
::rpc.doc/routes
::oidc/routes
::main/props
::assets/routes
::debug/routes
::db/pool
@ -151,7 +159,8 @@
[session/soft-auth cfg]
[actoken/soft-auth cfg]
[mw/errors errors/handle]
[mw/restrict-methods]]}
[mw/restrict-methods]
[mw/with-dispatch :vthread]]}
(::mtx/routes cfg)
(::assets/routes cfg)

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

@ -7,26 +7,12 @@
(ns app.http.access-token
(:require
[app.common.logging :as l]
[app.common.spec :as us]
[app.config :as cf]
[app.db :as db]
[app.main :as-alias main]
[app.tokens :as tokens]
[app.worker :as-alias wrk]
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px]
[yetti.request :as yrq]))
(s/def ::manager
(s/keys :req [::db/pool ::wrk/executor ::main/props]))
(defmethod ig/pre-init-spec ::manager [_] ::manager)
(defmethod ig/init-key ::manager [_ cfg] cfg)
(defmethod ig/halt-key! ::manager [_ _])
(def header-re #"^Token\s+(.*)")
(defn- get-token
@ -48,40 +34,32 @@
(db/decode-pgarray #{})))))
(defn- wrap-soft-auth
[handler {:keys [::manager]}]
(us/assert! ::manager manager)
"Soft Authentication, will be executed synchronously on the undertow
worker thread."
[handler {:keys [::main/props]}]
(letfn [(handle-request [request]
(try
(let [token (get-token request)
claims (decode-token props token)]
(cond-> request
(map? claims)
(assoc ::id (:tid claims))))
(catch Throwable cause
(l/trace :hint "exception on decoding malformed token" :cause cause)
request)))]
(let [{:keys [::wrk/executor ::main/props]} manager]
(fn [request respond raise]
(let [token (get-token request)]
(->> (px/submit! executor (partial decode-token props token))
(p/fnly (fn [claims cause]
(when cause
(l/trace :hint "exception on decoding malformed token" :cause cause))
(let [request (cond-> request
(map? claims)
(assoc ::id (:tid claims)))]
(handler request respond raise)))))))))
(let [request (handle-request request)]
(handler request respond raise)))))
(defn- wrap-authz
[handler {:keys [::manager]}]
(us/assert! ::manager manager)
(let [{:keys [::wrk/executor ::db/pool]} manager]
(fn [request respond raise]
(if-let [token-id (::id request)]
(->> (px/submit! executor (partial get-token-perms pool token-id))
(p/fnly (fn [perms cause]
(cond
(some? cause)
(raise cause)
(nil? perms)
(handler request respond raise)
:else
(let [request (assoc request ::perms perms)]
(handler request respond raise))))))
(handler request respond raise)))))
"Authorization middleware, will be executed synchronously on vthread."
[handler {:keys [::db/pool]}]
(fn [request]
(let [perms (some->> (::id request) (get-token-perms pool))]
(handler (cond-> request
(some? perms)
(assoc ::perms perms))))))
(def soft-auth
{:name ::soft-auth

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

@ -18,7 +18,7 @@
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.core :as p]
[yetti.response :as yrs]))
[yetti.response :as-alias yrs]))
(def ^:private cache-max-age
(dt/duration {:hours 24}))
@ -28,10 +28,9 @@
(defn get-id
[{:keys [path-params]}]
(if-let [id (some-> path-params :id d/parse-uuid)]
(p/resolved id)
(p/rejected (ex/error :type :not-found
:hunt "object not found"))))
(or (some-> path-params :id d/parse-uuid)
(ex/raise :type :not-found
:hunt "object not found")))
(defn- get-file-media-object
[pool id]
@ -46,9 +45,8 @@
"x-host" (cond-> host port (str ":" port))
"x-mtype" (:content-type mdata)
"cache-control" (str "max-age=" (inst-ms cache-max-age))}]
(yrs/response
:status 307
:headers headers)))))))
{::yrs/status 307
::yrs/headers headers}))))))
(defn- serve-object-from-fs
[{:keys [::path]} obj]
@ -59,7 +57,8 @@
"content-type" (:content-type mdata)
"cache-control" (str "max-age=" (inst-ms cache-max-age))}]
(p/resolved
(yrs/response :status 204 :headers headers))))
{::yrs/status 204
::yrs/headers headers})))
(defn- serve-object
"Helper function that returns the appropriate response depending on
@ -72,15 +71,14 @@
(defn objects-handler
"Handler that servers storage objects by id."
[{:keys [::sto/storage ::wrk/executor] :as cfg} request respond raise]
[{:keys [::sto/storage ::wrk/executor] :as cfg} request]
(->> (get-id request)
(p/mcat executor (fn [id] (sto/get-object storage id)))
(p/mcat executor (fn [obj]
(if (some? obj)
(serve-object cfg obj)
(p/resolved (yrs/response 404)))))
(p/fnly executor (fn [result cause]
(if cause (raise cause) (respond result))))))
(p/resolved {::yrs/status 404}))))
(p/await!)))
(defn- generic-handler
"A generic handler helper/common code for file-media based handlers."
@ -92,22 +90,18 @@
(p/mcat executor (fn [sobj]
(if sobj
(serve-object cfg sobj)
(p/resolved (yrs/response 404))))))))
(p/resolved {::yrs/status 404})))))))
(defn file-objects-handler
"Handler that serves storage objects by file media id."
[cfg request respond raise]
(->> (generic-handler cfg request :media-id)
(p/fnly (fn [result cause]
(if cause (raise cause) (respond result))))))
[cfg request]
(p/await! (generic-handler cfg request :media-id)))
(defn file-thumbnails-handler
"Handler that serves storage objects by thumbnail-id and quick
fallback to file-media-id if no thumbnail is available."
[cfg request respond raise]
(->> (generic-handler cfg request #(or (:thumbnail-id %) (:media-id %)))
(p/fnly (fn [result cause]
(if cause (raise cause) (respond result))))))
[cfg request]
(p/await! (generic-handler cfg request #(or (:thumbnail-id %) (:media-id %)))))
;; --- Initialization

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

@ -21,7 +21,7 @@
[jsonista.core :as j]
[promesa.exec :as px]
[yetti.request :as yrq]
[yetti.response :as yrs]))
[yetti.response :as-alias yrs]))
(declare parse-json)
(declare handle-request)
@ -39,7 +39,7 @@
(letfn [(handler [request respond _]
(let [data (-> request yrq/body slurp)]
(px/run! executor #(handle-request cfg data)))
(respond (yrs/response 200)))]
(respond {::yrs/status 200}))]
["/sns" {:handler handler
:allowed-methods #{:post}}]))

25
backend/src/app/http/client.clj
View file

@ -40,12 +40,25 @@
(catch Throwable cause
(p/rejected cause))))))
(defn- resolve-client
[params]
(cond
(instance? HttpClient params)
params
(map? params)
(resolve-client (::client params))
:else
(throw (UnsupportedOperationException. "invalid arguments"))))
(defn req!
"A convencience toplevel function for gradual migration to a new API
convention."
([{:keys [::client]} request]
(us/assert! ::client client)
(send! client request {}))
([{:keys [::client]} request options]
(us/assert! ::client client)
(send! client request options)))
([cfg-or-client request]
(let [client (resolve-client cfg-or-client)]
(send! client request {})))
([cfg-or-client request options]
(let [client (resolve-client cfg-or-client)]
(send! client request options))))

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

@ -13,7 +13,6 @@
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.http.middleware :as mw]
[app.http.session :as session]
[app.rpc.commands.binfile :as binf]
[app.rpc.commands.files-create :refer [create-file]]
@ -21,7 +20,6 @@
[app.util.blob :as blob]
[app.util.template :as tmpl]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.io :as io]
@ -48,13 +46,17 @@
(defn prepare-response
[body]
(let [headers {"content-type" "application/transit+json"}]
(yrs/response :status 200 :body body :headers headers)))
{::yrs/status 200
::yrs/body body
::yrs/headers headers}))
(defn prepare-download-response
[body filename]
(let [headers {"content-disposition" (str "attachment; filename=" filename)
"content-type" "application/octet-stream"}]
(yrs/response :status 200 :body body :headers headers)))
{::yrs/status 200
::yrs/body body
::yrs/headers headers}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INDEX
@ -65,10 +67,10 @@
(when-not (authorized? pool request)
(ex/raise :type :authentication
:code :only-admins-allowed))
(yrs/response :status 200
:headers {"content-type" "text/html"}
:body (-> (io/resource "app/templates/debug.tmpl")
(tmpl/render {}))))
{::yrs/status 200
::yrs/headers {"content-type" "text/html"}
::yrs/body (-> (io/resource "app/templates/debug.tmpl")
(tmpl/render {}))})
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FILE CHANGES
@ -115,7 +117,8 @@
:project-id project-id
:profile-id profile-id
:data data})
(yrs/response 201 "OK CREATED"))
{::yrs/status 201
::yrs/body "OK CREATED"})
:else
(prepare-response (blob/decode data))))))
@ -143,7 +146,8 @@
(db/update! pool :file
{:data (blob/encode data)}
{:id file-id})
(yrs/response 200 "OK UPDATED"))
{::yrs/status 200
::yrs/body "OK UPDATED"})
(do
(create-file pool {:id file-id
@ -151,9 +155,11 @@
:project-id project-id
:profile-id profile-id
:data data})
(yrs/response 201 "OK CREATED"))))
{::yrs/status 201
::yrs/body "OK CREATED"})))
(yrs/response 500 "ERROR"))))
{::yrs/status 500
::yrs/body "ERROR"})))
(defn file-data-handler
[cfg request]
@ -241,11 +247,12 @@
(let [result (if (= 1 (:version report))
(render-template-v1 report)
(render-template-v2 report))]
(yrs/response :status 200
:body result
:headers {"content-type" "text/html; charset=utf-8"
"x-robots-tag" "noindex"}))
(yrs/response 404 "not found"))))
{::yrs/status 200
::yrs/body result
::yrs/headers {"content-type" "text/html; charset=utf-8"
"x-robots-tag" "noindex"}})
{::yrs/status 404
::yrs/body "not found"})))
(def sql:error-reports
"SELECT id, created_at,
@ -261,11 +268,11 @@
:code :only-admins-allowed))
(let [items (->> (db/exec! pool [sql:error-reports])
(map #(update % :created-at dt/format-instant :rfc1123)))]
(yrs/response :status 200
:body (-> (io/resource "app/templates/error-list.tmpl")
(tmpl/render {:items items}))
:headers {"content-type" "text/html; charset=utf-8"
"x-robots-tag" "noindex"})))
{::yrs/status 200
::yrs/body (-> (io/resource "app/templates/error-list.tmpl")
(tmpl/render {:items items}))
::yrs/headers {"content-type" "text/html; charset=utf-8"
"x-robots-tag" "noindex"}}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; EXPORT/IMPORT
@ -301,16 +308,15 @@
::binf/profile-id profile-id
::binf/project-id project-id))
(yrs/response
:status 200
:headers {"content-type" "text/plain"}
:body "OK CLONED"))
{::yrs/status 200
::yrs/headers {"content-type" "text/plain"}
::yrs/body "OK CLONED"})
{::yrs/status 200
::yrs/body (io/input-stream path)
::yrs/headers {"content-type" "application/octet-stream"
"content-disposition" (str "attachmen; filename=" (first file-ids) ".penpot")}}))))
(yrs/response
:status 200
:headers {"content-type" "application/octet-stream"
"content-disposition" (str "attachmen; filename=" (first file-ids) ".penpot")}
:body (io/input-stream path))))))
(defn import-handler
@ -340,10 +346,9 @@
::binf/profile-id profile-id
::binf/project-id project-id))
(yrs/response
:status 200
:headers {"content-type" "text/plain"}
:body "OK")))
{::yrs/status 200
::yrs/headers {"content-type" "text/plain"}
::yrs/body "OK"}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OTHER SMALL VIEWS/HANDLERS
@ -354,11 +359,13 @@
[{:keys [::db/pool]} _]
(try
(db/exec-one! pool ["select count(*) as count from server_prop;"])
(yrs/response 200 "OK")
{::yrs/status 200
::yrs/body "OK"}
(catch Throwable cause
(l/warn :hint "unable to execute query on health handler"
:cause cause)
(yrs/response 503 "KO"))))
{::yrs/status 503
::yrs/body "KO"})))
(defn changelog-handler
[_ _]
@ -367,10 +374,11 @@
(md->html [text]
(md/md-to-html-string text :replacement-transformers (into [transform-emoji] mdt/transformer-vector)))]
(if-let [clog (io/resource "changelog.md")]
(yrs/response :status 200
:headers {"content-type" "text/html; charset=utf-8"}
:body (-> clog slurp md->html))
(yrs/response :status 404 :body "NOT FOUND"))))
{::yrs/status 200
::yrs/headers {"content-type" "text/html; charset=utf-8"}
::yrs/body (-> clog slurp md->html)}
{::yrs/status 404
::yrs/body "NOT FOUND"})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INIT
@ -380,33 +388,26 @@
{:compile
(fn [& _]
(fn [handler pool]
(fn [request respond raise]
(fn [request]
(if (authorized? pool request)
(handler request respond raise)
(raise (ex/error :type :authentication
:code :only-admins-allowed))))))})
(handler request)
(ex/raise :type :authentication
:code :only-admins-allowed)))))})
(defmethod ig/pre-init-spec ::routes [_]
(s/keys :req [::db/pool
::wrk/executor
::session/manager]))
(s/keys :req [::db/pool ::session/manager]))
(defmethod ig/init-key ::routes
[_ {:keys [::db/pool ::wrk/executor] :as cfg}]
[["/readyz" {:middleware [[mw/with-dispatch executor]
[mw/with-config cfg]]
:handler health-handler}]
[_ {:keys [::db/pool] :as cfg}]
[["/readyz" {:handler (partial health-handler cfg)}]
["/dbg" {:middleware [[session/authz cfg]
[with-authorization pool]
[mw/with-dispatch executor]
[mw/with-config cfg]]}
["" {:handler index-handler}]
["/health" {:handler health-handler}]
["/changelog" {:handler changelog-handler}]
;; ["/error-by-id/:id" {:handler error-handler}]
["/error/:id" {:handler error-handler}]
["/error" {:handler error-list-handler}]
["/file/export" {:handler export-handler}]
["/file/import" {:handler import-handler}]
["/file/data" {:handler file-data-handler}]
["/file/changes" {:handler file-changes-handler}]]])
[with-authorization pool]]}
["" {:handler (partial index-handler cfg)}]
["/health" {:handler (partial health-handler cfg)}]
["/changelog" {:handler (partial changelog-handler cfg)}]
["/error/:id" {:handler (partial error-handler cfg)}]
["/error" {:handler (partial error-list-handler cfg)}]
["/file/export" {:handler (partial export-handler cfg)}]
["/file/import" {:handler (partial import-handler cfg)}]
["/file/data" {:handler (partial file-data-handler cfg)}]
["/file/changes" {:handler (partial file-changes-handler cfg)}]]])

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

@ -46,20 +46,30 @@
(defmethod handle-exception :authentication
[err _]
(yrs/response 401 (ex-data err)))
{::yrs/status 401
::yrs/body (ex-data err)})
(defmethod handle-exception :authorization
[err _]
(yrs/response 403 (ex-data err)))
{::yrs/status 403
::yrs/body (ex-data err)})
(defmethod handle-exception :restriction
[err _]
(yrs/response 400 (ex-data err)))
{::yrs/status 400
::yrs/body (ex-data err)})
(defmethod handle-exception :rate-limit
[err _]
(let [headers (-> err ex-data ::http/headers)]
(yrs/response :status 429 :body "" :headers headers)))
{::yrs/status 429
::yrs/headers headers}))
(defmethod handle-exception :concurrency-limit
[err _]
(let [headers (-> err ex-data ::http/headers)]
{::yrs/status 429
::yrs/headers headers}))
(defmethod handle-exception :validation
[err _]
@ -67,16 +77,16 @@
(cond
(= code :spec-validation)
(let [explain (ex/explain data)]
(yrs/response :status 400
:body (-> data
(dissoc ::s/problems ::s/value)
(cond-> explain (assoc :explain explain)))))
{::yrs/status 400
::yrs/body (-> data
(dissoc ::s/problems ::s/value)
(cond-> explain (assoc :explain explain)))})
(= code :request-body-too-large)
(yrs/response :status 413 :body data)
{::yrs/status 413 ::yrs/body data}
:else
(yrs/response :status 400 :body data))))
{::yrs/status 400 ::yrs/body data})))
(defmethod handle-exception :assertion
[error request]
@ -84,31 +94,27 @@
explain (ex/explain edata)]
(binding [l/*context* (request->context request)]
(l/error :hint "Assertion error" :message (ex-message error) :cause error)
(yrs/response :status 500
:body {:type :server-error
:code :assertion
:data (-> edata
(dissoc ::s/problems ::s/value ::s/spec)
(cond-> explain (assoc :explain explain)))}))))
{::yrs/status 500
::yrs/body {:type :server-error
:code :assertion
:data (-> edata
(dissoc ::s/problems ::s/value ::s/spec)
(cond-> explain (assoc :explain explain)))}})))
(defmethod handle-exception :not-found
[err _]
(yrs/response 404 (ex-data err)))
{::yrs/status 404
::yrs/body (ex-data err)})
(defmethod handle-exception :internal
[error request]
(let [{:keys [code] :as edata} (ex-data error)]
(cond
(= :concurrency-limit-reached code)
(yrs/response 429)
:else
(binding [l/*context* (request->context request)]
(l/error :hint "Internal error" :message (ex-message error) :cause error)
(yrs/response 500 {:type :server-error
:code :unhandled
:hint (ex-message error)
:data edata})))))
(binding [l/*context* (request->context request)]
(l/error :hint "Internal error" :message (ex-message error) :cause error)
{::yrs/status 500
::yrs/body {:type :server-error
:code :unhandloed
:hint (ex-message error)
:data (ex-data error)}}))
(defmethod handle-exception org.postgresql.util.PSQLException
[error request]
@ -117,20 +123,23 @@
(l/error :hint "PSQL error" :message (ex-message error) :cause error)
(cond
(= state "57014")
(yrs/response 504 {:type :server-error
:code :statement-timeout
:hint (ex-message error)})
{::yrs/status 504
::yrs/body {:type :server-error
:code :statement-timeout
:hint (ex-message error)}}
(= state "25P03")
(yrs/response 504 {:type :server-error
:code :idle-in-transaction-timeout
:hint (ex-message error)})
{::yrs/status 504
::yrs/body {:type :server-error
:code :idle-in-transaction-timeout
:hint (ex-message error)}}
:else
(yrs/response 500 {:type :server-error
:code :unexpected
:hint (ex-message error)
:state state})))))
{::yrs/status 500
::yrs/body {:type :server-error
:code :unexpected
:hint (ex-message error)
:state state}}))))
(defmethod handle-exception :default
[error request]
@ -140,9 +149,10 @@
(nil? edata)
(binding [l/*context* (request->context request)]
(l/error :hint "Unexpected error" :message (ex-message error) :cause error)
(yrs/response 500 {:type :server-error
:code :unexpected
:hint (ex-message error)}))
{::yrs/status 500
::yrs/body {:type :server-error
:code :unexpected
:hint (ex-message error)}})
;; This is a special case for the idle-in-transaction error;
;; when it happens, the connection is automatically closed and
@ -156,10 +166,11 @@
:else
(binding [l/*context* (request->context request)]
(l/error :hint "Unhandled error" :message (ex-message error) :cause error)
(yrs/response 500 {:type :server-error
:code :unhandled
:hint (ex-message error)
:data edata})))))
{::yrs/status 500
::yrs/body {:type :server-error
:code :unhandled
:hint (ex-message error)
:data edata}}))))
(defn handle
[cause request]

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

@ -14,6 +14,7 @@
[cuerdas.core :as str]
[promesa.core :as p]
[promesa.exec :as px]
[promesa.util :as pu]
[yetti.adapter :as yt]
[yetti.middleware :as ymw]
[yetti.request :as yrq]
@ -22,7 +23,10 @@
com.fasterxml.jackson.core.JsonParseException
com.fasterxml.jackson.core.io.JsonEOFException
io.undertow.server.RequestTooBigException
java.io.OutputStream))
java.io.OutputStream
java.io.InputStream))
(set! *warn-on-reflection* true)
(def server-timing
{:name ::server-timing
@ -44,14 +48,14 @@
(let [header (yrq/get-header request "content-type")]
(cond
(str/starts-with? header "application/transit+json")
(with-open [is (yrq/body request)]
(with-open [^InputStream is (yrq/body request)]
(let [params (t/read! (t/reader is))]
(-> request
(assoc :body-params params)
(update :params merge params))))
(str/starts-with? header "application/json")
(with-open [is (yrq/body request)]
(with-open [^InputStream is (yrq/body request)]
(let [params (json/decode is json-mapper)]
(-> request
(assoc :body-params params)
@ -62,6 +66,11 @@
(handle-error [raise cause]
(cond
(instance? RuntimeException cause)
(if-let [cause (ex-cause cause)]
(handle-error raise cause)
(raise cause))
(instance? RequestTooBigException cause)
(raise (ex/error :type :validation
:code :request-body-too-large
@ -78,12 +87,12 @@
(raise cause)))]
(fn [request respond raise]
(let [request (ex/try! (process-request request))]
(if (ex/exception? request)
(if (ex/runtime-exception? request)
(handle-error raise (or (ex-cause request) request))
(handle-error raise request))
(handler request respond raise))))))
(if (= (yrq/method request) :post)
(let [request (ex/try! (process-request request))]
(if (ex/exception? request)
(handle-error raise request)
(handler request respond raise)))
(handler request respond raise)))))
(def parse-request
{:name ::parse-request
@ -94,12 +103,7 @@
needed because transit-java calls flush very aggresivelly on each
object write."
[^java.io.OutputStream os ^long chunk-size]
(proxy [java.io.BufferedOutputStream] [os (int chunk-size)]
;; Explicitly do not forward flush
(flush [])
(close []
(proxy-super flush)
(proxy-super close))))
(yetti.util.BufferedOutputStream. os (int chunk-size)))
(def ^:const buffer-size (:xnio/buffer-size yt/defaults))
@ -109,13 +113,10 @@
(reify yrs/StreamableResponseBody
(-write-body-to-stream [_ _ output-stream]
(try
(with-open [bos (buffered-output-stream output-stream buffer-size)]
(with-open [^OutputStream bos (buffered-output-stream output-stream buffer-size)]
(let [tw (t/writer bos opts)]
(t/write! tw data)))
(catch java.io.IOException _cause
;; Do nothing, EOF means client closes connection abruptly
nil)
(catch java.io.IOException _)
(catch Throwable cause
(l/warn :hint "unexpected error on encoding response"
:cause cause))
@ -126,13 +127,10 @@
(reify yrs/StreamableResponseBody
(-write-body-to-stream [_ _ output-stream]
(try
(with-open [bos (buffered-output-stream output-stream buffer-size)]
(with-open [^OutputStream bos (buffered-output-stream output-stream buffer-size)]
(json/write! bos data json-mapper))
(catch java.io.IOException _cause
;; Do nothing, EOF means client closes connection abruptly
nil)
(catch java.io.IOException _)
(catch Throwable cause
(l/warn :hint "unexpected error on encoding response"
:cause cause))
@ -140,15 +138,15 @@
(.close ^OutputStream output-stream))))))
(format-response-with-json [response _]
(let [body (yrs/body response)]
(let [body (::yrs/body response)]
(if (or (boolean? body) (coll? body))
(-> response
(update :headers assoc "content-type" "application/json")
(assoc :body (json-streamable-body body)))
(update ::yrs/headers assoc "content-type" "application/json")
(assoc ::yrs/body (json-streamable-body body)))
response)))
(format-response-with-transit [response request]
(let [body (yrs/body response)]
(let [body (::yrs/body response)]
(if (or (boolean? body) (coll? body))
(let [qs (yrq/query request)
opts (if (or (contains? cf/flags :transit-readable-response)
@ -156,8 +154,8 @@
{:type :json-verbose}
{:type :json})]
(-> response
(update :headers assoc "content-type" "application/transit+json")
(assoc :body (transit-streamable-body body opts))))
(update ::yrs/headers assoc "content-type" "application/transit+json")
(assoc ::yrs/body (transit-streamable-body body opts))))
response)))
(format-response [response request]
@ -181,8 +179,7 @@
(fn [request respond raise]
(handler request
(fn [response]
(let [response (process-response response request)]
(respond response)))
(respond (process-response response request)))
raise))))
(def format-response
@ -191,74 +188,59 @@
(defn wrap-errors
[handler on-error]
(fn [request respond _]
(fn [request respond raise]
(handler request respond (fn [cause]
(-> cause (on-error request) respond)))))
(try
(respond (on-error cause request))
(catch Throwable cause
(raise cause)))))))
(def errors
{:name ::errors
:compile (constantly wrap-errors)})
(defn- with-cors-headers
[headers origin]
(-> headers
(assoc "access-control-allow-origin" origin)
(assoc "access-control-allow-methods" "GET,POST,DELETE,OPTIONS,PUT,HEAD,PATCH")
(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")))
(defn wrap-cors
[handler]
(if-not (contains? cf/flags :cors)
handler
(letfn [(add-headers [headers request]
(let [origin (yrq/get-header request "origin")]
(-> headers
(assoc "access-control-allow-origin" origin)
(assoc "access-control-allow-methods" "GET,POST,DELETE,OPTIONS,PUT,HEAD,PATCH")
(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"))))
(update-response [response request]
(update response :headers add-headers request))]
(fn [request respond raise]
(if (= (yrq/method request) :options)
(-> (yrs/response 200)
(update-response request)
(respond))
(handler request
(fn [response]
(respond (update-response response request)))
raise))))))
(fn [request]
(let [response (if (= (yrq/method request) :options)
{::yrs/status 200}
(handler request))
origin (yrq/get-header request "origin")]
(update response ::yrs/headers with-cors-headers origin))))
(def cors
{:name ::cors
:compile (constantly wrap-cors)})
(defn compile-restrict-methods
[data _]
(when-let [allowed (:allowed-methods data)]
(fn [handler]
(fn [request respond raise]
(let [method (yrq/method request)]
(if (contains? allowed method)
(handler request respond raise)
(respond (yrs/response 405))))))))
:compile (fn [& _]
(when (contains? cf/flags :cors)
wrap-cors))})
(def restrict-methods
{:name ::restrict-methods
:compile compile-restrict-methods})
:compile
(fn [data _]
(when-let [allowed (:allowed-methods data)]
(fn [handler]
(fn [request respond raise]
(let [method (yrq/method request)]
(if (contains? allowed method)
(handler request respond raise)
(respond {::yrs/status 405})))))))})
(def with-dispatch
{:name ::with-dispatch
:compile
(fn [& _]
(fn [handler executor]
(fn [request respond raise]
(-> (px/submit! executor #(handler request))
(p/bind p/wrap)
(p/then respond)
(p/catch raise)))))})
(def with-config
{:name ::with-config
:compile
(fn [& _]
(fn [handler config]
(fn
([request] (handler config request))
([request respond raise] (handler config request respond raise)))))})
(let [executor (px/resolve-executor executor)]
(fn [request respond raise]
(->> (px/submit! executor (partial handler request))
(p/fnly (pu/handler respond raise)))))))})

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

@ -8,7 +8,6 @@
(:refer-clojure :exclude [read])
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.config :as cf]
@ -18,12 +17,9 @@
[app.main :as-alias main]
[app.tokens :as tokens]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px]
[yetti.request :as yrq]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -76,69 +72,56 @@
:id key})
(defn- database-manager
[{:keys [::db/pool ::wrk/executor ::main/props]}]
^{::wrk/executor executor
::db/pool pool
::main/props props}
[pool]
(reify ISessionManager
(read [_ token]
(px/with-dispatch executor
(db/exec-one! pool (sql/select :http-session {:id token}))))
(db/exec-one! pool (sql/select :http-session {:id token})))
(write! [_ key params]
(px/with-dispatch executor
(let [params (prepare-session-params key params)]
(db/insert! pool :http-session params)
params)))
(let [params (prepare-session-params key params)]
(db/insert! pool :http-session params)
params))
(update! [_ params]
(let [updated-at (dt/now)]
(px/with-dispatch executor
(db/update! pool :http-session
{:updated-at updated-at}
{:id (:id params)})
(assoc params :updated-at updated-at))))
(db/update! pool :http-session
{:updated-at updated-at}
{:id (:id params)})
(assoc params :updated-at updated-at)))
(delete! [_ token]
(px/with-dispatch executor
(db/delete! pool :http-session {:id token})
nil))))
(db/delete! pool :http-session {:id token})
nil)))
(defn inmemory-manager
[{:keys [::db/pool ::wrk/executor ::main/props]}]
[]
(let [cache (atom {})]
^{::main/props props
::wrk/executor executor
::db/pool pool}
(reify ISessionManager
(read [_ token]
(p/do (get @cache token)))
(get @cache token))
(write! [_ key params]
(p/do
(let [params (prepare-session-params key params)]
(swap! cache assoc key params)
params)))
(let [params (prepare-session-params key params)]
(swap! cache assoc key params)
params))
(update! [_ params]
(p/do
(let [updated-at (dt/now)]
(swap! cache update (:id params) assoc :updated-at updated-at)
(assoc params :updated-at updated-at))))
(let [updated-at (dt/now)]
(swap! cache update (:id params) assoc :updated-at updated-at)
(assoc params :updated-at updated-at)))
(delete! [_ token]
(p/do
(swap! cache dissoc token)
nil)))))
(swap! cache dissoc token)
nil))))
(defmethod ig/pre-init-spec ::manager [_]
(s/keys :req [::db/pool ::wrk/executor ::main/props]))
(s/keys :req [::db/pool]))
(defmethod ig/init-key ::manager
[_ {:keys [::db/pool] :as cfg}]
[_ {:keys [::db/pool]}]
(if (db/read-only? pool)
(inmemory-manager cfg)
(database-manager cfg)))
(inmemory-manager)
(database-manager pool)))
(defmethod ig/halt-key! ::manager
[_ _])
@ -154,40 +137,35 @@
(declare ^:private gen-token)
(defn create-fn
[{:keys [::manager]} profile-id]
[{:keys [::manager ::main/props]} profile-id]
(us/assert! ::manager manager)
(us/assert! ::us/uuid profile-id)
(let [props (-> manager meta ::main/props)]
(fn [request response]
(let [uagent (yrq/get-header request "user-agent")
params {:profile-id profile-id
:user-agent uagent
:created-at (dt/now)}
token (gen-token props params)]
(fn [request response]
(let [uagent (yrq/get-header request "user-agent")
params {:profile-id profile-id
:user-agent uagent
:created-at (dt/now)}
token (gen-token props params)
session (write! manager token params)]
(l/trace :hint "create" :profile-id (str profile-id))
(-> response
(assign-auth-token-cookie session)
(assign-authenticated-cookie session)))))
(->> (write! manager token params)
(p/fmap (fn [session]
(l/trace :hint "create" :profile-id (str profile-id))
(-> response
(assign-auth-token-cookie session)
(assign-authenticated-cookie session)))))))))
(defn delete-fn
[{:keys [::manager]}]
(us/assert! ::manager manager)
(letfn [(delete [{:keys [profile-id] :as request}]
(let [cname (cf/get :auth-token-cookie-name default-auth-token-cookie-name)
cookie (yrq/get-cookie request cname)]
(l/trace :hint "delete" :profile-id profile-id)
(some->> (:value cookie) (delete! manager))))]
(fn [request response]
(p/do
(delete request)
(-> response
(assoc :status 204)
(assoc :body nil)
(clear-auth-token-cookie)
(clear-authenticated-cookie))))))
(fn [request response]
(let [cname (cf/get :auth-token-cookie-name default-auth-token-cookie-name)
cookie (yrq/get-cookie request cname)]
(l/trace :hint "delete" :profile-id (:profile-id request))
(some->> (:value cookie) (delete! manager))
(-> response
(assoc :status 204)
(assoc :body nil)
(clear-auth-token-cookie)
(clear-authenticated-cookie)))))
(defn- gen-token
[props {:keys [profile-id created-at]}]
@ -216,58 +194,39 @@
(let [elapsed (dt/diff updated-at (dt/now))]
(neg? (compare default-renewal-max-age elapsed)))))
(defn- wrap-reneval
[respond manager session]
(fn [response]
(p/let [session (update! manager session)]
(-> response
(assign-auth-token-cookie session)
(assign-authenticated-cookie session)
(respond)))))
(defn- wrap-soft-auth
[handler {:keys [::manager]}]
[handler {:keys [::manager ::main/props]}]
(us/assert! ::manager manager)
(letfn [(handle-request [request]
(try
(let [token (get-token request)
claims (decode-token props token)]
(cond-> request
(map? claims)
(-> (assoc ::token-claims claims)
(assoc ::token token))))
(catch Throwable cause
(l/trace :hint "exception on decoding malformed token" :cause cause)
request)))]
(let [{:keys [::wrk/executor ::main/props]} (meta manager)]
(fn [request respond raise]
(let [token (ex/try! (get-token request))]
(if (ex/exception? token)
(raise token)
(->> (px/submit! executor (partial decode-token props token))
(p/fnly (fn [claims cause]
(when cause
(l/trace :hint "exception on decoding malformed token" :cause cause))
(let [request (cond-> request
(map? claims)
(-> (assoc ::token-claims claims)
(assoc ::token token)))]
(handler request respond raise))))))))))
(let [request (handle-request request)]
(handler request respond raise)))))
(defn- wrap-authz
[handler {:keys [::manager]}]
(us/assert! ::manager manager)
(fn [request respond raise]
(if-let [token (::token request)]
(->> (get-session manager token)
(p/fnly (fn [session cause]
(cond
(some? cause)
(raise cause)
(fn [request]
(let [session (get-session manager (::token request))
request (cond-> request
(some? session)
(assoc ::profile-id (:profile-id session)
::id (:id session)))]
(nil? session)
(handler request respond raise)
:else
(let [request (-> request
(assoc ::profile-id (:profile-id session))
(assoc ::id (:id session)))
respond (cond-> respond
(renew-session? session)
(wrap-reneval manager session))]
(handler request respond raise))))))
(handler request respond raise))))
(cond-> (handler request)
(renew-session? session)
(-> (assign-auth-token-cookie session)
(assign-authenticated-cookie session))))))
(def soft-auth
{:name ::soft-auth

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

@ -279,22 +279,21 @@
(s/keys :req-un [::session-id]))
(defn- http-handler
[cfg {:keys [params ::session/profile-id] :as request} respond raise]
[cfg {:keys [params ::session/profile-id] :as request}]
(let [{:keys [session-id]} (us/conform ::handler-params params)]
(cond
(not profile-id)
(raise (ex/error :type :authentication
:hint "Authentication required."))
(ex/raise :type :authentication
:hint "Authentication required.")
(not (yws/upgrade-request? request))
(raise (ex/error :type :validation
:code :websocket-request-expected
:hint "this endpoint only accepts websocket connections"))
(ex/raise :type :validation
:code :websocket-request-expected
:hint "this endpoint only accepts websocket connections")
:else
(do
(l/trace :hint "websocket request" :profile-id profile-id :session-id session-id)
(->> (ws/handler
::ws/on-rcv-message (partial on-rcv-message cfg)
::ws/on-snd-message (partial on-snd-message cfg)
@ -302,8 +301,7 @@
::ws/handler (partial handle-message cfg)
::profile-id profile-id
::session-id session-id)
(yws/upgrade request)
(respond))))))
(yws/upgrade request))))))
(defmethod ig/pre-init-spec ::routes [_]
(s/keys :req [::mbus/msgbus

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

@ -16,13 +16,15 @@
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.http.client :as http]
[app.http :as-alias http]
[app.http.client :as http.client]
[app.loggers.audit.tasks :as-alias tasks]
[app.loggers.webhooks :as-alias webhooks]
[app.main :as-alias main]
[app.rpc :as-alias rpc]
[app.tokens :as tokens]
[app.util.retry :as rtry]
[app.util.services :as-alias sv]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
@ -92,6 +94,15 @@
;; --- SPECS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; COLLECTOR
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Defines a service that collects the audit/activity log using
;; internal database. Later this audit log can be transferred to
;; an external storage and data cleared.
(s/def ::profile-id ::us/uuid)
(s/def ::name ::us/string)
(s/def ::type ::us/string)
@ -104,20 +115,13 @@
(s/or :fn fn? :str string? :kw keyword?))
(s/def ::event
(s/keys :req-un [::type ::name ::profile-id]
:opt-un [::ip-addr ::props]
:opt [::webhooks/event?
(s/keys :req [::type ::name ::profile-id]
:opt [::ip-addr
::props
::webhooks/event?
::webhooks/batch-timeout
::webhooks/batch-key]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; COLLECTOR
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Defines a service that collects the audit/activity log using
;; internal database. Later this audit log can be transferred to
;; an external storage and data cleared.
(s/def ::collector
(s/keys :req [::wrk/executor ::db/pool]))
@ -133,15 +137,58 @@
:else
cfg))
(defn prepare-event
[cfg mdata params result]
(let [resultm (meta result)
request (::http/request params)
profile-id (or (::profile-id resultm)
(:profile-id result)
(::rpc/profile-id params)
uuid/zero)
props (-> (or (::replace-props resultm)
(-> params
(merge (::props resultm))
(dissoc :profile-id)
(dissoc :type)))
(clean-props))]
{::type (or (::type resultm)
(::rpc/type cfg))
::name (or (::name resultm)
(::sv/name mdata))
::profile-id profile-id
::ip-addr (some-> request parse-client-ip)
::props props
;; NOTE: for batch-key lookup we need the params as-is
;; because the rpc api does not need to know the
;; audit/webhook specific object layout.
::rpc/params (dissoc params ::http/request)
::webhooks/batch-key
(or (::webhooks/batch-key mdata)
(::webhooks/batch-key resultm))
::webhooks/batch-timeout
(or (::webhooks/batch-timeout mdata)
(::webhooks/batch-timeout resultm))
::webhooks/event?
(or (::webhooks/event? mdata)
(::webhooks/event? resultm)
false)}))
(defn- handle-event!
[conn-or-pool event]
(us/verify! ::event event)
(let [params {:id (uuid/next)
:name (:name event)
:type (:type event)
:profile-id (:profile-id event)
:ip-addr (:ip-addr event)
:props (:props event)}]
:name (::name event)
:type (::type event)
:profile-id (::profile-id event)
:ip-addr (::ip-addr event)
:props (::props event)}]
(when (contains? cf/flags :audit-log)
;; NOTE: this operation may cause primary key conflicts on inserts
@ -207,7 +254,7 @@
(s/def ::tasks/uri ::us/string)
(defmethod ig/pre-init-spec ::tasks/archive-task [_]
(s/keys :req [::db/pool ::main/props ::http/client]))
(s/keys :req [::db/pool ::main/props ::http.client/client]))
(defmethod ig/init-key ::tasks/archive
[_ cfg]
@ -231,7 +278,7 @@
(if n
(do
(px/sleep 100)
(recur (+ total n)))
(recur (+ total ^long n)))
(when (pos? total)
(l/debug :hint "events archived" :total total)))))))))
@ -281,7 +328,7 @@
:method :post
:headers headers
:body body}
resp (http/req! cfg params {:sync? true})]
resp (http.client/req! cfg params {:sync? true})]
(if (= (:status resp) 204)
true
(do

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

@ -85,14 +85,10 @@
(defmethod ig/init-key ::reporter
[_ cfg]
(let [input (sp/chan :buf (sp/sliding-buffer 32)
:xf (filter error-record?))]
:xf (filter error-record?))]
(add-watch l/log-record ::reporter #(sp/put! input %4))
;; FIXME: we don't use virtual threads here until JDBC is uptaded
;; to >= 42.6.0 bacause it has the necessary fixes fro make the
;; JDBC driver properly compatible with Virtual Threads.
(px/thread {:name "penpot/database-reporter" :virtual false}
(px/thread {:name "penpot/database-reporter" :virtual true}
(l/info :hint "initializing database error persistence")
(try
(loop []

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

@ -14,7 +14,6 @@
[app.db :as-alias db]
[app.email :as-alias email]
[app.http :as-alias http]
[app.http.access-token :as-alias actoken]
[app.http.assets :as-alias http.assets]
[app.http.awsns :as http.awsns]
[app.http.client :as-alias http.client]
@ -37,7 +36,8 @@
[app.util.time :as dt]
[app.worker :as-alias wrk]
[cuerdas.core :as str]
[integrant.core :as ig])
[integrant.core :as ig]
[promesa.exec :as px])
(:gen-class))
(def default-metrics
@ -102,15 +102,15 @@
::mdef/labels ["name"]
::mdef/type :summary}
:rpc-climit-queue-size
{::mdef/name "penpot_rpc_climit_queue_size"
::mdef/help "Current number of queued submissions on the CLIMIT."
:rpc-climit-queue
{::mdef/name "penpot_rpc_climit_queue"
::mdef/help "Current number of queued submissions."
::mdef/labels ["name"]
::mdef/type :gauge}
:rpc-climit-concurrency
{::mdef/name "penpot_rpc_climit_concurrency"
::mdef/help "Current number of used concurrency capacity on the CLIMIT"
:rpc-climit-permits
{::mdef/name "penpot_rpc_climit_permits"
::mdef/help "Current number of available permits"
::mdef/labels ["name"]
::mdef/type :gauge}
@ -174,7 +174,8 @@
;; Default thread pool for IO operations
::wrk/executor
{::wrk/parallelism (cf/get :default-executor-parallelism 100)}
{::wrk/parallelism (cf/get :default-executor-parallelism
(+ 3 (* (px/get-available-processors) 3)))}
::wrk/monitor
{::mtx/metrics (ig/ref ::mtx/metrics)
@ -191,8 +192,9 @@
{::mtx/metrics (ig/ref ::mtx/metrics)}
::rds/redis
{::rds/uri (cf/get :redis-uri)
::mtx/metrics (ig/ref ::mtx/metrics)}
{::rds/uri (cf/get :redis-uri)
::mtx/metrics (ig/ref ::mtx/metrics)
::wrk/executor (ig/ref ::wrk/executor)}
::mbus/msgbus
{::wrk/executor (ig/ref ::wrk/executor)
@ -212,14 +214,7 @@
{::wrk/executor (ig/ref ::wrk/executor)}
::session/manager
{::db/pool (ig/ref ::db/pool)
::wrk/executor (ig/ref ::wrk/executor)
::props (ig/ref :app.setup/props)}
::actoken/manager
{::db/pool (ig/ref ::db/pool)
::wrk/executor (ig/ref ::wrk/executor)
::props (ig/ref :app.setup/props)}
{::db/pool (ig/ref ::db/pool)}
::session.tasks/gc
{::db/pool (ig/ref ::db/pool)}
@ -269,7 +264,6 @@
{::http.client/client (ig/ref ::http.client/client)
::db/pool (ig/ref ::db/pool)
::props (ig/ref :app.setup/props)
::wrk/executor (ig/ref ::wrk/executor)
::oidc/providers {:google (ig/ref ::oidc.providers/google)
:github (ig/ref ::oidc.providers/github)
:gitlab (ig/ref ::oidc.providers/gitlab)
@ -278,8 +272,6 @@
:app.http/router
{::session/manager (ig/ref ::session/manager)
::actoken/manager (ig/ref ::actoken/manager)
::wrk/executor (ig/ref ::wrk/executor)
::db/pool (ig/ref ::db/pool)
::rpc/routes (ig/ref ::rpc/routes)
::rpc.doc/routes (ig/ref ::rpc.doc/routes)
@ -344,7 +336,6 @@
::db/pool (ig/ref ::db/pool)
::wrk/executor (ig/ref ::wrk/executor)
::session/manager (ig/ref ::session/manager)
::actoken/manager (ig/ref ::actoken/manager)
::props (ig/ref :app.setup/props)}
::wrk/registry

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

@ -16,6 +16,7 @@
[app.storage :as-alias sto]
[app.storage.tmp :as tmp]
[app.util.svg :as svg]
[app.util.time :as dt]
[buddy.core.bytes :as bb]
[buddy.core.codecs :as bc]
[clojure.java.shell :as sh]
@ -168,7 +169,7 @@
(ex/raise :type :validation
:code :invalid-svg-file
:hint "uploaded svg does not provides dimensions"))
(merge input info))
(merge input info {:ts (dt/now)}))
(let [instance (Info. (str path))
mtype' (.getProperty instance "Mime type")]
@ -183,7 +184,8 @@
;; any frame.
(assoc input
:width (.getPageWidth instance)
:height (.getPageHeight instance))))))
:height (.getPageHeight instance)
:ts (dt/now))))))
(defmethod process-error org.im4java.core.InfoException
[error]

81
backend/src/app/redis.clj
View file

@ -8,11 +8,13 @@
"The msgbus abstraction implemented using redis as underlying backend."
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.metrics :as mtx]
[app.redis.script :as-alias rscript]
[app.util.time :as dt]
[app.worker :as-alias wrk]
[clojure.core :as c]
[clojure.java.io :as io]
[clojure.spec.alpha :as s]
@ -45,6 +47,10 @@
io.lettuce.core.resource.DefaultClientResources
io.netty.util.HashedWheelTimer
io.netty.util.Timer
java.util.function.Function
com.github.benmanes.caffeine.cache.Cache
com.github.benmanes.caffeine.cache.Caffeine
com.github.benmanes.caffeine.cache.RemovalListener
java.lang.AutoCloseable
java.time.Duration))
@ -88,7 +94,7 @@
(s/def ::connect? ::us/boolean)
(s/def ::io-threads ::us/integer)
(s/def ::worker-threads ::us/integer)
(s/def ::cache #(instance? clojure.lang.Atom %))
(s/def ::cache some?)
(s/def ::redis
(s/keys :req [::resources
@ -130,6 +136,20 @@
(def string-codec
(RedisCodec/of StringCodec/UTF8 StringCodec/UTF8))
(defn- create-cache
[{:keys [::wrk/executor] :as cfg}]
(let [listener (reify RemovalListener
(onRemoval [_ key cache cause]
(l/trace :hint "cache: remove" :key key :reason (str cause) :repr (pr-str cache))
(some-> cache d/close!)))
]
(.. (Caffeine/newBuilder)
(weakValues)
(executor executor)
(removalListener listener)
(build))))
(defn- initialize-resources
"Initialize redis connection resources"
[{:keys [::uri ::io-threads ::worker-threads ::connect?] :as cfg}]
@ -146,17 +166,18 @@
(timer ^Timer timer)
(build))
redis-uri (RedisURI/create ^String uri)]
redis-uri (RedisURI/create ^String uri)
cfg (-> cfg
(assoc ::resources resources)
(assoc ::timer timer)
(assoc ::redis-uri redis-uri))]
(-> cfg
(assoc ::resources resources)
(assoc ::timer timer)
(assoc ::cache (atom {}))
(assoc ::redis-uri redis-uri))))
(assoc cfg ::cache (create-cache cfg))))
(defn- shutdown-resources
[{:keys [::resources ::cache ::timer]}]
(run! d/close! (vals @cache))
(.invalidateAll ^Cache cache)
(when resources
(.shutdown ^ClientResources resources))
(when timer
@ -174,6 +195,7 @@
:default (.connect ^RedisClient client ^RedisCodec codec)
:pubsub (.connectPubSub ^RedisClient client ^RedisCodec codec))]
(l/trc :hint "connect" :hid (hash client))
(.setTimeout ^StatefulConnection conn ^Duration timeout)
(reify
IDeref
@ -181,8 +203,9 @@
AutoCloseable
(close [_]
(.close ^StatefulConnection conn)
(.shutdown ^RedisClient client)))))
(ex/ignoring (.close ^StatefulConnection conn))
(ex/ignoring (.shutdown ^RedisClient client))
(l/trc :hint "disconnect" :hid (hash client))))))
(defn connect
[state & {:as opts}]
@ -195,15 +218,16 @@
(defn get-or-connect
[{:keys [::cache] :as state} key options]
(us/assert! ::redis state)
(-> state
(assoc ::connection
(or (get @cache key)
(-> (swap! cache (fn [cache]
(when-let [prev (get cache key)]
(d/close! prev))
(assoc cache key (connect* state options))))
(get key))))
(dissoc ::cache)))
;; FIXME: the cache causes vthread pinning
(let [connection (.get ^Cache cache
^Object key
^Function (reify
Function
(apply [_ _key]
(connect* state options))))]
(-> state
(dissoc ::cache)
(assoc ::connection connection))))
(defn add-listener!
[{:keys [::connection] :as conn} listener]
@ -345,7 +369,7 @@
(do
(l/error :hint "no script found" :name sname :cause cause)
(->> (load-script)
(p/mapcat eval-script)))
(p/mcat eval-script)))
(if-let [on-error (::rscript/on-error script)]
(on-error cause)
(p/rejected cause))))
@ -376,15 +400,16 @@
(load-script []
(l/trace :hint "load script" :name sname)
(->> (.scriptLoad ^RedisScriptingAsyncCommands cmd
^String (read-script))
(p/map (fn [sha]
(swap! scripts-cache assoc sname sha)
sha))))]
^String (read-script))
(p/fmap (fn [sha]
(swap! scripts-cache assoc sname sha)
sha))))]
(if-let [sha (get @scripts-cache sname)]
(eval-script sha)
(->> (load-script)
(p/mapcat eval-script))))))
(p/await!
(if-let [sha (get @scripts-cache sname)]
(eval-script sha)
(->> (load-script)
(p/mapcat eval-script)))))))
(defn timeout-exception?
[cause]

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

@ -11,7 +11,6 @@
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.http :as-alias http]
@ -19,7 +18,6 @@
[app.http.client :as-alias http.client]
[app.http.session :as session]
[app.loggers.audit :as audit]
[app.loggers.webhooks :as-alias webhooks]
[app.main :as-alias main]
[app.metrics :as mtx]
[app.msgbus :as-alias mbus]
@ -35,7 +33,6 @@
[clojure.spec.alpha :as s]
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px]
[yetti.request :as yrq]
[yetti.response :as yrs]))
@ -47,12 +44,10 @@
(defn- handle-response-transformation
[response request mdata]
(let [transform-fn (reduce (fn [res-fn transform-fn]
(fn [request response]
(p/then (res-fn request response) #(transform-fn request %))))
(constantly response)
(::response-transform-fns mdata))]
(transform-fn request response)))
(reduce (fn [response transform-fn]
(transform-fn request response))
response
(::response-transform-fns mdata)))
(defn- handle-before-comple-hook
[response mdata]
@ -63,18 +58,18 @@
(defn- handle-response
[request result]
(if (fn? result)
(p/wrap (result request))
(result request)
(let [mdata (meta result)]
(p/-> (yrs/response {:status (::http/status mdata 200)
:headers (::http/headers mdata {})
:body (rph/unwrap result)})
(handle-response-transformation request mdata)
(handle-before-comple-hook mdata)))))
(-> {::yrs/status (::http/status mdata 200)
::yrs/headers (::http/headers mdata {})
::yrs/body (rph/unwrap result)}
(handle-response-transformation request mdata)
(handle-before-comple-hook mdata)))))
(defn- rpc-query-handler
"Ring handler that dispatches query requests and convert between
internal async flow into ring async flow."
[methods {:keys [params path-params] :as request} respond raise]
[methods {:keys [params path-params] :as request}]
(let [type (keyword (:type path-params))
profile-id (or (::session/profile-id request)
(::actoken/profile-id request))
@ -87,19 +82,14 @@
(assoc :profile-id profile-id)
(assoc ::profile-id profile-id))
(dissoc data :profile-id ::profile-id))
method (get methods type default-handler)]
(->> (method data)
(p/mcat (partial handle-response request))
(p/fnly (fn [response cause]
(if cause
(raise cause)
(respond response)))))))
method (get methods type default-handler)
response (method data)]
(handle-response request response)))
(defn- rpc-mutation-handler
"Ring handler that dispatches mutation requests and convert between
internal async flow into ring async flow."
[methods {:keys [params path-params] :as request} respond raise]
[methods {:keys [params path-params] :as request}]
(let [type (keyword (:type path-params))
profile-id (or (::session/profile-id request)
(::actoken/profile-id request))
@ -111,24 +101,18 @@
(assoc :profile-id profile-id)
(assoc ::profile-id profile-id))
(dissoc data :profile-id))
method (get methods type default-handler)]
(->> (method data)
(p/mcat (partial handle-response request))
(p/fnly (fn [response cause]
(if cause
(raise cause)
(respond response)))))))
method (get methods type default-handler)
response (method data)]
(handle-response request response)))
(defn- rpc-command-handler
"Ring handler that dispatches cmd requests and convert between
internal async flow into ring async flow."
[methods {:keys [params path-params] :as request} respond raise]
[methods {:keys [params path-params] :as request}]
(let [type (keyword (:type path-params))
etag (yrq/get-header request "if-none-match")
profile-id (or (::session/profile-id request)
(::actoken/profile-id request))
data (-> params
(assoc ::request-at (dt/now))
(assoc ::session/id (::session/id request))
@ -140,12 +124,8 @@
method (get methods type default-handler)]
(binding [cond/*enabled* true]
(->> (method data)
(p/mcat (partial handle-response request))
(p/fnly (fn [response cause]
(if cause
(raise cause)
(respond response))))))))
(let [response (method data)]
(handle-response request response)))))
(defn- wrap-metrics
"Wrap service method with metrics measurement."
@ -153,23 +133,22 @@
(let [labels (into-array String [(::sv/name mdata)])]
(fn [cfg params]
(let [tp (dt/tpoint)]
(->> (f cfg params)
(p/fnly (fn [_ _]
(mtx/run! metrics
:id metrics-id
:val (inst-ms (tp))
:labels labels))))))))
(try
(f cfg params)
(finally
(mtx/run! metrics
:id metrics-id
:val (inst-ms (tp))
:labels labels)))))))
(defn- wrap-authentication
[_ f mdata]
(fn [cfg params]
(let [profile-id (::profile-id params)]
(if (and (::auth mdata true) (not (uuid? profile-id)))
(p/rejected
(ex/error :type :authentication
:code :authentication-required
:hint "authentication required for this endpoint"))
(ex/raise :type :authentication
:code :authentication-required
:hint "authentication required for this endpoint")
(f cfg params)))))
(defn- wrap-access-token
@ -182,98 +161,34 @@
(let [perms (::actoken/perms request #{})]
(if (contains? perms name)
(f cfg params)
(p/rejected
(ex/error :type :authorization
:code :operation-not-allowed
:allowed perms))))
(ex/raise :type :authorization
:code :operation-not-allowed
:allowed perms)))
(f cfg params))))
f))
(defn- wrap-dispatch
"Wraps service method into async flow, with the ability to dispatching
it to a preconfigured executor service."
[{:keys [::wrk/executor] :as cfg} f mdata]
(with-meta
(fn [cfg params]
(->> (px/submit! executor (px/wrap-bindings #(f cfg params)))
(p/mapcat p/wrap)
(p/map rph/wrap)))
mdata))
(defn- wrap-audit
[cfg f mdata]
[_ f mdata]
(if (or (contains? cf/flags :webhooks)
(contains? cf/flags :audit-log))
(letfn [(handle-audit [params result]
(let [resultm (meta result)
request (::http/request params)
profile-id (or (::audit/profile-id resultm)
(:profile-id result)
(if (= (::type cfg) "command")
(::profile-id params)
(:profile-id params))
uuid/zero)
props (-> (or (::audit/replace-props resultm)
(-> params
(merge (::audit/props resultm))
(dissoc :profile-id)
(dissoc :type)))
(audit/clean-props))
event {:type (or (::audit/type resultm)
(::type cfg))
:name (or (::audit/name resultm)
(::sv/name mdata))
:profile-id profile-id
:ip-addr (some-> request audit/parse-client-ip)
:props props
;; NOTE: for batch-key lookup we need the params as-is
;; because the rpc api does not need to know the
;; audit/webhook specific object layout.
::params (dissoc params ::http/request)
::webhooks/batch-key
(or (::webhooks/batch-key mdata)
(::webhooks/batch-key resultm))
::webhooks/batch-timeout
(or (::webhooks/batch-timeout mdata)
(::webhooks/batch-timeout resultm))
::webhooks/event?
(or (::webhooks/event? mdata)
(::webhooks/event? resultm)
false)}]
(audit/submit! cfg event)))
(handle-request [cfg params]
(->> (f cfg params)
(p/fnly (fn [result cause]
(when-not cause
(handle-audit params result))))))]
(if-not (::audit/skip mdata)
(with-meta handle-request mdata)
f))
(if-not (::audit/skip mdata)
(fn [cfg params]
(let [result (f cfg params)]
(->> (audit/prepare-event cfg mdata params result)
(audit/submit! cfg))
result))
f)
f))
(defn- wrap-spec-conform
[_ f mdata]
(let [spec (or (::sv/spec mdata) (s/spec any?))]
(fn [cfg params]
(let [params (ex/try! (us/conform spec params))]
(if (ex/exception? params)
(p/rejected params)
(f cfg params))))))
(f cfg (us/conform spec params)))))
(defn- wrap-all
[cfg f mdata]
(as-> f $
(wrap-dispatch cfg $ mdata)
(wrap-metrics cfg $ mdata)
(cond/wrap cfg $ mdata)
(retry/wrap-retry cfg $ mdata)
@ -288,13 +203,11 @@
[cfg f mdata]
(l/debug :hint "register method" :name (::sv/name mdata))
(let [f (wrap-all cfg f mdata)]
(with-meta #(f cfg %) mdata)))
(partial f cfg)))
(defn- process-method
[cfg vfn]
(let [mdata (meta vfn)]
[(keyword (::sv/name mdata))
(wrap cfg vfn mdata)]))
[cfg [vfn mdata]]
[(keyword (::sv/name mdata)) [mdata (wrap cfg vfn mdata)]])
(defn- resolve-query-methods
[cfg]
@ -371,13 +284,13 @@
:commands (resolve-command-methods cfg)}))
(s/def ::mutations
(s/map-of keyword? fn?))
(s/map-of keyword? (s/tuple map? fn?)))
(s/def ::queries
(s/map-of keyword? fn?))
(s/map-of keyword? (s/tuple map? fn?)))
(s/def ::commands
(s/map-of keyword? fn?))
(s/map-of keyword? (s/tuple map? fn?)))
(s/def ::methods
(s/keys :req-un [::mutations
@ -391,15 +304,18 @@
::db/pool
::main/props
::wrk/executor
::session/manager
::actoken/manager]))
::session/manager]))
(defmethod ig/init-key ::routes
[_ {:keys [::methods] :as cfg}]
[["/rpc" {:middleware [[session/authz cfg]
[actoken/authz cfg]]}
["/command/:type" {:handler (partial rpc-command-handler (:commands methods))}]
["/query/:type" {:handler (partial rpc-query-handler (:queries methods))}]
["/mutation/:type" {:handler (partial rpc-mutation-handler (:mutations methods))
:allowed-methods #{:post}}]]])
(let [methods (-> methods
(update :commands update-vals peek)
(update :queries update-vals peek)
(update :mutations update-vals peek))]
[["/rpc" {:middleware [[session/authz cfg]
[actoken/authz cfg]]}
["/command/:type" {:handler (partial rpc-command-handler (:commands methods))}]
["/query/:type" {:handler (partial rpc-query-handler (:queries methods))}]
["/mutation/:type" {:handler (partial rpc-mutation-handler (:mutations methods))
:allowed-methods #{:post}}]]]))

298
backend/src/app/rpc/climit.clj
View file

@ -6,14 +6,15 @@
(ns app.rpc.climit
"Concurrencly limiter for RPC."
(:refer-clojure :exclude [run!])
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[app.common.spec :as us]
[app.config :as cf]
[app.metrics :as mtx]
[app.rpc :as-alias rpc]
[app.rpc.climit.config :as-alias config]
[app.util.services :as-alias sv]
[app.util.time :as dt]
[app.worker :as-alias wrk]
@ -23,84 +24,15 @@
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px]
[promesa.exec.bulkhead :as pxb])
[promesa.exec.bulkhead :as pbh])
(:import
com.github.benmanes.caffeine.cache.Cache
clojure.lang.ExceptionInfo
com.github.benmanes.caffeine.cache.LoadingCache
com.github.benmanes.caffeine.cache.CacheLoader
com.github.benmanes.caffeine.cache.Caffeine
com.github.benmanes.caffeine.cache.RemovalListener))
(defn- capacity-exception?
[o]
(and (ex/error? o)
(let [data (ex-data o)]
(and (= :bulkhead-error (:type data))
(= :capacity-limit-reached (:code data))))))
(defn invoke!
[limiter f]
(->> (px/submit! limiter f)
(p/hcat (fn [result cause]
(cond
(capacity-exception? cause)
(p/rejected
(ex/error :type :internal
:code :concurrency-limit-reached
:queue (-> limiter meta ::bkey name)
:cause cause))
(some? cause)
(p/rejected cause)
:else
(p/resolved result))))))
(defn- create-limiter
[{:keys [::wrk/executor ::mtx/metrics ::bkey ::skey concurrency queue-size]}]
(let [labels (into-array String [(name bkey)])
on-queue (fn [instance]
(l/trace :hint "enqueued"
:key (name bkey)
:skey (str skey)
:queue-size (get instance ::pxb/current-queue-size)
:concurrency (get instance ::pxb/current-concurrency))
(mtx/run! metrics
:id :rpc-climit-queue-size
:val (get instance ::pxb/current-queue-size)
:labels labels)
(mtx/run! metrics
:id :rpc-climit-concurrency
:val (get instance ::pxb/current-concurrency)
:labels labels))
on-run (fn [instance task]
(let [elapsed (- (inst-ms (dt/now))
(inst-ms task))]
(l/trace :hint "execute"
:key (name bkey)
:skey (str skey)
:elapsed (str elapsed "ms"))
(mtx/run! metrics
:id :rpc-climit-timing
:val elapsed
:labels labels)
(mtx/run! metrics
:id :rpc-climit-queue-size
:val (get instance ::pxb/current-queue-size)
:labels labels)
(mtx/run! metrics
:id :rpc-climit-concurrency
:val (get instance ::pxb/current-concurrency)
:labels labels)))
options {:executor executor
:concurrency concurrency
:queue-size (or queue-size Integer/MAX_VALUE)
:on-queue on-queue
:on-run on-run}]
(-> (pxb/create options)
(vary-meta assoc ::bkey bkey ::skey skey))))
(set! *warn-on-reflection* true)
(defn- create-cache
[{:keys [::wrk/executor] :as params} config]
@ -110,97 +42,187 @@
loader (reify CacheLoader
(load [_ key]
(let [[bkey skey] key]
(when-let [config (get config bkey)]
(-> (merge params config)
(assoc ::bkey bkey)
(assoc ::skey skey)
(create-limiter))))))]
(let [config (get config (nth key 0))]
(pbh/create :permits (or (:permits config) (:concurrency config))
:queue (or (:queue config) (:queue-size config))
:timeout (:timeout config)
:executor executor
:type (:type config :semaphore)))))]
(.. (Caffeine/newBuilder)
(weakValues)
(executor executor)
(removalListener listener)
(build loader))))
(.. (Caffeine/newBuilder)
(weakValues)
(executor executor)
(removalListener listener)
(build loader))))
(defprotocol IConcurrencyManager)
(s/def ::concurrency ::us/integer)
(s/def ::queue-size ::us/integer)
(s/def ::config/permits ::us/integer)
(s/def ::config/queue ::us/integer)
(s/def ::config/timeout ::us/integer)
(s/def ::config
(s/map-of keyword?
(s/keys :req-un [::concurrency]
:opt-un [::queue-size])))
(s/keys :opt-un [::config/permits
::config/queue
::config/timeout])))
(defmethod ig/prep-key ::rpc/climit
[_ cfg]
(merge {::path (cf/get :rpc-climit-config)}
(d/without-nils cfg)))
(assoc cfg ::path (cf/get :rpc-climit-config)))
(s/def ::path ::fs/path)
(defmethod ig/pre-init-spec ::rpc/climit [_]
(s/keys :req [::wrk/executor ::mtx/metrics ::path]))
(defmethod ig/init-key ::rpc/climit
[_ {:keys [::path] :as params}]
[_ {:keys [::path ::mtx/metrics ::wrk/executor] :as cfg}]
(when (contains? cf/flags :rpc-climit)
(if-let [config (some->> path slurp edn/read-string)]
(do
(l/info :hint "initializing concurrency limit" :config (str path))
(us/verify! ::config config)
(let [cache (create-cache params config)]
^{::cache cache}
(reify
IConcurrencyManager
clojure.lang.IDeref
(deref [_] config)
clojure.lang.ILookup
(valAt [_ key]
(let [key (if (vector? key) key [key])]
(.get ^Cache cache key))))))
(l/warn :hint "unable to load configuration" :config (str path)))))
(when-let [params (some->> path slurp edn/read-string)]
(l/info :hint "initializing concurrency limit" :config (str path))
(us/verify! ::config params)
{::cache (create-cache cfg params)
::config params
::wrk/executor executor
::mtx/metrics metrics})))
(s/def ::cache #(instance? LoadingCache %))
(s/def ::instance
(s/keys :req [::cache ::config ::wrk/executor]))
(s/def ::rpc/climit
(s/nilable #(satisfies? IConcurrencyManager %)))
(s/nilable ::instance))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PUBLIC API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn invoke!
[cache metrics id key f]
(let [limiter (.get ^LoadingCache cache [id key])
tpoint (dt/tpoint)
labels (into-array String [(name id)])
wrapped
(fn []
(let [elapsed (tpoint)
stats (pbh/get-stats limiter)]
(l/trace :hint "executed"
:id (name id)
:key key
:fnh (hash f)
:permits (:permits stats)
:queue (:queue stats)
:max-permits (:max-permits stats)
:max-queue (:max-queue stats)
:elapsed (dt/format-duration elapsed))
(mtx/run! metrics
:id :rpc-climit-timing
:val (inst-ms elapsed)
:labels labels)
(try
(f)
(finally
(let [elapsed (tpoint)]
(l/trace :hint "finished"
:id (name id)
:key key
:fnh (hash f)
:permits (:permits stats)
:queue (:queue stats)
:max-permits (:max-permits stats)
:max-queue (:max-queue stats)
:elapsed (dt/format-duration elapsed)))))))
measure!
(fn [stats]
(mtx/run! metrics
:id :rpc-climit-queue
:val (:queue stats)
:labels labels)
(mtx/run! metrics
:id :rpc-climit-permits
:val (:permits stats)
:labels labels))]
(try
(let [stats (pbh/get-stats limiter)]
(measure! stats)
(l/trace :hint "enqueued"
:id (name id)
:key key
:fnh (hash f)
:permits (:permits stats)
:queue (:queue stats)
:max-permits (:max-permits stats)
:max-queue (:max-queue stats))
(pbh/invoke! limiter wrapped))
(catch ExceptionInfo cause
(let [{:keys [type code]} (ex-data cause)]
(if (= :bulkhead-error type)
(ex/raise :type :concurrency-limit
:code code
:hint "concurrency limit reached")
(throw cause))))
(finally
(measure! (pbh/get-stats limiter))))))
(defn run!
[{:keys [::id ::cache ::mtx/metrics]} f]
(if (and cache id)
(invoke! cache metrics id nil f)
(f)))
(defn submit!
[{:keys [::id ::cache ::wrk/executor ::mtx/metrics]} f]
(let [f (partial px/submit! executor f)]
(if (and cache id)
(p/await! (invoke! cache metrics id nil f))
(p/await! (f)))))
(defn configure
([{:keys [::rpc/climit]} id]
(us/assert! ::rpc/climit climit)
(assoc climit ::id id))
([{:keys [::rpc/climit]} id executor]
(us/assert! ::rpc/climit climit)
(-> climit
(assoc ::id id)
(assoc ::wrk/executor executor))))
(defmacro with-dispatch!
"Dispatch blocking operation to a separated thread protected with the
specified concurrency limiter. If climit is not active, the function
will be scheduled to execute without concurrency monitoring."
[instance & body]
(if (vector? instance)
`(-> (app.rpc.climit/configure ~@instance)
(app.rpc.climit/run! (^:once fn* [] ~@body)))
`(run! ~instance (^:once fn* [] ~@body))))
(defmacro with-dispatch
[lim & body]
`(if ~lim
(invoke! ~lim (^:once fn [] (p/wrap (do ~@body))))
(p/wrap (do ~@body))))
"Dispatch blocking operation to a separated thread protected with
the specified semaphore.
DEPRECATED"
[& params]
`(with-dispatch! ~@params))
(def noop-fn (constantly nil))
(defn wrap
[{:keys [::rpc/climit]} f {:keys [::queue ::key-fn] :as mdata}]
(if (and (some? climit)
(some? queue))
(if-let [config (get @climit queue)]
(do
[{:keys [::rpc/climit ::mtx/metrics]} f {:keys [::id ::key-fn] :or {key-fn noop-fn} :as mdata}]
(if (and (some? climit) (some? id))
(if-let [config (get-in climit [::config id])]
(let [cache (::cache climit)]
(l/debug :hint "wrap: instrumenting method"
:limit-name (name queue)
:limit (name id)
:service-name (::sv/name mdata)
:queue-size (or (:queue-size config) Integer/MAX_VALUE)
:concurrency (:concurrency config)
:timeout (:timeout config)
:permits (:permits config)
:queue (:queue config)
:keyed? (some? key-fn))
(if (some? key-fn)
(fn [cfg params]
(let [key [queue (key-fn params)]
lim (get climit key)]
(invoke! lim (partial f cfg params))))
(let [lim (get climit queue)]
(fn [cfg params]
(invoke! lim (partial f cfg params))))))
(fn [cfg params]
(invoke! cache metrics id (key-fn params) (partial f cfg params))))
(do
(l/warn :hint "wrap: no config found"
:queue (name queue)
:service (::sv/name mdata))
(l/warn :hint "no config found for specified queue" :id id)
f))
f))

18
backend/src/app/rpc/commands/audit.clj
View file

@ -21,10 +21,7 @@
[app.rpc.helpers :as rph]
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as wrk]
[clojure.spec.alpha :as s]
[promesa.core :as p]
[promesa.exec :as px]))
[clojure.spec.alpha :as s]))
(defn- event->row [event]
[(uuid/next)
@ -71,17 +68,22 @@
:req-un [::events]))
(sv/defmethod ::push-audit-events
{::climit/queue :push-audit-events
{::climit/id :submit-audit-events-by-profile
::climit/key-fn ::rpc/profile-id
::audit/skip true
::doc/added "1.17"}
[{:keys [::db/pool ::wrk/executor] :as cfg} params]
[{:keys [::db/pool] :as cfg} params]
(if (or (db/read-only? pool)
(not (contains? cf/flags :audit-log)))
(do
(l/warn :hint "audit: http handler disabled or db is read-only")
(rph/wrap nil))
(->> (px/submit! executor #(handle-events cfg params))
(p/fmap (constantly nil)))))
(do
(try
(handle-events cfg params)
(catch Throwable cause
(l/error :hint "unexpected error on persisting audit events from frontend"
:cause cause)))
(rph/wrap nil))))

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

@ -6,7 +6,6 @@
(ns app.rpc.commands.auth
(:require
[app.auth :as auth]
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.spec :as us]
@ -18,7 +17,6 @@
[app.loggers.audit :as audit]
[app.main :as-alias main]
[app.rpc :as-alias rpc]
[app.rpc.climit :as climit]
[app.rpc.commands.profile :as profile]
[app.rpc.commands.teams :as teams]
[app.rpc.doc :as-alias doc]
@ -68,7 +66,7 @@
(ex/raise :type :validation
:code :account-without-password
:hint "the current account does not have password"))
(:valid (auth/verify-password password (:password profile))))
(:valid (profile/verify-password cfg password (:password profile))))
(validate-profile [profile]
(when-not profile
@ -118,7 +116,6 @@
(sv/defmethod ::login-with-password
"Performs authentication using penpot password."
{::rpc/auth false
::climit/queue :auth
::doc/added "1.15"}
[cfg params]
(login-with-password cfg params))
@ -144,7 +141,7 @@
(:profile-id tdata)))
(update-password [conn profile-id]
(let [pwd (auth/derive-password password)]
(let [pwd (profile/derive-password cfg password)]
(db/update! conn :profile {:password pwd} {:id profile-id})))]
(db/with-atomic [conn pool]
@ -158,7 +155,6 @@
(sv/defmethod ::recover-profile
{::rpc/auth false
::climit/queue :auth
::doc/added "1.15"}
[cfg params]
(recover-profile cfg params))
@ -264,9 +260,7 @@
:nudge {:big 10 :small 1}})
(db/tjson))
password (if-let [password (:password params)]
(auth/derive-password password)
"!")
password (or (:password params) "!")
locale (:locale params)
locale (when (and (string? locale) (not (str/blank? locale)))
@ -344,8 +338,11 @@
profile (if-let [profile-id (:profile-id claims)]
(profile/get-profile conn profile-id)
(->> (create-profile! conn (assoc params :is-active is-active))
(create-profile-rels! conn)))
(let [params (-> params
(assoc :is-active is-active)
(update :password #(profile/derive-password cfg %)))]
(->> (create-profile! conn params)
(create-profile-rels! conn))))
invitation (when-let [token (:invitation-token params)]
(tokens/verify (::main/props cfg) {:token token :iss :team-invitation}))]
@ -356,9 +353,9 @@
(when-let [id (:profile-id claims)]
(db/update! conn :profile {:modified-at (dt/now)} {:id id})
(audit/submit! cfg
{:type "fact"
:name "register-profile-retry"
:profile-id id}))
{::audit/type "fact"
::audit/name "register-profile-retry"
::audit/profile-id id}))
(cond
;; If invitation token comes in params, this is because the
@ -406,7 +403,6 @@
(sv/defmethod ::register-profile
{::rpc/auth false
::climit/queue :auth
::doc/added "1.15"}
[{:keys [::db/pool] :as cfg} params]
(db/with-atomic [conn pool]

12
backend/src/app/rpc/commands/binfile.clj
View file

@ -37,6 +37,7 @@
[clojure.walk :as walk]
[cuerdas.core :as str]
[datoteka.io :as io]
[promesa.core :as p]
[yetti.adapter :as yt]
[yetti.response :as yrs])
(:import
@ -354,7 +355,6 @@
(with-open [^AutoCloseable conn (db/open pool)]
(db/exec! conn [sql:file-library-rels (db/create-array conn "uuid" ids)])))
(defn- create-or-update-file
[conn params]
(let [sql (str "INSERT INTO file (id, project_id, name, revn, is_shared, data, created_at, modified_at) "
@ -527,13 +527,13 @@
(write-obj! output sids)
(doseq [id sids]
(let [{:keys [size] :as obj} @(sto/get-object storage id)]
(let [{:keys [size] :as obj} (p/await! (sto/get-object storage id))]
(l/debug :hint "write sobject" :id id ::l/sync? true)
(doto output
(write-uuid! id)
(write-obj! (meta obj)))
(with-open [^InputStream stream @(sto/get-object-data storage obj)]
(with-open [^InputStream stream (p/await! (sto/get-object-data storage obj))]
(let [written (write-stream! output stream size)]
(when (not= written size)
(ex/raise :type :validation
@ -719,7 +719,7 @@
(assoc ::sto/touched-at (dt/now))
(assoc :bucket "file-media-object"))
sobject @(sto/put-object! storage params)]
sobject (p/await! (sto/put-object! storage params))]
(l/debug :hint "persisted storage object" :id id :new-id (:id sobject) ::l/sync? true)
(vswap! *state* update :index assoc id (:id sobject)))))
@ -910,7 +910,9 @@
(export! output-stream))))]
(fn [_]
(yrs/response 200 body {"content-type" "application/octet-stream"}))))
{::yrs/status 200
::yrs/body body
::yrs/headers {"content-type" "application/octet-stream"}})))
(s/def ::file ::media/upload)
(s/def ::import-binfile

3
backend/src/app/rpc/commands/demo.clj
View file

@ -13,6 +13,7 @@
[app.loggers.audit :as audit]
[app.rpc :as-alias rpc]
[app.rpc.commands.auth :as auth]
[app.rpc.commands.profile :as profile]
[app.rpc.doc :as-alias doc]
[app.util.services :as sv]
[app.util.time :as dt]
@ -48,7 +49,7 @@
:fullname fullname
:is-active true
:deleted-at (dt/in-future cf/deletion-delay)
:password password
:password (profile/derive-password cfg password)
:props {}}]
(db/with-atomic [conn pool]

53
backend/src/app/rpc/commands/files_update.clj
View file

@ -101,7 +101,7 @@
(defn- wrap-with-pointer-map-context
[f]
(fn [{:keys [conn] :as cfg} {:keys [id] :as file}]
(fn [{:keys [::db/conn] :as cfg} {:keys [id] :as file}]
(binding [pmap/*tracked* (atom {})
pmap/*load-fn* (partial files/load-pointer conn id)
ffeat/*wrap-with-pointer-map-fn* pmap/wrap]
@ -126,7 +126,7 @@
;; database.
(sv/defmethod ::update-file
{::climit/queue :update-file
{::climit/id :update-file-by-id
::climit/key-fn :id
::webhooks/event? true
::webhooks/batch-timeout (dt/duration "2m")
@ -136,8 +136,7 @@
(db/with-atomic [conn pool]
(files/check-edition-permissions! conn profile-id id)
(db/xact-lock! conn id)
(let [cfg (assoc cfg :conn conn)
(let [cfg (assoc cfg ::db/conn conn)
params (assoc params :profile-id profile-id)
tpoint (dt/tpoint)]
(-> (update-file cfg params)
@ -145,7 +144,7 @@
(l/trace :hint "update-file" :time (dt/format-duration elapsed))))))))
(defn update-file
[{:keys [conn ::mtx/metrics] :as cfg} {:keys [profile-id id changes changes-with-metadata] :as params}]
[{:keys [::db/conn ::mtx/metrics] :as cfg} {:keys [profile-id id changes changes-with-metadata] :as params}]
(let [file (get-file conn id)
features (->> (concat (:features file)
(:features params))
@ -197,24 +196,34 @@
:project-id (:project-id file)
:team-id (:team-id file)}))))))
(defn- update-file-data
[file changes]
(-> file
(update :revn inc)
(update :data (fn [data]
(cond-> data
:always
(-> (blob/decode)
(assoc :id (:id file))
(pmg/migrate-data))
(and (contains? ffeat/*current* "components/v2")
(not (contains? ffeat/*previous* "components/v2")))
(ctf/migrate-to-components-v2)
:always
(-> (cp/process-changes changes)
(blob/encode)))))))
(defn- update-file*
[{:keys [conn] :as cfg} {:keys [profile-id file changes session-id ::created-at] :as params}]
(let [file (-> file
(update :revn inc)
(update :data (fn [data]
(cond-> data
:always
(-> (blob/decode)
(assoc :id (:id file))
(pmg/migrate-data))
[{:keys [::db/conn] :as cfg} {:keys [profile-id file changes session-id ::created-at] :as params}]
(let [;; Process the file data in the CLIMIT context; scheduling it
;; to be executed on a separated executor for avoid to do the
;; CPU intensive operation on vthread.
file (-> (climit/configure cfg :update-file)
(climit/submit! (partial update-file-data file changes)))]
(and (contains? ffeat/*current* "components/v2")
(not (contains? ffeat/*previous* "components/v2")))
(ctf/migrate-to-components-v2)
:always
(-> (cp/process-changes changes)
(blob/encode))))))]
(db/insert! conn :file-change
{:id (uuid/next)
:session-id session-id
@ -273,7 +282,7 @@
(vec)))
(defn- send-notifications!
[{:keys [conn] :as cfg} {:keys [file changes session-id] :as params}]
[{:keys [::db/conn] :as cfg} {:keys [file changes session-id] :as params}]
(let [lchanges (filter library-change? changes)
msgbus (::mbus/msgbus cfg)]

94
backend/src/app/rpc/commands/fonts.clj
View file

@ -6,7 +6,6 @@
(ns app.rpc.commands.fonts
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.spec :as us]
[app.common.uuid :as uuid]
@ -15,7 +14,7 @@
[app.loggers.webhooks :as-alias webhooks]
[app.media :as media]
[app.rpc :as-alias rpc]
[app.rpc.climit :as-alias climit]
[app.rpc.climit :as climit]
[app.rpc.commands.files :as files]
[app.rpc.commands.projects :as projects]
[app.rpc.commands.teams :as teams]
@ -25,10 +24,8 @@
[app.storage :as sto]
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as-alias wrk]
[clojure.spec.alpha :as s]
[promesa.core :as p]
[promesa.exec :as px]))
[promesa.core :as p]))
(def valid-weight #{100 200 300 400 500 600 700 800 900 950})
(def valid-style #{"normal" "italic"})
@ -107,50 +104,45 @@
(create-font-variant cfg (assoc params :profile-id profile-id))))
(defn create-font-variant
[{:keys [::sto/storage ::db/pool ::wrk/executor ::rpc/climit]} {:keys [data] :as params}]
(letfn [(generate-fonts [data]
(climit/with-dispatch (:process-font climit)
(media/run {:cmd :generate-fonts :input data})))
[{:keys [::sto/storage ::db/pool] :as cfg} {:keys [data] :as params}]
(letfn [(generate-missing! [data]
(let [data (media/run {:cmd :generate-fonts :input data})]
(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
:hint "invalid font upload, unable to generate missing font assets"))
data))
;; Function responsible of calculating cryptographyc hash of
;; the provided data.
(calculate-hash [data]
(px/with-dispatch executor
(sto/calculate-hash data)))
(validate-data [data]
(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))
data)
(persist-font-object [data mtype]
(prepare-font [data mtype]
(when-let [resource (get data mtype)]
(p/let [hash (calculate-hash resource)
content (-> (sto/content resource)
(sto/wrap-with-hash hash))]
(sto/put-object! storage {::sto/content content
::sto/touched-at (dt/now)
::sto/deduplicate? true
:content-type mtype
:bucket "team-font-variant"}))))
(let [hash (sto/calculate-hash resource)
content (-> (sto/content resource)
(sto/wrap-with-hash hash))]
{::sto/content content
::sto/touched-at (dt/now)
::sto/deduplicate? true
:content-type mtype
:bucket "team-font-variant"})))
(persist-fonts [data]
(p/let [otf (persist-font-object data "font/otf")
ttf (persist-font-object data "font/ttf")
woff1 (persist-font-object data "font/woff")
woff2 (persist-font-object data "font/woff2")]
(persist-fonts-files! [data]
(let [otf-params (prepare-font data "font/otf")
ttf-params (prepare-font data "font/ttf")
wf1-params (prepare-font data "font/woff")
wf2-params (prepare-font data "font/woff2")]
(cond-> {}
(some? otf-params)
(assoc :otf (p/await! (sto/put-object! storage otf-params)))
(some? ttf-params)
(assoc :ttf (p/await! (sto/put-object! storage ttf-params)))
(some? wf1-params)
(assoc :woff1 (p/await! (sto/put-object! storage wf1-params)))
(some? wf2-params)
(assoc :woff2 (p/await! (sto/put-object! storage wf2-params))))))
(d/without-nils
{:otf otf
:ttf ttf
:woff1 woff1
:woff2 woff2})))
(insert-into-db [{:keys [woff1 woff2 otf ttf]}]
(insert-font-variant! [{:keys [woff1 woff2 otf ttf]}]
(db/insert! pool :team-font-variant
{:id (uuid/next)
:team-id (:team-id params)
@ -164,13 +156,11 @@
:ttf-file-id (:id ttf)}))
]
(->> (generate-fonts data)
(p/fmap validate-data)
(p/mcat executor persist-fonts)
(p/fmap executor insert-into-db)
(p/fmap (fn [result]
(let [params (update params :data (comp vec keys))]
(rph/with-meta result {::audit/replace-props params})))))))
(let [data (-> (climit/configure cfg :process-font)
(climit/submit! (partial generate-missing! data)))
assets (persist-fonts-files! data)
result (insert-font-variant! assets)]
(vary-meta result assoc ::audit/replace-props (update params :data (comp vec keys))))))
;; --- UPDATE FONT FAMILY

166
backend/src/app/rpc/commands/media.clj
View file

@ -22,13 +22,10 @@
[app.storage :as sto]
[app.storage.tmp :as tmp]
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as-alias wrk]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[datoteka.io :as io]
[promesa.core :as p]
[promesa.exec :as px]))
[promesa.core :as p]))
(def default-max-file-size
(* 1024 1024 10)) ; 10 MiB
@ -110,71 +107,62 @@
;; witch holds the reference to storage object (it some kind of
;; inverse, soft referential integrity).
(defn- process-main-image
[info]
(let [hash (sto/calculate-hash (:path info))
data (-> (sto/content (:path info))
(sto/wrap-with-hash hash))]
{::sto/content data
::sto/deduplicate? true
::sto/touched-at (:ts info)
:content-type (:mtype info)
:bucket "file-media-object"}))
(defn- process-thumb-image
[info]
(let [thumb (-> thumbnail-options
(assoc :cmd :generic-thumbnail)
(assoc :input info)
(media/run))
hash (sto/calculate-hash (:data thumb))
data (-> (sto/content (:data thumb) (:size thumb))
(sto/wrap-with-hash hash))]
{::sto/content data
::sto/deduplicate? true
::sto/touched-at (:ts info)
:content-type (:mtype thumb)
:bucket "file-media-object"}))
(defn- process-image
[content]
(let [info (media/run {:cmd :info :input content})]
(cond-> info
(and (not (svg-image? info))
(big-enough-for-thumbnail? info))
(assoc ::thumb (process-thumb-image info))
:always
(assoc ::image (process-main-image info)))))
(defn create-file-media-object
[{:keys [::sto/storage ::db/pool climit ::wrk/executor]}
[{:keys [::sto/storage ::db/pool] :as cfg}
{:keys [id file-id is-local name content]}]
(letfn [;; Function responsible to retrieve the file information, as
;; it is synchronous operation it should be wrapped into
;; with-dispatch macro.
(get-info [content]
(climit/with-dispatch (:process-image climit)
(media/run {:cmd :info :input content})))
;; Function responsible of calculating cryptographyc hash of
;; the provided data.
(calculate-hash [data]
(px/with-dispatch executor
(sto/calculate-hash data)))
(let [result (-> (climit/configure cfg :process-image)
(climit/submit! (partial process-image content)))
;; Function responsible of generating thumnail. As it is synchronous
;; opetation, it should be wrapped into with-dispatch macro
(generate-thumbnail [info]
(climit/with-dispatch (:process-image climit)
(media/run (assoc thumbnail-options
:cmd :generic-thumbnail
:input info))))
image (p/await! (sto/put-object! storage (::image result)))
thumb (when-let [params (::thumb result)]
(p/await! (sto/put-object! storage params)))]
(create-thumbnail [info]
(when (and (not (svg-image? info))
(big-enough-for-thumbnail? info))
(p/let [thumb (generate-thumbnail info)
hash (calculate-hash (:data thumb))
content (-> (sto/content (:data thumb) (:size thumb))
(sto/wrap-with-hash hash))]
(sto/put-object! storage
{::sto/content content
::sto/deduplicate? true
::sto/touched-at (dt/now)
:content-type (:mtype thumb)
:bucket "file-media-object"}))))
(create-image [info]
(p/let [data (:path info)
hash (calculate-hash data)
content (-> (sto/content data)
(sto/wrap-with-hash hash))]
(sto/put-object! storage
{::sto/content content
::sto/deduplicate? true
::sto/touched-at (dt/now)
:content-type (:mtype info)
:bucket "file-media-object"})))
(insert-into-database [info image thumb]
(px/with-dispatch executor
(db/exec-one! pool [sql:create-file-media-object
(or id (uuid/next))
file-id is-local name
(:id image)
(:id thumb)
(:width info)
(:height info)
(:mtype info)])))]
(p/let [info (get-info content)
thumb (create-thumbnail info)
image (create-image info)]
(insert-into-database info image thumb))))
(db/exec-one! pool [sql:create-file-media-object
(or id (uuid/next))
file-id is-local name
(:id image)
(:id thumb)
(:width result)
(:height result)
(:mtype result)])))
;; --- Create File Media Object (from URL)
@ -192,9 +180,9 @@
(files/check-edition-permissions! pool profile-id file-id)
(create-file-media-object-from-url cfg params)))
(defn- create-file-media-object-from-url
[cfg {:keys [url name] :as params}]
(letfn [(parse-and-validate-size [headers]
(defn- download-image
[{:keys [::http/client]} uri]
(letfn [(parse-and-validate [{:keys [headers] :as response}]
(let [size (some-> (get headers "content-length") d/parse-integer)
mtype (get headers "content-type")
format (cm/mtype->format mtype)
@ -217,32 +205,34 @@
:code :media-type-not-allowed
:hint "seems like the url points to an invalid media object"))
{:size size
:mtype mtype
:format format}))
{:size size :mtype mtype :format format}))]
(download-media [uri]
(-> (http/req! cfg {:method :get :uri uri} {:response-type :input-stream})
(p/then process-response)))
(let [{:keys [body] :as response} (http/req! client
{:method :get :uri uri}
{:response-type :input-stream :sync? true})
{:keys [size mtype]} (parse-and-validate response)
(process-response [{:keys [body headers] :as response}]
(let [{:keys [size mtype]} (parse-and-validate-size headers)
path (tmp/tempfile :prefix "penpot.media.download.")
written (io/write-to-file! body path :size size)]
path (tmp/tempfile :prefix "penpot.media.download.")
written (io/write-to-file! body path :size size)]
(when (not= written size)
(ex/raise :type :internal
:code :mismatch-write-size
:hint "unexpected state: unable to write to file"))
(when (not= written size)
(ex/raise :type :internal
:code :mismatch-write-size
:hint "unexpected state: unable to write to file"))
{:filename "tempfile"
:size size
:path path
:mtype mtype}))]
{:filename "tempfile"
:size size
:path path
:mtype mtype})))
(p/let [content (download-media url)]
(->> (merge params {:content content :name (or name (:filename content))})
(create-file-media-object cfg)))))
(defn- create-file-media-object-from-url
[cfg {:keys [url name] :as params}]
(let [content (download-image cfg url)
params (-> params
(assoc :content content)
(assoc :name (or name (:filename content))))]
(create-file-media-object cfg params)))
;; --- Clone File Media object (Upload and create from url)

131
backend/src/app/rpc/commands/profile.clj
View file

@ -26,17 +26,17 @@
[app.tokens :as tokens]
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as-alias wrk]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[promesa.core :as p]
[promesa.exec :as px]))
[promesa.core :as p]))
(declare check-profile-existence!)
(declare decode-row)
(declare derive-password)
(declare filter-props)
(declare get-profile)
(declare strip-private-attrs)
(declare filter-props)
(declare check-profile-existence!)
(declare verify-password)
;; --- QUERY: Get profile (own)
@ -50,6 +50,7 @@
;; 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
;; cases we need to reraise the exception.
(try
(-> (get-profile pool profile-id)
(strip-private-attrs)
@ -120,10 +121,10 @@
:req-un [::password ::old-password]))
(sv/defmethod ::update-profile-password
{::climit/queue :auth}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id password] :as params}]
(db/with-atomic [conn pool]
(let [profile (validate-password! conn (assoc params :profile-id profile-id))
(let [cfg (assoc cfg ::db/conn conn)
profile (validate-password! cfg (assoc params :profile-id profile-id))
session-id (::session/id params)]
(when (= (str/lower (:email profile))
@ -132,29 +133,30 @@
: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 profile-id session-id)
(update-profile-password! cfg (assoc profile :password password))
(invalidate-profile-session! cfg profile-id session-id)
nil)))
(defn- invalidate-profile-session!
"Removes all sessions except the current one."
[conn profile-id session-id]
[{:keys [::db/conn]} profile-id session-id]
(let [sql "delete from http_session where profile_id = ? and id != ?"]
(:next.jdbc/update-count (db/exec-one! conn [sql profile-id session-id]))))
(defn- validate-password!
[conn {:keys [profile-id old-password] :as params}]
[{:keys [::db/conn] :as cfg} {:keys [profile-id old-password] :as params}]
(let [profile (db/get-by-id conn :profile profile-id ::db/for-update? true)]
(when-not (:valid (auth/verify-password old-password (:password profile)))
(when-not (:valid (verify-password cfg old-password (:password profile)))
(ex/raise :type :validation
:code :old-password-not-match))
profile))
(defn update-profile-password!
[conn {:keys [id password] :as profile}]
(db/update! conn :profile
{:password (auth/derive-password password)}
{:id id}))
[{:keys [::db/conn] :as cfg} {:keys [id password] :as profile}]
(let [password (derive-password cfg password)]
(db/update! conn :profile
{:password password}
{:id id})))
;; --- MUTATION: Update Photo
@ -173,61 +175,49 @@
(let [cfg (update cfg ::sto/storage media/configure-assets-storage)]
(update-profile-photo cfg (assoc params :profile-id profile-id))))
;; TODO: reimplement it without p/let
(defn update-profile-photo
[{:keys [::db/pool ::sto/storage ::wrk/executor] :as cfg} {:keys [profile-id file] :as params}]
(letfn [(on-uploaded [photo]
(let [profile (db/get-by-id pool :profile profile-id ::db/for-update? true)]
[{:keys [::db/pool ::sto/storage] :as cfg} {:keys [profile-id file] :as params}]
(let [photo (upload-photo cfg params)
profile (db/get-by-id pool :profile profile-id ::db/for-update? true)]
;; Schedule deletion of old photo
(when-let [id (:photo-id profile)]
(sto/touch-object! storage id))
;; Schedule deletion of old photo
(when-let [id (:photo-id profile)]
(p/await! (sto/touch-object! storage id)))
;; Save new photo
(db/update! pool :profile
{:photo-id (:id photo)}
{:id profile-id})
;; Save new photo
(db/update! pool :profile
{:photo-id (:id photo)}
{:id profile-id})
(-> (rph/wrap)
(rph/with-meta {::audit/replace-props
{:file-name (:filename file)
:file-size (:size file)
:file-path (str (:path file))
:file-mtype (:mtype file)}}))))]
(->> (upload-photo cfg params)
(p/fmap executor on-uploaded))))
(-> (rph/wrap)
(rph/with-meta {::audit/replace-props
{:file-name (:filename file)
:file-size (:size file)
:file-path (str (:path file))
:file-mtype (:mtype file)}}))))
(defn- generate-thumbnail!
[file]
(let [input (media/run {:cmd :info :input file})
thumb (media/run {:cmd :profile-thumbnail
:format :jpeg
:quality 85
:width 256
:height 256
:input input})
hash (sto/calculate-hash (:data thumb))
content (-> (sto/content (:data thumb) (:size thumb))
(sto/wrap-with-hash hash))]
{::sto/content content
::sto/deduplicate? true
:bucket "profile"
:content-type (:mtype thumb)}))
(defn upload-photo
[{:keys [::sto/storage ::wrk/executor climit] :as cfg} {:keys [file]}]
(letfn [(get-info [content]
(climit/with-dispatch (:process-image climit)
(media/run {:cmd :info :input content})))
(generate-thumbnail [info]
(climit/with-dispatch (:process-image climit)
(media/run {:cmd :profile-thumbnail
:format :jpeg
:quality 85
:width 256
:height 256
:input info})))
;; Function responsible of calculating cryptographyc hash of
;; the provided data.
(calculate-hash [data]
(px/with-dispatch executor
(sto/calculate-hash data)))]
(p/let [info (get-info file)
thumb (generate-thumbnail info)
hash (calculate-hash (:data thumb))
content (-> (sto/content (:data thumb) (:size thumb))
(sto/wrap-with-hash hash))]
(sto/put-object! storage {::sto/content content
::sto/deduplicate? true
:bucket "profile"
:content-type (:mtype thumb)}))))
[{:keys [::sto/storage] :as cfg} {:keys [file]}]
(let [params (-> (climit/configure cfg :process-image)
(climit/submit! (partial generate-thumbnail! file)))]
(p/await! (sto/put-object! storage params))))
;; --- MUTATION: Request Email Change
@ -417,6 +407,17 @@
[props]
(into {} (filter (fn [[k _]] (simple-ident? k))) props))
(defn derive-password
[cfg password]
(when password
(-> (climit/configure cfg :derive-password)
(climit/submit! (partial auth/derive-password password)))))
(defn verify-password
[cfg password password-data]
(-> (climit/configure cfg :derive-password)
(climit/submit! (partial auth/verify-password password password-data))))
(defn decode-row
[{:keys [props] :as row}]
(cond-> row

43
backend/src/app/rpc/commands/teams.clj
View file

@ -27,11 +27,9 @@
[app.tokens :as tokens]
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as-alias wrk]
[clojure.spec.alpha :as s]
[cuerdas.core :as str]
[promesa.core :as p]
[promesa.exec :as px]))
[promesa.core :as p]))
;; --- Helpers & Specs
@ -78,6 +76,8 @@
(declare retrieve-teams)
(def counter (volatile! 0))
(s/def ::get-teams
(s/keys :req [::rpc/profile-id]))
@ -588,15 +588,14 @@
(update-team-photo cfg (assoc params :profile-id profile-id))))
(defn update-team-photo
[{:keys [::db/pool ::sto/storage ::wrk/executor] :as cfg} {:keys [profile-id team-id] :as params}]
(p/let [team (px/with-dispatch executor
(retrieve-team pool profile-id team-id))
photo (profile/upload-photo cfg params)]
[{:keys [::db/pool ::sto/storage] :as cfg} {:keys [profile-id team-id] :as params}]
(let [team (retrieve-team pool profile-id team-id)
photo (profile/upload-photo cfg params)]
;; Mark object as touched for make it ellegible for tentative
;; garbage collection.
(when-let [id (:photo-id team)]
(sto/touch-object! storage id))
(p/await! (sto/touch-object! storage id)))
;; Save new photo
(db/update! pool :team
@ -694,13 +693,13 @@
(l/info :hint "invitation token" :token itoken))
(audit/submit! cfg
{:type "action"
:name (if updated?
"update-team-invitation"
"create-team-invitation")
:profile-id (:id profile)
:props (-> (dissoc tprops :profile-id)
(d/without-nils))})
{::audit/type "action"
::audit/name (if updated?
"update-team-invitation"
"create-team-invitation")
::audit/profile-id (:id profile)
::audit/props (-> (dissoc tprops :profile-id)
(d/without-nils))})
(eml/send! {::eml/conn conn
::eml/factory eml/invite-to-team
@ -802,13 +801,13 @@
::quotes/incr (count emails)}))
(audit/submit! cfg
{:type "command"
:name "create-team-invitations"
:profile-id profile-id
:props {:emails emails
:role role
:profile-id profile-id
:invitations (count emails)}})
{::audit/type "command"
::audit/name "create-team-invitations"
::audit/profile-id profile-id
::audit/props {:emails emails
:role role
:profile-id profile-id
:invitations (count emails)}})
(vary-meta team assoc ::audit/props {:invitations (count emails)}))))

50
backend/src/app/rpc/commands/webhooks.clj
View file

@ -48,30 +48,26 @@
(defn- validate-webhook!
[cfg whook params]
(letfn [(handle-exception [exception]
(if-let [hint (webhooks/interpret-exception exception)]
(ex/raise :type :validation
:code :webhook-validation
:hint hint)
(ex/raise :type :internal
:code :webhook-validation
:cause exception)))
(when (not= (:uri whook) (:uri params))
(try
(let [response (http/req! cfg
{:method :head
:uri (str (:uri params))
:timeout (dt/duration "3s")}
{:sync? true})]
(when-let [hint (webhooks/interpret-response response)]
(ex/raise :type :validation
:code :webhook-validation
:hint hint)))
(handle-response [response]
(when-let [hint (webhooks/interpret-response response)]
(ex/raise :type :validation
:code :webhook-validation
:hint hint)))]
(if (not= (:uri whook) (:uri params))
(->> (http/req! cfg {:method :head
:uri (str (:uri params))
:timeout (dt/duration "3s")})
(p/hmap (fn [response exception]
(if exception
(handle-exception exception)
(handle-response response)))))
(p/resolved nil))))
(catch Throwable cause
(if-let [hint (webhooks/interpret-exception cause)]
(ex/raise :type :validation
:code :webhook-validation
:hint hint)
(ex/raise :type :internal
:code :webhook-validation
:cause cause))))))
(defn- validate-quotes!
[{:keys [::db/pool]} {:keys [team-id]}]
@ -109,8 +105,8 @@
[{:keys [::db/pool ::wrk/executor] :as cfg} {:keys [::rpc/profile-id team-id] :as params}]
(check-edition-permissions! pool profile-id team-id)
(validate-quotes! cfg params)
(->> (validate-webhook! cfg nil params)
(p/fmap executor (fn [_] (insert-webhook! cfg params)))))
(validate-webhook! cfg nil params)
(insert-webhook! cfg params))
(s/def ::update-webhook
(s/keys :req-un [::id ::uri ::mtype ::is-active]))
@ -120,8 +116,8 @@
[{:keys [::db/pool ::wrk/executor] :as cfg} {:keys [::rpc/profile-id id] :as params}]
(let [whook (-> (db/get pool :webhook {:id id}) (decode-row))]
(check-edition-permissions! pool profile-id (:team-id whook))
(->> (validate-webhook! cfg whook params)
(p/fmap executor (fn [_] (update-webhook! cfg whook params))))))
(validate-webhook! cfg whook params)
(update-webhook! cfg whook params)))
(s/def ::delete-webhook
(s/keys :req [::rpc/profile-id]

32
backend/src/app/rpc/cond.clj
View file

@ -27,8 +27,6 @@
[app.common.logging :as l]
[app.rpc.helpers :as rph]
[app.util.services :as-alias sv]
[promesa.core :as p]
[promesa.exec :as px]
[yetti.response :as yrs]))
(def
@ -38,30 +36,24 @@
(defn- fmt-key
[s]
(when s
(str "W/\"" s "\"")))
(str "W/\"" s "\""))
(defn wrap
[{:keys [executor]} f {:keys [::get-object ::key-fn ::reuse-key?] :as mdata}]
[_ f {:keys [::get-object ::key-fn ::reuse-key?] :as mdata}]
(if (and (ifn? get-object) (ifn? key-fn))
(do
(l/debug :hint "instrumenting method" :service (::sv/name mdata))
(fn [cfg {:keys [::key] :as params}]
(if *enabled*
(->> (if (or key reuse-key?)
(->> (px/submit! executor (partial get-object cfg params))
(p/map key-fn)
(p/map fmt-key))
(p/resolved nil))
(p/mapcat (fn [key']
(if (and (some? key)
(= key key'))
(p/resolved (fn [_] (yrs/response 304)))
(->> (f cfg params)
(p/map (fn [result]
(->> (or (and reuse-key? key')
(-> result meta ::key fmt-key)
(-> result key-fn fmt-key))
(rph/with-header result "etag")))))))))
(let [key' (when (or key reuse-key?)
(some-> (get-object cfg params) key-fn fmt-key))]
(if (and (some? key)
(= key key'))
(fn [_] {::yrs/status 304})
(let [result (f cfg params)
etag (or (and reuse-key? key')
(some-> result meta ::key fmt-key)
(some-> result key-fn fmt-key))]
(rph/with-header result "etag" etag))))
(f cfg params))))
f))

34
backend/src/app/rpc/doc.clj
View file

@ -30,32 +30,34 @@
(defn- prepare-context
[methods]
(letfn [(gen-doc [type [name f]]
(let [mdata (meta f)]
{:type (d/name type)
:name (d/name name)
:module (-> (:ns mdata) (str/split ".") last)
:auth (:auth mdata true)
:webhook (::webhooks/event? mdata false)
:docs (::sv/docstring mdata)
:deprecated (::deprecated mdata)
:added (::added mdata)
:changes (some->> (::changes mdata) (partition-all 2) (map vec))
:spec (get-spec-str (::sv/spec mdata))}))]
(letfn [(gen-doc [type [{:keys [::sv/name] :as mdata} _f]]
{:type (d/name type)
:name (d/name name)
:module (-> (:ns mdata) (str/split ".") last)
:auth (:auth mdata true)
:webhook (::webhooks/event? mdata false)
:docs (::sv/docstring mdata)
:deprecated (::deprecated mdata)
:added (::added mdata)
:changes (some->> (::changes mdata) (partition-all 2) (map vec))
:spec (get-spec-str (::sv/spec mdata))})]
{:version (:main cf/version)
:command-methods
(->> (:commands methods)
(map val)
(map (partial gen-doc :command))
(sort-by (juxt :module :name)))
:query-methods
(->> (:queries methods)
(map val)
(map (partial gen-doc :query))
(sort-by (juxt :module :name)))
:mutation-methods
(->> (:mutations methods)
(map val)
(map (partial gen-doc :query))
(sort-by (juxt :module :name)))}))
@ -64,11 +66,11 @@
(if (contains? cf/flags :backend-api-doc)
(let [context (prepare-context methods)]
(fn [_ respond _]
(respond (yrs/response 200 (-> (io/resource "app/templates/api-doc.tmpl")
(tmpl/render context))))))
(respond {::yrs/status 200
::yrs/body (-> (io/resource "app/templates/api-doc.tmpl")
(tmpl/render context))})))
(fn [_ respond _]
(respond (yrs/response 404)))))
(respond {::yrs/status 404}))))
(s/def ::routes vector?)

9
backend/src/app/rpc/helpers.clj
View file

@ -10,7 +10,8 @@
(:require
[app.common.data.macros :as dm]
[app.http :as-alias http]
[app.rpc :as-alias rpc]))
[app.rpc :as-alias rpc]
[yetti.response :as-alias yrs]))
;; A utilty wrapper object for wrap service responses that does not
;; implements the IObj interface that make possible attach metadata to
@ -35,7 +36,9 @@
o
(MetadataWrapper. o {})))
([o m]
(MetadataWrapper. o m)))
(if (instance? clojure.lang.IObj o)
(vary-meta o merge m)
(MetadataWrapper. o m))))
(defn wrapped?
[o]
@ -74,4 +77,4 @@
(fn [_ response]
(let [exp (if (integer? max-age) max-age (inst-ms max-age))
val (dm/fmt "max-age=%" (int (/ exp 1000.0)))]
(update response :headers assoc "cache-control" val)))))
(update response ::yrs/headers assoc "cache-control" val)))))

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

@ -14,7 +14,6 @@
[app.http.session :as session]
[app.loggers.audit :as audit]
[app.media :as media]
[app.rpc.climit :as-alias climit]
[app.rpc.commands.profile :as profile]
[app.rpc.doc :as-alias doc]
[app.rpc.helpers :as rph]
@ -78,20 +77,20 @@
(s/keys :req-un [::profile-id ::password ::old-password]))
(sv/defmethod ::update-profile-password
{::climit/queue :auth
::doc/added "1.0"
{::doc/added "1.0"
::doc/deprecated "1.18"}
[{:keys [::db/pool] :as cfg} {:keys [password] :as params}]
(db/with-atomic [conn pool]
(let [profile (#'profile/validate-password! conn params)
(let [cfg (assoc cfg ::db/conn conn)
profile (#'profile/validate-password! cfg params)
session-id (::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"))
(profile/update-profile-password! conn (assoc profile :password password))
(#'profile/invalidate-profile-session! conn (:id profile) session-id)
(profile/update-profile-password! cfg (assoc profile :password password))
(#'profile/invalidate-profile-session! cfg (:id profile) session-id)
nil)))

27
backend/src/app/rpc/retry.clj
View file

@ -10,8 +10,7 @@
(:require
[app.common.logging :as l]
[app.util.retry :refer [conflict-exception?]]
[app.util.services :as sv]
[promesa.core :as p]))
[app.util.services :as sv]))
(defn conflict-db-insert?
"Check if exception matches a insertion conflict on postgresql."
@ -28,18 +27,16 @@
(if-let [max-retries (::max-retries mdata)]
(fn [cfg params]
(letfn [(run [retry]
(->> (f cfg params)
(p/merr (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 1)))
((fn run [retry]
(try
(f cfg params)
(catch Throwable 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))))) 1))
f))

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

@ -55,6 +55,7 @@
[app.redis :as rds]
[app.redis.script :as-alias rscript]
[app.rpc :as-alias rpc]
[app.rpc.helpers :as rph]
[app.rpc.rlimit.result :as-alias lresult]
[app.util.services :as-alias sv]
[app.util.time :as dt]
@ -64,7 +65,6 @@
[cuerdas.core :as str]
[datoteka.fs :as fs]
[integrant.core :as ig]
[promesa.core :as p]
[promesa.exec :as px]))
(def ^:private default-timeout
@ -82,7 +82,7 @@
{::rscript/name ::window-rate-limit
::rscript/path "app/rpc/rlimit/window.lua"})
(def enabled?
(def enabled
"Allows on runtime completely disable rate limiting."
(atom true))
@ -119,116 +119,97 @@
(defmethod parse-limit :bucket
[[name strategy opts :as vlimit]]
(us/assert! ::limit-tuple vlimit)
(merge
{::name name
::strategy strategy}
(if-let [[_ capacity rate interval] (re-find bucket-opts-re opts)]
(let [interval (dt/duration interval)
rate (parse-long rate)
capacity (parse-long capacity)]
{::capacity capacity
::rate rate
::interval interval
::opts opts
::params [(dt/->seconds interval) rate capacity]
::key (str "ratelimit.bucket." (d/name name))})
(ex/raise :type :validation
:code :invalid-bucket-limit-opts
:hint (str/ffmt "looks like '%' does not have a valid format" opts)))))
(if-let [[_ capacity rate interval] (re-find bucket-opts-re opts)]
(let [interval (dt/duration interval)
rate (parse-long rate)
capacity (parse-long capacity)]
{::name name
::strategy strategy
::capacity capacity
::rate rate
::interval interval
::opts opts
::params [(dt/->seconds interval) rate capacity]
::key (str "ratelimit.bucket." (d/name name))})
(ex/raise :type :validation
:code :invalid-bucket-limit-opts
:hint (str/ffmt "looks like '%' does not have a valid format" opts))))
(defmethod process-limit :bucket
[redis user-id now {:keys [::key ::params ::service ::capacity ::interval ::rate] :as limit}]
(let [script (-> bucket-rate-limit-script
(assoc ::rscript/keys [(str key "." service "." user-id)])
(assoc ::rscript/vals (conj params (dt/->seconds now))))]
(->> (rds/eval! redis script)
(p/fmap (fn [result]
(let [allowed? (boolean (nth result 0))
remaining (nth result 1)
reset (* (/ (inst-ms interval) rate)
(- capacity remaining))]
(l/trace :hint "limit processed"
:service service
:limit (name (::name limit))
:strategy (name (::strategy limit))
:opts (::opts limit)
:allowed? allowed?
:remaining remaining)
(-> limit
(assoc ::lresult/allowed? allowed?)
(assoc ::lresult/reset (dt/plus now reset))
(assoc ::lresult/remaining remaining))))))))
(let [script (-> bucket-rate-limit-script
(assoc ::rscript/keys [(str key "." service "." user-id)])
(assoc ::rscript/vals (conj params (dt/->seconds now))))
result (rds/eval! redis script)
allowed? (boolean (nth result 0))
remaining (nth result 1)
reset (* (/ (inst-ms interval) rate)
(- capacity remaining))]
(l/trace :hint "limit processed"
:service service
:limit (name (::name limit))
:strategy (name (::strategy limit))
:opts (::opts limit)
:allowed allowed?
:remaining remaining)
(-> limit
(assoc ::lresult/allowed allowed?)
(assoc ::lresult/reset (dt/plus now reset))
(assoc ::lresult/remaining remaining))))
(defmethod process-limit :window
[redis user-id now {:keys [::nreq ::unit ::key ::service] :as limit}]
(let [ts (dt/truncate now unit)
ttl (dt/diff now (dt/plus ts {unit 1}))
script (-> window-rate-limit-script
(assoc ::rscript/keys [(str key "." service "." user-id "." (dt/format-instant ts))])
(assoc ::rscript/vals [nreq (dt/->seconds ttl)]))]
(->> (rds/eval! redis script)
(p/fmap (fn [result]
(let [allowed? (boolean (nth result 0))
remaining (nth result 1)]
(l/trace :hint "limit processed"
:service service
:limit (name (::name limit))
:strategy (name (::strategy limit))
:opts (::opts limit)
:allowed? allowed?
:remaining remaining)
(-> limit
(assoc ::lresult/allowed? allowed?)
(assoc ::lresult/remaining remaining)
(assoc ::lresult/reset (dt/plus ts {unit 1})))))))))
(let [ts (dt/truncate now unit)
ttl (dt/diff now (dt/plus ts {unit 1}))
script (-> window-rate-limit-script
(assoc ::rscript/keys [(str key "." service "." user-id "." (dt/format-instant ts))])
(assoc ::rscript/vals [nreq (dt/->seconds ttl)]))
result (rds/eval! redis script)
allowed? (boolean (nth result 0))
remaining (nth result 1)]
(l/trace :hint "limit processed"
:service service
:limit (name (::name limit))
:strategy (name (::strategy limit))
:opts (::opts limit)
:allowed allowed?
:remaining remaining)
(-> limit
(assoc ::lresult/allowed allowed?)
(assoc ::lresult/remaining remaining)
(assoc ::lresult/reset (dt/plus ts {unit 1})))))
(defn- process-limits!
[redis user-id limits now]
(->> (p/all (map (partial process-limit redis user-id now) limits))
(p/fmap (fn [results]
(let [remaining (->> results
(d/index-by ::name ::lresult/remaining)
(uri/map->query-string))
reset (->> results
(d/index-by ::name (comp dt/->seconds ::lresult/reset))
(uri/map->query-string))
rejected (->> results
(filter (complement ::lresult/allowed?))
(first))]
(let [results (into [] (map (partial process-limit redis user-id now)) limits)
remaining (->> results
(d/index-by ::name ::lresult/remaining)
(uri/map->query-string))
reset (->> results
(d/index-by ::name (comp dt/->seconds ::lresult/reset))
(uri/map->query-string))
(when rejected
(l/warn :hint "rejected rate limit"
:user-id (str user-id)
:limit-service (-> rejected ::service name)
:limit-name (-> rejected ::name name)
:limit-strategy (-> rejected ::strategy name)))
rejected (d/seek (complement ::lresult/allowed) results)]
{:enabled? true
:allowed? (not (some? rejected))
:headers {"x-rate-limit-remaining" remaining
"x-rate-limit-reset" reset}})))))
(when rejected
(l/warn :hint "rejected rate limit"
:user-id (str user-id)
:limit-service (-> rejected ::service name)
:limit-name (-> rejected ::name name)
:limit-strategy (-> rejected ::strategy name)))
(defn- handle-response
[f cfg params result]
(if (:enabled? result)
(let [headers (:headers result)]
(if (:allowed? result)
(->> (f cfg params)
(p/fmap (fn [response]
(vary-meta response update ::http/headers merge headers))))
(p/rejected
(ex/error :type :rate-limit
:code :request-blocked
:hint "rate limit reached"
::http/headers headers))))
(f cfg params)))
{::enabled true
::allowed (not (some? rejected))
::remaingin remaining
::reset reset
::headers {"x-rate-limit-remaining" remaining
"x-rate-limit-reset" reset}}))
(defn- get-limits
[state skey sname]
(some->> (or (get-in @state [::limits skey])
(get-in @state [::limits :default]))
(map #(assoc % ::service sname))
(seq)))
(when-let [limits (or (get-in @state [::limits skey])
(get-in @state [::limits :default]))]
(into [] (map #(assoc % ::service sname)) limits)))
(defn- get-uid
[{:keys [::http/request] :as params}]
@ -236,6 +217,31 @@
(some-> request parse-client-ip)
uuid/zero))
(defn process-request!
[{:keys [::rpc/rlimit ::rds/redis ::skey ::sname] :as cfg} params]
(when-let [limits (get-limits rlimit skey sname)]
(let [redis (rds/get-or-connect redis ::rpc/rlimit default-options)
uid (get-uid params)
;; FIXME: why not clasic try/catch?
result (ex/try! (process-limits! redis uid limits (dt/now)))]
(l/trc :hint "process-limits"
:service sname
:remaining (::remaingin result)
:reset (::reset result))
(cond
(ex/exception? result)
(do
(l/error :hint "error on processing rate-limit" :cause result)
{::enabled false})
(contains? cf/flags :soft-rpc-rlimit)
{::enabled false}
:else
result))))
(defn wrap
[{:keys [::rpc/rlimit ::rds/redis] :as cfg} f mdata]
(us/assert! ::rpc/rlimit rlimit)
@ -243,36 +249,25 @@
(if rlimit
(let [skey (keyword (::rpc/type cfg) (->> mdata ::sv/spec name))
sname (str (::rpc/type cfg) "." (->> mdata ::sv/spec name))]
sname (str (::rpc/type cfg) "." (->> mdata ::sv/spec name))
cfg (-> cfg
(assoc ::skey skey)
(assoc ::sname sname))]
(fn [cfg params]
(if @enabled?
(try
(let [uid (get-uid params)
rsp (when-let [limits (get-limits rlimit skey sname)]
(let [redis (rds/get-or-connect redis ::rpc/rlimit default-options)
rsp (->> (process-limits! redis uid limits (dt/now))
(p/merr (fn [cause]
;; If we have an error on processing the rate-limit we just skip
;; it for do not cause service interruption because of redis
;; downtime or similar situation.
(l/error :hint "error on processing rate-limit" :cause cause)
(p/resolved {:enabled? false}))))]
;; If soft rate are enabled, we process the rate-limit but return unprotected
;; response.
(if (contains? cf/flags :soft-rpc-rlimit)
{:enabled? false}
rsp)))]
(->> (p/promise rsp)
(p/fmap #(or % {:enabled? false}))
(p/mcat #(handle-response f cfg params %))))
(catch Throwable cause
(p/rejected cause)))
(f cfg params))))
(fn [hcfg params]
(if @enabled
(let [result (process-request! cfg params)]
(if (::enabled result)
(if (::allowed result)
(-> (f hcfg params)
(rph/wrap)
(vary-meta update ::http/headers merge (::headers result)))
(ex/raise :type :rate-limit
:code :request-blocked
:hint "rate limit reached"
::http/headers (::headers result)))
(f hcfg params)))
(f hcfg params))))
f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

@ -45,9 +45,9 @@
(map second)
(filter #(::spec (meta %)))
(map (fn [fvar]
(with-meta (deref fvar)
(-> (meta fvar)
(assoc :ns (-> ns ns-name str)))))))))))
[(deref fvar)
(-> (meta fvar)
(assoc :ns (-> ns ns-name str)))])))))))
(defn scan-ns
[& nsyms]

11
backend/src/app/util/svg.clj
View file

@ -6,27 +6,30 @@
(ns app.util.svg
(:require
[app.common.data.macros :as dm]
[app.common.exceptions :as ex]
[app.common.logging :as l]
[clojure.xml :as xml]
[cuerdas.core :as str])
(:import
javax.xml.XMLConstants
java.io.InputStream
javax.xml.parsers.SAXParserFactory
clojure.lang.XMLHandler
org.apache.commons.io.IOUtils))
(defn- secure-parser-factory
[s ch]
[^InputStream input ^XMLHandler handler]
(.. (doto (SAXParserFactory/newInstance)
(.setFeature XMLConstants/FEATURE_SECURE_PROCESSING true)
(.setFeature "http://apache.org/xml/features/disallow-doctype-decl" true))
(newSAXParser)
(parse s ch)))
(parse input handler)))
(defn parse
[data]
[^String data]
(try
(with-open [istream (IOUtils/toInputStream data "UTF-8")]
(dm/with-open [istream (IOUtils/toInputStream data "UTF-8")]
(xml/parse istream secure-parser-factory))
(catch Exception e
(l/warn :hint "error on processing svg"

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

@ -46,10 +46,18 @@
[skey {:keys [::parallelism]}]
(let [prefix (if (vector? skey) (-> skey first name) "default")
tname (str "penpot/" prefix "/%s")
factory (px/forkjoin-thread-factory :name tname)]
(px/forkjoin-executor {:factory factory
:parallelism parallelism
:async true})))
ttype (cf/get :worker-executor-type :fjoin)]
(case ttype
:fjoin
(let [factory (px/forkjoin-thread-factory :name tname)]
(px/forkjoin-executor {:factory factory
:core-size (px/get-available-processors)
:parallelism parallelism
:async true}))
:cached
(let [factory (px/thread-factory :name tname)]
(px/cached-executor :factory factory)))))
(defmethod ig/halt-key! ::executor
[_ instance]
@ -246,11 +254,7 @@
(if (db/read-only? pool)
(l/warn :hint "dispatcher: not started (db is read-only)")
;; FIXME: we don't use virtual threads here until JDBC is uptaded to >= 42.6.0
;; bacause it has the necessary fixes fro make the JDBC driver properly compatible
;; with Virtual Threads.
(px/fn->thread dispatcher :name "penpot/worker/dispatcher" :virtual false))))
(px/fn->thread dispatcher :name "penpot/worker/dispatcher" :virtual true))))
(defmethod ig/halt-key! ::dispatcher
[_ thread]
@ -446,7 +450,8 @@
(case status
:retry (handle-task-retry result)
:failed (handle-task-failure result)
:completed (handle-task-completion result))))
:completed (handle-task-completion result)
nil)))
(run-task-loop [task-id]
(loop [result (run-task task-id)]

26
backend/test/backend_tests/helpers.clj
View file

@ -138,9 +138,7 @@
:app.http.oauth/handler
:app.notifications/handler
:app.loggers.mattermost/reporter
:app.loggers.loki/reporter
:app.loggers.database/reporter
:app.loggers.zmq/receiver
:app.worker/cron
:app.worker/worker))
_ (ig/load-namespaces system)
@ -164,11 +162,15 @@
" AND table_name != 'migrations';")]
(db/with-atomic [conn *pool*]
(let [result (->> (db/exec! conn [sql])
(map :table-name))]
(db/exec! conn [(str "TRUNCATE "
(apply str (interpose ", " result))
" CASCADE;")]))))
(next))
(map :table-name)
(remove #(= "task" %)))
sql (str "TRUNCATE "
(apply str (interpose ", " result))
" CASCADE;")]
(doseq [table result]
(db/exec! conn [(str "delete from " table ";")]))))
(next)))
(defn clean-storage
[next]
@ -321,7 +323,7 @@
(with-open [conn (db/open pool)]
(let [features #{"components/v2"}
cfg (-> (select-keys *system* [::mbus/msgbus ::mtx/metrics])
(assoc :conn conn))]
(assoc ::db/conn conn))]
(files.update/update-file cfg
{:id file-id
:revn revn
@ -354,7 +356,7 @@
(defmacro try-on!
[expr]
`(try
(let [result# (deref ~expr)
(let [result# ~expr
result# (cond-> result# (rph/wrapped? result#) deref)]
{:error nil
:result result#})
@ -364,7 +366,7 @@
(defn command!
[{:keys [::type] :as data}]
(let [method-fn (get-in *system* [:app.rpc/methods :commands type])]
(let [[mdata method-fn] (get-in *system* [:app.rpc/methods :commands type])]
(when-not method-fn
(ex/raise :type :assertion
:code :rpc-method-not-found
@ -377,7 +379,7 @@
(defn mutation!
[{:keys [::type profile-id] :as data}]
(let [method-fn (get-in *system* [:app.rpc/methods :mutations type])]
(let [[mdata method-fn] (get-in *system* [:app.rpc/methods :mutations type])]
(try-on! (method-fn (-> data
(dissoc ::type)
(assoc ::rpc/profile-id profile-id)
@ -385,7 +387,7 @@
(defn query!
[{:keys [::type profile-id] :as data}]
(let [method-fn (get-in *system* [:app.rpc/methods :queries type])]
(let [[mdata method-fn] (get-in *system* [:app.rpc/methods :queries type])]
(try-on! (method-fn (-> data
(dissoc ::type)
(assoc ::rpc/profile-id profile-id)

2
backend/test/backend_tests/rpc_cond_middleware_test.clj
View file

@ -40,6 +40,6 @@
{:keys [error result]} (th/command! (assoc params ::cond/key etag))]
(t/is (nil? error))
(t/is (fn? result))
(t/is (= 304 (-> (result nil) :status))))
(t/is (= 304 (-> (result nil) :yetti.response/status))))
))))

1
backend/test/backend_tests/rpc_team_test.clj
View file

@ -6,6 +6,7 @@
(ns backend-tests.rpc-team-test
(:require
[app.common.logging :as l]
[app.common.uuid :as uuid]
[app.db :as db]
[app.http :as http]

42
common/src/app/common/logging.cljc
View file

@ -213,26 +213,28 @@
`(when (enabled? ~logger ~level)
(let [props# (cond-> (delay ~props) ~sync? deref)
ts# (current-timestamp)
context# *context*]
(px/run! *default-executor*
(fn []
(let [props# (if ~sync? props# (deref props#))
props# (into (d/ordered-map) props#)
cause# ~cause
context# (d/without-nils
(merge context# ~context))
lrecord# {::id (uuid/next)
::timestamp ts#
::message (delay (build-message props#))
::props props#
::context context#
::level ~level
::logger ~logger}
lrecord# (cond-> lrecord#
(some? cause#)
(assoc ::cause cause#
::trace (delay (build-stack-trace cause#))))]
(swap! log-record (constantly lrecord#)))))))))
context# *context*
logfn# (fn []
(let [props# (if ~sync? props# (deref props#))
props# (into (d/ordered-map) props#)
cause# ~cause
context# (d/without-nils
(merge context# ~context))
lrecord# {::id (uuid/next)
::timestamp ts#
::message (delay (build-message props#))
::props props#
::context context#
::level ~level
::logger ~logger}
lrecord# (cond-> lrecord#
(some? cause#)
(assoc ::cause cause#
::trace (delay (build-stack-trace cause#))))]
(swap! log-record (constantly lrecord#))))]
(if ~sync?
(logfn#)
(px/exec! *default-executor* logfn#))))))
#?(:clj
(defn slf4j-log-handler

4
frontend/src/app/main/repo.cljs
View file

@ -21,6 +21,7 @@
(derive :get-font-variants ::query)
(derive :get-profile ::query)
(derive :get-project ::query)
(derive :get-projects ::query)
(derive :get-team-invitations ::query)
(derive :get-team-members ::query)
(derive :get-team-shared-files ::query)
@ -29,6 +30,9 @@
(derive :get-teams ::query)
(derive :get-view-only-bundle ::query)
(derive :search-files ::query)
(derive :retrieve-list-of-builtin-templates ::query)
(derive :get-unread-comment-threads ::query)
(derive :get-team-recent-files ::query)
(defn handle-response
[{:keys [status body] :as response}]

7
frontend/src/app/main/store.cljs
View file

@ -46,9 +46,10 @@
(defonce state
(ptk/store {:resolve ptk/resolve
:on-event on-event
:on-error (fn [e]
(.log js/console "ERROR!!" e)
(@on-error e))}))
:on-error (fn [cause]
(when cause
(log/error :hint "unexpected exception on store" :cause cause)
(@on-error cause)))}))
(defonce stream
(ptk/input-stream state))

6
frontend/src/app/main/ui/auth/login.cljs
View file

@ -7,6 +7,7 @@
(ns app.main.ui.auth.login
(:require
[app.common.data :as d]
[app.common.logging :as log]
[app.common.spec :as us]
[app.config :as cf]
[app.main.data.messages :as dm]
@ -38,7 +39,10 @@
(dom/prevent-default event)
(->> (rp/command! :login-with-oidc (assoc params :provider provider))
(rx/subs (fn [{:keys [redirect-uri] :as rsp}]
(.replace js/location redirect-uri))
(if redirect-uri
(.replace js/location redirect-uri)
(log/error :hint "unexpected response from OIDC method"
:resp (pr-str rsp))))
(fn [{:keys [type code] :as error}]
(cond
(and (= type :restriction)