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

♻️ Refactor http server layer

Browse source 
Make it fully asynchronous.
This commit is contained in:
Andrey Antukh 2022-03-04 18:00:16 +01:00 • committed by Andrés Moya
parent a7e79b13f9
commit 1b444a42f2
28 changed files with 615 additions and 630 deletions
Download patch file Download diff file Expand all files Collapse all files

6
backend/deps.edn
View file

@ -19,12 +19,12 @@
io.lettuce/lettuce-core {:mvn/version "6.1.6.RELEASE"} io.lettuce/lettuce-core {:mvn/version "6.1.6.RELEASE"}
java-http-clj/java-http-clj {:mvn/version "0.4.3"} java-http-clj/java-http-clj {:mvn/version "0.4.3"}
funcool/yetti {:git/tag "v5.0" :git/sha "f7d61e2" funcool/yetti {:git/tag "v6.0" :git/sha "4c8690e"
:git/url "https://github.com/funcool/yetti" :git/url "https://github.com/funcool/yetti.git"
:exclusions [org.slf4j/slf4j-api]} :exclusions [org.slf4j/slf4j-api]}
com.github.seancorfield/next.jdbc {:mvn/version "1.2.772"} com.github.seancorfield/next.jdbc {:mvn/version "1.2.772"}
metosin/reitit-ring {:mvn/version "0.5.16"} metosin/reitit-core {:mvn/version "0.5.16"}
org.postgresql/postgresql {:mvn/version "42.3.3"} org.postgresql/postgresql {:mvn/version "42.3.3"}
com.zaxxer/HikariCP {:mvn/version "5.0.1"} com.zaxxer/HikariCP {:mvn/version "5.0.1"}
funcool/datoteka {:mvn/version "2.0.0"} funcool/datoteka {:mvn/version "2.0.0"}

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

