github/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2026-10-31 06:50:33 +00:00
Code Issues Packages Projects Releases Wiki Activity

♻️ Drop the ! suffix from the exporter namespaces

Browse Source 
Mechanical rename, no behavior change: every function the exporter
defines loses the `!`, at the definition and at every call site, in
`src` and in the tests. Two names could not just drop it: the
mutating `merge!` shares the namespace with a persistent `merge` of
another contract, so it becomes `merge-into`; the test restore thunks
take the role as their name (`fetch-restore`, `render-restore`). Two
dead pieces go away with their bangs: the never-called `rmdir!` and
an unused `mark!` binding in the cancel test. Untouched on purpose:
the stdlib (`swap!`, `run!`, `try!`, …), the `set!` special form,
`common` (`serialize-shape!`, `write-shape-*`), and the shared-key
config the deploy still reads.

AI-assisted-by: glm-5.3-flash
This commit is contained in:
Andrey Antukh 2026-10-07 14:37:08 +00:00
parent 74f8d563b4
commit b1cd524f9b
24 changed files with 341 additions and 345 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
exporter/src/app/browser.cljs
View File

@ -5,6 +5,7 @@
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns app.browser
(:refer-clojure :exclude [eval])
(:require
["generic-pool" :as gp]
["generic-pool/lib/errors.js" :as gpe]
@ -38,8 +39,8 @@
:name name
:value token}]))
(defn nav!
([page url] (nav! page url nil))
(defn nav
([page url] (nav page url nil))
([page url {:keys [wait-until timeout] :or {wait-until "networkidle" timeout 20000}}]
(.goto ^js page (str url) #js {:waitUntil wait-until :timeout timeout})))
@ -89,15 +90,15 @@
([frame {:keys [full-page? omit-background? type quality path]
:or {type "png" full-page? false omit-background? false quality 95}}]
(let [options (-> (obj/new)
(obj/set! "type" (name type))
(obj/set! "omitBackground" omit-background?)
(cond-> path (obj/set! "path" path))
(cond-> (= "jpeg" type) (obj/set! "quality" quality))
(cond-> full-page? (-> (obj/set! "fullPage" true)
(obj/set! "clip" nil))))]
(obj/set "type" (name type))
(obj/set "omitBackground" omit-background?)
(cond-> path (obj/set "path" path))
(cond-> (= "jpeg" type) (obj/set "quality" quality))
(cond-> full-page? (-> (obj/set "fullPage" true)
(obj/set "clip" nil))))]
(.screenshot ^js frame options))))
(defn emulate-media!
(defn emulate-media
[page {:keys [media]}]
(.emulateMedia ^js page #js {:media media})
page)
@ -112,7 +113,7 @@
:pageRanges page-ranges
:printBackground true
:preferCSSPageSize true})))
(defn eval!
(defn eval
[frame f]
(.evaluate ^js frame f))
@ -189,7 +190,7 @@
:cause cause)
(p/rejected cause)))
(defn exec!
(defn exec
[config handle]
(letfn [(handle-browser [browser]
(p/let [id (unchecked-get browser "__id")

158
exporter/src/app/consumer/exports.cljs
View File

@ -47,7 +47,7 @@
;; ---- PROGRESS AND CANCEL (the milestones of the contract)
(defn- start-beats!
(defn- start-beats
"The reporter of one run's beats.
The beat reports the stage and the counters and asks the backend to
@ -85,29 +85,29 @@
:cause cause)
(p/resolved {:action :run})))
(p/fmap check)))
beats! (fn [stage counters & {:keys [force?]}]
(let [now (js/Date.now)
now? (or force?
(>= (- now @last-beat) report-throttle-ms))]
(if now?
(do (reset! last-beat now)
(reset! last {:stage stage :counters counters})
(report stage counters))
(p/resolved {:action :run :throttled? true}))))]
{:beat! beats! :last last}))
beat (fn [stage counters & {:keys [force?]}]
(let [now (js/Date.now)
now? (or force?
(>= (- now @last-beat) report-throttle-ms))]
(if now?
(do (reset! last-beat now)
(reset! last {:stage stage :counters counters})
(report stage counters))
(p/resolved {:action :run :throttled? true}))))]
{:beat beat :last last}))
;; ---- THE WATCHDOG
(defn- with-watchdog!
(defn- with-watchdog
"The forced beats of one run: one every `watchdog-interval-ms`, and
they repeat the last report the run made, so a cancellation that
lands mid-render (no object landing, no unit of work ending) is seen
within that interval. `stop!` clears it once the run settles."
[beats! last]
within that interval. `stop` clears it once the run settles."
[beat last]
(let [timer (js/setInterval
#(beats! (:stage @last) (:counters @last) :force? true)
#(beat (:stage @last) (:counters @last) :force? true)
watchdog-interval-ms)]
(fn stop! [] (js/clearInterval timer))))
(fn stop [] (js/clearInterval timer))))
(defn- counter
"One counter of the vocabulary: `kind` is `objects` or `pages`."
@ -177,7 +177,7 @@
;; ---- THE CANCEL CHECK
(defn- check-cancelled!
(defn- check-cancelled
"The local arm of the cancel: the watchdog's terminate already died
the in-flight thread; the units of work that follow check the flag
and unwind without rendering anything else. The backend's row is
@ -190,7 +190,7 @@
;; ---- THE RUNNERS
(defn- check-beat!
(defn- check-beat
"A forced beat after a unit of work: a `skip` there is a cancelled
job, the same exception the legacy surfaces raised, so everything
below unwinds."
@ -201,34 +201,34 @@
:hint "export job was cancelled"))
answer)
(defn- run-single!
(defn- run-single
"One render, one object: the artifact IS the object, moved into the
resource path the multipart settle will name."
[beats! plan]
[beat plan]
(let [{:keys [job-id resource counter-kind]} plan
export (-> plan :prepared first)
object (atom nil)]
(job.utils/track! job-id (:path resource))
(p/let [beat-one (beats! :rendering (counter counter-kind 0 1) :force? true)
_ (check-beat! beat-one)
(job.utils/track job-id (:path resource))
(p/let [beat-one (beat :rendering (counter counter-kind 0 1) :force? true)
_ (check-beat beat-one)
_ (rd/render (assoc export
:job-id job-id
:skip-children (:skip-children plan))
(fn [obj]
(reset! object obj)
(job.utils/track! job-id (:path obj))))
_ (sh/move! (:path @object) (:path resource))
beat-end (beats! :packaging (counter counter-kind 1 1) :force? true)
_ (check-beat! beat-end)]
(job.utils/track job-id (:path obj))))
_ (sh/move (:path @object) (:path resource))
beat-end (beat :packaging (counter counter-kind 1 1) :force? true)
_ (check-beat beat-end)]
resource)))
(defn- run-multiple!
(defn- run-multiple
"The multi-object render: every prepared export renders with the same
on-object callback, appending each object to the zip as it lands, and
the progress counts what has landed so far. Any zipping error
surfaces after the renders, so the failures of the writer do not
compete with the ones of the render."
[beats! cancelled plan]
[beat cancelled plan]
(let [{:keys [job-id resource prepared total counter-kind]} plan
failure (volatile! nil)
rendered (volatile! 0)
@ -236,17 +236,17 @@
:on-error (fn [cause] (vreset! failure cause))
:on-progress (fn [_] nil))
append (fn [{:keys [filename path]}]
(check-cancelled! cancelled)
(job.utils/track! job-id path)
(check-cancelled cancelled)
(job.utils/track job-id path)
(vswap! rendered inc)
(beats! :rendering
(counter counter-kind @rendered total))
(beat :rendering
(counter counter-kind @rendered total))
(rsc/add-to-zip zip path
(str/replace filename
plan/sanitize-file-regex
"_")))]
(p/let [beat-one (beats! :rendering (counter counter-kind 0 total) :force? true)
_ (check-beat! beat-one)
(p/let [beat-one (beat :rendering (counter counter-kind 0 total) :force? true)
_ (check-beat beat-one)
_ (rd/with-scope prepared
(fn [scoped-render]
(p/all (map (fn [export]
@ -258,37 +258,37 @@
(p/rejected cause)
(rsc/close-zip zip))
_ (do error)
beat-end (beats! :packaging (counter counter-kind total total) :force? true)
_ (check-beat! beat-end)]
beat-end (beat :packaging (counter counter-kind total total) :force? true)
_ (check-beat beat-end)]
resource)))
(defn- join-pdf!
(defn- join-pdf
"The pages render one file per page; `pdfunite` stitches one pdf out
of them all, the way the legacy export did."
[job-id file-id paths]
(let [path (job.utils/track! job-id
(sh/tempfile :prefix (str/concat "penpot.pdfunite." file-id ".")
:suffix ".pdf"))]
(p/let [_ (sh/run-cmd! "pdfunite" (into [] (concat (vec paths) [path])))]
(let [path (job.utils/track job-id
(sh/tempfile :prefix (str/concat "penpot.pdfunite." file-id ".")
:suffix ".pdf"))]
(p/let [_ (sh/run-cmd "pdfunite" (into [] (concat (vec paths) [path])))]
path)))
(defn- run-frames!
(defn- run-frames
"The frames render: a file per page, joined into the pdf of the file
once every page has landed."
[beats! cancelled plan]
[beat cancelled plan]
(let [{:keys [job-id resource prepared total]} plan
file-id (-> prepared first :file-id)
paths (volatile! [])
rendered (volatile! 0)
on-object (fn [{:keys [path]}]
(check-cancelled! cancelled)
(job.utils/track! job-id path)
(check-cancelled cancelled)
(job.utils/track job-id path)
(vswap! paths conj path)
(vswap! rendered inc)
(beats! :rendering
(counter :pages @rendered total)))]
(p/let [beat-one (beats! :rendering (counter :pages 0 total) :force? true)
_ (check-beat! beat-one)
(beat :rendering
(counter :pages @rendered total)))]
(p/let [beat-one (beat :rendering (counter :pages 0 total) :force? true)
_ (check-beat beat-one)
_ (rd/with-scope prepared
(fn [scoped-render]
(p/all (map (fn [export]
@ -297,18 +297,18 @@
:is-wasm (:is-wasm plan))
on-object))
prepared))))
joined (join-pdf! job-id file-id @paths)
_ (sh/move! joined (:path resource))
beat-end (beats! :packaging (counter :pages total total) :force? true)
_ (check-beat! beat-end)]
joined (join-pdf job-id file-id @paths)
_ (sh/move joined (:path resource))
beat-end (beat :packaging (counter :pages total total) :force? true)
_ (check-beat beat-end)]
resource)))
(defn- run-prepared!
[beats! cancelled plan]
(defn- run-prepared
[beat cancelled plan]
(cond
(:single? plan) (run-single! beats! plan)
(:frames? plan) (run-frames! beats! cancelled plan)
:else (run-multiple! beats! cancelled plan)))
(:single? plan) (run-single beat plan)
(:frames? plan) (run-frames beat cancelled plan)
:else (run-multiple beat cancelled plan)))
;; ---- THE SETTLE
@ -329,21 +329,21 @@
[cause]
(= :job-cancelled (:code (ex-data cause))))
(defn- settle-failure!
(defn- settle-failure
"Settles the job as failed, after releasing the temp files the run
owns. The settle never rejects: if the failure cannot reach the
backend, the row keeps running until the lease GC turns it `aborted`,
which is the honest state for a worker that cannot talk."
[job-id session cause]
(p/do
(job.utils/release! job-id)
(job.utils/release job-id)
(->> (api/fail-job job-id (failure-report cause)
:session-id (some-> @session :session-id))
(p/merr (fn [settle-cause]
(l/warn :hint "unable to settle the failed job"
:job-id job-id :cause settle-cause))))))
(defn run-export!
(defn run-export
[{:keys [job-id]} params]
(let [session (atom nil)
cancelled (atom false)
@ -351,46 +351,46 @@
;; stopper travels in this atom: a run that ends badly stops
;; beating too, or its interval would knock on a dead job
;; forever, one HTTP call a second that only ever answers skip
stop-watchdog! (atom nil)
_ (jobs/register! job-id)
stop-cmd! (fn []
(reset! cancelled true)
;; the hard-cancel of the render the run holds: the
;; `renderer.wasm/with-scope` of the in-flight render
;; registered a terminate callback for this job
(jobs/mark-cancelled job-id))]
stop-watchdog (atom nil)
_ (jobs/register job-id)
stop-cmd (fn []
(reset! cancelled true)
;; the hard-cancel of the render the run holds: the
;; `renderer.wasm/with-scope` of the in-flight render
;; registered a terminate callback for this job
(jobs/mark-cancelled job-id))]
(p/catch
(p/let [beats (start-beats! job-id stop-cmd!)
beats! (:beat! beats)
_ (reset! stop-watchdog! (with-watchdog! beats! (:last beats)))
(p/let [beats (start-beats job-id stop-cmd)
beat (:beat beats)
_ (reset! stop-watchdog (with-watchdog beat (:last beats)))
;; the first breath right after the claim, before the
;; session roundtrip: the widget moves from queued to
;; exporting on it, and a cancel that landed meanwhile
;; raises here instead of after wasted work
_ (check-beat! (beats! :preparing {} :force? true))
_ (check-beat (beat :preparing {} :force? true))
session' (api/create-job-session job-id)
_ (reset! session session')
token (:session-token session')
_ (l/info :hint "render session minted"
:job-id (str job-id))
plan (make-plan job-id token params)
resource (run-prepared! beats! cancelled plan)
_ (@stop-watchdog!)
resource (run-prepared beat cancelled plan)
_ (@stop-watchdog)
artifact {:path (str (:path resource))
:filename (:filename resource)
:mtype (:mtype resource)}
_ (api/complete-job-with-artifact
{:job-id job-id :session-id (:session-id session')}
artifact)
_ (job.utils/release! job-id)
_ (job.utils/release job-id)
_ (l/info :hint "export job settled" :job-id (str job-id)
:outcome "completed")]
nil)
(fn [cause]
(when-let [stop @stop-watchdog!] (stop))
(when-let [stop @stop-watchdog] (stop))
(if (cancelled? cause)
(l/info :hint "export job cancelled" :job-id (str job-id))
(l/error :hint "export job failed" :job-id (str job-id) :cause cause))
(settle-failure! job-id session cause)))))
(settle-failure job-id session cause)))))

24
exporter/src/app/consumer/worker.cljs
View File

@ -40,7 +40,7 @@
[]
(ccfg/queue-key))
(defn- connect!
(defn- connect
"One Redis connection of one poller. ioredis reconnects on its own
strategy, so a fallen Redis comes back with this process doing
nothing but wait (and the failed pop comes right after)."
@ -49,7 +49,7 @@
;; ---- THE QUEUE
(defn read-payload!
(defn read-payload
"The JSON payload of the dispatcher: `job-id` and the `scheduled-at`
of the row when it was pushed. Anything else is a corrupt payload:
none, and the caller drops it."
@ -62,7 +62,7 @@
:payload (str payload) :cause cause)
nil)))
(defn process!
(defn process
"One payload of the queue: claim the job, and when the backend gives
it to this poller, run the export to its settle. `skip` means
something else won it (or it is gone): the payload is dropped, with
@ -74,30 +74,30 @@
:name (:name answer) :status (:status answer))
(p/do
(l/info :hint "running job" :job-id (str job-id) :name (:name answer))
(exports/run-export! {:job-id job-id} (:params answer))
(exports/run-export {:job-id job-id} (:params answer))
(l/info :hint "job settled" :job-id (str job-id))))))
;; ---- THE POLLER
(defn poll-once!
(defn poll-once
"One turn: pop the queue, claim what came, and wait for the settle.
An empty pop and a dropped payload both resolve; a claimed job is
awaited the whole run."
[conn key on-payload]
(p/let [answer (.blpop ^js conn key poll-timeout-s)
payload (second answer)
claim (when (some? payload) (read-payload! payload))
claim (when (some? payload) (read-payload payload))
settled (when (some? claim) (on-payload claim))]
settled))
(defn- poll-loop!
(defn- poll-loop
"The wait of one poller, turn after turn, for the life of the
process. A failed turn (Redis down, a bug) is logged, never allowed
to end the loop; a delay keeps the retry from spinning while the
connection rebuilds."
[conn key on-payload]
(p/loop []
(->> (poll-once! conn key on-payload)
(->> (poll-once conn key on-payload)
(p/merr (fn [cause]
(l/error :hint "poller turn failed" :key key :cause cause)
(p/delay reconnect-delay-ms)))
@ -113,7 +113,7 @@
;; ---- THE START
(defn start!
(defn start
"Launches `K` pollers, one connection each. The worker cleans the
temp files a previous process left behind at the same moment: a
crashed worker owns nothing of its crash."
@ -127,12 +127,12 @@
(l/info :hint "worker started" :pollers k :queue key
:redis-host (redis-host) :backend (str (cf/get-internal-uri)))
(doseq [i (range k)]
(let [conn (connect!)]
(let [conn (connect)]
(swap! pollers assoc i conn)
(l/info :hint "poller started" :id i :key key)
(poll-loop! conn key process!)))))
(poll-loop conn key process)))))
(defn stop!
(defn stop
"Ends the pollers, closing their connections. The job that got orphan
in a settle goes one row further to the next poller; no state hides
in this process."

4
exporter/src/app/core.cljs
View File

@ -42,7 +42,7 @@
(bwr/init)
(job.utils/init)
(wasm.pool/init)
(worker/start!)))))
(worker/start)))))
(def main start)
@ -79,7 +79,7 @@
;; the pollers own their connections and may sit in a blocking
;; pop for the whole poll timeout; draining the pools first lets
;; the exports in flight unwind against their own resources
(shutdown-step "consumer-worker" worker/stop!)
(shutdown-step "consumer-worker" worker/stop)
(done)))))
(.on proc/default "uncaughtException"

8
exporter/src/app/jobs.cljs
View File

@ -64,13 +64,13 @@
(swap! registry update (str job-id)
(fn [rt] (some-> rt (update :cancel-fns (fnil conj []) f)))))
(defn release!
(defn release
"Drops the local runtime entry once the job settled. The row stays in
the backend until it is read once more or expires."
[job-id]
(swap! registry dissoc (str job-id)))
(defn register!
(defn register
"The runtime record of a job this process runs. The local cancel arm
reads it (`mark-cancelled`), so the in-flight render of a claimed job
is terminable without the jobs substrate: the row is the backend's
@ -80,7 +80,7 @@
{:job {:id job-id :state "running" :total total}
:cancelled? false}))
(defn- check-cancel-callback!
(defn- check-cancel-callback
[job-id f]
(try
(f)
@ -110,5 +110,5 @@
(when-let [signal (:cancel-signal (get @registry k))]
(js/Atomics.store signal 0 1))
(doseq [f callbacks]
(check-cancel-callback! job-id f)))
(check-cancel-callback job-id f)))
true))))

