Files
penpot/backend/src/app/http/debug.clj
Andrey Antukh 61d9b57bc7 ♻️ Refactor internal tokens API
Mainly make it receive the whol cfg/system instead only props. This
makes the api more flexible for a future extending without the need
to change the api again.
2025-10-07 12:08:00 +02:00

583 lines
23 KiB
Clojure

;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC
(ns app.http.debug
(:refer-clojure :exclude [error-handler])
(:require
[app.binfile.common :as bfc]
[app.binfile.v1 :as bf.v1]
[app.binfile.v3 :as bf.v3]
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.features :as cfeat]
[app.common.logging :as l]
[app.common.pprint :as pp]
[app.common.time :as ct]
[app.common.transit :as t]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.features.file-migrations :as feat.fmig]
[app.http.session :as session]
[app.rpc.commands.auth :as auth]
[app.rpc.commands.files-create :refer [create-file]]
[app.rpc.commands.profile :as profile]
[app.rpc.commands.teams :as teams]
[app.setup :as-alias setup]
[app.setup.clock :as clock]
[app.srepl.main :as srepl]
[app.storage :as-alias sto]
[app.storage.tmp :as tmp]
[app.util.blob :as blob]
[app.util.template :as tmpl]
[cuerdas.core :as str]
[datoteka.io :as io]
[emoji.core :as emj]
[integrant.core :as ig]
[markdown.core :as md]
[markdown.transformers :as mdt]
[yetti.request :as yreq]
[yetti.response :as yres]))
;; (selmer.parser/cache-off!)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INDEX
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn index-handler
[_cfg _request]
(let [{:keys [clock offset]} @clock/current]
{::yres/status 200
::yres/headers {"content-type" "text/html"}
::yres/body (-> (io/resource "app/templates/debug.tmpl")
(tmpl/render {:version (:full cf/version)
:current-clock (str clock)
:current-offset (if offset
(ct/format-duration offset)
"NO OFFSET")
:current-time (ct/format-inst (ct/now) :http)
:supported-features cfeat/supported-features}))}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FILE CHANGES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- get-resolved-file
[cfg file-id]
(some-> (bfc/get-file cfg file-id :migrate? false)
(update :data blob/encode)))
(defn prepare-download
[file filename]
{::yres/status 200
::yres/headers
{"content-disposition" (str "attachment; filename=" filename ".json")
"content-type" "application/octet-stream"}
::yres/body
(t/encode file {:type :json-verbose})})
(def sql:retrieve-range-of-changes
"select revn, changes from file_change where file_id=? and revn >= ? and revn <= ? order by revn")
(def sql:retrieve-single-change
"select revn, changes, data from file_change where file_id=? and revn = ?")
(defn- download-file-data
[cfg {:keys [params ::session/profile-id] :as request}]
(let [file-id (some-> params :file-id parse-uuid)
filename (str file-id)]
(when-not file-id
(ex/raise :type :validation
:code :missing-arguments))
(if-let [file (get-resolved-file cfg file-id)]
(cond
(contains? params :download)
(prepare-download file filename)
(contains? params :clone)
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]
(let [profile (profile/get-profile conn profile-id)
project-id (:default-project-id profile)
file (-> (create-file cfg {:id (uuid/next)
:name (str "Cloned: " (:name file))
:features (:features file)
:project-id project-id
:profile-id profile-id})
(assoc :data (:data file))
(assoc :migrations (:migrations file)))]
(feat.fmig/reset-migrations! conn file)
(db/update! conn :file
{:data (:data file)}
{:id (:id file)}
{::db/return-keys false})
{::yres/status 201
::yres/body "OK CLONED"})))
:else
(ex/raise :type :validation
:code :invalid-params
:hint "invalid button"))
(ex/raise :type :not-found
:code :enpty-data
:hint "empty response"))))
(defn- is-file-exists?
[pool id]
(let [sql "select exists (select 1 from file where id=?) as exists;"]
(-> (db/exec-one! pool [sql id]) :exists)))
(defn- upload-file-data
[{:keys [::db/pool] :as cfg} {:keys [::session/profile-id params] :as request}]
(let [profile (profile/get-profile pool profile-id)
project-id (:default-project-id profile)
file (some-> params :file :path io/read* t/decode)]
(if (and file project-id)
(let [fname (str "Imported: " (:name file) "(" (ct/now) ")")
reuse-id? (contains? params :reuseid)
file-id (or (and reuse-id? (ex/ignoring (-> params :file :filename parse-uuid)))
(uuid/next))]
(if (and reuse-id? file-id
(is-file-exists? pool file-id))
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]
(db/update! conn :file
{:data (:data file)
:features (into-array (:features file))
:deleted-at nil}
{:id file-id}
{::db/return-keys false})
(feat.fmig/reset-migrations! conn file)
{::yres/status 200
::yres/body "OK UPDATED"}))
(db/tx-run! cfg
(fn [{:keys [::db/conn] :as cfg}]
(let [file (-> (create-file cfg {:id file-id
:name fname
:features (:features file)
:project-id project-id
:profile-id profile-id})
(assoc :data (:data file))
(assoc :migrations (:migrations file)))]
(db/update! conn :file
{:data (:data file)}
{:id file-id}
{::db/return-keys false})
(feat.fmig/reset-migrations! conn file)
{::yres/status 201
::yres/body "OK CREATED"})))))
(ex/raise :type :validation
:code :invalid-params
:hint "invalid file uploaded"))))
(defn raw-export-import-handler
[cfg request]
(case (yreq/method request)
:get (download-file-data cfg request)
:post (upload-file-data cfg request)
(ex/raise :type :http
:code :method-not-found)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ERROR BROWSER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn error-handler
[{:keys [::db/pool]} request]
(letfn [(get-report [{:keys [path-params]}]
(ex/ignoring
(let [report-id (some-> path-params :id parse-uuid)]
(some-> (db/get-by-id pool :server-error-report report-id)
(update :content db/decode-transit-pgobject)))))
(render-template-v1 [{:keys [content]}]
(let [context (dissoc content
:trace :cause :params :data :spec-problems :message
:spec-explain :spec-value :error :explain :hint)
params {:context (pp/pprint-str context :width 200)
:hint (:hint content)
:spec-explain (:spec-explain content)
:spec-problems (:spec-problems content)
:spec-value (:spec-value content)
:data (:data content)
:trace (or (:trace content)
(some-> content :error :trace))
:params (:params content)}]
(-> (io/resource "app/templates/error-report.tmpl")
(tmpl/render params))))
(render-template-v2 [{report :content}]
(-> (io/resource "app/templates/error-report.v2.tmpl")
(tmpl/render report)))
(render-template-v3 [{:keys [content id created-at]}]
(-> (io/resource "app/templates/error-report.v3.tmpl")
(tmpl/render (-> content
(assoc :id id)
(assoc :created-at (ct/format-inst created-at :rfc1123))))))]
(if-let [report (get-report request)]
(let [result (case (:version report)
1 (render-template-v1 report)
2 (render-template-v2 report)
3 (render-template-v3 report))]
{::yres/status 200
::yres/body result
::yres/headers {"content-type" "text/html; charset=utf-8"
"x-robots-tag" "noindex"}})
{::yres/status 404
::yres/body "not found"})))
(def sql:error-reports
"SELECT id, created_at,
content->>'~:hint' AS hint
FROM server_error_report
ORDER BY created_at DESC
LIMIT 200")
(defn error-list-handler
[{:keys [::db/pool]} _request]
(let [items (->> (db/exec! pool [sql:error-reports])
(map #(update % :created-at ct/format-inst :rfc1123)))]
{::yres/status 200
::yres/body (-> (io/resource "app/templates/error-list.tmpl")
(tmpl/render {:items items}))
::yres/headers {"content-type" "text/html; charset=utf-8"
"x-robots-tag" "noindex"}}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; EXPORT/IMPORT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn export-handler
[{:keys [::db/pool] :as cfg} {:keys [params ::session/profile-id] :as request}]
(let [file-ids (into #{}
(comp (remove empty?)
(map parse-uuid))
(:file-ids params))
libs? (contains? params :includelibs)
clone? (contains? params :clone)
embed? (contains? params :embedassets)]
(when-not (seq file-ids)
(ex/raise :type :validation
:code :missing-arguments))
(let [path (tmp/tempfile :prefix "penpot.export." :min-age "30m")]
(with-open [output (io/output-stream path)]
(-> cfg
(assoc ::bfc/ids file-ids)
(assoc ::bfc/embed-assets embed?)
(assoc ::bfc/include-libraries libs?)
(bf.v3/export-files! output)))
(if clone?
(let [profile (profile/get-profile pool profile-id)
project-id (:default-project-id profile)
cfg (assoc cfg
::bfc/overwrite false
::bfc/profile-id profile-id
::bfc/project-id project-id
::bfc/input path)]
(bf.v3/import-files! cfg)
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body "OK CLONED"})
{::yres/status 200
::yres/body (io/input-stream path)
::yres/headers {"content-type" "application/octet-stream"
"content-disposition" (str "attachmen; filename=" (first file-ids) ".penpot")}}))))
(defn import-handler
[{:keys [::db/pool] :as cfg} {:keys [params ::session/profile-id] :as request}]
(when-not (contains? params :file)
(ex/raise :type :validation
:code :missing-upload-file
:hint "missing upload file"))
(let [profile (profile/get-profile pool profile-id)
project-id (:default-project-id profile)
team (teams/get-team pool
:profile-id profile-id
:project-id project-id)]
(when-not project-id
(ex/raise :type :validation
:code :missing-project
:hint "project not found"))
(let [path (-> params :file :path)
format (bfc/parse-file-format path)
cfg (assoc cfg
::bfc/profile-id profile-id
::bfc/project-id project-id
::bfc/input path
::bfc/features (cfeat/get-team-enabled-features cf/flags team))]
(if (= format :binfile-v3)
(bf.v3/import-files! cfg)
(bf.v1/import-files! cfg))
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body "OK"})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ACTIONS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- resend-email-notification
[cfg {:keys [params] :as request}]
(db/tx-run! cfg (fn [{:keys [::db/conn] :as cfg}]
(when-not (contains? params :force)
(ex/raise :type :validation
:code :missing-force
:hint "missing force checkbox"))
(let [profile (some->> params
:email
(profile/clean-email)
(profile/get-profile-by-email conn))]
(when-not profile
(ex/raise :type :validation
:code :missing-profile
:hint "unable to find profile by email"))
(cond
(contains? params :block)
(do
(db/update! conn :profile {:is-blocked true} {:id (:id profile)})
(db/delete! conn :http-session {:profile-id (:id profile)})
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body (str/ffmt "PROFILE '%' BLOCKED" (:email profile))})
(contains? params :unblock)
(do
(db/update! conn :profile {:is-blocked false} {:id (:id profile)})
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body (str/ffmt "PROFILE '%' UNBLOCKED" (:email profile))})
(contains? params :resend)
(if (:is-blocked profile)
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body "PROFILE ALREADY BLOCKED"}
(do
(#'auth/send-email-verification! cfg profile)
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body (str/ffmt "RESENDED FOR '%'" (:email profile))}))
:else
(do
(db/update! conn :profile {:is-active true} {:id (:id profile)})
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body (str/ffmt "PROFILE '%' ACTIVATED" (:email profile))}))))))
(defn- reset-file-version
[cfg {:keys [params] :as request}]
(let [file-id (some-> params :file-id d/parse-uuid)
version (some-> params :version d/parse-integer)]
(when-not (contains? params :force)
(ex/raise :type :validation
:code :missing-force
:hint "missing force checkbox"))
(when (nil? file-id)
(ex/raise :type :validation
:code :invalid-file-id
:hint "provided invalid file id"))
(when (nil? version)
(ex/raise :type :validation
:code :invalid-version
:hint "provided invalid version"))
(db/tx-run! cfg srepl/process-file! file-id #(assoc % :version version))
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body "OK"}))
(defn- handle-team-features
[cfg {:keys [params] :as request}]
(let [team-id (some-> params :team-id d/parse-uuid)
feature (some-> params :feature str)
action (some-> params :action)
skip-check (contains? params :skip-check)]
(when (nil? team-id)
(ex/raise :type :validation
:code :invalid-team-id
:hint "provided invalid team id"))
(if (= action "show")
(let [team (db/run! cfg teams/get-team-info {:id team-id})]
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body (apply str "Team features:\n"
(->> (:features team)
(map (fn [feature]
(str "- " feature "\n")))))})
(do
(when-not (contains? params :force)
(ex/raise :type :validation
:code :missing-force
:hint "missing force checkbox"))
(cond
(= action "enable")
(srepl/enable-team-feature! team-id feature :skip-check skip-check)
(= action "disable")
(srepl/disable-team-feature! team-id feature :skip-check skip-check)
:else
(ex/raise :type :validation
:code :invalid-action
:hint (str "invalid action: " action)))
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body "OK"}))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; VIRTUAL CLOCK
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- set-virtual-clock
[_ {:keys [params] :as request}]
(let [offset (some-> params :offset str/trim not-empty ct/duration)
reset? (contains? params :reset)]
(if (or reset? (zero? (inst-ms offset)))
(clock/set-offset! nil)
(clock/set-offset! offset))
{::yres/status 302
::yres/headers {"location" "/dbg"}}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OTHER SMALL VIEWS/HANDLERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn health-handler
"Mainly a task that performs a health check."
[{:keys [::db/pool]} _]
(try
(db/exec-one! pool ["select count(*) as count from server_prop;"])
{::yres/status 200
::yres/body "OK"}
(catch Throwable cause
(l/warn :hint "unable to execute query on health handler"
:cause cause)
{::yres/status 503
::yres/body "KO"})))
(defn changelog-handler
[_ _]
(letfn [(transform-emoji [text state]
[(emj/emojify text) state])
(md->html [text]
(md/md-to-html-string text :replacement-transformers (into [transform-emoji] mdt/transformer-vector)))]
(if-let [clog (io/resource "changelog.md")]
{::yres/status 200
::yres/headers {"content-type" "text/html; charset=utf-8"}
::yres/body (-> clog slurp md->html)}
{::yres/status 404
::yres/body "NOT FOUND"})))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INIT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn authorized?
[pool {:keys [::session/profile-id]}]
(or (= "devenv" (cf/get :host))
(let [profile (ex/ignoring (profile/get-profile pool profile-id))
admins (or (cf/get :admins) #{})]
(contains? admins (:email profile)))))
(def with-authorization
{:compile
(fn [& _]
(fn [handler pool]
(fn [request]
(if (authorized? pool request)
(handler request)
(ex/raise :type :authentication
:code :only-admins-allowed)))))})
(def errors
(letfn [(handle-error [cause]
(when-let [data (ex-data cause)]
(when (= :validation (:type data))
(str "Error: " (or (:hint data) (ex-message cause)) "\n"))))]
{:name ::errors
:compile
(fn [& _params]
(fn [handler]
(fn [request]
(try
(handler request)
(catch Throwable cause
(let [body (or (handle-error cause)
(ex/format-throwable cause))]
{::yres/status 400
::yres/headers {"content-type" "text/plain"}
::yres/body body}))))))}))
(defmethod ig/assert-key ::routes
[_ params]
(assert (db/pool? (::db/pool params)) "expected a valid database pool")
(assert (session/manager? (::session/manager params)) "expected a valid session manager"))
(defmethod ig/init-key ::routes
[_ {:keys [::db/pool] :as cfg}]
[["/readyz" {:handler (partial health-handler cfg)}]
["/dbg" {:middleware [[session/authz cfg]
[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)}]
["/actions" {:middleware [[errors]]}
["/set-virtual-clock"
{:handler (partial set-virtual-clock cfg)}]
["/resend-email-verification"
{:handler (partial resend-email-notification cfg)}]
["/reset-file-version"
{:handler (partial reset-file-version cfg)}]
["/handle-team-features"
{:handler (partial handle-team-features cfg)}]
["/file-export" {:handler (partial export-handler cfg)}]
["/file-import" {:handler (partial import-handler cfg)}]
["/file-raw-export-import" {:handler (partial raw-export-import-handler cfg)}]]]])