@ -10,18 +10,18 @@
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.logging :as l] [app.common.logging :as l]
[app.common.spec :as us] [app.common.spec :as us]
[app.config :as cf]
[app.http.doc :as doc] [app.http.doc :as doc]
[app.http.errors :as errors] [app.http.errors :as errors]
[app.http.middleware :as middleware] [app.http.middleware :as middleware]
[app.metrics :as mtx] [app.metrics :as mtx]
[app.worker :as wrk]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[integrant.core :as ig] [integrant.core :as ig]
[reitit.ring :as rr] [reitit.core :as r]
[yetti.adapter :as yt]) [reitit.middleware :as rr]
(:import [yetti.adapter :as yt]
org.eclipse.jetty.server.Server [yetti.request :as yrq]
org.eclipse.jetty.server.handler.StatisticsHandler)) [yetti.response :as yrs]))
(declare wrap-router) (declare wrap-router)
@ -29,55 +29,43 @@
;; HTTP SERVER ;; HTTP SERVER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::session map?)
(s/def ::handler fn?) (s/def ::handler fn?)
(s/def ::router some?) (s/def ::router some?)
(s/def ::port ::us/integer) (s/def ::port ::us/integer)
(s/def ::host ::us/string) (s/def ::host ::us/string)
(s/def ::name ::us/string) (s/def ::name ::us/string)
(s/def ::max-threads ::cf/http-server-max-threads) (s/def ::executors (s/map-of keyword? ::wrk/executor))
(s/def ::min-threads ::cf/http-server-min-threads)
;; (s/def ::max-threads ::cf/http-server-max-threads)
;; (s/def ::min-threads ::cf/http-server-min-threads)
(defmethod ig/prep-key ::server (defmethod ig/prep-key ::server
[_ cfg] [_ cfg]
(merge {:name "http" (merge {:name "http"
:min-threads 4
:max-threads 60
:port 6060 :port 6060
:host "0.0.0.0"} :host "0.0.0.0"}
(d/without-nils cfg))) (d/without-nils cfg)))
(defmethod ig/pre-init-spec ::server [_] (defmethod ig/pre-init-spec ::server [_]
(s/keys :req-un [::port ::host ::name ::min-threads ::max-threads ::session] (s/keys :req-un [::port ::host ::name ::executors]
:opt-un [::mtx/metrics ::router ::handler])) :opt-un [::router ::handler]))
(defn- instrument-metrics
[^Server server metrics]
(let [stats (doto (StatisticsHandler.)
(.setHandler (.getHandler server)))]
(.setHandler server stats)
(mtx/instrument-jetty! (:registry metrics) stats)
server))
(defmethod ig/init-key ::server (defmethod ig/init-key ::server
[_ {:keys [handler router port name metrics host] :as cfg}] [_ {:keys [handler router port name host executors] :as cfg}]
(l/info :hint "starting http server" (l/info :hint "starting http server"
:port port :host host :name name :port port :host host :name name)
:min-threads (:min-threads cfg)
:max-threads (:max-threads cfg))
(let [options {:http/port port (let [options {:http/port port
:http/host host :http/host host
:thread-pool/max-threads (:max-threads cfg) :ring/async true
:thread-pool/min-threads (:min-threads cfg) :xnio/dispatch (:default executors)}
:ring/async true}
handler (cond handler (cond
(fn? handler) handler (fn? handler) handler
(some? router) (wrap-router cfg router) (some? router) (wrap-router cfg router)
:else (ex/raise :type :internal :else (ex/raise :type :internal
:code :invalid-argument :code :invalid-argument
:hint "Missing `handler` or `router` option.")) :hint "Missing `handler` or `router` option."))
server (-> (yt/server handler (d/without-nils options)) server (yt/server handler (d/without-nils options))]
(cond-> metrics (instrument-metrics metrics)))]
(assoc cfg :server (yt/start! server)))) (assoc cfg :server (yt/start! server))))
(defmethod ig/halt-key! ::server (defmethod ig/halt-key! ::server
@ -85,24 +73,34 @@
(l/info :msg "stoping http server" :name name :port port) (l/info :msg "stoping http server" :name name :port port)
(yt/stop! server)) (yt/stop! server))
(defn- not-found-handler
[_ respond _]
(respond (yrs/response 404)))
(defn- ring-handler
[router]
(fn [request respond raise]
(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 (-> request
(assoc :path-params params)
(update :params merge params))]
(handler request respond raise))
(not-found-handler request respond raise))))
(defn- wrap-router (defn- wrap-router
[{:keys [session] :as cfg} router] [_ router]
(let [default (rr/routes (let [handler (ring-handler router)]
(rr/create-resource-handler {:path "/"})
(rr/create-default-handler))
options {:middleware [[middleware/wrap-server-timing]
[middleware/cookies]
[(:middleware session)]]
:inject-match? false
:inject-router? false}
handler (rr/ring-handler router default options)]
(fn [request respond _] (fn [request respond _]
(handler request respond (fn [cause] (handler request respond
(l/error :hint "unexpected error processing request" (fn [cause]
::l/context (errors/get-error-context request cause) (l/error :hint "unexpected error processing request"
:query-string (:query-string request) ::l/context (errors/get-error-context request cause)
:cause cause) :query-string (yrq/query request)
(respond {:status 500 :body "internal server error"})))))) :cause cause)
(respond (yrs/response 500 "internal server error")))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HTTP ROUTER ;; HTTP ROUTER
@ -117,62 +115,64 @@
(s/def ::audit-handler fn?) (s/def ::audit-handler fn?)
(s/def ::debug map?) (s/def ::debug map?)
(s/def ::awsns-handler fn?) (s/def ::awsns-handler fn?)
(s/def ::session map?)
(defmethod ig/pre-init-spec ::router [_] (defmethod ig/pre-init-spec ::router [_]
(s/keys :req-un [::rpc ::mtx/metrics ::ws ::oauth ::storage ::assets (s/keys :req-un [::rpc ::mtx/metrics ::ws ::oauth ::storage ::assets
::feedback ::awsns-handler ::debug ::audit-handler])) ::session ::feedback ::awsns-handler ::debug ::audit-handler]))
(defmethod ig/init-key ::router (defmethod ig/init-key ::router
[_ {:keys [ws session rpc oauth metrics assets feedback debug] :as cfg}] [_ {:keys [ws session rpc oauth metrics assets feedback debug] :as cfg}]
(rr/router (rr/router
[["/metrics" {:get (:handler metrics)}] [["" {:middleware [[middleware/server-timing]
["/assets" {:middleware [[middleware/format-response-body] [middleware/format-response]
[middleware/errors errors/handle]]} [middleware/errors errors/handle]
["/by-id/:id" {:get (:objects-handler assets)}] [middleware/restrict-methods]]}
["/by-file-media-id/:id" {:get (:file-objects-handler assets)}] ["/metrics" {:handler (:handler metrics)}]
["/by-file-media-id/:id/thumbnail" {:get (:file-thumbnails-handler assets)}]] ["/assets" {:middleware [(:middleware session)]}
["/by-id/:id" {:handler (:objects-handler assets)}]
["/by-file-media-id/:id" {:handler (:file-objects-handler assets)}]
["/by-file-media-id/:id/thumbnail" {:handler (:file-thumbnails-handler assets)}]]
["/dbg" {:middleware [[middleware/multipart-params] ["/dbg" {:middleware [[middleware/params]
[middleware/params] [middleware/parse-request]
[middleware/keyword-params] (:middleware session)]}
[middleware/format-response-body] ["" {:handler (:index debug)}]
[middleware/errors errors/handle]]} ["/error-by-id/:id" {:handler (:retrieve-error debug)}]
["" {:get (:index debug)}] ["/error/:id" {:handler (:retrieve-error debug)}]
["/error-by-id/:id" {:get (:retrieve-error debug)}] ["/error" {:handler (:retrieve-error-list debug)}]
["/error/:id" {:get (:retrieve-error debug)}] ["/file/data" {:handler (:file-data debug)}]
["/error" {:get (:retrieve-error-list debug)}] ["/file/changes" {:handler (:retrieve-file-changes debug)}]]
["/file/data" {:get (:retrieve-file-data debug)
:post (:upload-file-data debug)}]
["/file/changes" {:get (:retrieve-file-changes debug)}]]
["/webhooks" ["/webhooks"
["/sns" {:post (:awsns-handler cfg)}]] ["/sns" {:handler (:awsns-handler cfg)
:allowed-methods #{:post}}]]
["/ws/notifications" ["/ws/notifications" {:middleware [[middleware/params]
{:middleware [[middleware/params] [middleware/parse-request]
[middleware/keyword-params] (:middleware session)]
[middleware/format-response-body] :handler ws
[middleware/errors errors/handle]] :allowed-methods #{:get}}]
:get ws}]
["/api" {:middleware [[middleware/cors] ["/api" {:middleware [[middleware/cors]
[middleware/params] [middleware/params]
[middleware/multipart-params] [middleware/parse-request]
[middleware/keyword-params] (:middleware session)]}
[middleware/format-response-body] ["/health" {:handler (:health-check debug)}]
[middleware/parse-request-body] ["/_doc" {:handler (doc/handler rpc)
[middleware/errors errors/handle]]} :allowed-methods #{:get}}]
["/feedback" {:handler feedback
:allowed-methods #{:post}}]
["/health" {:get (:health-check debug)}] ["/auth/oauth/:provider" {:handler (:handler oauth)
["/_doc" {:get (doc/handler rpc)}] :allowed-methods #{:post}}]
["/feedback" {:middleware [(:middleware session)] ["/auth/oauth/:provider/callback" {:handler (:callback-handler oauth)
:post feedback}] :allowed-methods #{:get}}]
["/auth/oauth/:provider" {:post (:handler oauth)}]
["/auth/oauth/:provider/callback" {:get (:callback-handler oauth)}]
["/audit/events" {:post (:audit-handler cfg)}] ["/audit/events" {:handler (:audit-handler cfg)
:allowed-methods #{:post}}]
["/rpc" ["/rpc"
["/query/:type" {:get (:query-handler rpc) ["/query/:type" {:handler (:query-handler rpc)}]
:post (:query-handler rpc)}] ["/mutation/:type" {:handler (:mutation-handler rpc)
["/mutation/:type" {:post (:mutation-handler rpc)}]]]])) :allowed-methods #{:post}}]]]]]))

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

@ -18,7 +18,8 @@
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[integrant.core :as ig] [integrant.core :as ig]
[promesa.core :as p] [promesa.core :as p]
[promesa.exec :as px])) [promesa.exec :as px]
[yetti.response :as yrs]))
(def ^:private cache-max-age (def ^:private cache-max-age
(dt/duration {:hours 24})) (dt/duration {:hours 24}))
@ -53,27 +54,25 @@
(case (:type backend) (case (:type backend)
:db :db
(p/let [body (sto/get-object-bytes storage obj)] (p/let [body (sto/get-object-bytes storage obj)]
{:status 200 (yrs/response :status 200
:headers {"content-type" (:content-type mdata) :body body
"cache-control" (str "max-age=" (inst-ms cache-max-age))} :headers {"content-type" (:content-type mdata)
:body body}) "cache-control" (str "max-age=" (inst-ms cache-max-age))}))
:s3 :s3
(p/let [{:keys [host port] :as url} (sto/get-object-url storage obj {:max-age signature-max-age})] (p/let [{:keys [host port] :as url} (sto/get-object-url storage obj {:max-age signature-max-age})]
{:status 307 (yrs/response :status 307
:headers {"location" (str url) :headers {"location" (str url)
"x-host" (cond-> host port (str ":" port)) "x-host" (cond-> host port (str ":" port))
"cache-control" (str "max-age=" (inst-ms cache-max-age))} "cache-control" (str "max-age=" (inst-ms cache-max-age))}))
:body ""})
:fs :fs
(p/let [purl (u/uri (:assets-path cfg)) (p/let [purl (u/uri (:assets-path cfg))
purl (u/join purl (sto/object->relative-path obj))] purl (u/join purl (sto/object->relative-path obj))]
{:status 204 (yrs/response :status 204
:headers {"x-accel-redirect" (:path purl) :headers {"x-accel-redirect" (:path purl)
"content-type" (:content-type mdata) "content-type" (:content-type mdata)
"cache-control" (str "max-age=" (inst-ms cache-max-age))} "cache-control" (str "max-age=" (inst-ms cache-max-age))})))))
:body ""}))))
(defn objects-handler (defn objects-handler
"Handler that servers storage objects by id." "Handler that servers storage objects by id."
@ -84,7 +83,7 @@
obj (sto/get-object storage id)] obj (sto/get-object storage id)]
(if obj (if obj
(serve-object cfg obj) (serve-object cfg obj)
{:status 404 :body ""}))) (yrs/response 404))))
(p/bind p/wrap) (p/bind p/wrap)
(p/then' respond) (p/then' respond)
@ -98,7 +97,7 @@
obj (sto/get-object storage (kf mobj))] obj (sto/get-object storage (kf mobj))]
(if obj (if obj
(serve-object cfg obj) (serve-object cfg obj)
{:status 404 :body ""}))) (yrs/response 404))))
(defn file-objects-handler (defn file-objects-handler
"Handler that serves storage objects by file media id." "Handler that serves storage objects by file media id."

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

@ -15,7 +15,8 @@
[cuerdas.core :as str] [cuerdas.core :as str]
[integrant.core :as ig] [integrant.core :as ig]
[jsonista.core :as j] [jsonista.core :as j]
[promesa.exec :as px])) [promesa.exec :as px]
[yetti.response :as yrs]))
(declare parse-json) (declare parse-json)
(declare handle-request) (declare handle-request)
@ -32,7 +33,7 @@
(fn [request respond _] (fn [request respond _]
(let [data (slurp (:body request))] (let [data (slurp (:body request))]
(px/run! executor #(handle-request cfg data)) (px/run! executor #(handle-request cfg data))
(respond {:status 200 :body ""})))) (respond (yrs/response 200)))))
(defn handle-request (defn handle-request
[{:keys [http-client] :as cfg} data] [{:keys [http-client] :as cfg} data]

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

@ -25,7 +25,9 @@
[fipp.edn :as fpp] [fipp.edn :as fpp]
[integrant.core :as ig] [integrant.core :as ig]
[promesa.core :as p] [promesa.core :as p]
[promesa.exec :as px])) [promesa.exec :as px]
[yetti.request :as yrq]
[yetti.response :as yrs]))
;; (selmer.parser/cache-off!) ;; (selmer.parser/cache-off!)
@ -41,11 +43,10 @@
(when-not (authorized? pool request) (when-not (authorized? pool request)
(ex/raise :type :authentication (ex/raise :type :authentication
:code :only-admins-allowed)) :code :only-admins-allowed))
(yrs/response :status 200
{:status 200 :headers {"content-type" "text/html"}
:headers {"content-type" "text/html"} :body (-> (io/resource "templates/debug.tmpl")
:body (-> (io/resource "templates/debug.tmpl") (tmpl/render {}))))
(tmpl/render {}))})
(def sql:retrieve-range-of-changes (def sql:retrieve-range-of-changes
@ -61,13 +62,14 @@
:code :enpty-data :code :enpty-data
:hint "empty response")) :hint "empty response"))
(cond-> {:status 200 (cond-> (yrs/response :status 200
:headers {"content-type" "application/transit+json"} :body body
:body body} :headers {"content-type" "application/transit+json"})
(contains? params :download) (contains? params :download)
(update :headers assoc "content-disposition" "attachment"))) (update :headers assoc "content-disposition" "attachment")))
(defn retrieve-file-data
(defn- retrieve-file-data
[{:keys [pool]} {:keys [params] :as request}] [{:keys [pool]} {:keys [params] :as request}]
(when-not (authorized? pool request) (when-not (authorized? pool request)
(ex/raise :type :authentication (ex/raise :type :authentication
@ -87,7 +89,7 @@
(update :headers assoc "content-type" "application/octet-stream")) (update :headers assoc "content-type" "application/octet-stream"))
(prepare-response request (some-> data blob/decode)))))) (prepare-response request (some-> data blob/decode))))))
(defn upload-file-data (defn- upload-file-data
[{:keys [pool]} {:keys [profile-id params] :as request}] [{:keys [pool]} {:keys [profile-id params] :as request}]
(let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id) (let [project-id (some-> (profile/retrieve-additional-data pool profile-id) :default-project-id)
data (some-> params :file :tempfile fs/slurp-bytes blob/decode)] data (some-> params :file :tempfile fs/slurp-bytes blob/decode)]
@ -99,10 +101,16 @@
:project-id project-id :project-id project-id
:profile-id profile-id :profile-id profile-id
:data data}) :data data})
{:status 200 (yrs/response 200 "OK"))
:body "OK"}) (yrs/response 500 "ERROR"))))
{:status 500
:body "error"}))) (defn file-data
[cfg request]
(case (yrq/method request)
:get (retrieve-file-data cfg request)
:post (upload-file-data cfg request)
(ex/raise :type :http
:code :method-not-found)))
(defn retrieve-file-changes (defn retrieve-file-changes
[{:keys [pool]} request] [{:keys [pool]} request]
@ -175,12 +183,11 @@
(retrieve-report) (retrieve-report)
(render-template))] (render-template))]
(if result (if result
{:status 200 (yrs/response :status 200
:headers {"content-type" "text/html; charset=utf-8" :body result
"x-robots-tag" "noindex"} :headers {"content-type" "text/html; charset=utf-8"
:body result} "x-robots-tag" "noindex"})
{:status 404 (yrs/response 404 "not found")))))
:body "not found"}))))
(def sql:error-reports (def sql:error-reports
"select id, created_at from server_error_report order by created_at desc limit 100") "select id, created_at from server_error_report order by created_at desc limit 100")
@ -192,18 +199,18 @@
:code :only-admins-allowed)) :code :only-admins-allowed))
(let [items (db/exec! pool [sql:error-reports]) (let [items (db/exec! pool [sql:error-reports])
items (map #(update % :created-at dt/format-instant :rfc1123) items)] items (map #(update % :created-at dt/format-instant :rfc1123) items)]
{:status 200 (yrs/response :status 200
:headers {"content-type" "text/html; charset=utf-8" :body (-> (io/resource "templates/error-list.tmpl")
"x-robots-tag" "noindex"} (tmpl/render {:items items}))
:body (-> (io/resource "templates/error-list.tmpl") :headers {"content-type" "text/html; charset=utf-8"
(tmpl/render {:items items}))})) "x-robots-tag" "noindex"})))
(defn health-check (defn health-check
"Mainly a task that performs a health check." "Mainly a task that performs a health check."
[{:keys [pool]} _] [{:keys [pool]} _]
(db/with-atomic [conn pool] (db/with-atomic [conn pool]
(db/exec-one! conn ["select count(*) as count from server_prop;"]) (db/exec-one! conn ["select count(*) as count from server_prop;"])
{:status 200 :body "Ok"})) (yrs/response 200 "OK")))
(defn- wrap-async (defn- wrap-async
[{:keys [executor] :as cfg} f] [{:keys [executor] :as cfg} f]
@ -219,8 +226,7 @@
[_ cfg] [_ cfg]
{:index (wrap-async cfg index) {:index (wrap-async cfg index)
:health-check (wrap-async cfg health-check) :health-check (wrap-async cfg health-check)
:retrieve-file-data (wrap-async cfg retrieve-file-data)
:retrieve-file-changes (wrap-async cfg retrieve-file-changes) :retrieve-file-changes (wrap-async cfg retrieve-file-changes)
:retrieve-error (wrap-async cfg retrieve-error) :retrieve-error (wrap-async cfg retrieve-error)
:retrieve-error-list (wrap-async cfg retrieve-error-list) :retrieve-error-list (wrap-async cfg retrieve-error-list)
:upload-file-data (wrap-async cfg upload-file-data)}) :file-data (wrap-async cfg file-data)})

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

@ -13,7 +13,8 @@
[app.util.template :as tmpl] [app.util.template :as tmpl]
[clojure.java.io :as io] [clojure.java.io :as io]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[pretty-spec.core :as ps])) [pretty-spec.core :as ps]
[yetti.response :as yrs]))
(defn get-spec-str (defn get-spec-str
[k] [k]
@ -47,8 +48,7 @@
(let [context (prepare-context rpc)] (let [context (prepare-context rpc)]
(if (contains? cf/flags :backend-api-doc) (if (contains? cf/flags :backend-api-doc)
(fn [_ respond _] (fn [_ respond _]
(respond {:status 200 (respond (yrs/response 200 (-> (io/resource "api-doc.tmpl")
:body (-> (io/resource "api-doc.tmpl") (tmpl/render context)))))
(tmpl/render context))}))
(fn [_ respond _] (fn [_ respond _]
(respond {:status 404 :body ""}))))) (respond (yrs/response 404))))))

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