14
exporter/src/app/jobs/utils.cljs
View File

@ -24,21 +24,21 @@
(defonce ^:private tracked (atom {}))
(defn track!
(defn track
"Registers `path` as owned by `job-id`, so it is removed when the job settles."
[job-id path]
(when (and job-id path)
(swap! tracked update (str job-id) (fnil conj #{}) path))
path)
(defn- remove-path!
(defn- remove-path
[path]
(->> (p/do (fsp/rm path #js {:recursive true :force true}))
(p/merr (fn [cause]
(l/warn :hint "unable to remove job temp file" :path path :cause cause)
(p/resolved nil)))))
(defn release!
(defn release
"Removes every file the job owns. Called once the job reached a terminal
state and its result has already been uploaded, so nothing else reads them."
[job-id]
@ -46,14 +46,14 @@
paths (get @tracked k)]
(swap! tracked dissoc k)
(if (seq paths)
(->> (map remove-path! paths)
(->> (map remove-path paths)
(p/all)
(p/fmap (fn [_]
(l/dbg :hint "released job temp files" :job-id k :count (count paths))
nil)))
(p/resolved nil))))
(defn- clean!
(defn- clean
"Removes managed temp files older than the job TTL. They can only be leftovers
of a previous process: every live one belongs to a job of this process."
[]
@ -67,7 +67,7 @@
(->> (p/do (fsp/stat fpath))
(p/mcat (fn [^js stat]
(if (> (- now (inst-ms (.-mtime stat))) max-age)
(->> (remove-path! fpath)
(->> (remove-path fpath)
(p/fmap (constantly 1)))
(p/resolved 0))))
(p/merr (fn [_] (p/resolved 0)))))))
@ -83,4 +83,4 @@
(defn init
[]
(clean!))
(clean))

8
exporter/src/app/renderer/bitmap.cljs
View File

@ -38,17 +38,17 @@
:webp (p/let [png-path (sh/tempfile :prefix "penpot.tmp.bitmap." :suffix ".png")]
;; playwright only supports jpg and png, we need to convert it afterwards
(bw/screenshot node {:omit-background? true :type :png :path png-path})
(sh/run-cmd! "convert" png-path "-quality" "100" (str "WEBP:" path))))
(sh/run-cmd "convert" png-path "-quality" "100" (str "WEBP:" path))))
(on-object (assoc object :path path))))
(render [uri page]
(l/info :uri uri)
(p/do
;; navigate to the page and perform basic setup
(bw/nav! page (str uri))
(bw/nav page (str uri))
(bw/sleep page 1000) ; the good old fix with sleep
(bw/wait-for-fonts page)
(bw/eval! page (js* "() => document.body.style.background = 'transparent'"))
(bw/eval page (js* "() => document.body.style.background = 'transparent'"))
;; take the screnshot of requested objects, one by one
(p/run (partial render-object page) objects)
@ -64,4 +64,4 @@
(u/ensure-path-slash)
(u/join "render.html")
(assoc :query (u/map->query-string params)))]
(bw/exec! (prepare-options uri) (partial render uri)))))
(bw/exec (prepare-options uri) (partial render uri)))))

