github/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2026-11-13 05:22:03 +00:00
Code Issues Packages Projects Releases Wiki Activity
penpot/backend/src/app/http/debug.clj
Andrey Antukh 93d36d04d8
✨ Stabilize fragmented file data across snapshots and GC (#12420) 
* ✨ Stabilize fragmented file data across snapshots and GC

Snapshots, automatic and user, now store pointer-based rows that share
fragments with the live file instead of duplicating page content.
`get-file-snapshot` resolves those pointers on the server so version
previews keep rendering plain data, and `restore!` reuses the shared
rows. Export still materializes (the package carries no fragments) and
import regenerates them.

`file-gc` treats the main file and every unpurged snapshot as liveness
roots, reads the file unrealized, and reattaches the original pointer
wherever the cleaned value is unchanged, so a pass over an untouched
file writes no fragments and a pass over an edited file keeps the ids
of the pages it did not touch. Snapshot creation and the restore
backup take the file row `FOR SHARE`, which serializes them with the
pass and closes the race that let a new snapshot reference fragments
the pass was about to mark.

All backend pointer bindings go through the `fdata/with-pointers`,
`with-tracked`, `with-tracked-pointers` and `with-untracked` macros.
The loader reads fragments a previous pass marked until `objects-gc`
purges them, and the frontend fails loudly with retry instead of
dropping an unresolved fragment.

Review fixes in this branch: the automatic snapshot attaches before
pending migrations, `realize-pointers` is the single verb,
`reattach-unchanged` takes the identity fast path, the restore guard
takes its revn from the backup read, and `PointerMap.withMeta`
generates a fresh id when metadata changes.

Tests cover both snapshot writers (red without the lock), snapshot
sharing and pin release through the real delete and purge paths,
reattach against orphan marking, preview after offload, the pointer
binding contracts and the with-meta id change.

Closes #12410

AI-assisted-by: muse-spark-1.3-contributor
AI-assisted-by: deepseek-v4.1-flash

♻️ Pin no-churn behavior for untouched pages

Pin the behavior the churn verification measured: a save keeps the
fragment id of every page it does not touch, with a page of eleven keys
(PersistentHashMap), a 46-shape objects map and a nine-page index (hash
map). Also pin the mixed case: a data-level objects-map flip rewrites
the old pointer pages once and the next save keeps the new ids.

The memory records the identity rule behind it: re-assoc with the same
value returns the same map in array and hash maps alike.

Closes #12410

AI-assisted-by: deepseek-v4.1-flash

⚡ Stop loading untouched pages when enabling objects-map

`enable-objects-map` wrapped every page on every save, and reading a
page's objects forced its PointerMap to load the fragment. A save of
one page in a seven-page file therefore made seven fragment reads.

Skip unloaded pointers: their fragment was already wrapped by the
encode-file that wrote it, so loading it only to wrap it again is a
no-op. The save now loads only the pages it edits. A page with a plain
fragment (a data-level feature flip) keeps its plain fragment until it
is first loaded or edited; a migration that enables the feature must
rewrite the data itself.

Cover the change with load-count tests for save and restore, update the
flip test to the new contract, and drop the stale restore comment.

Closes #12410

AI-assisted-by: deepseek-v4.1-flash

⚡ Keep page fragment ids through pending migrations

Applying a pending migration on read realized the file, ran the
migration and persisted it again; the persist wrapped every plain page
in a new PointerMap, so every page got a new fragment id even when the
migration did not change it. That leaves the fragment cache cold and
rewrites every fragment on the first read after a deploy.

Capture the original pointers before realizing, reattach the unchanged
positions after migrating (same value comparison file-gc already uses),
persist the reattached file and return the realized one: the read
contract is plain data. Read-only connections skip the persist and the
reattach. A migration that adds objects-map skips the reattach so the
pages get wrapped.

Move the three helpers to fdata so file-gc and the migration path share
them, and cover the path with a real 0031 migration test: the unchanged
page keeps its id, the changed page gets a new one, the caller gets
realized data and a second read does not migrate again.

Closes #12410

AI-assisted-by: deepseek-v4.1-flash

* 🐛 Realize library pointers with each library's own loader

Fragment rows are keyed by file id, and every caller binds the
fragment loader of the file it works on. get-resolved-file-libraries
returned libraries with their pages still as pointers, so the first
read of a library page under fdata/pointer-map asked the consuming
file for the fragment and failed with :fragment-not-found. That
broke migrations and file validation for every file using a
pointer-mapped library.

The weak-map loader now realizes each library's pointers with the
library's own id. The test fails without the change.

AI-assisted-by: claude-opus-5-5
Signed-off-by: Álvaro Tejero Cantero <alvorithm@teje.ro>

* 🐛 Restore the pointer-map require the repair path still needs

The branch dropped `app.util.pointer-map` from the namespace while the
auto-repair path (added to develop before this branch) still rebinds
`pmap/*tracked*` around validation and repair in
`repair-preexisting-damage` and `process-changes-and-validate`. The
namespace did not compile, so the whole backend failed to load.

Those toggles do not fit the fdata macros: `with-untracked` binds nil
and `with-tracked` creates a fresh atom, while the repair path has to
turn tracking off and restore the existing atom (and read it before the
repair starts). Restore the require and keep the bindings explicit.

Also pin the feature-off path with a test: with `fdata/pointer-map` off
(the default), a save creates no fragments, file-gc writes nothing and
the snapshot preview still returns plain data. Drop a stray `\n` char
literal left at the end of one deftest.

Update the memories with the exception to the macro rule, the snapshot
FOR SHARE locking and the pre-migration automatic snapshot.

Closes #12410

AI-assisted-by: deepseek-v4.1-flash

* 🐛 Validate debug files with their own pointer loader

The `/dbg/actions` file validation passed the file id where
`get-resolved-file-libraries` expects the file map, so the library map
was seeded with a nil key. It also validated a file read without
realizing it, so the first page lookup of a pointer-mapped file raised
"load is not supported when *load-fn* is not bind" and the endpoint
could not validate exactly the files the feature touches.

Read the file realized (validation walks every page and component
anyway) and build the library map from the file. The library loader
already resolves each library's pointers with its own id, so the
realized file and its libraries validate as plain data. Covered by a
handler-level test that fails before the change.

AI-assisted-by: deepseek-v4.1-flash

* ♻️ Bind the snapshot loader through the fdata helper

`reduce-snapshots` hand-rolled the same `binding` that
`fdata/with-pointers` builds (it also loaded the function's own
pointer loader before entering the reduction). Use the macro so the
rule holds there too and the namespace no longer needs
`app.util.pointer-map`; the loader is identical (same cfg and file-id)
and snapshot walking behaves the same.

AI-assisted-by: deepseek-v4.1-flash

* 📚 Note the pointer-binding exceptions and snapshot ordering

Record what the feature review settled:

- Two direct `binding`s stay on purpose: the fine-grained `*tracked*`
  toggles of `app.rpc.commands.files-update` (validation/repair turn
  tracking off and restore the existing atom) and
  `binfile.common/encode-file` (fresh tracked set inheriting the
  current one). Atom-scoped macros would only be worth it if the set
  grows.
- The automatic snapshot is taken before the pending migration, and
  the pre-migration window is narrow: the `get-file` RPC migrates on
  read and its ETag hashes the available migrations, so a post-deploy
  read cannot be a 304 from the pre-deploy state. The old-format
  snapshot only appears when the save is the first request to touch
  the file after the deploy, and `get-file-snapshot` previews it as
  stored.

AI-assisted-by: deepseek-v4.1-flash

* 🐛 Apply pending migrations when previewing a version

Automatic snapshots are attached before the save applies pending file
migrations, so a version can store the old format. The preview RPC
handed that data to the UI as stored, and the viewport renders it with
the current code.

Realize the snapshot with the live file id (fragments are keyed by
file, not by snapshot), normalize its migrations to a set (the decoder
keeps the pgarray as a vector, and `set/difference` would compare
indexes) and apply the pending migrations with the pure
`fmg/migrate-file` and the live libraries. Nothing is persisted: the
stored version keeps its data and restoring it re-migrates on the next
read. The response now carries the snapshot's migrations.

Use `:features` the way `get-file` does for `fdata/objects-map`: a
client that does not declare it gets plain objects. The historical
feature set is not checked against the enabled one on purpose: a
version may predate a feature change.

Cover the preview of a snapshot with a pending migration and the
objects realization; both pin that the stored row is untouched. Update
the file-data memory with the preview contract and the vector/set
trap.

AI-assisted-by: deepseek-v4.1-flash

* 🐛 Decode snapshot migrations as an ordered set

`file-snapshots/decode-snapshot` handed the `file_change.migrations`
pgarray as a vector. `set/difference` falls back to index lookups when
the first collection is shorter than the second, so the pending set was
right only by accident: a stored subset happens to work, while a
stored set larger than `available-migrations` (a snapshot taken by a
newer build) marks every available migration as pending and re-applies
it to already migrated data.

Decode it as a `d/ordered-set`, the type the rest of the code and
`schema:file` expect. This also covers `restore!` and the snapshot
list, and it lets `get-file-snapshot` drop the `(into #{} ...)`
normalization it was carrying. Re-wrap the union in `fmg/migrate` so
the invariant holds even when a caller hands a plain set.

A snapshot with NULL `migrations` predates SQL migration 0140 and
keeps the format version of its time. Pin that legacy path: the
preview regenerates the applied set from that version, migrates in
memory and leaves the stored row untouched. Update the file-data
memory with the invariant and the legacy path.

AI-assisted-by: deepseek-v4.1-flash

* 🐛 Fix flaky waiting-gauge assertion in climit test

The throwable-while-waiting test asserted the exact list of
waiting-gauge publications, but the component sampler republishes
the same count when its first tick lands inside the recorded
window under load. Assert only the last value, which is the
contract the helper documents.

AI-assisted-by: muse-spark-1.3

---------

Signed-off-by: Álvaro Tejero Cantero <alvorithm@teje.ro>
Co-authored-by: Álvaro Tejero Cantero <alvorithm@teje.ro>
2026-11-02 15:02:55 +01:00

995 lines
42 KiB
Clojure
Raw Blame History

;; 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 SUBSIDIARY SL
(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.files.changes :as cfc]
[app.common.files.repair :as cfr]
[app.common.files.validate :as cfv]
[app.common.json :as json]
[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.health :as health]
[app.http.session :as session]
[app.redis :as rds]
[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.helpers :as h]
[app.srepl.main :as srepl]
[app.storage :as-alias sto]
[app.storage.tmp :as tmp]
[app.util.template :as tmpl]
[cuerdas.core :as str]
[datoteka.fs :as fs]
[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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:private max-export-jobs 200)
(defn- scan-export-job-keys
"Note: no index for now, get them all and filter"
[conn pattern]
(loop [cursor "0"
found []]
(let [[cursor keys] (rds/scan conn cursor pattern max-export-jobs)
found (into found keys)]
(if (or (nil? cursor)
(= "0" cursor)
(>= (count found) max-export-jobs))
(into [] (take max-export-jobs) found)
(recur cursor found)))))
(defn- get-export-jobs
[cfg job-id]
(let [filtered? (not (str/empty-or-nil? job-id))
job-uuid (when filtered? (parse-uuid job-id))]
(if (and filtered? (nil? job-uuid))
[]
(try
(let [pattern (str "penpot.exporter." (cf/get :tenant) ".job." (or job-uuid "*"))]
(->> (rds/run! cfg (fn [{:keys [::rds/conn]}]
(->> (scan-export-job-keys conn pattern)
(mapv (fn [key] (rds/hget conn key "data"))))))
(keep (fn [blob]
(try
(t/decode-str blob)
(catch Throwable _ nil))))
(sort-by :created-at #(compare %2 %1))
;; The exporter stores instants as epoch millis.
(map (fn [{:keys [created-at ended-at] :as job}]
(-> job
(assoc :created-at (some-> created-at ct/inst (ct/format-inst :rfc1123)))
(assoc :ended-at (some-> ended-at ct/inst (ct/format-inst :rfc1123))))))
(vec)))
(catch Throwable cause
(l/warn :hint "unable to read export jobs" :cause cause)
[])))))
(defn index-handler
[cfg request]
(let [profile-id (::session/profile-id request)
offset (clock/get-offset profile-id)
profile (profile/get-profile cfg profile-id)
job-filter (some-> request :params :job-id str/trim)]
{::yres/status 200
::yres/headers {"content-type" "text/html"}
::yres/body (-> (io/resource "app/templates/debug.tmpl")
(tmpl/render {:version (:full cf/version)
:profile profile
:graph-enabled (contains? cf/flags :graph)
:current-clock ct/*clock*
:current-offset (if offset
(ct/format-duration offset)
"NO OFFSET")
:current-time (ct/format-inst (ct/now) :http)
:export-jobs (get-export-jobs cfg job-filter)
:export-job-filter job-filter
:supported-features cfeat/supported-features}))}))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FILE CHANGES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- get-resolved-file
[cfg file-id]
(bfc/get-file cfg file-id :migrate? false :decode? false))
(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 :empty-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 :source 3)
(assoc :created-at (ct/format-inst created-at :rfc1123))))))
(render-template-v4 [{:keys [content id created-at]}]
(-> (io/resource "app/templates/error-report.v4.tmpl")
(tmpl/render (-> content
(assoc :id id)
(assoc :source 4)
(assoc :kind (or (:kind content) (:origin content)))
(assoc :trace (or (:trace content) (:report content)))
(assoc :created-at (ct/format-inst created-at :rfc1123))))))
(render-template-v5 [{:keys [content id created-at]}]
(-> (io/resource "app/templates/error-report.v5.tmpl")
(tmpl/render (-> content
(assoc :id id)
(assoc :source 5)
(assoc :value (or (:value content) (:result content)))
(assoc :created-at (ct/format-inst created-at :rfc1123))))))]
(if-let [report (get-report request)]
(let [result (case (:source report)
1 (render-template-v1 report)
2 (render-template-v2 report)
3 (render-template-v3 report)
4 (render-template-v4 report)
5 (render-template-v5 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 ^:private sql:error-reports
"SELECT id, created_at,
content->>'~:hint' AS hint
FROM server_error_report
WHERE (version = ? OR source = ? OR ? = 0)
ORDER BY created_at DESC
LIMIT 300")
(defn- error-list-handler
[{:keys [::db/pool]} {:keys [params]}]
(let [source (or (some-> (get params :source) parse-long) 3)
items (->> (db/exec! pool [sql:error-reports source source source])
(map #(update % :created-at ct/format-inst :rfc1123)))]
{::yres/status 200
::yres/body (-> (io/resource "app/templates/error-list.tmpl")
(tmpl/render {:items items :source source}))
::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/file-ids file-ids)
(assoc ::bfc/embed-assets embed?)
(assoc ::bfc/include-libraries libs?)
(assoc ::bfc/output output)
(bf.v3/export-files!)))
(if clone?
(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)
cfg (assoc cfg
::bfc/overwrite false
::bfc/profile-id profile-id
::bfc/project-id project-id
::bfc/team-id (:id team)
::bfc/input path
::bfc/import-max-binary-entry-size (cf/get :binfile-import-max-binary-entry-size)
::bfc/import-max-text-entry-size (cf/get :binfile-import-max-text-entry-size)
::bfc/import-max-text-total-size (cf/get :binfile-import-max-text-total-size)
::bfc/import-max-zip-entries (cf/get :binfile-import-max-zip-entries))]
(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")}}))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GRAPH (flag: :graph)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; `app.graph.*` resolves at call time, never at the top of this namespace.
;; `app.graph.ladybug` imports `com.ladybugdb.*`, so requiring it links the
;; Ladybug native library into the JVM, and this namespace loads on every
;; backend boot. The routes below are registered only under the `:graph` flag,
;; so with the flag off nothing resolves and no native code loads.
(defn- graph-export-file
"Path of a freshly projected graph for `file-id`."
[cfg file-id]
(let [ingest-file! (requiring-resolve 'app.graph.ingest/ingest-file!)
{:keys [db-path]} (ingest-file! cfg file-id :skip-stats? true)]
(when-not (fs/exists? db-path)
(ex/raise :type :internal
:code :graph-file-not-found
:hint "graph database file missing after ingest"
:file-id (str file-id)
:db-path db-path))
db-path))
(defn- graph-export-session
"Path of a snapshot of the caller's live in-memory graph for `file-id`."
[profile-id file-id]
(let [session-info (requiring-resolve 'app.graph.debug/session-info)
export-session-database! (requiring-resolve 'app.graph.debug/export-session-database!)
info (session-info profile-id)]
(when-not info
(ex/raise :type :not-found
:code :graph-session-not-loaded
:hint "no in-memory graph is loaded; load one first, or use source=file"))
(when-not (= file-id (:file-id info))
(ex/raise :type :validation
:code :graph-session-file-mismatch
:hint "the loaded session holds a different file"
:requested (str file-id)
:loaded (str (:file-id info))))
(export-session-database! profile-id)))
(defn graph-export-handler
"Stream a Ladybug `.lbug` database for a file.
`source=file` (default) projects the file afresh from the database — the
reproducible artifact. `source=session` snapshots the caller's live
in-memory console graph instead, which live-sync may have moved away from a
fresh projection; taking that away to query it elsewhere is the whole point
of asking for it. Synchronous on each request."
[cfg {:keys [params] :as request}]
(let [file-id (some-> params :file-id parse-uuid)
source (or (some-> params :source str/lower) "file")]
(when-not file-id
(ex/raise :type :validation
:code :missing-arguments
:hint "missing file-id"))
(when-not (contains? #{"file" "session"} source)
(ex/raise :type :validation
:code :invalid-arguments
:hint "source must be 'file' or 'session'"
:source source))
(let [session? (= "session" source)
db-path (if session?
(graph-export-session (::session/profile-id request) file-id)
(graph-export-file cfg file-id))]
{::yres/status 200
;; A session export is a temp file this request owns; deleting it on
;; close would race the streaming body, so it is left for the OS temp
;; sweep. A file export is the canonical per-file database and is meant
;; to persist.
::yres/body (io/input-stream db-path)
::yres/headers {"content-type" "application/octet-stream"
"content-disposition"
(str "attachment; filename=" file-id
(when session? "-session") ".lbug")}})))
(defn- graph-console-response
[data]
{::yres/status 200
::yres/headers {"content-type" "text/html; charset=utf-8"
"x-robots-tag" "noindex"}
::yres/body (-> (io/resource "app/templates/graph-console.tmpl")
(tmpl/render (assoc data :version (:full cf/version))))})
(defn graph-console-handler
[_cfg {:keys [::session/profile-id]}]
(let [console-context (requiring-resolve 'app.graph.debug/console-context)]
(graph-console-response (console-context profile-id))))
(defn graph-load-handler
[cfg {:keys [params ::session/profile-id]}]
(let [file-id (some-> (:file-id params) parse-uuid)
load-session! (requiring-resolve 'app.graph.debug/load-session!)]
(when-not file-id
(ex/raise :type :validation
:code :missing-arguments
:hint "missing file-id"))
(load-session! cfg profile-id file-id)
{::yres/status 302
::yres/headers {"location" "/dbg/graph"}}))
(defn graph-unload-handler
[_cfg {:keys [::session/profile-id]}]
((requiring-resolve 'app.graph.debug/unload-session!) profile-id)
{::yres/status 302
::yres/headers {"location" "/dbg/graph"}})
(defn graph-reload-handler
"Re-ingest the currently loaded file into the in-memory graph session."
[cfg {:keys [::session/profile-id]}]
(let [session-info (requiring-resolve 'app.graph.debug/session-info)
load-session! (requiring-resolve 'app.graph.debug/load-session!)]
(if-let [file-id (some-> (session-info profile-id) :file-id)]
(do
(load-session! cfg profile-id file-id)
{::yres/status 302
::yres/headers {"location" "/dbg/graph"}})
(ex/raise :type :not-found
:code :graph-session-not-loaded
:hint "load a file graph before reloading"))))
(defn graph-sync-status-handler
[_cfg {:keys [::session/profile-id]}]
(if-let [status ((requiring-resolve 'app.graph.debug/sync-status) profile-id)]
{::yres/status 200
::yres/headers {"content-type" "application/json; charset=utf-8"}
::yres/body (t/encode-str status {:type :json-verbose})}
{::yres/status 404
::yres/headers {"content-type" "application/json; charset=utf-8"}
::yres/body (t/encode-str {:error "no-session"} {:type :json-verbose})}))
(defn graph-data-handler
"Export the in-memory session graph as plain JSON (not transit) for the
G6 graph view embedded in the console page."
[_cfg {:keys [::session/profile-id]}]
(if-let [data ((requiring-resolve 'app.graph.debug/export-graph-data!) profile-id)]
{::yres/status 200
::yres/headers {"content-type" "application/json; charset=utf-8"}
::yres/body (json/encode data)}
{::yres/status 404
::yres/headers {"content-type" "application/json; charset=utf-8"}
::yres/body (json/encode {:error "no-session"})}))
(def ^:private sql:graph-files
"select t.id as team_id, t.name as team_name,
p.id as project_id, p.name as project_name,
f.id as file_id, f.name as file_name
from team as t
join team_profile_rel as tpr on (tpr.team_id = t.id)
join project as p on (p.team_id = t.id)
join file as f on (f.project_id = p.id)
where tpr.profile_id = ?
and t.deleted_at is null
and p.deleted_at is null
and f.deleted_at is null
order by t.name, p.name, f.name
limit 500")
(defn- graph-files-tree
[rows]
(->> (group-by (juxt :team-id :team-name) rows)
(mapv (fn [[[team-id team-name] team-rows]]
{:id (str team-id)
:name team-name
:projects
(->> (group-by (juxt :project-id :project-name) team-rows)
(mapv (fn [[[project-id project-name] project-rows]]
{:id (str project-id)
:name project-name
:files (mapv (fn [{:keys [file-id file-name]}]
{:id (str file-id) :name file-name})
project-rows)}))
(sort-by :name)
(vec))}))
(sort-by :name)
(vec)))
(defn graph-files-handler
"List teams -> projects -> files reachable by the current profile, as
plain JSON for the graph console file tree."
[{:keys [::db/pool]} {:keys [::session/profile-id]}]
(let [rows (db/exec! pool [sql:graph-files profile-id])]
{::yres/status 200
::yres/headers {"content-type" "application/json; charset=utf-8"}
::yres/body (json/encode {:teams (graph-files-tree rows)})}))
(defn- json-request?
[request]
(some-> request
(yreq/get-header "accept")
(str/includes? "application/json")))
(defn graph-query-handler
[_cfg {:keys [params ::session/profile-id] :as request}]
(let [query (:query params)
query-session! (requiring-resolve 'app.graph.debug/query-session!)
console-context (requiring-resolve 'app.graph.debug/console-context)]
(try
(let [result (query-session! profile-id query)]
(if (json-request? request)
{::yres/status 200
::yres/headers {"content-type" "application/json; charset=utf-8"}
::yres/body (t/encode-str {:query query
:query-result result}
{:type :json-verbose})}
(graph-console-response (console-context profile-id
:query query
:query-result result))))
(catch Throwable e
(let [error (or (:hint (ex-data e)) (ex-message e))]
(if (json-request? request)
{::yres/status 200
::yres/headers {"content-type" "application/json; charset=utf-8"}
::yres/body (t/encode-str {:query query :error error}
{:type :json-verbose})}
(graph-console-response (console-context profile-id
:query query
:error error))))))))
(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/team-id (:id team)
::bfc/features (cfeat/get-team-enabled-features cf/flags team)
::bfc/import-max-binary-entry-size (cf/get :binfile-import-max-binary-entry-size)
::bfc/import-max-text-entry-size (cf/get :binfile-import-max-text-entry-size)
::bfc/import-max-text-total-size (cf/get :binfile-import-max-text-total-size)
::bfc/import-max-zip-entries (cf/get :binfile-import-max-zip-entries))]
(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)})
(session/invalidate-all cfg (: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- 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)
profile-id (::session/profile-id request)
reset? (contains? params :reset)]
(if (= "production" (cf/get :tenant))
{::yres/status 501
::yres/body "OPERATION NOT ALLOWED"}
(do
(if (or reset? (zero? (inst-ms offset)))
(clock/assign-offset profile-id nil)
(clock/assign-offset profile-id offset))
{::yres/status 302
::yres/headers {"location" "/dbg"}}))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; VALIDATE / REPAIR
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- validate-file
[cfg {:keys [params] :as request}]
(let [file-id (some-> params :file-id parse-uuid)]
(when-not file-id
(ex/raise :type :validation
:code :missing-arguments))
(db/tx-run! (assoc cfg ::db/rollback true)
(fn [cfg]
;; Validation walks every page and component, so the
;; file is read realized; the library map is built
;; from the file (not its id) and its own loader
;; resolves each library's pointers.
(let [file (bfc/get-file cfg file-id :realize? true)
libs (bfc/get-resolved-file-libraries cfg file)]
(if file
(let [errors (cfv/validate-file file libs)]
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body (if (empty? errors)
"NO VALIDATION ERRORS FOUND"
(pp/pprint-str errors))})
(ex/raise :type :not-found
:code :empty-data
:hint "empty response")))))))
(defn- repair-file
[cfg {:keys [params] :as request}]
(let [file-id (some-> params :file-id parse-uuid)
skip-snapshot? (contains? params :skip-snapshot)
profile-id (:app.http.session/profile-id request)]
(when-not file-id
(ex/raise :type :validation
:code :missing-arguments))
(let [output (StringBuilder.)
repair-file
(fn [file libs _]
(let [errors (cfv/validate-file file libs)]
(.append output (if (empty? errors)
"NO VALIDATION ERRORS FOUND\n"
(str "VALIDATION ERRORS FOUND:\n"
(pp/pprint-str errors) "\n")))
(if (empty? errors)
file
(let [changes (cfr/repair-file file libs errors)]
(-> file
(update :revn inc)
(update :data cfc/process-changes changes))))))]
(add-watch l/log-record ::repair-watcher
(fn [_ _ _ record]
(when (= "app.common.files.repair" (::l/logger record))
(let [props (::l/props record)
hint (get props :hint "")
args (dissoc props :hint)
message (str hint " "
(when-not (empty? args)
args)
"\n")]
(.append output message)))))
(try
(db/tx-run! cfg
h/process-file!
file-id
repair-file
{::h/with-libraries? true
::h/validate? false
::h/profile-id profile-id
::h/snapshot-label (when-not skip-snapshot? "repair")})
(.append output "\nREPAIR FINISHED")
{::yres/status 200
::yres/headers {"content-type" "text/plain"}
::yres/body (.toString output)}
(finally
(remove-watch l/log-record ::repair-watcher))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OTHER SMALL VIEWS/HANDLERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn health-handler
"Mainly a task that performs a health check. When the instance is marked
as offline (see `app.health`), it reports the instance as unavailable
without querying the database, so the load balancer drains it while the
requests in flight are still served."
[{:keys [::db/pool]} _]
(if (health/online?)
(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"}))
{::yres/status 503
::yres/body "OFFLINE"}))
(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 (and (= "devenv" (cf/get :host)) profile-id)
(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))
(let [hint (or (:hint data) (ex-message cause))
explain (ex/explain data)]
(str "Error: " hint
(when (and explain (not (str/includes? hint explain)))
(str "\n" explain))
"\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"))
(defn- graph-action-routes
[cfg]
[["/graph-export" {:handler (partial graph-export-handler cfg)}]
["/graph-load" {:handler (partial graph-load-handler cfg)}]
["/graph-query" {:handler (partial graph-query-handler cfg)}]
["/graph-unload" {:handler (partial graph-unload-handler cfg)}]
["/graph-reload" {:handler (partial graph-reload-handler cfg)}]
["/graph-sync-status" {:handler (partial graph-sync-status-handler cfg)}]
["/graph-data" {:handler (partial graph-data-handler cfg)}]
["/graph-files" {:handler (partial graph-files-handler cfg)}]])
(defmethod ig/init-key ::routes
[_ {:keys [::db/pool] :as cfg}]
;; The graph routes are registered only under the `:graph` flag. Left
;; unregistered they 404, and nothing ever resolves `app.graph.*`. The `/dbg`
;; admin gate is unchanged: it covers the graph routes exactly as before.
(let [graph? (contains? cf/flags :graph)
actions (cond-> ["/actions" {:middleware [[errors]]}
["/set-virtual-clock"
{:handler (partial set-virtual-clock cfg)}]
["/resend-email-verification"
{:handler (partial resend-email-notification 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)}]
["/file-validate" {:handler (partial validate-file cfg)}]
["/file-repair" {:handler (partial repair-file cfg)}]]
graph? (into (graph-action-routes cfg)))
dbg (cond-> ["/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]
graph? (conj ["/graph" {:handler (partial graph-console-handler cfg)}]))]
(when graph?
;; With the flag on, the Ladybug native library belongs to this process,
;; so load it here. A missing or unusable library then fails the boot
;; instead of the first console request.
(require 'app.graph.debug 'app.graph.ingest))
[["/readyz" {:handler (partial health-handler cfg)}]
dbg]))
Reference in New Issue View Git Blame Copy Permalink