@ -11,13 +11,15 @@
[app.common.logging :as l] [app.common.logging :as l]
[app.common.spec :as us] [app.common.spec :as us]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[cuerdas.core :as str])) [cuerdas.core :as str]
[yetti.request :as yrq]
[yetti.response :as yrs]))
(defn- parse-client-ip (defn- parse-client-ip
[{:keys [headers] :as request}] [request]
(or (some-> (get headers "x-forwarded-for") (str/split ",") first) (or (some-> (yrq/get-header request "x-forwarded-for") (str/split ",") first)
(get headers "x-real-ip") (yrq/get-header request "x-real-ip")
(get request :remote-addr))) (yrq/remote-addr request)))
(defn get-error-context (defn get-error-context
[request error] [request error]
@ -49,20 +51,19 @@
(defmethod handle-exception :authentication (defmethod handle-exception :authentication
[err _] [err _]
{:status 401 :body (ex-data err)}) (yrs/response 401 (ex-data err)))
(defmethod handle-exception :restriction (defmethod handle-exception :restriction
[err _] [err _]
{:status 400 :body (ex-data err)}) (yrs/response 400 (ex-data err)))
(defmethod handle-exception :validation (defmethod handle-exception :validation
[err _] [err _]
(let [data (ex-data err) (let [data (ex-data err)
explain (us/pretty-explain data)] explain (us/pretty-explain data)]
{:status 400 (yrs/response 400 (-> data
:body (-> data (dissoc ::s/problems ::s/value)
(dissoc ::s/problems ::s/value) (cond-> explain (assoc :explain explain))))))
(cond-> explain (assoc :explain explain)))}))
(defmethod handle-exception :assertion (defmethod handle-exception :assertion
[error request] [error request]
@ -71,17 +72,16 @@
(l/error ::l/raw (ex-message error) (l/error ::l/raw (ex-message error)
::l/context (get-error-context request error) ::l/context (get-error-context request error)
:cause error) :cause error)
(yrs/response :status 500
{:status 500 :body {:type :server-error
:body {:type :server-error :code :assertion
:code :assertion :data (-> edata
:data (-> edata (dissoc ::s/problems ::s/value ::s/spec)
(dissoc ::s/problems ::s/value ::s/spec) (cond-> explain (assoc :explain explain)))})))
(cond-> explain (assoc :explain explain)))}}))
(defmethod handle-exception :not-found (defmethod handle-exception :not-found
[err _] [err _]
{:status 404 :body (ex-data err)}) (yrs/response 404 (ex-data err)))
(defmethod handle-exception :default (defmethod handle-exception :default
[error request] [error request]
@ -98,11 +98,10 @@
(l/error ::l/raw (ex-message error) (l/error ::l/raw (ex-message error)
::l/context (get-error-context request error) ::l/context (get-error-context request error)
:cause error) :cause error)
{:status 500 (yrs/response 500 {:type :server-error
:body {:type :server-error :code :unexpected
:code :unexpected :hint (ex-message error)
:hint (ex-message error) :data edata})))))
:data edata}}))))
(defmethod handle-exception org.postgresql.util.PSQLException (defmethod handle-exception org.postgresql.util.PSQLException
[error request] [error request]
@ -112,23 +111,20 @@
:cause error) :cause error)
(cond (cond
(= state "57014") (= state "57014")
{:status 504 (yrs/response 504 {:type :server-timeout
:body {:type :server-timeout :code :statement-timeout
:code :statement-timeout :hint (ex-message error)})
:hint (ex-message error)}}
(= state "25P03") (= state "25P03")
{:status 504 (yrs/response 504 {:type :server-timeout
:body {:type :server-timeout :code :idle-in-transaction-timeout
:code :idle-in-transaction-timeout :hint (ex-message error)})
:hint (ex-message error)}}
:else :else
{:status 500 (yrs/response 500 {:type :server-error
:body {:type :server-error :code :psql-exception
:code :psql-exception :hint (ex-message error)
:hint (ex-message error) :state state}))))
:state state}})))
(defn handle (defn handle
[error req] [error req]

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

@ -7,7 +7,6 @@
(ns app.http.feedback (ns app.http.feedback
"A general purpose feedback module." "A general purpose feedback module."
(:require (:require
[app.common.data :as d]
[app.common.exceptions :as ex] [app.common.exceptions :as ex]
[app.common.spec :as us] [app.common.spec :as us]
[app.config :as cf] [app.config :as cf]
@ -18,7 +17,9 @@
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[integrant.core :as ig] [integrant.core :as ig]
[promesa.core :as p] [promesa.core :as p]
[promesa.exec :as px])) [promesa.exec :as px]
[yetti.request :as yrq]
[yetti.response :as yrs]))
(declare ^:private send-feedback) (declare ^:private send-feedback)
(declare ^:private handler) (declare ^:private handler)
@ -42,9 +43,8 @@
(defn- handler (defn- handler
[{:keys [pool] :as cfg} {:keys [profile-id] :as request}] [{:keys [pool] :as cfg} {:keys [profile-id] :as request}]
(let [ftoken (cf/get :feedback-token ::no-token) (let [ftoken (cf/get :feedback-token ::no-token)
token (get-in request [:headers "x-feedback-token"]) token (yrq/get-header request "x-feedback-token")
params (d/merge (:params request) params (::yrq/params request)]
(:body-params request))]
(cond (cond
(uuid? profile-id) (uuid? profile-id)
(let [profile (profile/retrieve-profile-data pool profile-id) (let [profile (profile/retrieve-profile-data pool profile-id)
@ -54,7 +54,7 @@
(= token ftoken) (= token ftoken)
(send-feedback cfg nil params)) (send-feedback cfg nil params))
{:status 204 :body ""})) (yrs/response 204)))
(s/def ::content ::us/string) (s/def ::content ::us/string)
(s/def ::from ::us/email) (s/def ::from ::us/email)

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

@ -10,49 +10,41 @@
[app.common.transit :as t] [app.common.transit :as t]
[app.config :as cf] [app.config :as cf]
[app.util.json :as json] [app.util.json :as json]
[ring.core.protocols :as rp] [cuerdas.core :as str]
[ring.middleware.cookies :refer [wrap-cookies]] [yetti.adapter :as yt]
[ring.middleware.keyword-params :refer [wrap-keyword-params]] [yetti.middleware :as ymw]
[ring.middleware.multipart-params :refer [wrap-multipart-params]] [yetti.request :as yrq]
[ring.middleware.params :refer [wrap-params]] [yetti.response :as yrs])
[yetti.adapter :as yt])) (:import java.io.OutputStream))
(defn wrap-server-timing (def server-timing
{:name ::server-timing
:compile (constantly ymw/wrap-server-timing)})
(def params
{:name ::params
:compile (constantly ymw/wrap-params)})
(defn wrap-parse-request
[handler] [handler]
(letfn [(get-age [start] (letfn [(process-request [request]
(float (/ (- (System/nanoTime) start) 1000000000))) (let [header (yrq/get-header request "content-type")]
(cond
(str/starts-with? header "application/transit+json")
(with-open [is (-> request yrq/body yrq/body-stream)]
(let [params (t/read! (t/reader is))]
(-> request
(assoc :body-params params)
(update :params merge params))))
(update-headers [headers start] (str/starts-with? header "application/json")
(assoc headers "Server-Timing" (str "total;dur=" (get-age start))))] (with-open [is (-> request yrq/body yrq/body-stream)]
(let [params (json/read is)]
(fn [request respond raise] (-> request
(let [start (System/nanoTime)] (assoc :body-params params)
(handler request #(respond (update % :headers update-headers start)) raise))))) (update :params merge params))))
(defn wrap-parse-request-body
[handler]
(letfn [(parse-transit [body]
(let [reader (t/reader body)]
(t/read! reader)))
(parse-json [body]
(json/read body))
(handle-request [{:keys [headers body] :as request}]
(let [ctype (get headers "content-type")]
(case ctype
"application/transit+json"
(let [params (parse-transit body)]
(-> request
(assoc :body-params params)
(update :params merge params)))
"application/json"
(let [params (parse-json body)]
(-> request
(assoc :body-params params)
(update :params merge params)))
:else
request))) request)))
(handle-exception [cause] (handle-exception [cause]
@ -60,20 +52,20 @@
:code :unable-to-parse-request-body :code :unable-to-parse-request-body
:hint "malformed params"}] :hint "malformed params"}]
(l/error :hint (ex-message cause) :cause cause) (l/error :hint (ex-message cause) :cause cause)
{:status 400 (yrs/response :status 400
:headers {"content-type" "application/transit+json"} :headers {"content-type" "application/transit+json"}
:body (t/encode-str data {:type :json-verbose})}))] :body (t/encode-str data {:type :json-verbose}))))]
(fn [request respond raise] (fn [request respond raise]
(try (try
(let [request (handle-request request)] (let [request (process-request request)]
(handler request respond raise)) (handler request respond raise))
(catch Exception cause (catch Exception cause
(respond (handle-exception cause))))))) (respond (handle-exception cause)))))))
(def parse-request-body (def parse-request
{:name ::parse-request-body {:name ::parse-request
:compile (constantly wrap-parse-request-body)}) :compile (constantly wrap-parse-request)})
(defn buffered-output-stream (defn buffered-output-stream
"Returns a buffered output stream that ignores flush calls. This is "Returns a buffered output stream that ignores flush calls. This is
@ -87,56 +79,51 @@
(proxy-super flush) (proxy-super flush)
(proxy-super close)))) (proxy-super close))))
(def ^:const buffer-size (:http/output-buffer-size yt/base-defaults)) (def ^:const buffer-size (:xnio/buffer-size yt/defaults))
(defn wrap-format-response-body (defn wrap-format-response
[handler] [handler]
(letfn [(transit-streamable-body [data opts] (letfn [(transit-streamable-body [data opts]
(reify rp/StreamableResponseBody (reify yrs/StreamableResponseBody
(write-body-to-stream [_ _ output-stream] (-write-body-to-stream [_ _ output-stream]
;; Use the same buffer as jetty output buffer size
(try (try
(with-open [bos (buffered-output-stream output-stream buffer-size)] (with-open [bos (buffered-output-stream output-stream buffer-size)]
(let [tw (t/writer bos opts)] (let [tw (t/writer bos opts)]
(t/write! tw data))) (t/write! tw data)))
(catch org.eclipse.jetty.io.EofException _cause
(catch java.io.IOException _cause
;; Do nothing, EOF means client closes connection abruptly ;; Do nothing, EOF means client closes connection abruptly
nil) nil)
(catch Throwable cause (catch Throwable cause
(l/warn :hint "unexpected error on encoding response" (l/warn :hint "unexpected error on encoding response"
:cause cause)))))) :cause cause))
(finally
(.close ^OutputStream output-stream))))))
(impl-format-response-body [response {:keys [query-params] :as request}] (format-response [response request]
(let [body (:body response) (let [body (yrs/body response)]
opts {:type (if (contains? query-params "transit_verbose") :json-verbose :json)}] (if (coll? body)
(cond (let [qs (yrq/query request)
(:ws response) opts {:type (if (str/includes? qs "verbose") :json-verbose :json)}]
response (-> response
(update :headers assoc "content-type" "application/transit+json")
(coll? body) (assoc :body (transit-streamable-body body opts))))
(-> response
(update :headers assoc "content-type" "application/transit+json")
(assoc :body (transit-streamable-body body opts)))
(nil? body)
(assoc response :status 204 :body "")
:else
response))) response)))
(handle-response [response request] (process-response [response request]
(cond-> response (cond-> response
(map? response) (impl-format-response-body request)))] (map? response) (format-response request)))]
(fn [request respond raise] (fn [request respond raise]
(handler request (handler request
(fn [response] (fn [response]
(respond (handle-response response request))) (let [response (process-response response request)]
(respond response)))
raise)))) raise))))
(def format-response-body (def format-response
{:name ::format-response-body {:name ::format-response
:compile (constantly wrap-format-response-body)}) :compile (constantly wrap-format-response)})
(defn wrap-errors (defn wrap-errors
[handler on-error] [handler on-error]
@ -148,51 +135,46 @@
{:name ::errors {:name ::errors
:compile (constantly wrap-errors)}) :compile (constantly wrap-errors)})
(def cookies
{:name ::cookies
:compile (constantly wrap-cookies)})
(def params
{:name ::params
:compile (constantly wrap-params)})
(def multipart-params
{:name ::multipart-params
:compile (constantly wrap-multipart-params)})
(def keyword-params
{:name ::keyword-params
:compile (constantly wrap-keyword-params)})
(def server-timing
{:name ::server-timing
:compile (constantly wrap-server-timing)})
(defn wrap-cors (defn wrap-cors
[handler] [handler]
(if-not (contains? cf/flags :cors) (if-not (contains? cf/flags :cors)
handler handler
(letfn [(add-cors-headers [response request] (letfn [(add-headers [headers request]
(-> response (let [origin (yrq/get-header request "origin")]
(update (-> headers
:headers (assoc "access-control-allow-origin" origin)
(fn [headers] (assoc "access-control-allow-methods" "GET,POST,DELETE,OPTIONS,PUT,HEAD,PATCH")
(-> headers (assoc "access-control-allow-credentials" "true")
(assoc "access-control-allow-origin" (get-in request [:headers "origin"])) (assoc "access-control-expose-headers" "x-requested-with, content-type, cookie")
(assoc "access-control-allow-methods" "GET,POST,DELETE,OPTIONS,PUT,HEAD,PATCH") (assoc "access-control-allow-headers" "x-frontend-version, content-type, accept, x-requested-width"))))
(assoc "access-control-allow-credentials" "true")
(assoc "access-control-expose-headers" "x-requested-with, content-type, cookie") (update-response [response request]
(assoc "access-control-allow-headers" "x-frontend-version, content-type, accept, x-requested-width"))))))] (update response :headers add-headers request))]
(fn [request respond raise] (fn [request respond raise]
(if (= (:request-method request) :options) (if (= (yrq/method request) :options)
(-> {:status 200 :body ""} (-> (yrs/response 200)
(add-cors-headers request) (update-response request)
(respond)) (respond))
(handler request (handler request
(fn [response] (fn [response]
(respond (add-cors-headers response request))) (respond (update-response response request)))
raise)))))) raise))))))
(def cors (def cors
{:name ::cors {:name ::cors
:compile (constantly wrap-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))))))))
(def restrict-methods
{:name ::restrict-methods
:compile compile-restrict-methods})

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