40
exporter/src/app/renderer/pdf.cljs
View File

@ -38,32 +38,32 @@
(u/join "render.html")
(assoc :query (u/map->query-string params)))))
(sync-page-size! [dom]
(bw/eval! dom
(fn [elem]
;; IMPORTANT: No CLJS runtime allowed. Use only JS
;; primitives. This runs in a context without access to
;; cljs.core. Avoid any functions that transpile to
;; cljs.core/* calls, as they will break in the browser
;; runtime.
(sync-page-size [dom]
(bw/eval dom
(fn [elem]
;; IMPORTANT: No CLJS runtime allowed. Use only JS
;; primitives. This runs in a context without access to
;; cljs.core. Avoid any functions that transpile to
;; cljs.core/* calls, as they will break in the browser
;; runtime.
(let [width (.getAttribute ^js elem "width")
height (.getAttribute ^js elem "height")
style-node (let [node (.createElement js/document "style")]
(.appendChild (.-head js/document) node)
node)]
(set! (.-textContent style-node)
(dm/str "@page { size: " width "px " height "px; margin: 0; }\n"
"html, body, #app { margin: 0; padding: 0; width: " width "px; height: " height "px; overflow: visible; }"))))))
(let [width (.getAttribute ^js elem "width")
height (.getAttribute ^js elem "height")
style-node (let [node (.createElement js/document "style")]
(.appendChild (.-head js/document) node)
node)]
(set! (.-textContent style-node)
(dm/str "@page { size: " width "px " height "px; margin: 0; }\n"
"html, body, #app { margin: 0; padding: 0; width: " width "px; height: " height "px; overflow: visible; }"))))))
(render-object [page base-uri {:keys [id] :as object}]
(p/let [uri (prepare-uri base-uri id)
path (sh/tempfile :prefix "penpot.tmp.pdf." :suffix (mime/get-extension type))]
(l/info :uri uri)
(bw/nav! page uri)
(bw/nav page uri)
(p/let [dom (bw/select page (dm/str "#screenshot-" id))]
(bw/wait-for dom)
(sync-page-size! dom)
(sync-page-size dom)
(bw/screenshot dom {:full-page? true})
(bw/sleep page 2000) ; the good old fix with sleep
(bw/wait-for-fonts page)
@ -79,5 +79,5 @@
(let [base-uri (-> (cf/get-internal-uri)
(u/ensure-path-slash))]
(bw/exec! (prepare-options base-uri)
(partial render base-uri)))))
(bw/exec (prepare-options base-uri)
(partial render base-uri)))))

24
exporter/src/app/renderer/svg.cljs
View File

@ -128,13 +128,13 @@
(letfn [(convert-to-ppm [pngpath]
(let [ppmpath (str/concat pngpath "origin.ppm")]
(l/trace :fn :convert-to-ppm :path ppmpath)
(-> (sh/run-cmd! "convert" pngpath ppmpath)
(-> (sh/run-cmd "convert" pngpath ppmpath)
(p/then (constantly ppmpath)))))
(trace-color-mask [pbmpath]
(l/trace :fn :trace-color-mask :pbmpath pbmpath)
(let [svgpath (str/concat pbmpath ".svg")]
(-> (sh/run-cmd! "potrace" "--flat" "-b" "svg" pbmpath "-o" svgpath)
(-> (sh/run-cmd "potrace" "--flat" "-b" "svg" pbmpath "-o" svgpath)
(p/then (constantly svgpath)))))
(generate-color-layer [ppmpath color]
@ -144,9 +144,9 @@
:hint (str "invalid hex color: " color)))
(l/trace :fn :generate-color-layer :ppmpath ppmpath :color color)
(let [pbmpath (str/concat ppmpath ".mask-" (subs color 1) ".pbm")]
(-> (sh/run-cmd! "ppmcolormask" color ppmpath)
(-> (sh/run-cmd "ppmcolormask" color ppmpath)
(p/then (fn [stdout]
(-> (sh/write-file! pbmpath stdout)
(-> (sh/write-file pbmpath stdout)
(p/then (constantly pbmpath)))))
(p/then trace-color-mask)
(p/then sh/read-file)
@ -236,7 +236,7 @@
(l/trace :fn :trace-node)
(p/let [pngpath (sh/tempfile :prefix "penpot.tmp.render.svg.parse."
:suffix ".origin.png")
_ (sh/write-file! pngpath data)
_ (sh/write-file pngpath data)
ppmpath (convert-to-ppm pngpath)
svgdata (convert-to-svg ppmpath node)]
(-> node
@ -258,7 +258,7 @@
(extract-single-node [[shot node]]
(l/trace :fn :extract-single-node)
(p/let [attrs (bw/eval! node extract-element-attrs)]
(p/let [attrs (bw/eval node extract-element-attrs)]
{:id (unchecked-get attrs "id")
:x (unchecked-get attrs "x")
:y (unchecked-get attrs "y")
@ -269,7 +269,7 @@
:data shot}))
(resolve-text-node [page node]
(p/let [attrs (bw/eval! node extract-element-attrs)
(p/let [attrs (bw/eval node extract-element-attrs)
id (unchecked-get attrs "id")
text-node (bw/select page (str "#screenshot-text-" id " foreignObject"))
shot (bw/screenshot text-node {:omit-background? true :type "png"})]
@ -290,7 +290,7 @@
(extract-svg [page {:keys [id] :as object}]
(let [node (bw/select page (str/concat "#screenshot-" id))]
(bw/wait-for node)
(bw/eval! node (fn [elem] (.-outerHTML ^js elem)))))
(bw/eval node (fn [elem] (.-outerHTML ^js elem)))))
(prepare-options [uri]
#js {:screen #js {:width bw/default-viewport-width
@ -327,7 +327,7 @@
;; (cljs.pprint/pprint (xml->clj result))
;; (println "-------")
(sh/write-file! path result)
(sh/write-file path result)
(on-object (assoc object :path path))
path)))
@ -335,7 +335,7 @@
(l/info :uri uri)
(p/do
;; navigate to the page and perform basic setup
(bw/nav! page (str uri))
(bw/nav page (str uri))
(bw/sleep page 1000) ; the good old fix with sleep
(bw/wait-for-fonts page)
@ -352,5 +352,5 @@
(u/ensure-path-slash)
(u/join "render.html")
(assoc :query (u/map->query-string params)))]
(bw/exec! (prepare-options uri)
(partial render uri)))))
(bw/exec (prepare-options uri)
(partial render uri)))))

2
exporter/src/app/renderer/wasm.cljs
View File

@ -40,7 +40,7 @@
;; Between objects the worker sees the flag; inside a render only
;; terminating the thread stops it. Cleared on the way out so a later
;; cancel cannot terminate a worker that is by then somebody else's.
(jobs/on-cancel job-id (fn [] (pool/terminate! @live))))
(jobs/on-cancel job-id (fn [] (pool/terminate @live))))
(->> (p/do (f (fn [params on-object]
(chain #(pool/render-on worker params on-object opts)))))
(p/fnly (fn [_ _] (vreset! live nil))))))))

10
exporter/src/app/util/object.cljs
View File

@ -6,7 +6,7 @@
(ns app.util.object
"A collection of helpers for work with javascript objects."
(:refer-clojure :exclude [set! get get-in merge clone contains?])
(:refer-clojure :exclude [set get get-in merge update clone contains?])
(:require
[cuerdas.core :as str]))
@ -46,24 +46,24 @@
[a]
(js/Object.assign #js {} a))
(defn merge!
(defn merge-into
([a b]
(js/Object.assign a b))
([a b & more]
(reduce merge! (merge! a b) more)))
(reduce merge-into (merge-into a b) more)))
(defn merge
([a b]
(js/Object.assign #js {} a b))
([a b & more]
(reduce merge! (merge a b) more)))
(reduce merge-into (merge a b) more)))
(defn set!
[obj key value]
(unchecked-set obj key value)
obj)
(defn update!
(defn update
[obj key f & args]
(let [found (get obj key ::not-found)]
(if-not (identical? ::not-found found)

10
exporter/src/app/util/shell.cljs
View File

@ -67,7 +67,7 @@
:code :unable-to-locate-temporal-file
:hint "unable to find a tempfile candidate"))))
(defn move!
(defn move
[origin-path dest-path]
(.rename fs/promises origin-path dest-path))
@ -81,11 +81,7 @@
(p/merr (fn [_cause]
(p/resolved nil)))))
(defn rmdir!
[path]
(.rm fs/promises path #js {:recursive true}))
(defn write-file!
(defn write-file
[fpath content]
(.writeFile fs/promises fpath content))
@ -93,7 +89,7 @@
[fpath]
(.readFile fs/promises fpath))
(defn run-cmd!
(defn run-cmd
[cmd & args]
(p/create
(fn [resolve reject]

32
exporter/src/app/wasm.cljs
View File

@ -56,11 +56,11 @@
;; --- MODULE LIFECYCLE
(defn init!
(defn init
"Loads the render-wasm artifact under Node and boots it headless. Sets the
shared `wasm/internal-module` so the portable serialization leaves work.
Idempotent-ish: callers should hold the returned module."
([] (init! default-viewport-width default-viewport-height))
([] (init default-viewport-width default-viewport-height))
([width height]
(let [dir artifact-dir
js-path (path/resolve dir "render-wasm.js")
@ -130,7 +130,7 @@
(d/distinct-xf font-key))
shape-ids))
(defn store-font!
(defn store-font
"Uploads one font's TTF bytes into the WASM font store, keyed by the family
(uuid quartet + weight + style). `font-bytes` is a Uint8Array/Buffer.
@ -147,12 +147,12 @@
(aget id 0) (aget id 1) (aget id 2) (aget id 3)
weight style (boolean emoji?) (boolean fallback?))))
(defn store-font-url!
(defn store-font-url
"Registers the public URL a font family was loaded from. The SVG export emits
one `@font-face` per family from these, and skips families without one, so
this must run for every family `store-font!` uploads.
this must run for every family `store-font` uploads.
Does NOT call `mem/free`, for the same reason as `store-font!`."
Does NOT call `mem/free`, for the same reason as `store-font`."
[{:keys [id weight style]} url]
(let [bytes (js/Buffer.from url "utf-8")
ptr (mem/alloc (.-byteLength bytes))]
@ -161,16 +161,16 @@
(aget id 0) (aget id 1) (aget id 2) (aget id 3)
weight style)))
(defn clear-fonts!
(defn clear-fonts
"Resets the WASM font store. Must be called once per render request because
the shared module would otherwise accumulate fonts across requests."
[]
(h/call wasm/internal-module "_clear_fonts"))
(defn update-text-layout!
(defn update-text-layout
"Recomputes a text shape's layout with the currently provisioned fonts. Text is
laid out at serialize time using the fallback font (real fonts aren't uploaded
yet), so this must run again after `provision-fonts!` or glyph metrics/line
yet), so this must run again after `provision-fonts` or glyph metrics/line
breaks are wrong.
Forced, because provisioning a font changes nothing `update_layout` keys on:
@ -191,13 +191,13 @@
(aget buf 0) (aget buf 1) (aget buf 2) (aget buf 3)
false)))))
(defn store-image-url!
(defn store-image-url
"Registers the public URL an image was loaded from. The SVG export emits
linked `<image href>` from these, and falls back to Skia base64 when missing,
so this should run for every media id the scene references (including
already-cached images).
Does NOT call `mem/free`, for the same reason as `store-font-url!`."
Does NOT call `mem/free`, for the same reason as `store-font-url`."
[image-id url]
(when (and (some? url) (not (str/blank? url)))
(let [bytes (js/Buffer.from url "utf-8")
@ -207,7 +207,7 @@
(h/call wasm/internal-module "_store_image_url"
(aget quart 0) (aget quart 1) (aget quart 2) (aget quart 3)))))
(defn store-image!
(defn store-image
"Uploads one image's *encoded* bytes (PNG/JPEG — Skia decodes, no WebGL) into
the WASM image store via `_store_image`. Buffer layout matches the Rust reader:
[shape uuid 16][image uuid 16][is_thumbnail u32][encoded bytes]. Images are
@ -239,13 +239,13 @@
(.set heap img-u8 (+ ptr 36))
(h/call module "_store_image")))
(defn evict-images!
(defn evict-images
"Evicts least-recently-used images until the store retains at most `max-bytes`
bytes. Returns the number evicted."
[max-bytes]
(h/call wasm/internal-module "_evict_images_to_budget" max-bytes))
(defn provision-fonts!
(defn provision-fonts
"Resolves and uploads every font needed by `shape-ids`, each family fetched
once. `resolve-font` is an injected fn of the family map -> promise of TTF
bytes (or nil to skip); optional `font-url` is a fn of the family map -> the
@ -257,9 +257,9 @@
(->> (resolve-font family)
(p/fmap (fn [bytes]
(when bytes
(store-font! family bytes)
(store-font family bytes)
(when-let [url (when font-url (font-url family))]
(store-font-url! family url))))))))
(store-font-url family url))))))))
(p/all)))
;; --- RENDER

2
exporter/src/app/wasm/pool.cljs
View File

@ -231,7 +231,7 @@
:hint "export job was cancelled"))
(run-on-worker worker params cancel-buffer on-object)))
(defn terminate!
(defn terminate
[^js worker]
(when worker
(unchecked-set worker "__alive" false)

64
exporter/src/app/wasm/render.cljs
View File

@ -52,10 +52,10 @@
(defonce ^:private module* (atom nil))
(defn- ensure-module!
(defn- ensure-module
[]
(or @module*
(reset! module* (wasm/init!))))
(reset! module* (wasm/init))))
;; --- backend endpoints
;;
@ -94,7 +94,7 @@
(if code (str code ": " msg) msg))))
(str/join " <- ")))
(defn- fetch!
(defn- fetch
"`undici/fetch` that fails with an ex-info carrying the target uri and the
unwrapped cause chain, so a failed request says what actually went wrong and
against which endpoint."
@ -106,7 +106,7 @@
cause))))))
(defn- explain
"Log-friendly reason for `cause`: the detail `fetch!` already attached, or a
"Log-friendly reason for `cause`: the detail `fetch` already attached, or a
freshly unwrapped chain for anything else (WASM aborts, decode errors)."
[cause]
(or (:detail (ex-data cause))
@ -146,7 +146,7 @@
:file-id (str file-id)
:page-id (str page-id)
:roots (count root-ids))
(->> (fetch! uri #js {:method "POST" :headers headers :body body})
(->> (fetch uri #js {:method "POST" :headers headers :body body})
(p/mcat (fn [^js resp]
(if (= 200 (.-status resp))
(.text resp)
@ -177,7 +177,7 @@
body (t/encode-str (cond-> {:file-id file-id}
share-id (assoc :share-id share-id)))
uri (internal-uri "api/rpc/command/get-font-variants")]
(->> (fetch! uri #js {:method "POST" :headers headers :body body})
(->> (fetch uri #js {:method "POST" :headers headers :body body})
(p/mcat (fn [^js resp]
(if (= 200 (.-status resp))
(.text resp)
@ -193,7 +193,7 @@
here degrades to fallback fonts, it does not fail the export."
([uri] (fetch-ttf-bytes uri #js {:method "GET"}))
([uri opts]
(->> (fetch! uri opts)
(->> (fetch uri opts)
(p/mcat (fn [^js resp]
(if (= 200 (.-status resp))
(.arrayBuffer resp)
@ -291,7 +291,7 @@
;; Emoji and non-latin scripts render through fallback families, not through
;; any span's font family, so `wasm/fonts-for-shape` never reports them and the
;; provisioning above never uploads them. Must run per request, since
;; `clear-fonts!` empties the store; the TTF bytes stay cached per process.
;; `clear-fonts` empties the store; the TTF bytes stay cached per process.
(defn- scene-fallback-fonts
"Fallback font descriptors needed by the scene's text. Deduped because
@ -319,7 +319,7 @@
(cached-ttf-bytes [font-id weight style] #(fetch-gfont-bytes ttf-url))
(p/resolved nil)))
(defn- provision-fallback-fonts!
(defn- provision-fallback-fonts
[scene]
(->> (scene-fallback-fonts scene)
(map (fn [{:keys [font-id weight style is-emoji is-fallback] :as font}]
@ -327,12 +327,12 @@
(->> (fetch-fallback-font-bytes font)
(p/fmap (fn [buf]
(if buf
(wasm/store-font! {:id (uuid/get-u32 font-uuid)
:weight weight
:style style
:emoji? (boolean is-emoji)
:fallback? (boolean is-fallback)}
buf)
(wasm/store-font {:id (uuid/get-u32 font-uuid)
:weight weight
:style style
:emoji? (boolean is-emoji)
:fallback? (boolean is-fallback)}
buf)
(l/warn :hint "wasm render: fallback font unavailable"
:font-id font-id)))))
(p/resolved nil))))
@ -349,7 +349,7 @@
[media-id {:keys [token]}]
(let [headers (asset-headers token)
uri (internal-uri (str "assets/by-file-media-id/" media-id))]
(->> (fetch! uri #js {:method "GET" :headers headers})
(->> (fetch uri #js {:method "GET" :headers headers})
(p/mcat (fn [^js resp]
(if (= 200 (.-status resp))
(.arrayBuffer resp)
@ -365,7 +365,7 @@
:detail (explain cause) :cause cause)
(p/resolved nil))))))
(defn- provision-images!
(defn- provision-images
"Fetches and stores every image the scene references (shape, stroke and
text-span fills, enumerated by `app.common.types.shape.images`). Unlike fonts,
the image store is not reset per request, so already-held images are skipped
@ -380,7 +380,7 @@
:total (count all-ids)
:cached (- (count all-ids) (count new-ids)))
(doseq [image-id all-ids]
(wasm/store-image-url! image-id (public-uri (str "assets/by-file-media-id/" image-id))))
(wasm/store-image-url image-id (public-uri (str "assets/by-file-media-id/" image-id))))
(->> new-ids
(map (fn [image-id]
(->> (fetch-file-media-bytes image-id params)
@ -390,22 +390,22 @@
(l/dbg :hint "wasm render: image stored"
:media-id (str image-id)
:bytes (.-byteLength ^js buf))
(wasm/store-image! image-id buf))
(wasm/store-image image-id buf))
(l/warn :hint "wasm render: image unavailable"
:media-id (str image-id))))))))
(p/all))))
(defn- relayout-text!
(defn- relayout-text
"Recomputes layout for every text shape, once the real fonts are provisioned
(serialize-time layout used the fallback)."
[scene]
(doseq [shape (vals scene)
:when (= :text (:type shape))]
(wasm/update-text-layout! (:id shape))))
(wasm/update-text-layout (:id shape))))
;; --- render
(defn- check-cancelled!
(defn- check-cancelled
"Cancellation is cooperative: a render already inside Skia cannot be
interrupted, so the flag is only observed between objects. Killing a job
mid-object is the caller's job (terminating the worker)."
@ -440,17 +440,17 @@
:objects (count objects)
:file-id (str (:file-id params))
:page-id (str (:page-id params)))
(->> (ensure-module!)
(->> (ensure-module)
(p/mcat (fn [_] (fetch-objects params)))
(p/mcat (fn [scene]
(l/dbg :hint "wasm render: scene fetched" :shapes (count scene))
(serialize/serialize-scene! scene)
(serialize/serialize-scene scene)
(l/dbg :hint "wasm render: scene serialized")
;; So fonts from a previous request don't leak into this one.
(wasm/clear-fonts!)
(wasm/clear-fonts)
(->> (p/all [(fetch-font-variants params)
(provision-images! scene params)
(provision-fallback-fonts! scene)])
(provision-images scene params)
(provision-fallback-fonts scene)])
(p/mcat
(fn [[variants _]]
(let [variants (or variants [])
@ -459,14 +459,14 @@
;; Before rendering, so the relayout below sees real
;; font metrics. Deduped across objects: shapes
;; sharing one family download its TTF once.
(wasm/provision-fonts! (map :id objects) resolve-font
:font-url font-url))))
(wasm/provision-fonts (map :id objects) resolve-font
:font-url font-url))))
(p/mcat
(fn [_]
(relayout-text! scene)
(relayout-text scene)
(p/run
(fn [{:keys [id] :as object}]
(check-cancelled! params)
(check-cancelled params)
(let [bytes (render-object-bytes type id scale)
path (sh/tempfile :prefix "penpot.tmp.wasm."
:suffix (mime/get-extension type))]
@ -481,7 +481,7 @@
(p/fmap (fn [result]
;; After the request, never mid-render, so an image can't
;; disappear under a running export.
(let [evicted (wasm/evict-images! (cf/get :wasm-worker-image-cache-size wasm/image-cache-size))]
(let [evicted (wasm/evict-images (cf/get :wasm-worker-image-cache-size wasm/image-cache-size))]
(when (pos? evicted)
(l/info :hint "wasm render: evicted cached images" :count evicted)))
result))

8
exporter/src/app/wasm/serialize.cljs
View File

@ -20,7 +20,7 @@
[app.common.render-wasm.wasm :as wasm]
[app.wasm.text :as text]))
(defn set-shape!
(defn set-shape
"Serializes a single shape into the WASM design state. The host-independent
properties (base props, children, blur, shadows, svg-attrs, mask, bool-type,
path geometry, grow-type) go through the shared `serialize-shape!` — the same
@ -34,13 +34,13 @@
(when-not (= type :group)
(props/write-shape-strokes! (:strokes prepared)))
(when (= type :text)
(text/set-shape-text! (:content prepared)))))
(text/set-shape-text (:content prepared)))))
(defn serialize-scene!
(defn serialize-scene
"Loads every shape of an `objects` map into the WASM design state. Resets the
shapes pool first so repeated exports don't accumulate into the shared
state. Order is irrelevant: shapes reference each other by id and the tree
is resolved at render time."
[objects]
(h/call wasm/internal-module "_init_shapes_pool" (count objects))
(run! set-shape! (vals objects)))
(run! set-shape (vals objects)))

2
exporter/src/app/wasm/text.cljs
View File

@ -14,7 +14,7 @@
[app.common.render-wasm.text-content :as tc]
[app.common.render-wasm.wasm :as wasm]))
(defn set-shape-text!
(defn set-shape-text
"Serializes a text shape's content into the current WASM shape. Mirrors the
editor's sequence: clear -> vertical-align -> append each paragraph -> layout.
Byte writing and font resolution are the shared

14
exporter/src/app/wasm/worker.cljs
View File

@ -23,7 +23,7 @@
[app.wasm.render :as render]
[promesa.core :as p]))
(defn- post!
(defn- post
[message]
(.postMessage ^js wt/parentPort message))
@ -41,13 +41,13 @@
(assoc :cancelled? (cancelled-fn (unchecked-get data "cancel"))))]
(->> (render/render params
(fn [object]
(post! #js {:type "object" :payload (t/encode-str object)})))
(p/fmap (fn [_] (post! #js {:type "done"})))
(post #js {:type "object" :payload (t/encode-str object)})))
(p/fmap (fn [_] (post #js {:type "done"})))
(p/merr (fn [cause]
(l/warn :hint "render worker: request failed" :cause cause)
(post! #js {:type "error"
:message (or (ex-message cause) (str cause))
:code (some-> cause ex-data :code name)})
(post #js {:type "error"
:message (or (ex-message cause) (str cause))
:code (some-> cause ex-data :code name)})
(p/resolved nil))))))
(defn- on-message
@ -67,5 +67,5 @@
(defn main
[& _]
@listening
(post! #js {:type "ready"})
(post #js {:type "ready"})
(l/info :hint "render worker ready"))

36
exporter/test/exporter_tests/api_test.cljs
View File

@ -41,11 +41,11 @@
(p/resolved #js {:status 403
:text (constantly (p/resolved "{}"))}))
(defn- install-fetch!
(defn- install-fetch
"Put a fake in place and return the thunk that puts the original
back. The thunk belongs at the end of the promise chain's `p/do`, so
the fake covers the whole async run."
([] (install-fetch! fake-fetch))
([] (install-fetch fake-fetch))
([the-fake]
(set! api/fetch the-fake)
(reset! calls [])
@ -78,13 +78,13 @@
"Run `thunk`, then put the original fetch back, then say the test is
finished: the rest never waits on the assertions, so a broken chain
reports a failure, never a hang."
[thunk restore! done]
(p/do thunk (restore!) (done)))
[thunk restore-fetch done]
(p/do thunk (restore-fetch) (done)))
(t/deftest claim-job-posts-the-claim-of-one-poller
(t/async done
(let [job-id (uuid/next)
restore! (install-fetch!)]
restore-fetch (install-fetch)]
(with-restore-and-done
(p/fmap (fn [_]
(t/is (str/ends-with? (last-uri) "/api/management/methods/claim-job"))
@ -92,20 +92,20 @@
(t/is (= {:job-id job-id :scheduled-at "2026-10-07T00:00:00Z"}
(decode-body))))
(api/claim-job job-id "2026-10-07T00:00:00Z"))
restore!
restore-fetch
done))))
(t/deftest json-calls-declare-the-transit-content-type
;; without it the backend never parses the body as transit and
;; validates an empty map (every key a `missing-key`)
(t/async done
(let [restore! (install-fetch!)]
(let [restore-fetch (install-fetch)]
(with-restore-and-done
(p/fmap (fn [_]
(t/is (= "application/transit+json"
(fetch-header "Content-Type"))))
(api/claim-job (uuid/next) "2026-10-07T00:00:00Z"))
restore!
restore-fetch
done))))
(t/deftest report-job-progress-posts-the-beat
@ -113,13 +113,13 @@
(let [job-id (uuid/next)
progress {:stage :rendering
:counters {:objects {:current 1 :total 2}}}
restore! (install-fetch!)]
restore-fetch (install-fetch)]
(with-restore-and-done
(p/fmap (fn [_]
(t/is (str/ends-with? (last-uri) "/api/management/methods/report-job-progress"))
(t/is (= {:job-id job-id :progress progress} (decode-body))))
(api/report-job-progress job-id progress))
restore!
restore-fetch
done))))
(t/deftest fail-job-carries-the-error-and-the-session
@ -127,7 +127,7 @@
(let [job-id (uuid/next)
sid (uuid/next)
error {:type :internal :code :processing-error :hint "boom"}
restore! (install-fetch!)]
restore-fetch (install-fetch)]
(with-restore-and-done
(p/mcat (fn [_]
(p/fmap (fn [_]
@ -135,14 +135,14 @@
(decode-body))))
(api/fail-job job-id error :session-id sid)))
(api/fail-job job-id error))
restore!
restore-fetch
done))))
(t/deftest complete-job-posts-the-plain-result
(t/async done
(let [job-id (uuid/next)
sid (uuid/next)
restore! (install-fetch!)]
restore-fetch (install-fetch)]
(with-restore-and-done
(p/mcat (fn [_]
(p/fmap (fn [_]
@ -150,7 +150,7 @@
(decode-body))))
(api/complete-job job-id {:total 1} {:session-id sid})))
(api/complete-job job-id {:total 1}))
restore!
restore-fetch
done))))
(t/deftest complete-job-with-artifact-rides-multipart
@ -158,7 +158,7 @@
(let [job-id (uuid/next)
sid (uuid/next)
tmpfile (path/join sh/tmpdir (str "test-artifact." (uuid/next)))
restore! (install-fetch!)]
restore-fetch (install-fetch)]
(with-restore-and-done
(p/mcat (fn [_]
(p/fmap (fn [_]
@ -176,12 +176,12 @@
:mtype "application/zip"})))
(->> (fsp/writeFile tmpfile "the export bytes")
(p/fmap (fn [_] nil))))
restore!
restore-fetch
done))))
(t/deftest a-failed-management-answer-is-the-failure-of-the-call
(t/async done
(let [restore! (install-fetch! failure-fetch)]
(let [restore-fetch (install-fetch failure-fetch)]
(with-restore-and-done
(p/catch (fn [error]
(let [data (ex-data error)]
@ -189,5 +189,5 @@
(t/is (= :failed-management-request (:code data)))
(t/is (= 403 (:status data)))))
(api/claim-job (uuid/next) "2026-10-07T00:00:00Z"))
restore!
restore-fetch
done))))

14
exporter/test/exporter_tests/jobs_test.cljs
View File

@ -13,16 +13,16 @@
[app.jobs :as jobs]
[cljs.test :as t :include-macros true]))
(defn- register!
(defn- register
[]
(let [job-id (uuid/next)]
(jobs/register! job-id)
(jobs/register job-id)
job-id))
(t/deftest mark-cancelled-runs-the-cancel-pieces-once
(t/testing "the signal arms, the callbacks run, and a second mark is a no-op"
(t/async done
(let [job-id (register!)
(let [job-id (register)
seen (atom [])]
(jobs/on-cancel job-id (fn [] (swap! seen conj :first)))
(jobs/on-cancel job-id (fn [] (swap! seen conj :second)))
@ -46,7 +46,7 @@
;; terminate of the worker is what a hard-cancel is for, and the pieces
;; below it must not race the writer
(t/async done
(let [job-id (register!)
(let [job-id (register)
seen (atom ::not-called)]
(jobs/on-cancel job-id (fn [] (reset! seen (jobs/cancelled? job-id))))
(jobs/mark-cancelled job-id)
@ -57,7 +57,7 @@
(t/testing "a job cancelled before its render leased a worker is
already stoppable for the render that comes next"
(t/async done
(let [job-id (register!)]
(let [job-id (register)]
(jobs/mark-cancelled job-id)
(let [^js signal (jobs/cancel-signal job-id)]
(t/is (some? signal))
@ -68,10 +68,10 @@
(t/testing "a late cancel for a settled job changes nothing, and
release drops every piece"
(t/async done
(let [job-id (register!)
(let [job-id (register)
seen (atom ::not-called)]
(jobs/on-cancel job-id (fn [] (reset! seen :callback-ran)))
(jobs/release! job-id)
(jobs/release job-id)
(t/is (nil? (jobs/mark-cancelled job-id)))
(t/is (= ::not-called @seen))

4
exporter/test/exporter_tests/renderer_svg_test.cljs
View File

@ -58,10 +58,10 @@
(deftest exporter-honours-svg-attr-fills
(async done
(->> (wasm-io/init!)
(->> (wasm-io/init)
(p/mcat
(fn [_]
(serialize/serialize-scene! (scene))
(serialize/serialize-scene (scene))
(let [red (render-svg-string svg-red-id)
blue (render-svg-string blue-id)]
(is (str/includes? blue "blue")

22
exporter/test/exporter_tests/runner.cljs
View File

@ -83,7 +83,7 @@
"Log level example:\n"
" node target/tests/test.js --focus exporter-tests.renderer-svg-test --log-level warn"))
(defn- fail!
(defn- fail
[message]
(js/console.error message)
(.exit js/process 1))
@ -93,7 +93,7 @@
(let [[ns-name test-name & extra] (str/split focus #"/")]
(cond
(or (str/blank? ns-name) (seq extra))
(fail! (str "Invalid --focus value: " focus))
(fail (str "Invalid --focus value: " focus))
(some? test-name)
{:ns (symbol ns-name) :test test-name}
@ -129,17 +129,17 @@
(defn- selected-tests
[{:keys [ns test]}]
(when-not (some #{ns} test-namespaces)
(fail! (str "Unknown test namespace: " ns)))
(fail (str "Unknown test namespace: " ns)))
(let [vars (vec (ns-test-vars ns))]
(when (empty? vars)
(fail! (str "No tests found in namespace: " ns)))
(fail (str "No tests found in namespace: " ns)))
(if test
(let [test-sym (symbol test)
test-var (some #(when (= test-sym (:name (meta %))) %) vars)]
(if test-var
{:vars [test-var]
:fixtures (ns-fixtures ns [test-var])}
(fail! (str "Unknown test var: " ns "/" test))))
(fail (str "Unknown test var: " ns "/" test))))
{:vars vars
:fixtures (ns-fixtures ns vars)})))
@ -148,7 +148,7 @@
{:once (apply merge (keep :once fixtures))
:each (apply merge (keep :each fixtures))})
(defn- run-test-vars!
(defn- run-test-vars
[tests]
(let [vars (vec (mapcat :vars tests))
fixtures (merge-fixtures (map :fixtures tests))
@ -167,16 +167,16 @@
(t/report @summary)
(t/report (assoc @summary :type :end-run-tests)))]))))
(defn- run-focused-test!
(defn- run-focused-test
[focus]
(run-test-vars! [(selected-tests (parse-focus focus))]))
(run-test-vars [(selected-tests (parse-focus focus))]))
(defn -main
[]
(let [{:keys [options errors summary]} (parse-opts (argv) cli-options)]
(cond
(seq errors)
(fail! (str/join "\n" errors))
(fail (str/join "\n" errors))
(:help options)
(do
@ -187,5 +187,5 @@
(do
(l/setup! {:app (or (:log-level options) :warn)})
(if (:focus options)
(run-focused-test! (:focus options))
(run-test-vars! (map #(selected-tests {:ns %}) test-namespaces)))))))
(run-focused-test (:focus options))
(run-test-vars (map #(selected-tests {:ns %}) test-namespaces)))))))

6
exporter/test/exporter_tests/wasm_pool_test.cljs
View File

@ -12,7 +12,7 @@
[cljs.test :as t :include-macros true]
[promesa.core :as p]))
(defn- stub-pool!
(defn- stub-pool
"Installs a pool whose acquire/release/destroy only count calls."
[]
(let [calls (atom {:acquired 0 :released 0 :destroyed 0})]
@ -24,7 +24,7 @@
(t/deftest releases-the-worker-when-the-body-succeeds
(t/async done
(let [calls (stub-pool!)]
(let [calls (stub-pool)]
(p/let [result (pool/with-worker (fn [_] (p/resolved :ok)))]
(t/is (= :ok result))
(t/is (= 1 (:acquired @calls)))
@ -36,7 +36,7 @@
(t/deftest gives-the-worker-back-when-the-body-throws-synchronously
(t/testing "a raise out of the scope body must not leave the worker borrowed"
(t/async done
(let [calls (stub-pool!)]
(let [calls (stub-pool)]
(->> (pool/with-worker (fn [_] (throw (ex-info "cancelled" {}))))
(p/hmap (fn [_ cause]
(t/is (some? cause))

157
exporter/test/exporter_tests/worker_test.cljs
View File

@ -50,7 +50,7 @@
(when (= m method) body))
@calls))
(defn- fake-fetch!
(defn- fake-fetch
"Installs a management http fake: `respond` answers with the `:action`
envelope per [method, body] (the multipart arrives as a FormData
instance). Every call lands in `calls` before the answer. Returns the
@ -75,11 +75,11 @@
(def ^:private original-render rd/render)
(defn- fake-render!
(defn- fake-render
"Installs a fake renderer that writes one file of `content` per
object and calls back with it. When `captured` is an atom, it also
keeps the params of the last render. Returns the restore thunk."
([content] (fake-render! content nil))
([content] (fake-render content nil))
([content captured]
(let [original rd/render]
(set! rd/render
@ -94,7 +94,7 @@
(p/resolved nil))))
(fn [] (set! rd/render original)))))
(defn- fake-render-fail!
(defn- fake-render-fail
"A renderer that always fails: the failure path of the run."
[]
(let [original rd/render]
@ -104,7 +104,7 @@
;; ---- THE QUEUE FAKE
(defn- fake-conn!
(defn- fake-conn
"A fake ioredis connection: `blpop` pops one payload from the queue
the atom holds, or nil."
[queue]
@ -150,7 +150,7 @@
{:action :run})))
(defn- run-claim
"The claim payload of one call of `process!`."
"The claim payload of one call of `process`."
[job-id]
{:job-id job-id
:scheduled-at "2026-10-07T09:00:00Z"})
@ -160,12 +160,12 @@
(let [job-id (uuid/next)]
(t/is (= {:job-id (str job-id)
:scheduled-at "2026-10-07T09:00:00Z"}
(worker/read-payload! (encoded-claim job-id
"2026-10-07T09:00:00Z"))))))
(worker/read-payload (encoded-claim job-id
"2026-10-07T09:00:00Z"))))))
(t/testing "a corrupt payload is dropped, not thrown at the loop"
(t/is (nil? (worker/read-payload! "{not a payload")))))
(t/is (nil? (worker/read-payload "{not a payload")))))
(t/deftest process-hands-the-renderer-uuids-not-claim-strings
;; the claim carries the job row JSON: every id a string. The render
@ -186,10 +186,10 @@
:name "the export"}
stages (volatile! [])
captured (atom nil)
respond! (fake-fetch! (answer-with params sid stages))
restore! (fake-render! "rendered!" captured)]
(p/let [_ (worker/process! {:job-id (str job-id)
:scheduled-at "2026-10-07T09:00:00Z"})]
fetch-restore (fake-fetch (answer-with params sid stages))
render-restore (fake-render "rendered!" captured)]
(p/let [_ (worker/process {:job-id (str job-id)
:scheduled-at "2026-10-07T09:00:00Z"})]
(let [render-params @captured]
(t/testing "every id arrived as a uuid object"
(t/is (uuid? (:file-id render-params)))
@ -199,52 +199,52 @@
(t/is (uuid? (-> render-params :objects first :id))))
(t/testing "and the job-id traveled with the render"
(t/is (= job-id (:job-id render-params)))))
(respond!)
(restore!)
(fetch-restore)
(render-restore)
(done)))))
(t/deftest poll-once-awaits-what-it-claims
(t/async done
(let [queue (atom [(encoded-claim (uuid/next) "2026-10-07T09:00:00Z")])
conn (fake-conn! queue)
conn (fake-conn queue)
handled (atom [])]
(p/let [_ (worker/poll-once! conn
"the.queue.key"
(fn [claim] (swap! handled conj claim)))]
(p/let [_ (worker/poll-once conn
"the.queue.key"
(fn [claim] (swap! handled conj claim)))]
(t/is (= 1 (count @handled)))
(done)))))
(t/deftest poll-once-drops-empty-pops-and-corrupt-payloads
(t/async done
(let [queue (atom ["{corrupt"])
conn (fake-conn! queue)]
(p/let [_ (worker/poll-once! conn
"the.queue.key"
(fn [_claim]
(t/is false "corrupt must not be handled")))
_ (worker/poll-once! conn
"the.queue.key"
(fn [_claim]
(t/is false "a corrupt pop has nothing to handle")))]
conn (fake-conn queue)]
(p/let [_ (worker/poll-once conn
"the.queue.key"
(fn [_claim]
(t/is false "corrupt must not be handled")))
_ (worker/poll-once conn
"the.queue.key"
(fn [_claim]
(t/is false "a corrupt pop has nothing to handle")))]
(t/is (empty? @queue))
(done)))))
(t/deftest process-drops-a-claim-the-worker-never-won
(t/async done
(let [respond! (fake-fetch!
(fn [method _body]
(case method
"claim-job" {:action :skip :status "cancelled"}
{:action :run})))
render! (fake-render! "should never render")]
(p/let [settled (worker/process!
(let [fetch-restore (fake-fetch
(fn [method _body]
(case method
"claim-job" {:action :skip :status "cancelled"}
{:action :run})))
render-restore (fake-render "should never render")]
(p/let [settled (worker/process
{:job-id (uuid/next)
:scheduled-at "2026-10-07T09:00:00Z"})]
(t/testing "only the claim traveled: no session, no report, no render"
(t/is (= ["claim-job"] (steps-of)))
(t/is (nil? settled)))
(respond!)
(render!)
(fetch-restore)
(render-restore)
(done)))))
(t/deftest process-runs-the-claimed-export-to-a-multipart-settle
@ -253,9 +253,9 @@
sid (uuid/next)
params (export-params)
stages (volatile! [])
respond! (fake-fetch! (answer-with params sid stages))
restore! (fake-render! "rendered!")]
(p/let [_ (worker/process! (run-claim job-id))]
fetch-restore (fake-fetch (answer-with params sid stages))
render-restore (fake-render "rendered!")]
(p/let [_ (worker/process (run-claim job-id))]
(t/testing "the run went by claim, first breath, session, beats, settle"
(t/is (= ["claim-job" "report-job-progress" "create-job-session"
"report-job-progress" "report-job-progress"
@ -269,8 +269,8 @@
(t/is (= "image/png" (.get fd "mtype")))))
(t/testing "the beats painted the vocabulary in order"
(t/is (= [:preparing :rendering :packaging] @stages)))
(respond!)
(restore!)
(fetch-restore)
(render-restore)
(done)))))
(t/deftest cancelled-is-a-normal-ending-not-a-failure
@ -291,14 +291,14 @@
sid (uuid/next)
params (export-params)
stages (volatile! [])
respond! (fake-fetch! (answer-with params sid stages))
restore! (fake-render-fail!)]
(p/let [_ (worker/process! (run-claim job-id))
fetch-restore (fake-fetch (answer-with params sid stages))
render-restore (fake-render-fail)]
(p/let [_ (worker/process (run-claim job-id))
_ (p/delay 1400)]
(t/testing "no beat traveled after the fail settle"
(t/is (= "fail-job" (last (steps-of)))))
(respond!)
(restore!)
(fetch-restore)
(render-restore)
(done)))))
(t/deftest process-settles-a-failed-export-with-fail-job
@ -307,9 +307,9 @@
sid (uuid/next)
params (export-params)
stages (volatile! [])
respond! (fake-fetch! (answer-with params sid stages))
restore! (fake-render-fail!)]
(p/let [_ (worker/process! (run-claim job-id))]
fetch-restore (fake-fetch (answer-with params sid stages))
render-restore (fake-render-fail)]
(p/let [_ (worker/process (run-claim job-id))]
(t/testing "the settle was a fail, not a complete"
(t/is (= "fail-job" (last (steps-of)))))
(t/testing "the failure is the shape the backend stores"
@ -318,8 +318,8 @@
(t/is (= :export-failed (get-in fail [:error :code])))
(t/is (= "render boom" (get-in fail [:error :hint])))
(t/is (= sid (:session-id fail)))))
(respond!)
(restore!)
(fetch-restore)
(render-restore)
(done)))))
;; ---- THE CANCEL
@ -335,21 +335,21 @@
params (export-params)
stages (volatile! [])
port (atom 0)
respond! (fake-fetch!
(fn [method body]
(when (= "report-job-progress" method)
(vswap! stages conj (get-in body [:progress :stage])))
(case method
"claim-job" {:action :run :name "export-assets" :params params}
"create-job-session" {:session-id sid :session-token "session-token"}
"report-job-progress" {:action :skip}
{:action :run})))]
(p/let [_ (worker/process! (run-claim job-id))]
fetch-restore (fake-fetch
(fn [method body]
(when (= "report-job-progress" method)
(vswap! stages conj (get-in body [:progress :stage])))
(case method
"claim-job" {:action :run :name "export-assets" :params params}
"create-job-session" {:session-id sid :session-token "session-token"}
"report-job-progress" {:action :skip}
{:action :run})))]
(p/let [_ (worker/process (run-claim job-id))]
(t/testing "the settle of a cancelled job was a fail the backend answers skip"
(t/is (= "fail-job" (last (steps-of))))
(let [fail (call-of "fail-job")]
(t/is (= :job-cancelled (get-in fail [:error :code])))))
(respond!)
(fetch-restore)
(done)))))
(t/deftest cancel-kills-the-mid-skia-render
@ -362,20 +362,19 @@
params (export-params)
stages (volatile! [])
terminated (atom 0)
mark! (atom nil)
respond! (fake-fetch!
(fn [method body]
(when (= "report-job-progress" method)
(vswap! stages conj (get-in body [:progress :stage])))
(case method
"claim-job" {:action :run :name "export-assets" :params params}
"create-job-session" {:session-id sid :session-token "session-token"}
;; the first beat runs, everything else skips:
;; the cancel lands right after the claim
"report-job-progress" (if (empty? @stages)
{:action :run}
{:action :skip})
{:action :run})))
fetch-restore (fake-fetch
(fn [method body]
(when (= "report-job-progress" method)
(vswap! stages conj (get-in body [:progress :stage])))
(case method
"claim-job" {:action :run :name "export-assets" :params params}
"create-job-session" {:session-id sid :session-token "session-token"}
;; the first beat runs, everything else skips:
;; the cancel lands right after the claim
"report-job-progress" (if (empty? @stages)
{:action :run}
{:action :skip})
{:action :run})))
render-restore (let [original rd/render]
(set! rd/render
(fn [_params _on-object]
@ -385,9 +384,9 @@
;; does not exist in this fake
(p/delay 30000)))
(fn [] (set! rd/render original)))]
(p/let [_ (worker/process! (run-claim job-id))]
(p/let [_ (worker/process (run-claim job-id))]
(t/testing "the run ended in a fail job, not a complete"
(t/is (= "fail-job" (last (steps-of)))))
(render-restore)
(respond!)
(fetch-restore)
(done)))))