@ -22,7 +22,8 @@
[cuerdas.core :as str] [cuerdas.core :as str]
[integrant.core :as ig] [integrant.core :as ig]
[promesa.core :as p] [promesa.core :as p]
[promesa.exec :as px])) [promesa.exec :as px]
[yetti.response :as yrs]))
(defn- build-redirect-uri (defn- build-redirect-uri
[{:keys [provider] :as cfg}] [{:keys [provider] :as cfg}]
@ -175,9 +176,7 @@
(defn- redirect-response (defn- redirect-response
[uri] [uri]
{:status 302 (yrs/response :status 302 :headers {"location" (str uri)}))
:headers {"location" (str uri)}
:body ""})
(defn- generate-error-redirect (defn- generate-error-redirect
[cfg error] [cfg error]
@ -233,7 +232,7 @@
:props props :props props
:exp (dt/in-future "15m")}) :exp (dt/in-future "15m")})
uri (build-auth-uri cfg state)] uri (build-auth-uri cfg state)]
(respond {:status 200 :body {:redirect-uri uri}}))) (respond (yrs/response 200 {:redirect-uri uri}))))
(defn- callback-handler (defn- callback-handler
[cfg request respond _] [cfg request respond _]

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

@ -19,7 +19,9 @@
[clojure.core.async :as a] [clojure.core.async :as a]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[integrant.core :as ig] [integrant.core :as ig]
[ring.middleware.session.store :as rss])) [promesa.core :as p]
[promesa.exec :as px]
[yetti.request :as yrq]))
;; A default cookie name for storing the session. We don't allow to configure it. ;; A default cookie name for storing the session. We don't allow to configure it.
(def token-cookie-name "auth-token") (def token-cookie-name "auth-token")
@ -29,65 +31,100 @@
;; prevents using it if some one wants to. ;; prevents using it if some one wants to.
(def authenticated-cookie-name "authenticated") (def authenticated-cookie-name "authenticated")
(deftype DatabaseStore [pool tokens] (defprotocol ISessionStore
rss/SessionStore (read-session [store key])
(read-session [_ token] (write-session [store key data])
(db/exec-one! pool (sql/select :http-session {:id token}))) (delete-session [store key]))
(write-session [_ _ data] (defn- make-database-store
(let [profile-id (:profile-id data) [{:keys [pool tokens executor]}]
user-agent (:user-agent data) (reify ISessionStore
token (tokens :generate {:iss "authentication" (read-session [_ token]
:iat (dt/now) (px/with-dispatch executor
:uid profile-id}) (db/exec-one! pool (sql/select :http-session {:id token}))))
now (dt/now) (write-session [_ _ data]
params {:user-agent user-agent (px/with-dispatch executor
:profile-id profile-id (let [profile-id (:profile-id data)
:created-at now user-agent (:user-agent data)
:updated-at now token (tokens :generate {:iss "authentication"
:id token}] :iat (dt/now)
(db/insert! pool :http-session params) :uid profile-id})
token))
(delete-session [_ token] now (dt/now)
(db/delete! pool :http-session {:id token}) params {:user-agent user-agent
nil)) :profile-id profile-id
:created-at now
:updated-at now
:id token}]
(db/insert! pool :http-session params)
token)))
(deftype MemoryStore [cache tokens] (delete-session [_ token]
rss/SessionStore (px/with-dispatch executor
(read-session [_ token] (db/delete! pool :http-session {:id token})
(get @cache token)) nil))))
(write-session [_ _ data] (defn make-inmemory-store
(let [profile-id (:profile-id data) [{:keys [tokens]}]
user-agent (:user-agent data) (let [cache (atom {})]
token (tokens :generate {:iss "authentication" (reify ISessionStore
:iat (dt/now) (read-session [_ token]
:uid profile-id}) (p/do (get @cache token)))
params {:user-agent user-agent
:profile-id profile-id
:id token}]
(swap! cache assoc token params) (write-session [_ _ data]
token)) (p/do
(let [profile-id (:profile-id data)
user-agent (:user-agent data)
token (tokens :generate {:iss "authentication"
:iat (dt/now)
:uid profile-id})
params {:user-agent user-agent
:profile-id profile-id
:id token}]
(delete-session [_ token] (swap! cache assoc token params)
(swap! cache dissoc token) token)))
nil))
(delete-session [_ token]
(p/do
(swap! cache dissoc token)
nil)))))
(s/def ::tokens fn?)
(defmethod ig/pre-init-spec ::store [_]
(s/keys :req-un [::db/pool ::wrk/executor ::tokens]))
(defmethod ig/init-key ::store
[_ {:keys [pool] :as cfg}]
(if (db/read-only? pool)
(make-inmemory-store cfg)
(make-database-store cfg)))
(defmethod ig/halt-key! ::store
[_ _])
;; --- IMPL ;; --- IMPL
(defn- create-session (defn- create-session!
[store request profile-id] [store request profile-id]
(let [params {:user-agent (get-in request [:headers "user-agent"]) (let [params {:user-agent (yrq/get-header request "user-agent")
:profile-id profile-id}] :profile-id profile-id}]
(rss/write-session store nil params))) (write-session store nil params)))
(defn- delete-session (defn- delete-session!
[store {:keys [cookies] :as request}] [store {:keys [cookies] :as request}]
(when-let [token (get-in cookies [token-cookie-name :value])] (when-let [token (get-in cookies [token-cookie-name :value])]
(rss/delete-session store token))) (delete-session store token)))
(defn- retrieve-session
[store request]
(when-let [cookie (yrq/get-cookie request token-cookie-name)]
(-> (read-session store (:value cookie))
(p/then (fn [session]
(when session
{:session-id (:id session)
:profile-id (:profile-id session)}))))))
(defn- add-cookies (defn- add-cookies
[response token] [response token]
@ -114,43 +151,40 @@
(defn- clear-cookies (defn- clear-cookies
[response] [response]
(let [authenticated-cookie-domain (cfg/get :authenticated-cookie-domain)] (let [authenticated-cookie-domain (cfg/get :authenticated-cookie-domain)]
(assoc response :cookies {token-cookie-name {:path "/" (assoc response :cookies
:value "" {token-cookie-name {:path "/"
:max-age -1} :value ""
authenticated-cookie-name {:domain authenticated-cookie-domain :max-age -1}
:path "/" authenticated-cookie-name {:domain authenticated-cookie-domain
:value "" :path "/"
:max-age -1}}))) :value ""
:max-age -1}})))
;; NOTE: for now the session middleware is synchronous and is (defn- make-middleware
;; processed on jetty threads. This is because of probably a bug on [{:keys [::events-ch store] :as cfg}]
;; jetty that causes NPE on upgrading connection to websocket from {:name :session-middleware
;; thread not managed by jetty. We probably can fix it running :wrap (fn [handler]
;; websocket server in different port as standalone service. (fn [request respond raise]
(try
(-> (retrieve-session store request)
(p/then' #(merge request %))
(p/finally (fn [request cause]
(if cause
(raise cause)
(do
(when-let [session-id (:session-id request)]
(a/offer! events-ch session-id))
(handler request respond raise))))))
(catch Throwable cause
(raise cause)))))})
(defn- middleware
[{:keys [::events-ch ::store] :as cfg} handler]
(letfn [(get-session [{:keys [cookies] :as request}]
(if-let [token (get-in cookies [token-cookie-name :value])]
(if-let [{:keys [id profile-id]} (rss/read-session store token)]
(assoc request :session-id id :profile-id profile-id)
request)
request))]
(fn [request respond raise]
(try
(let [{:keys [session-id profile-id] :as request} (get-session request)]
(when (and session-id profile-id)
(a/offer! events-ch session-id))
(handler request respond raise))
(catch Throwable cause
(raise cause))))))
;; --- STATE INIT: SESSION ;; --- STATE INIT: SESSION
(s/def ::tokens fn?) (s/def ::store #(satisfies? ISessionStore %))
(defmethod ig/pre-init-spec :app.http/session [_] (defmethod ig/pre-init-spec :app.http/session [_]
(s/keys :req-un [::db/pool ::tokens ::wrk/executor])) (s/keys :req-un [::store]))
(defmethod ig/prep-key :app.http/session (defmethod ig/prep-key :app.http/session
[_ cfg] [_ cfg]
@ -158,29 +192,23 @@
(d/without-nils cfg))) (d/without-nils cfg)))
(defmethod ig/init-key :app.http/session (defmethod ig/init-key :app.http/session
[_ {:keys [pool tokens] :as cfg}] [_ {:keys [store] :as cfg}]
(let [events-ch (a/chan (a/dropping-buffer (:buffer-size cfg))) (let [events-ch (a/chan (a/dropping-buffer (:buffer-size cfg)))
store (if (db/read-only? pool) cfg (assoc cfg ::events-ch events-ch)]
(->MemoryStore (atom {}) tokens)
(->DatabaseStore pool tokens))
cfg (assoc cfg ::store store ::events-ch events-ch)]
(when (db/read-only? pool)
(l/warn :hint "sessions module initialized with in-memory store"))
(-> cfg (-> cfg
(assoc :middleware (partial middleware cfg)) (assoc :middleware (make-middleware cfg))
(assoc :create (fn [profile-id] (assoc :create (fn [profile-id]
(fn [request response] (fn [request response]
(let [token (create-session store request profile-id)] (p/let [token (create-session! store request profile-id)]
(add-cookies response token))))) (add-cookies response token)))))
(assoc :delete (fn [request response] (assoc :delete (fn [request response]
(delete-session store request) (p/do
(-> response (delete-session! store request)
(assoc :status 204) (-> response
(assoc :body "") (assoc :status 204)
(clear-cookies))))))) (assoc :body nil)
(clear-cookies))))))))
(defmethod ig/halt-key! :app.http/session (defmethod ig/halt-key! :app.http/session
[_ data] [_ data]

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

@ -24,13 +24,15 @@
[integrant.core :as ig] [integrant.core :as ig]
[lambdaisland.uri :as u] [lambdaisland.uri :as u]
[promesa.core :as p] [promesa.core :as p]
[promesa.exec :as px])) [promesa.exec :as px]
[yetti.request :as yrq]
[yetti.response :as yrs]))
(defn parse-client-ip (defn parse-client-ip
[{:keys [headers] :as request}] [request]
(or (some-> (get headers "x-forwarded-for") (str/split ",") first) (or (some-> (yrq/get-header request "x-forwarded-for") (str/split ",") first)
(get headers "x-real-ip") (yrq/get-header request "x-real-ip")
(get request :remote-addr))) (yrq/remote-addr request)))
(defn profile->props (defn profile->props
[profile] [profile]
@ -87,11 +89,10 @@
(do (do
(l/warn :hint "audit log http handler disabled or db is read-only") (l/warn :hint "audit log http handler disabled or db is read-only")
(fn [_ respond _] (fn [_ respond _]
(respond {:status 204 :body ""}))) (respond (yrs/response 204))))
(letfn [(handler [{:keys [profile-id] :as request}]
(letfn [(handler [{:keys [params profile-id] :as request}] (let [events (->> (:events (:params request))
(let [events (->> (:events params)
(remove #(not= profile-id (:profile-id %))) (remove #(not= profile-id (:profile-id %)))
(us/conform ::frontend-events)) (us/conform ::frontend-events))
@ -113,7 +114,7 @@
(-> (px/submit! executor #(handler request)) (-> (px/submit! executor #(handler request))
(p/catch handle-error)) (p/catch handle-error))
(respond {:status 204 :body ""}))))) (respond (yrs/response 204))))))
(defn- persist-http-events (defn- persist-http-events
[{:keys [pool events ip-addr source] :as cfg}] [{:keys [pool events ip-addr source] :as cfg}]

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

@ -83,6 +83,9 @@
{:executor (ig/ref [::default :app.worker/executor])} {:executor (ig/ref [::default :app.worker/executor])}
:app.http/session :app.http/session
{:store (ig/ref :app.http.session/store)}
:app.http.session/store
{:pool (ig/ref :app.db/pool) {:pool (ig/ref :app.db/pool)
:tokens (ig/ref :app.tokens/tokens) :tokens (ig/ref :app.tokens/tokens)
:executor (ig/ref [::default :app.worker/executor])} :executor (ig/ref [::default :app.worker/executor])}
@ -110,14 +113,12 @@
:host (cf/get :http-server-host) :host (cf/get :http-server-host)
:router (ig/ref :app.http/router) :router (ig/ref :app.http/router)
:metrics (ig/ref :app.metrics/metrics) :metrics (ig/ref :app.metrics/metrics)
:executor (ig/ref [::default :app.worker/executor]) :executors (ig/ref :app.worker/executors)}
:session (ig/ref :app.http/session)
:max-threads (cf/get :http-server-max-threads)
:min-threads (cf/get :http-server-min-threads)}
:app.http/router :app.http/router
{:assets (ig/ref :app.http.assets/handlers) {:assets (ig/ref :app.http.assets/handlers)
:feedback (ig/ref :app.http.feedback/handler) :feedback (ig/ref :app.http.feedback/handler)
:session (ig/ref :app.http/session)
:awsns-handler (ig/ref :app.http.awsns/handler) :awsns-handler (ig/ref :app.http.awsns/handler)
:oauth (ig/ref :app.http.oauth/handler) :oauth (ig/ref :app.http.oauth/handler)
:debug (ig/ref :app.http.debug/handlers) :debug (ig/ref :app.http.debug/handlers)

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

@ -28,28 +28,30 @@
org.im4java.core.IMOperation org.im4java.core.IMOperation
org.im4java.core.Info)) org.im4java.core.Info))
(s/def ::image-content-type cm/valid-image-types) (s/def ::path fs/path?)
(s/def ::font-content-type cm/valid-font-types) (s/def ::filename string?)
(s/def ::size integer?)
(s/def :internal.http.upload/filename ::us/string) (s/def ::headers (s/map-of string? string?))
(s/def :internal.http.upload/size ::us/integer) (s/def ::mtype string?)
(s/def :internal.http.upload/content-type ::us/string)
(s/def :internal.http.upload/tempfile any?)
(s/def ::upload (s/def ::upload
(s/keys :req-un [:internal.http.upload/filename (s/keys :req-un [::filename ::size ::path]
:internal.http.upload/size :opt-un [::mtype ::headers]))
:internal.http.upload/tempfile
:internal.http.upload/content-type])) ;; A subset of fields from the ::upload spec
(s/def ::input
(s/keys :req-un [::path]
:opt-un [::mtype]))
(defn validate-media-type! (defn validate-media-type!
([mtype] (validate-media-type! mtype cm/valid-image-types)) ([upload] (validate-media-type! upload cm/valid-image-types))
([mtype allowed] ([upload allowed]
(when-not (contains? allowed mtype) (when-not (contains? allowed (:mtype upload))
(ex/raise :type :validation (ex/raise :type :validation
:code :media-type-not-allowed :code :media-type-not-allowed
:hint "Seems like you are uploading an invalid media object")) :hint "Seems like you are uploading an invalid media object"))
mtype))
upload))
(defmulti process :cmd) (defmulti process :cmd)
(defmulti process-error class) (defmulti process-error class)
@ -72,26 +74,16 @@
(process-error e)))) (process-error e))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- Thumbnails Generation ;; IMAGE THUMBNAILS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(s/def ::cmd keyword?)
(s/def ::path (s/or :path fs/path?
:string string?
:file fs/file?))
(s/def ::input
(s/keys :req-un [::path]
:opt-un [::cm/mtype]))
(s/def ::width integer?) (s/def ::width integer?)
(s/def ::height integer?) (s/def ::height integer?)
(s/def ::format #{:jpeg :webp :png}) (s/def ::format #{:jpeg :webp :png})
(s/def ::quality #(< 0 % 101)) (s/def ::quality #(< 0 % 101))
(s/def ::thumbnail-params (s/def ::thumbnail-params
(s/keys :req-un [::cmd ::input ::format ::width ::height])) (s/keys :req-un [::input ::format ::width ::height]))
;; Related info on how thumbnails generation ;; Related info on how thumbnails generation
;; http://www.imagemagick.org/Usage/thumbnails/ ;; http://www.imagemagick.org/Usage/thumbnails/
@ -178,7 +170,7 @@
(ex/raise :type :validation (ex/raise :type :validation
:code :invalid-svg-file :code :invalid-svg-file
:hint "uploaded svg does not provides dimensions")) :hint "uploaded svg does not provides dimensions"))
(assoc info :mtype mtype)) (merge input info))
(let [instance (Info. (str path)) (let [instance (Info. (str path))
mtype' (.getProperty instance "Mime type")] mtype' (.getProperty instance "Mime type")]
@ -191,9 +183,9 @@
;; For an animated GIF, getImageWidth/Height returns the delta size of one frame (if no frame given ;; For an animated GIF, getImageWidth/Height returns the delta size of one frame (if no frame given
;; it returns size of the last one), whereas getPageWidth/Height always return the full size of ;; it returns size of the last one), whereas getPageWidth/Height always return the full size of
;; any frame. ;; any frame.
{:width (.getPageWidth instance) (assoc input
:height (.getPageHeight instance) :width (.getPageWidth instance)
:mtype mtype})))) :height (.getPageHeight instance))))))
(defmethod process-error org.im4java.core.InfoException (defmethod process-error org.im4java.core.InfoException
[error] [error]
@ -203,7 +195,7 @@
:cause error)) :cause error))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Fonts Generation ;; FONTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod process :generate-fonts (defmethod process :generate-fonts
@ -326,11 +318,10 @@
(defn configure-assets-storage (defn configure-assets-storage
"Given storage map, returns a storage configured with the appropriate "Given storage map, returns a storage configured with the appropriate
backend for assets." backend for assets and optional connection attached."
([storage] ([storage]
(assoc storage :backend (cf/get :assets-storage-backend :assets-fs))) (assoc storage :backend (cf/get :assets-storage-backend :assets-fs)))
([storage conn] ([storage conn]
(-> storage (-> storage
(assoc :conn conn) (assoc :conn conn)
(assoc :backend (cf/get :assets-storage-backend :assets-fs))))) (assoc :backend (cf/get :assets-storage-backend :assets-fs)))))

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

@ -23,8 +23,6 @@
io.prometheus.client.Histogram$Child io.prometheus.client.Histogram$Child
io.prometheus.client.exporter.common.TextFormat io.prometheus.client.exporter.common.TextFormat
io.prometheus.client.hotspot.DefaultExports io.prometheus.client.hotspot.DefaultExports
io.prometheus.client.jetty.JettyStatisticsCollector
org.eclipse.jetty.server.handler.StatisticsHandler
java.io.StringWriter)) java.io.StringWriter))
(set! *warn-on-reflection* true) (set! *warn-on-reflection* true)
@ -265,9 +263,9 @@
:summary (make-summary props) :summary (make-summary props)
:histogram (make-histogram props))) :histogram (make-histogram props)))
(defn instrument-jetty! ;; (defn instrument-jetty!
[^CollectorRegistry registry ^StatisticsHandler handler] ;; [^CollectorRegistry registry ^StatisticsHandler handler]
(doto (JettyStatisticsCollector. handler) ;; (doto (JettyStatisticsCollector. handler)
(.register registry)) ;; (.register registry))
nil) ;; nil)

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

@ -21,7 +21,8 @@
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[integrant.core :as ig] [integrant.core :as ig]
[promesa.core :as p] [promesa.core :as p]
[promesa.exec :as px])) [promesa.exec :as px]
[yetti.response :as yrs]))
(defn- default-handler (defn- default-handler
[_] [_]
@ -30,8 +31,8 @@
(defn- handle-response-transformation (defn- handle-response-transformation
[response request mdata] [response request mdata]
(if-let [transform-fn (:transform-response mdata)] (if-let [transform-fn (:transform-response mdata)]
(transform-fn request response) (p/do (transform-fn request response))
response)) (p/resolved response)))
(defn- handle-before-comple-hook (defn- handle-before-comple-hook
[response mdata] [response mdata]
@ -42,54 +43,44 @@
(defn- rpc-query-handler (defn- rpc-query-handler
"Ring handler that dispatches query requests and convert between "Ring handler that dispatches query requests and convert between
internal async flow into ring async flow." internal async flow into ring async flow."
[methods {:keys [profile-id session-id] :as request} respond raise] [methods {:keys [profile-id session-id params] :as request} respond raise]
(letfn [(handle-response [result] (letfn [(handle-response [result]
(let [mdata (meta result)] (let [mdata (meta result)]
(-> {:status 200 :body result} (-> (yrs/response 200 result)
(handle-response-transformation request mdata))))] (handle-response-transformation request mdata))))]
(let [type (keyword (get-in request [:path-params :type])) (let [type (keyword (:type params))
data (merge (:params request) data (into {::request request} params)
(:body-params request)
(:uploads request)
{::request request})
data (if profile-id data (if profile-id
(assoc data :profile-id profile-id ::session-id session-id) (assoc data :profile-id profile-id ::session-id session-id)
(dissoc data :profile-id)) (dissoc data :profile-id))
;; Get the method from methods registry and if method does
;; not exists asigns it to the default handler.
method (get methods type default-handler)] method (get methods type default-handler)]
(-> (method data) (-> (method data)
(p/then #(respond (handle-response %))) (p/then handle-response)
(p/then respond)
(p/catch raise))))) (p/catch raise)))))
(defn- rpc-mutation-handler (defn- rpc-mutation-handler
"Ring handler that dispatches mutation requests and convert between "Ring handler that dispatches mutation requests and convert between
internal async flow into ring async flow." internal async flow into ring async flow."
[methods {:keys [profile-id session-id] :as request} respond raise] [methods {:keys [profile-id session-id params] :as request} respond raise]
(letfn [(handle-response [result] (letfn [(handle-response [result]
(let [mdata (meta result)] (let [mdata (meta result)]
(-> {:status 200 :body result} (p/-> (yrs/response 200 result)
(handle-response-transformation request mdata) (handle-response-transformation request mdata)
(handle-before-comple-hook mdata))))] (handle-before-comple-hook mdata))))]
(let [type (keyword (get-in request [:path-params :type]))
data (merge (:params request)
(:body-params request)
(:uploads request)
{::request request})
(let [type (keyword (:type params))
data (into {::request request} params)
data (if profile-id data (if profile-id
(assoc data :profile-id profile-id ::session-id session-id) (assoc data :profile-id profile-id ::session-id session-id)
(dissoc data :profile-id)) (dissoc data :profile-id))
method (get methods type default-handler)] method (get methods type default-handler)]
(-> (method data) (-> (method data)
(p/then #(respond (handle-response %))) (p/then handle-response)
(p/then respond)
(p/catch raise))))) (p/catch raise)))))
(defn- wrap-metrics (defn- wrap-metrics
@ -147,7 +138,7 @@
:name (or (::audit/name resultm) :name (or (::audit/name resultm)
(::sv/name mdata)) (::sv/name mdata))
:profile-id profile-id :profile-id profile-id
:ip-addr (audit/parse-client-ip request) :ip-addr (some-> request audit/parse-client-ip)
:props (dissoc props ::request))))))) :props (dissoc props ::request)))))))
mdata) mdata)
f)) f))

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

@ -32,7 +32,6 @@
(s/def ::weight valid-weight) (s/def ::weight valid-weight)
(s/def ::style valid-style) (s/def ::style valid-style)
(s/def ::font-id ::us/uuid) (s/def ::font-id ::us/uuid)
(s/def ::content-type ::media/font-content-type)
(s/def ::data (s/map-of ::us/string any?)) (s/def ::data (s/map-of ::us/string any?))
(s/def ::create-font-variant (s/def ::create-font-variant

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

@ -20,7 +20,6 @@
[app.util.services :as sv] [app.util.services :as sv]
[app.util.time :as dt] [app.util.time :as dt]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[datoteka.core :as fs]
[promesa.core :as p] [promesa.core :as p]
[promesa.exec :as px])) [promesa.exec :as px]))
@ -41,9 +40,7 @@
(declare create-file-media-object) (declare create-file-media-object)
(declare select-file) (declare select-file)
(s/def ::content-type ::media/image-content-type) (s/def ::content ::media/upload)
(s/def ::content (s/and ::media/upload (s/keys :req-un [::content-type])))
(s/def ::is-local ::us/boolean) (s/def ::is-local ::us/boolean)
(s/def ::upload-file-media-object (s/def ::upload-file-media-object
@ -95,14 +92,14 @@
(defn create-file-media-object (defn create-file-media-object
[{:keys [storage pool executors] :as cfg} {:keys [id file-id is-local name content] :as params}] [{:keys [storage pool executors] :as cfg} {:keys [id file-id is-local name content] :as params}]
(media/validate-media-type! (:content-type content)) (media/validate-media-type! content)
(letfn [;; Function responsible to retrieve the file information, as (letfn [;; Function responsible to retrieve the file information, as
;; it is synchronous operation it should be wrapped into ;; it is synchronous operation it should be wrapped into
;; with-dispatch macro. ;; with-dispatch macro.
(get-info [path mtype] (get-info [content]
(px/with-dispatch (:blocking executors) (px/with-dispatch (:blocking executors)
(media/run {:cmd :info :input {:path path :mtype mtype}}))) (media/run {:cmd :info :input content})))
;; Function responsible of calculating cryptographyc hash of ;; Function responsible of calculating cryptographyc hash of
;; the provided data. Even though it uses the hight ;; the provided data. Even though it uses the hight
@ -114,16 +111,16 @@
;; Function responsible of generating thumnail. As it is synchronous ;; Function responsible of generating thumnail. As it is synchronous
;; opetation, it should be wrapped into with-dispatch macro ;; opetation, it should be wrapped into with-dispatch macro
(generate-thumbnail [info path] (generate-thumbnail [info]
(px/with-dispatch (:blocking executors) (px/with-dispatch (:blocking executors)
(media/run (assoc thumbnail-options (media/run (assoc thumbnail-options
:cmd :generic-thumbnail :cmd :generic-thumbnail
:input {:mtype (:mtype info) :path path})))) :input info))))
(create-thumbnail [info path] (create-thumbnail [info]
(when (and (not (svg-image? info)) (when (and (not (svg-image? info))
(big-enough-for-thumbnail? info)) (big-enough-for-thumbnail? info))
(p/let [thumb (generate-thumbnail info path) (p/let [thumb (generate-thumbnail info)
hash (calculate-hash (:data thumb)) hash (calculate-hash (:data thumb))
content (-> (sto/content (:data thumb) (:size thumb)) content (-> (sto/content (:data thumb) (:size thumb))
(sto/wrap-with-hash hash))] (sto/wrap-with-hash hash))]
@ -134,8 +131,8 @@
:content-type (:mtype thumb) :content-type (:mtype thumb)
:bucket "file-media-object"})))) :bucket "file-media-object"}))))
(create-image [info path] (create-image [info]
(p/let [data (cond-> path (= (:mtype info) "image/svg+xml") slurp) (p/let [data (cond-> (:path info) (= (:mtype info) "image/svg+xml") slurp)
hash (calculate-hash data) hash (calculate-hash data)
content (-> (sto/content data) content (-> (sto/content data)
(sto/wrap-with-hash hash))] (sto/wrap-with-hash hash))]
@ -157,11 +154,9 @@
(:height info) (:height info)
(:mtype info)])))] (:mtype info)])))]
(p/let [path (fs/path (:tempfile content)) (p/let [info (get-info content)
info (get-info path (:content-type content)) thumb (create-thumbnail info)
thumb (create-thumbnail info path) image (create-image info)]
image (create-image info path)]
(insert-into-database info image thumb)))) (insert-into-database info image thumb))))
;; --- Create File Media Object (from URL) ;; --- Create File Media Object (from URL)
@ -208,6 +203,14 @@
:mtype mtype :mtype mtype
:format format})) :format format}))
(get-upload-object [sobj]
(p/let [path (sto/get-object-path storage sobj)
mdata (meta sobj)]
{:filename "tempfile"
:size (:size sobj)
:path path
:mtype (:content-type mdata)}))
(download-media [uri] (download-media [uri]
(p/let [{:keys [body headers]} (http-client {:method :get :uri uri} {:response-type :input-stream}) (p/let [{:keys [body headers]} (http-client {:method :get :uri uri} {:response-type :input-stream})
{:keys [size mtype]} (parse-and-validate-size headers)] {:keys [size mtype]} (parse-and-validate-size headers)]
@ -217,12 +220,7 @@
::sto/expired-at (dt/in-future {:minutes 30}) ::sto/expired-at (dt/in-future {:minutes 30})
:content-type mtype :content-type mtype
:bucket "file-media-object"}) :bucket "file-media-object"})
(p/then (fn [sobj] (p/then get-upload-object))))]
(p/let [path (sto/get-object-path storage sobj)]
{:filename "tempfile"
:size (:size sobj)
:tempfile path
:content-type (:content-type (meta sobj))}))))))]
(p/let [content (download-media url)] (p/let [content (download-media url)]
(->> (merge params {:content content :name (or name (:filename content))}) (->> (merge params {:content content :name (or name (:filename content))})
@ -240,7 +238,6 @@
(db/with-atomic [conn pool] (db/with-atomic [conn pool]
(let [file (select-file conn file-id)] (let [file (select-file conn file-id)]
(teams/check-edition-permissions! conn profile-id (:team-id file)) (teams/check-edition-permissions! conn profile-id (:team-id file))
(-> (assoc cfg :conn conn) (-> (assoc cfg :conn conn)
(clone-file-media-object params))))) (clone-file-media-object params)))))

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

@ -407,43 +407,32 @@
(declare update-profile-photo) (declare update-profile-photo)
(s/def ::content-type ::media/image-content-type) (s/def ::file ::media/upload)
(s/def ::file (s/and ::media/upload (s/keys :req-un [::content-type])))
(s/def ::update-profile-photo (s/def ::update-profile-photo
(s/keys :req-un [::profile-id ::file])) (s/keys :req-un [::profile-id ::file]))
;; TODO: properly handle resource usage, transactions and storage
(sv/defmethod ::update-profile-photo (sv/defmethod ::update-profile-photo
[cfg {:keys [file] :as params}] [cfg {:keys [file] :as params}]
;; Validate incoming mime type ;; Validate incoming mime type
(media/validate-media-type! (:content-type file) #{"image/jpeg" "image/png" "image/webp"}) (media/validate-media-type! file #{"image/jpeg" "image/png" "image/webp"})
(let [cfg (update cfg :storage media/configure-assets-storage)] (let [cfg (update cfg :storage media/configure-assets-storage)]
(update-profile-photo cfg params))) (update-profile-photo cfg params)))
(defn update-profile-photo (defn update-profile-photo
[{:keys [pool storage executors] :as cfg} {:keys [profile-id file] :as params}] [{:keys [pool storage executors] :as cfg} {:keys [profile-id] :as params}]
(p/do (p/let [profile (px/with-dispatch (:default executors)
;; Perform file validation, this operation executes some (db/get-by-id pool :profile profile-id))
;; comandline helpers for true check of the image file. And it photo (teams/upload-photo cfg params)]
;; raises an exception if somethig is wrong with the file.
(px/with-dispatch (:blocking executors)
(media/run {:cmd :info :input {:path (:tempfile file) :mtype (:content-type file)}}))
(p/let [profile (px/with-dispatch (:default executors) ;; Schedule deletion of old photo
(db/get-by-id pool :profile profile-id)) (when-let [id (:photo-id profile)]
photo (teams/upload-photo cfg params)] (sto/touch-object! storage id))
;; Schedule deletion of old photo ;; Save new photo
(when-let [id (:photo-id profile)] (db/update! pool :profile
(sto/touch-object! storage id)) {:photo-id (:id photo)}
{:id profile-id})
;; Save new photo nil))
(db/update! pool :profile
{:photo-id (:id photo)}
{:id profile-id})
nil)))
;; --- MUTATION: Request Email Change ;; --- MUTATION: Request Email Change

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

@ -22,7 +22,6 @@
[app.util.time :as dt] [app.util.time :as dt]
[clojure.spec.alpha :as s] [clojure.spec.alpha :as s]
[cuerdas.core :as str] [cuerdas.core :as str]
[datoteka.core :as fs]
[promesa.core :as p] [promesa.core :as p]
[promesa.exec :as px])) [promesa.exec :as px]))
@ -281,54 +280,49 @@
(declare ^:private upload-photo) (declare ^:private upload-photo)
(declare ^:private update-team-photo) (declare ^:private update-team-photo)
(s/def ::content-type ::media/image-content-type) (s/def ::file ::media/upload)
(s/def ::file (s/and ::media/upload (s/keys :req-un [::content-type])))
(s/def ::update-team-photo (s/def ::update-team-photo
(s/keys :req-un [::profile-id ::team-id ::file])) (s/keys :req-un [::profile-id ::team-id ::file]))
(sv/defmethod ::update-team-photo (sv/defmethod ::update-team-photo
[cfg {:keys [file] :as params}] [cfg {:keys [file] :as params}]
;; Validate incoming mime type ;; Validate incoming mime type
(media/validate-media-type! (:content-type file) #{"image/jpeg" "image/png" "image/webp"}) (media/validate-media-type! file #{"image/jpeg" "image/png" "image/webp"})
(let [cfg (update cfg :storage media/configure-assets-storage)] (let [cfg (update cfg :storage media/configure-assets-storage)]
(update-team-photo cfg params))) (update-team-photo cfg params)))
(defn update-team-photo (defn update-team-photo
[{:keys [pool storage executors] :as cfg} {:keys [profile-id file team-id] :as params}] [{:keys [pool storage executors] :as cfg} {:keys [profile-id team-id] :as params}]
(p/do (p/let [team (px/with-dispatch (:default executors)
;; Perform file validation, this operation executes some (teams/retrieve-team pool profile-id team-id))
;; comandline helpers for true check of the image file. And it photo (upload-photo cfg params)]
;; raises an exception if somethig is wrong with the file.
(px/with-dispatch (:blocking executors)
(media/run {:cmd :info :input {:path (:tempfile file) :mtype (:content-type file)}}))
(p/let [team (px/with-dispatch (:default executors) ;; Mark object as touched for make it ellegible for tentative
(teams/retrieve-team pool profile-id team-id)) ;; garbage collection.
photo (upload-photo cfg params)] (when-let [id (:photo-id team)]
(sto/touch-object! storage id))
;; Mark object as touched for make it ellegible for tentative ;; Save new photo
;; garbage collection. (db/update! pool :team
(when-let [id (:photo-id team)] {:photo-id (:id photo)}
(sto/touch-object! storage id)) {:id team-id})
;; Save new photo (assoc team :photo-id (:id photo))))
(db/update! pool :team
{:photo-id (:id photo)}
{:id team-id})
(assoc team :photo-id (:id photo)))))
(defn upload-photo (defn upload-photo
[{:keys [storage executors] :as cfg} {:keys [file]}] [{:keys [storage executors] :as cfg} {:keys [file]}]
(letfn [(generate-thumbnail [path mtype] (letfn [(get-info [content]
(px/with-dispatch (:blocking executors)
(media/run {:cmd :info :input content})))
(generate-thumbnail [info]
(px/with-dispatch (:blocking executors) (px/with-dispatch (:blocking executors)
(media/run {:cmd :profile-thumbnail (media/run {:cmd :profile-thumbnail
:format :jpeg :format :jpeg
:quality 85 :quality 85
:width 256 :width 256
:height 256 :height 256
:input {:path path :mtype mtype}}))) :input info})))
;; Function responsible of calculating cryptographyc hash of ;; Function responsible of calculating cryptographyc hash of
;; the provided data. Even though it uses the hight ;; the provided data. Even though it uses the hight
@ -338,8 +332,8 @@
(px/with-dispatch (:blocking executors) (px/with-dispatch (:blocking executors)
(sto/calculate-hash data)))] (sto/calculate-hash data)))]
(p/let [thumb (generate-thumbnail (fs/path (:tempfile file)) (p/let [info (get-info file)
(:content-type file)) thumb (generate-thumbnail info)
hash (calculate-hash (:data thumb)) hash (calculate-hash (:data thumb))
content (-> (sto/content (:data thumb) (:size thumb)) content (-> (sto/content (:data thumb) (:size thumb))
(sto/wrap-with-hash hash))] (sto/wrap-with-hash hash))]

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

@ -257,7 +257,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; A task responsible to permanently delete already marked as deleted ;; A task responsible to permanently delete already marked as deleted
;; storage files. ;; storage files. The storage objects are practically never marked to
;; be deleted directly by the api call. The touched-gc is responsible
;; collect the usage of the object and mark it as deleted.
(declare sql:retrieve-deleted-objects-chunk) (declare sql:retrieve-deleted-objects-chunk)
@ -308,7 +310,7 @@
and s.deleted_at < (now() - ?::interval) and s.deleted_at < (now() - ?::interval)
and s.created_at < ? and s.created_at < ?
order by s.created_at desc order by s.created_at desc
limit 100 limit 25
) )
delete from storage_object delete from storage_object
where id in (select id from items_part) where id in (select id from items_part)
@ -318,9 +320,9 @@
;; Garbage Collection: Analyze touched objects ;; Garbage Collection: Analyze touched objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This task is part of the garbage collection of storage objects and ;; This task is part of the garbage collection process of storage
;; is responsible on analyzing the touched objects and mark them for ;; objects and is responsible on analyzing the touched objects and
;; deletion if corresponds. ;; mark them for deletion if corresponds.
;; ;;
;; For example: when file_media_object is deleted, the depending ;; For example: when file_media_object is deleted, the depending
;; storage_object are marked as touched. This means that some files ;; storage_object are marked as touched. This means that some files

1
backend/src/app/tasks/objects_gc.clj
View file

@ -51,7 +51,6 @@
(count result))) (count result)))
;; --- IMPL: file deletion ;; --- IMPL: file deletion
(defmethod delete-objects "file" (defmethod delete-objects "file"

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

@ -13,10 +13,10 @@
[app.metrics :as mtx] [app.metrics :as mtx]
[app.util.time :as dt] [app.util.time :as dt]
[clojure.core.async :as a] [clojure.core.async :as a]
[yetti.util :as yu]
[yetti.websocket :as yws]) [yetti.websocket :as yws])
(:import (:import
java.nio.ByteBuffer java.nio.ByteBuffer))
org.eclipse.jetty.io.EofException))
(declare decode-beat) (declare decode-beat)
(declare encode-beat) (declare encode-beat)
@ -48,15 +48,17 @@
output-buff-size 64 output-buff-size 64
idle-timeout 30000} idle-timeout 30000}
:as options}] :as options}]
(fn [_] (fn [{:keys [::yws/channel] :as request}]
(let [input-ch (a/chan input-buff-size) (let [input-ch (a/chan input-buff-size)
output-ch (a/chan output-buff-size) output-ch (a/chan output-buff-size)
pong-ch (a/chan (a/sliding-buffer 6)) pong-ch (a/chan (a/sliding-buffer 6))
close-ch (a/chan) close-ch (a/chan)
options (-> options options (-> options
(assoc ::input-ch input-ch) (assoc ::input-ch input-ch)
(assoc ::output-ch output-ch) (assoc ::output-ch output-ch)
(assoc ::close-ch close-ch) (assoc ::close-ch close-ch)
(assoc ::channel channel)
(dissoc ::metrics)) (dissoc ::metrics))
terminated (atom false) terminated (atom false)
@ -76,33 +78,10 @@
on-error on-error
(fn [_ error] (fn [_ error]
(on-terminate) (on-terminate)
(when-not (or (instance? org.eclipse.jetty.websocket.api.exceptions.WebSocketTimeoutException error) ;; TODO: properly log timeout exceptions
(instance? java.nio.channels.ClosedChannelException error)) (when-not (instance? java.nio.channels.ClosedChannelException error)
(l/error :hint (ex-message error) :cause error))) (l/error :hint (ex-message error) :cause error)))
on-connect
(fn [conn]
(mtx/run! metrics {:id :websocket-active-connections :inc 1})
(let [wsp (atom (assoc options ::conn conn))]
;; Handle heartbeat
(yws/idle-timeout! conn (dt/duration idle-timeout))
(-> @wsp
(assoc ::pong-ch pong-ch)
(assoc ::on-close on-terminate)
(process-heartbeat))
;; Forward all messages from output-ch to the websocket
;; connection
(a/go-loop []
(when-let [val (a/<! output-ch)]
(mtx/run! metrics {:id :websocket-messages-total :labels ["send"] :inc 1})
(a/<! (ws-send! conn (t/encode-str val)))
(recur)))
;; React on messages received from the client
(process-input wsp handle-message)))
on-message on-message
(fn [_ message] (fn [_ message]
(mtx/run! metrics {:id :websocket-messages-total :labels ["recv"] :inc 1}) (mtx/run! metrics {:id :websocket-messages-total :labels ["recv"] :inc 1})
@ -116,35 +95,55 @@
(on-terminate)))) (on-terminate))))
on-pong on-pong
(fn [_ buffer] (fn [_ buffers]
(a/>!! pong-ch buffer))] (a/>!! pong-ch (yu/copy-many buffers)))]
{:on-connect on-connect (mtx/run! metrics {:id :websocket-active-connections :inc 1})
:on-error on-error
:on-close on-terminate (let [wsp (atom options)]
:on-text on-message ;; Handle heartbeat
:on-pong on-pong})))) (yws/idle-timeout! channel (dt/duration idle-timeout))
(-> @wsp
(assoc ::pong-ch pong-ch)
(assoc ::on-close on-terminate)
(process-heartbeat))
;; Forward all messages from output-ch to the websocket
;; connection
(a/go-loop []
(when-let [val (a/<! output-ch)]
(mtx/run! metrics {:id :websocket-messages-total :labels ["send"] :inc 1})
(a/<! (ws-send! channel (t/encode-str val)))
(recur)))
;; React on messages received from the client
(process-input wsp handle-message)
{:on-error on-error
:on-close on-terminate
:on-text on-message
:on-pong on-pong})))))
(defn- ws-send! (defn- ws-send!
[conn s] [channel s]
(let [ch (a/chan 1)] (let [ch (a/chan 1)]
(try (try
(yws/send! conn s (fn [e] (yws/send! channel s (fn [e]
(when e (a/offer! ch e)) (when e (a/offer! ch e))
(a/close! ch))) (a/close! ch)))
(catch EofException cause (catch java.io.IOException cause
(a/offer! ch cause) (a/offer! ch cause)
(a/close! ch))) (a/close! ch)))
ch)) ch))
(defn- ws-ping! (defn- ws-ping!
[conn s] [channel s]
(let [ch (a/chan 1)] (let [ch (a/chan 1)]
(try (try
(yws/ping! conn s (fn [e] (yws/ping! channel s (fn [e]
(when e (a/offer! ch e)) (when e (a/offer! ch e))
(a/close! ch))) (a/close! ch)))
(catch EofException cause (catch java.io.IOException cause
(a/offer! ch cause) (a/offer! ch cause)
(a/close! ch))) (a/close! ch)))
ch)) ch))
@ -184,19 +183,19 @@
(a/<! (handler wsp {:type :disconnect}))))) (a/<! (handler wsp {:type :disconnect})))))
(defn- process-heartbeat (defn- process-heartbeat
[{:keys [::conn ::close-ch ::on-close ::pong-ch [{:keys [::channel ::close-ch ::on-close ::pong-ch
::heartbeat-interval ::max-missed-heartbeats] ::heartbeat-interval ::max-missed-heartbeats]
:or {heartbeat-interval 2000 :or {heartbeat-interval 2000
max-missed-heartbeats 4}}] max-missed-heartbeats 4}}]
(let [beats (atom #{})] (let [beats (atom #{})]
(a/go-loop [i 0] (a/go-loop [i 0]
(let [[_ port] (a/alts! [close-ch (a/timeout heartbeat-interval)])] (let [[_ port] (a/alts! [close-ch (a/timeout heartbeat-interval)])]
(when (and (yws/connected? conn) (when (and (yws/connected? channel)
(not= port close-ch)) (not= port close-ch))
(a/<! (ws-ping! conn (encode-beat i))) (a/<! (ws-ping! channel (encode-beat i)))
(let [issued (swap! beats conj (long i))] (let [issued (swap! beats conj (long i))]
(if (>= (count issued) max-missed-heartbeats) (if (>= (count issued) max-missed-heartbeats)
(on-close conn -1 "heartbeat-timeout") (on-close channel -1 "heartbeat-timeout")
(recur (inc i))))))) (recur (inc i)))))))
(a/go-loop [] (a/go-loop []

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

@ -120,8 +120,8 @@
(t/deftest file-media-gc-task (t/deftest file-media-gc-task
(letfn [(create-file-media-object [{:keys [profile-id file-id]}] (letfn [(create-file-media-object [{:keys [profile-id file-id]}]
(let [mfile {:filename "sample.jpg" (let [mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/test_files/sample.jpg") :path (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg" :mtype "image/jpeg"
:size 312043} :size 312043}
params {::th/type :upload-file-media-object params {::th/type :upload-file-media-object
:profile-id profile-id :profile-id profile-id

8
backend/test/app/services_media_test.clj
View file

@ -57,8 +57,8 @@
:project-id (:default-project-id prof) :project-id (:default-project-id prof)
:is-shared false}) :is-shared false})
mfile {:filename "sample.jpg" mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/test_files/sample.jpg") :path (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg" :mtype "image/jpeg"
:size 312043} :size 312043}
params {::th/type :upload-file-media-object params {::th/type :upload-file-media-object
@ -96,8 +96,8 @@
:project-id (:default-project-id prof) :project-id (:default-project-id prof)
:is-shared false}) :is-shared false})
mfile {:filename "sample.jpg" mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/test_files/sample.jpg") :path (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg" :mtype "image/jpeg"
:size 312043} :size 312043}
params {::th/type :upload-file-media-object params {::th/type :upload-file-media-object

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

@ -110,8 +110,8 @@
:profile-id (:id profile) :profile-id (:id profile)
:file {:filename "sample.jpg" :file {:filename "sample.jpg"
:size 123123 :size 123123
:tempfile (th/tempfile "app/test_files/sample.jpg") :path (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg"}} :mtype "image/jpeg"}}
out (th/mutation! data)] out (th/mutation! data)]
;; (th/print-result! out) ;; (th/print-result! out)

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

@ -126,8 +126,8 @@
:is-shared false}) :is-shared false})
mfile {:filename "sample.jpg" mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/test_files/sample.jpg") :path (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg" :mtype "image/jpeg"
:size 312043} :size 312043}
params {::th/type :upload-file-media-object params {::th/type :upload-file-media-object
@ -200,8 +200,8 @@
(fs/slurp-bytes)) (fs/slurp-bytes))
mfile {:filename "sample.jpg" mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/test_files/sample.jpg") :path (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg" :mtype "image/jpeg"
:size 312043} :size 312043}
params1 {::th/type :upload-file-media-object params1 {::th/type :upload-file-media-object
@ -266,8 +266,8 @@
:project-id (:default-project-id prof) :project-id (:default-project-id prof)
:is-shared false}) :is-shared false})
mfile {:filename "sample.jpg" mfile {:filename "sample.jpg"
:tempfile (th/tempfile "app/test_files/sample.jpg") :path (th/tempfile "app/test_files/sample.jpg")
:content-type "image/jpeg" :mtype "image/jpeg"
:size 312043} :size 312043}
params {::th/type :upload-file-media-object params {::th/type :upload-file-media-object

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

@ -30,6 +30,7 @@
[expound.alpha :as expound] [expound.alpha :as expound]
[integrant.core :as ig] [integrant.core :as ig]
[mockery.core :as mk] [mockery.core :as mk]
[yetti.request :as yrq]
[promesa.core :as p]) [promesa.core :as p])
(:import org.postgresql.ds.PGSimpleDataSource)) (:import org.postgresql.ds.PGSimpleDataSource))
@ -55,12 +56,20 @@
(dissoc :app.srepl/server (dissoc :app.srepl/server
:app.http/server :app.http/server
:app.http/router :app.http/router
:app.notifications/handler :app.http.awsns/handler
:app.loggers.sentry/reporter :app.http.session/updater
:app.http.oauth/google :app.http.oauth/google
:app.http.oauth/gitlab :app.http.oauth/gitlab
:app.http.oauth/github :app.http.oauth/github
:app.http.oauth/all :app.http.oauth/all
:app.worker/executors-monitor
:app.http.oauth/handler
:app.notifications/handler
:app.loggers.sentry/reporter
:app.loggers.mattermost/reporter
:app.loggers.loki/reporter
:app.loggers.database/reporter
:app.loggers.zmq/receiver
:app.worker/cron :app.worker/cron
:app.worker/worker) :app.worker/worker)
(d/deep-merge (d/deep-merge
@ -71,7 +80,11 @@
(try (try
(binding [*system* system (binding [*system* system
*pool* (:app.db/pool system)] *pool* (:app.db/pool system)]
(next)) (mk/with-mocks [mock1 {:target 'app.rpc.mutations.profile/derive-password
:return identity}
mock2 {:target 'app.rpc.mutations.profile/verify-password
:return (fn [a b] {:valid (= a b)})}]
(next)))
(finally (finally
(ig/halt! system))))) (ig/halt! system)))))