mirror of
https://github.com/penpot/penpot.git
synced 2026-11-05 17:40:39 +00:00
846 lines
32 KiB
Clojure
846 lines
32 KiB
Clojure
;; This Source Code Form is subject to the terms of the Mozilla Public
|
|
;; License, v. 2.0. If a copy of the MPL was not distributed with this
|
|
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
|
;;
|
|
;; Copyright (c) KALEIDOS SUBSIDIARY SL
|
|
|
|
(ns benches.render-wasm.node.run
|
|
"Renderer benchmark runs over fixed builds.
|
|
|
|
Runs are stored in a `home`, and execute via a loopback host and at most one
|
|
Chromium process.
|
|
|
|
`:fresh` cases prepare once per slot on a new page and context.
|
|
`:reuse` cases prepare once and run every slot on the same page and context.
|
|
|
|
A failed attempt consumes its slot.
|
|
|
|
Browser failures leave the current case's remaining slots unattempted and
|
|
continue with the next case in a new browser."
|
|
(:require-macros
|
|
[app.common.exceptions :as ex])
|
|
(:require
|
|
["module" :as node-module]
|
|
["os" :as os]
|
|
["path" :as path]
|
|
[app.common.schema :as sm]
|
|
[app.common.transit :as transit]
|
|
[benches.render-wasm.declarations :as declarations]
|
|
[benches.render-wasm.errors :as errors :refer [attempt failure?]]
|
|
[benches.render-wasm.measurement :as measurement]
|
|
[benches.render-wasm.node.artifacts :as artifacts]
|
|
[benches.render-wasm.node.browser :as browser]
|
|
[benches.render-wasm.node.build :as build]
|
|
[benches.render-wasm.node.catalog :as catalog]
|
|
[benches.render-wasm.node.log :as log]
|
|
[benches.render-wasm.node.outcome :as outcome]
|
|
[benches.render-wasm.node.process :as process]
|
|
[benches.render-wasm.node.runs :as runs]
|
|
[benches.render-wasm.node.server :as server]
|
|
[benches.render-wasm.node.time :as time]
|
|
[benches.render-wasm.report.format :as format]
|
|
[benches.render-wasm.report.summarize :as summary]
|
|
[benches.render-wasm.result :as result]
|
|
[clojure.string :as str]))
|
|
|
|
(def schema:run-options
|
|
"Resolved options for run preparation and execution."
|
|
(let [timeout-ms [:int {:min 1 :max 2147483647}]]
|
|
[:map {:closed true}
|
|
[:seed [:int {:min 0 :max 4294967295}]]
|
|
[:warmups [:int {:min 0 :max js/Number.MAX_SAFE_INTEGER}]]
|
|
[:repetitions [:int {:min 1 :max js/Number.MAX_SAFE_INTEGER}]]
|
|
[:timeout-ms timeout-ms]
|
|
[:build-timeout-ms timeout-ms]
|
|
[:startup-timeout-ms timeout-ms]
|
|
[:filter {:optional true} [:maybe :string]]
|
|
[:build-id {:optional true} [:string {:min 1}]]
|
|
[:output-dir {:optional true} [:maybe [:string {:min 1}]]]
|
|
[:default-features {:optional true} :boolean]
|
|
[:features {:optional true} [:vector [:string {:min 1}]]]
|
|
[:screenshots {:optional true} :boolean]
|
|
[:remove {:optional true} :boolean]
|
|
[:require-gpu {:optional true} :boolean]
|
|
[:browser {:optional true} [:map-of :keyword fn?]]]))
|
|
|
|
(def ^:private check-options
|
|
(sm/check-fn schema:run-options
|
|
:hint "invalid run options"
|
|
:type ::invalid-options))
|
|
|
|
(defn- cause-evidence
|
|
"Plain failure evidence for a rejected browser, server or persistence action."
|
|
[cause fallback-phase]
|
|
(errors/fail-data
|
|
(errors/evidence (or (:phase (ex-data cause)) fallback-phase) cause)))
|
|
|
|
(defn- failure-evidence
|
|
"Projects a bridge failure response into diagnostics evidence."
|
|
[evidence fallback-phase]
|
|
(if (map? evidence)
|
|
(cond-> (select-keys evidence [:status :phase :message :cause :partial])
|
|
(nil? (:status evidence)) (assoc :status "failed")
|
|
(nil? (:phase evidence)) (assoc :phase (name fallback-phase)))
|
|
{:status "failed"
|
|
:phase (name fallback-phase)
|
|
:message (str evidence)}))
|
|
|
|
(defn- interruption
|
|
[signal]
|
|
(when-let [name (process/signal-name signal)]
|
|
{:signal name :cause (.-reason ^js signal)}))
|
|
|
|
(defn- interrupted?
|
|
[state]
|
|
(some? (interruption (:signal state))))
|
|
|
|
(defn- keep-sink-failure
|
|
"Remembers the first failed write to the run record or log. The failure stays
|
|
in the outcome even when a later write succeeds."
|
|
[state cause]
|
|
(swap! (:sink-failure-ref state) #(or % cause))
|
|
cause)
|
|
|
|
(defn- write-log
|
|
[state output text]
|
|
(try
|
|
(output text)
|
|
(catch :default cause
|
|
(throw (keep-sink-failure
|
|
state
|
|
(if (errors/fatal? cause)
|
|
cause
|
|
(errors/fatal-error "cannot write the run log" {} cause)))))))
|
|
|
|
(defn- warn-safely
|
|
"Appends runner diagnostics without replacing an error already under handling."
|
|
[state text]
|
|
(ex/ignoring (write-log state log/warn text))
|
|
nil)
|
|
|
|
(defn- persist
|
|
[state]
|
|
(try
|
|
(runs/write-record! (:home state) @(:run-ref state))
|
|
(catch :default cause
|
|
(throw (keep-sink-failure
|
|
state
|
|
(errors/fatal-error "cannot save the run record" {:log-path (get-in state [:home :log-path])} cause))))))
|
|
|
|
(defn- record-preparation
|
|
[state preparation]
|
|
(swap! (:run-ref state) result/record-preparation preparation)
|
|
(persist state)
|
|
(write-log state log/debug (str "Prepared " (result/case-name (:case-id preparation)))))
|
|
|
|
(defn- record-attempt
|
|
[state measured]
|
|
(swap! (:run-ref state) result/record-attempt measured)
|
|
(persist state)
|
|
(let [remaining (get-in @(:run-ref state) [:remaining (:case-id measured)])
|
|
total (+ (:warmups (:opts state)) (:repetitions (:opts state)))
|
|
index (- total (:warmups remaining) (:repetitions remaining))]
|
|
(write-log state (if (= :failed (:outcome measured)) log/warn log/info)
|
|
(str " attempt " index "/" total " " (name (:outcome measured))
|
|
(when (:warmup? measured) " (warmup)")))))
|
|
|
|
(defn- record-failure
|
|
[state case-id stage evidence]
|
|
(let [failure (cond-> (assoc (select-keys evidence [:status :phase :message :cause :partial])
|
|
:stage stage)
|
|
(some? case-id) (assoc :case-id case-id))]
|
|
(reset! (:harness-failed? state) true)
|
|
(swap! (:run-ref state) update-in [:metadata :diagnostics :failures]
|
|
(fnil conj []) failure)
|
|
(persist state)
|
|
(write-log state log/warn (str (name stage) " failed"
|
|
(when (some? case-id) (str " for " (result/case-name case-id)))
|
|
": " (:message failure) "\n"))
|
|
failure))
|
|
|
|
(defn- record-screenshot-status
|
|
[state case-id status]
|
|
(swap! (:run-ref state) assoc-in
|
|
[:metadata :diagnostics :screenshots (result/case-name case-id)] status)
|
|
(persist state))
|
|
|
|
(defn- screenshot-status
|
|
[state case-id]
|
|
(get-in @(:run-ref state)
|
|
[:metadata :diagnostics :screenshots (result/case-name case-id)]))
|
|
|
|
(defn- record-screenshot-skip
|
|
[state case-id reason]
|
|
(when (:screenshots (:opts state))
|
|
(when-not (screenshot-status state case-id)
|
|
(record-screenshot-status state case-id {:status :skipped :reason reason}))))
|
|
|
|
(defn- ensure-screenshot-status
|
|
[state case reason]
|
|
(when (:screenshots (:opts state))
|
|
(when-not (screenshot-status state (:id case))
|
|
(record-screenshot-skip state (:id case) reason))))
|
|
|
|
(defn- ^:async screenshot-case
|
|
[state case page]
|
|
(when (:screenshots (:opts state))
|
|
(let [{:keys [file path]} (runs/screenshot-path (:home state) (:id case))
|
|
opts (:opts state)
|
|
bounds {:deadline (process/deadline (:startup-timeout-ms opts))
|
|
:signal (:signal state) :phase :screenshot}
|
|
shot (attempt (await ((get-in state [:services :screenshot]) page path bounds)))]
|
|
(if (failure? shot)
|
|
(do
|
|
(record-screenshot-status state (:id case)
|
|
{:file file :status :failed
|
|
:message (errors/message-of shot)
|
|
:cause (errors/describe-cause shot)})
|
|
(write-log state log/warn (str "Screenshot failed for "
|
|
(result/case-name (:id case)) ": "
|
|
(errors/message-of shot) "\n")))
|
|
(do
|
|
(record-screenshot-status state (:id case) {:file file :status :ok})
|
|
(write-log state log/debug (str "Screenshot " file)))))))
|
|
|
|
(defn- case-slots
|
|
"Returns each scheduled slot in order: all warmups, then measured slots.
|
|
True marks a warmup."
|
|
[opts]
|
|
(vec (concat (repeat (:warmups opts) true)
|
|
(repeat (:repetitions opts) false))))
|
|
|
|
(defn- renderer-url
|
|
[build-id file]
|
|
(str "/renderer/" file "?build=" (js/encodeURIComponent build-id)))
|
|
|
|
(defn- ^:async prepare-case
|
|
[state case page deadline]
|
|
(let [opts (:opts state)
|
|
build-id (:id (:selected-build state))
|
|
response (attempt
|
|
(await ((get-in state [:services :prepare])
|
|
page
|
|
(transit/encode-str
|
|
{:case case
|
|
:preparation-id (str (random-uuid))
|
|
:timeout-ms (:timeout-ms opts)
|
|
:module-url (renderer-url build-id "render-wasm.js")
|
|
:wasm-url (renderer-url build-id "render-wasm.wasm")})
|
|
{:deadline deadline :signal (:signal state) :phase :preparation})))]
|
|
(cond
|
|
(failure? response) {:failure (cause-evidence response :preparation)}
|
|
(= "ok" (:status response)) {:preparation (:preparation response)}
|
|
:else {:failure (failure-evidence response :preparation)})))
|
|
|
|
(defn- ^:async run-attempt
|
|
"Returns the bridge evidence of one attempt, or the failure."
|
|
[state page preparation-id deadline]
|
|
(attempt
|
|
(await ((get-in state [:services :run])
|
|
page
|
|
(transit/encode-str
|
|
{:preparation-id preparation-id
|
|
:timeout-ms (max 1 (process/remaining deadline))})
|
|
{:deadline deadline :signal (:signal state) :phase :attempt}))))
|
|
|
|
(defn- ^:async recycle-browser
|
|
[state]
|
|
(when-let [owner @(:owner-ref state)]
|
|
(reset! (:owner-ref state) nil)
|
|
(let [closed (attempt (await ((get-in state [:services :close]) owner)))]
|
|
(when (failure? closed)
|
|
(write-log state log/warn (str "Browser cleanup failed: " (errors/message-of closed)))))))
|
|
|
|
(defn- ^:async close-current-page
|
|
[state]
|
|
(let [owner @(:owner-ref state)
|
|
connected? (get-in state [:services :connected?])]
|
|
(if (and owner connected? (not (connected? owner)))
|
|
(do
|
|
(reset! (:page-ref state) nil)
|
|
(await (recycle-browser state))
|
|
false)
|
|
(if-let [page @(:page-ref state)]
|
|
(do
|
|
(reset! (:page-ref state) nil)
|
|
(let [closed (attempt (await ((get-in state [:services :close-page]) page)))]
|
|
(if (failure? closed)
|
|
(do
|
|
(record-failure state nil :browser-close (cause-evidence closed :browser-close))
|
|
(await (recycle-browser state))
|
|
false)
|
|
true)))
|
|
true))))
|
|
|
|
(defn- ^:async ensure-browser
|
|
[state]
|
|
(or @(:owner-ref state)
|
|
(let [opts (:opts state)
|
|
options (cond-> {:startup-timeout-ms (:startup-timeout-ms opts)
|
|
:signal (:signal state)}
|
|
(some? @(:launch-deadline state))
|
|
(assoc :deadline @(:launch-deadline state)))
|
|
owner (await ((get-in state [:services :launch]) options))]
|
|
(reset! (:owner-ref state) owner)
|
|
(swap! (:run-ref state) assoc-in [:metadata :environment :browser] (:version owner))
|
|
(persist state)
|
|
(write-log state log/debug (str "Browser " (:version owner)))
|
|
owner)))
|
|
|
|
(defn- usable-graphics-identity?
|
|
[value]
|
|
(and (string? value)
|
|
(not (contains? #{"" "unknown" "unavailable" "null" "undefined"}
|
|
(str/lower-case (str/trim value))))))
|
|
|
|
(defn- check-gpu
|
|
[state preparation]
|
|
(let [graphics (:effective-graphics preparation)
|
|
accepted (and (true? (:webgl2 graphics))
|
|
(false? (:software graphics))
|
|
(usable-graphics-identity? (:vendor graphics))
|
|
(usable-graphics-identity? (:renderer graphics)))]
|
|
(if (and (:require-gpu (:opts state)) (not accepted))
|
|
(do
|
|
(record-failure state (:case-id preparation) :gpu
|
|
{:status "failed" :phase "gpu"
|
|
:message (str "GPU check failed; renderer: " (pr-str (:renderer graphics))
|
|
". Hardware WebGL2 with a usable vendor and renderer is required."
|
|
" Start the container with ./manage.sh run-devenv --gpu and use pnpm run render-bench.")
|
|
:partial {:graphics graphics}})
|
|
(reset! (:abort-run? state) true)
|
|
:abort)
|
|
:ok)))
|
|
|
|
(defn- ^:async open-case-page
|
|
[state case owner]
|
|
(let [opened (attempt
|
|
(await ((get-in state [:services :new-page])
|
|
owner @(:host-ref state)
|
|
{:viewport (declarations/resolve-viewport (:view case))
|
|
:startup-timeout-ms (:startup-timeout-ms (:opts state))
|
|
:signal (:signal state)})))]
|
|
(cond
|
|
(not (failure? opened))
|
|
(do
|
|
(reset! (:page-ref state) opened)
|
|
{:page (:page opened)})
|
|
|
|
(interrupted? state)
|
|
{:outcome :interrupted}
|
|
|
|
:else
|
|
(do
|
|
(record-failure state (:id case) :browser-page (cause-evidence opened :browser-page))
|
|
(await (recycle-browser state))
|
|
{:outcome :abandon}))))
|
|
|
|
(defn- ^:async open-page
|
|
[state case]
|
|
(if (interrupted? state)
|
|
{:outcome :interrupted}
|
|
(let [owner (attempt (await (ensure-browser state)))]
|
|
(cond
|
|
(not (failure? owner))
|
|
(await (open-case-page state case owner))
|
|
|
|
(interrupted? state)
|
|
{:outcome :interrupted}
|
|
|
|
:else
|
|
(do
|
|
(record-failure state (:id case) :browser-launch
|
|
(cause-evidence owner :browser-launch))
|
|
(reset! (:abort-run? state) true)
|
|
{:outcome :abort})))))
|
|
|
|
(defn- accept-preparation
|
|
[state preparation]
|
|
(record-preparation state preparation)
|
|
(check-gpu state preparation))
|
|
|
|
(defn- ^:async execute-slot
|
|
[state case page preparation-id warmup? deadline]
|
|
(let [response (await (run-attempt state page preparation-id deadline))
|
|
measured (measurement/attempt (:id case) preparation-id warmup?
|
|
(if (failure? response)
|
|
(cause-evidence response :attempt)
|
|
response))]
|
|
(record-attempt state measured)
|
|
(cond
|
|
(and (failure? response) (interrupted? state)) :interrupted
|
|
(= :completed (:outcome measured)) :ok
|
|
:else :failed)))
|
|
|
|
(defn- ^:async finish-slot
|
|
[state case page outcome final?]
|
|
(when final?
|
|
(if (= :ok outcome)
|
|
(await (screenshot-case state case page))
|
|
(record-screenshot-skip state (:id case) :no-completed-measured-attempt)))
|
|
outcome)
|
|
|
|
(defn- ^:async run-fresh-slot
|
|
[state case page warmup? final?]
|
|
(let [deadline (process/deadline (:timeout-ms (:opts state)))
|
|
prepared (await (prepare-case state case page deadline))]
|
|
(if-let [evidence (:failure prepared)]
|
|
(do
|
|
(record-attempt state (measurement/attempt (:id case) nil warmup? evidence))
|
|
(await (finish-slot state case page
|
|
(if (interrupted? state) :interrupted :failed) final?)))
|
|
(let [preparation (:preparation prepared)]
|
|
(if (= :abort (accept-preparation state preparation))
|
|
:abort
|
|
(let [outcome (await (execute-slot state case page (:preparation-id preparation)
|
|
warmup? deadline))]
|
|
(await (finish-slot state case page outcome final?))))))))
|
|
|
|
(defn- ^:async run-fresh-page
|
|
[state case warmup? final?]
|
|
(let [{:keys [page outcome]} (await (open-page state case))]
|
|
(if page
|
|
(let [outcome (await (run-fresh-slot state case page warmup? final?))
|
|
closed? (await (close-current-page state))]
|
|
(cond
|
|
(#{:abort :interrupted} outcome) outcome
|
|
(not closed?) :abandon
|
|
:else outcome))
|
|
(or outcome :abandon))))
|
|
|
|
(defn- ^:async run-fresh-slots
|
|
[state case slots]
|
|
(if-let [[warmup? & pending] (seq slots)]
|
|
(let [outcome (await (run-fresh-page state case warmup? (empty? pending)))]
|
|
(if (#{:ok :failed} outcome)
|
|
(run-fresh-slots state case pending)
|
|
outcome))
|
|
:done))
|
|
|
|
(defn- ^:async run-fresh-case
|
|
[state case]
|
|
(let [outcome (await (run-fresh-slots state case (case-slots (:opts state))))]
|
|
(ensure-screenshot-status state case :case-abandoned)
|
|
outcome))
|
|
|
|
(defn- ^:async run-reuse-slots
|
|
[state case page preparation-id slots]
|
|
(if-let [[warmup? & pending] (seq slots)]
|
|
(let [deadline (process/deadline (:timeout-ms (:opts state)))
|
|
outcome (await (execute-slot state case page preparation-id warmup? deadline))]
|
|
(await (finish-slot state case page outcome (empty? pending)))
|
|
(if (= :ok outcome)
|
|
(run-reuse-slots state case page preparation-id pending)
|
|
outcome))
|
|
:done))
|
|
|
|
(defn- ^:async abandon-preparation
|
|
[state case evidence]
|
|
(record-failure state (:id case) :preparation evidence)
|
|
(ensure-screenshot-status state case :no-completed-measured-attempt)
|
|
(await (close-current-page state))
|
|
(if (interrupted? state) :interrupted :abandon))
|
|
|
|
(defn- ^:async run-reuse-prepared
|
|
[state case page preparation]
|
|
(let [accepted (accept-preparation state preparation)
|
|
outcome (if (= :abort accepted)
|
|
:abort
|
|
(await (run-reuse-slots state case page (:preparation-id preparation)
|
|
(case-slots (:opts state)))))
|
|
closed? (await (close-current-page state))]
|
|
(ensure-screenshot-status state case :case-abandoned)
|
|
(if closed? outcome :abandon)))
|
|
|
|
(defn- ^:async run-reuse-page
|
|
[state case page]
|
|
(let [deadline (process/deadline (:timeout-ms (:opts state)))
|
|
prepared (await (prepare-case state case page deadline))]
|
|
(if-let [evidence (:failure prepared)]
|
|
(await (abandon-preparation state case evidence))
|
|
(await (run-reuse-prepared state case page (:preparation prepared))))))
|
|
|
|
(defn- ^:async run-reuse-case
|
|
[state case]
|
|
(let [{:keys [page outcome]} (await (open-page state case))]
|
|
(cond
|
|
page (await (run-reuse-page state case page))
|
|
(= :abort outcome) :abort
|
|
|
|
:else
|
|
(do
|
|
(ensure-screenshot-status state case :case-abandoned)
|
|
(or outcome :abandon)))))
|
|
|
|
|
|
(defn- fail-startup
|
|
"Records the startup failure and aborts the run. An interrupted run records
|
|
nothing. Returns false."
|
|
[state stage cause]
|
|
(when-not (interrupted? state)
|
|
(record-failure state nil stage (cause-evidence cause stage))
|
|
(reset! (:abort-run? state) true))
|
|
false)
|
|
|
|
(defn- ^:async launch-initial
|
|
[state]
|
|
(let [owner (attempt (await (ensure-browser state)))]
|
|
(reset! (:launch-deadline state) nil)
|
|
(if (failure? owner)
|
|
(fail-startup state :browser-launch owner)
|
|
true)))
|
|
|
|
(defn- ^:async record-provenance
|
|
[state deadline]
|
|
(let [git (attempt (await (build/git-provenance (:root state)
|
|
{:deadline deadline :signal (:signal state)})))]
|
|
(if (failure? git)
|
|
(fail-startup state :runner-git git)
|
|
(do
|
|
(swap! (:run-ref state) assoc-in [:metadata :diagnostics :runner-git] git)
|
|
(persist state)
|
|
true))))
|
|
|
|
(defn- ^:async start-server
|
|
[state deadline]
|
|
(let [remaining (process/remaining deadline)
|
|
host (attempt
|
|
(when (zero? remaining)
|
|
(throw (ex-info "server startup timed out"
|
|
{:type ::startup-timeout :phase :server-startup})))
|
|
(await (server/open (:selected-build state)
|
|
{:startup-timeout-ms remaining :signal (:signal state)})))]
|
|
(if (failure? host)
|
|
(fail-startup state :server-startup host)
|
|
(do
|
|
(reset! (:host-ref state) host)
|
|
true))))
|
|
|
|
(defn- session-active?
|
|
[state]
|
|
(and (not @(:abort-run? state)) (not (interrupted? state))))
|
|
|
|
(defn- ^:async run-cases
|
|
[state cases]
|
|
(when (and (seq cases) (session-active? state))
|
|
(let [case (first cases)]
|
|
(write-log state log/info (str "▸ Case " (result/case-name (:id case))
|
|
" (" (name (:context case)) ")"))
|
|
(let [outcome (if (= :fresh (:context case))
|
|
(await (run-fresh-case state case))
|
|
(await (run-reuse-case state case)))]
|
|
(if (#{:abort :interrupted} outcome)
|
|
(do
|
|
(reset! (:abort-run? state) true)
|
|
outcome)
|
|
(run-cases state (rest cases)))))))
|
|
|
|
(defn- ^:async run-session
|
|
[state]
|
|
(let [deadline (process/deadline (:startup-timeout-ms (:opts state)))]
|
|
(reset! (:launch-deadline state) deadline)
|
|
(let [provenance-ready? (await (record-provenance state deadline))
|
|
server-ready? (and provenance-ready? (await (start-server state deadline)))
|
|
browser-ready? (and server-ready? (session-active? state) (await (launch-initial state)))]
|
|
(when (and browser-ready? (session-active? state))
|
|
(await (run-cases state (:cases state)))))))
|
|
|
|
(defn- get-termination
|
|
[run interrupted harness-failed?]
|
|
(let [all-attempted? (every? (fn [[_ slots]]
|
|
(and (zero? (:warmups slots))
|
|
(zero? (:repetitions slots))))
|
|
(:remaining run))
|
|
failed? (some #(= :failed (:outcome %)) (:attempts run))
|
|
reason (cond
|
|
interrupted :interrupted
|
|
all-attempted? (if failed? :failed :completed)
|
|
:else :incomplete)
|
|
failures (get-in run [:metadata :diagnostics :failures])
|
|
attempt-failure (some #(when (:failure %) (:failure %))
|
|
(reverse (:attempts run)))
|
|
termination (cond-> {:reason reason}
|
|
interrupted
|
|
(assoc :signal (:signal interrupted))
|
|
|
|
(and (seq failures)
|
|
(or (not= :completed reason) harness-failed?))
|
|
(assoc :failure (last failures))
|
|
|
|
(and (not= :completed reason)
|
|
(empty? failures)
|
|
(some? attempt-failure))
|
|
(assoc :failure attempt-failure))]
|
|
termination))
|
|
|
|
(defn- complete-screenshots
|
|
[screenshots cases]
|
|
(let [defaults (into {} (map (fn [case]
|
|
[(result/case-name (:id case)) {:status :skipped :reason :not-run}]))
|
|
cases)]
|
|
(merge defaults screenshots)))
|
|
|
|
(defn- finish-run
|
|
[state]
|
|
(let [termination (get-termination @(:run-ref state) (interruption (:signal state))
|
|
@(:harness-failed? state))]
|
|
(when (:screenshots (:opts state))
|
|
(swap! (:run-ref state) update-in [:metadata :diagnostics :screenshots]
|
|
complete-screenshots (:cases state)))
|
|
(swap! (:run-ref state) result/finish-run (time/now) termination)
|
|
(persist state)
|
|
@(:run-ref state)))
|
|
|
|
(defn- ^:async release-resource
|
|
"Closes the resource in `reference`. Returns nil or the failure."
|
|
[reference close]
|
|
(attempt :catch-fatal
|
|
(when-let [resource @reference]
|
|
(reset! reference nil)
|
|
(await (close resource)))
|
|
nil))
|
|
|
|
(defn- ^:async cleanup
|
|
[state]
|
|
(let [page-failure (await (release-resource (:page-ref state) (get-in state [:services :close-page])))
|
|
browser-failure (await (release-resource (:owner-ref state) (get-in state [:services :close])))
|
|
server-failure (await (release-resource (:host-ref state) server/close))
|
|
failure (or page-failure browser-failure server-failure)]
|
|
(when failure
|
|
(warn-safely state (str "run: cleanup failed: " (errors/message-of failure) "\n")))
|
|
failure))
|
|
|
|
(defn- remove-build
|
|
[root selected-build]
|
|
(artifacts/remove-builds root [(:id selected-build)]))
|
|
|
|
(defn- git-facts
|
|
[selected-build]
|
|
(merge {:sha nil :dirty nil}
|
|
(get-in selected-build [:manifest :provenance :git])))
|
|
|
|
(defn- playwright-version
|
|
[root]
|
|
(ex/ignoring
|
|
(let [require-package (if (exists? js/require)
|
|
js/require
|
|
(node-module/createRequire (path/join root "package.json")))]
|
|
(.-version (require-package "playwright/package.json")))))
|
|
|
|
(defn- environment
|
|
[root _selected-build]
|
|
(let [cpus (array-seq (os/cpus))]
|
|
{:node (.-version js/process)
|
|
:playwright (playwright-version root)
|
|
:browser nil
|
|
:platform (os/platform)
|
|
:release (os/release)
|
|
:arch (os/arch)
|
|
:cpu {:models (vec (distinct (map #(.-model %) cpus)))
|
|
:logical-count (count cpus)}
|
|
:launch (browser/launch-settings)}))
|
|
|
|
(defn- metadata
|
|
[root selected-build opts]
|
|
{:git (git-facts selected-build)
|
|
:build (cond-> {:functional (or (get-in selected-build [:manifest :functional]) {})
|
|
:provenance (assoc (get-in selected-build [:manifest :provenance])
|
|
:build-id (:id selected-build))}
|
|
(contains? (:manifest selected-build) :environment)
|
|
(assoc :environment (get-in selected-build [:manifest :environment])))
|
|
:environment (environment root selected-build)
|
|
:scored? true
|
|
:diagnostics {:seed (:seed opts)
|
|
:filter (:filter opts)
|
|
:warmups (:warmups opts)
|
|
:repetitions (:repetitions opts)
|
|
:timeout-ms (:timeout-ms opts)
|
|
:build-timeout-ms (:build-timeout-ms opts)
|
|
:startup-timeout-ms (:startup-timeout-ms opts)
|
|
:screenshots? (boolean (:screenshots opts))
|
|
:require-gpu? (boolean (:require-gpu opts))
|
|
:penpot-gpu (or (.-PENPOT_GPU (.-env js/process)) nil)
|
|
:runner-git {:sha nil :dirty nil}
|
|
:runtime-helper-identity :unverified
|
|
:screenshots {}
|
|
:failures []}})
|
|
|
|
(defn- create-run-record
|
|
[root run-id selected-build cases opts]
|
|
(result/create-run
|
|
{:run-id run-id
|
|
:started-at (time/now)
|
|
:plan {:cases cases
|
|
:warmups (:warmups opts)
|
|
:repetitions (:repetitions opts)
|
|
:timeout-policy {:attempt-ms (:timeout-ms opts)}}
|
|
:metadata (metadata root selected-build opts)}))
|
|
|
|
(defn- create-run-state
|
|
[root home selected-build cases opts signal]
|
|
{:root root
|
|
:selected-build selected-build
|
|
:cases cases
|
|
:opts opts
|
|
:signal signal
|
|
:home home
|
|
:run-ref (atom (create-run-record root (:run-id home) selected-build cases opts))
|
|
:sink-failure-ref (atom nil)
|
|
:owner-ref (atom nil)
|
|
:page-ref (atom nil)
|
|
:host-ref (atom nil)
|
|
:launch-deadline (atom nil)
|
|
:abort-run? (atom false)
|
|
:harness-failed? (atom false)
|
|
:services (merge browser/service (:browser opts))})
|
|
|
|
(defn- record-session-failure
|
|
[state stage cause]
|
|
(let [recorded (attempt :catch-fatal
|
|
(record-failure state nil stage (cause-evidence cause stage)))]
|
|
(when (failure? recorded)
|
|
(warn-safely state (str "Could not record " (when (= :cleanup stage) "cleanup ")
|
|
"failure: " (errors/message-of recorded) "\n")))))
|
|
|
|
(defn- ^:async execute-session
|
|
"Runs the session. Returns the failure that ended it, or nil. An interruption
|
|
is not a failure."
|
|
[state]
|
|
(let [ended (attempt :catch-fatal (await (run-session state)))]
|
|
(when (and (failure? ended) (not (interrupted? state)))
|
|
(record-session-failure state :runner ended)
|
|
ended)))
|
|
|
|
(defn- ^:async cleanup-session
|
|
[state]
|
|
(when-let [cause (await (cleanup state))]
|
|
(record-session-failure state :cleanup cause)
|
|
cause))
|
|
|
|
(defn- remove-run-build
|
|
[state saved?]
|
|
(when (and saved? (:remove (:opts state)))
|
|
(attempt :catch-fatal
|
|
(remove-build (:root state) (:selected-build state))
|
|
nil)))
|
|
|
|
(defn- format-run-report
|
|
"Returns the report text or the failure."
|
|
[state run]
|
|
(let [report (attempt (format/format-run (summary/summarize run)))]
|
|
(when (failure? report)
|
|
(warn-safely state (str "Report failed: " (errors/message-of report) "\n")))
|
|
report))
|
|
|
|
(defn- log-run-completion
|
|
[state run]
|
|
(attempt :catch-fatal
|
|
(write-log state log/debug (str "Run " (name (get-in run [:termination :reason]))))
|
|
nil))
|
|
|
|
(defn- get-exit-code
|
|
[run causes harness-failed?]
|
|
(case (get-in run [:termination :reason])
|
|
:interrupted (outcome/interruption-code (get-in run [:termination :signal]))
|
|
:completed (if (or (seq causes) harness-failed?) 1 0)
|
|
1))
|
|
|
|
(defn- finish-execution
|
|
[state session-error cleanup-error]
|
|
(let [saved (attempt :catch-fatal (finish-run state))
|
|
run (if (failure? saved) @(:run-ref state) saved)
|
|
removal (remove-run-build state (not (failure? saved)))
|
|
report (format-run-report state run)
|
|
logged (log-run-completion state run)
|
|
causes (->> [cleanup-error session-error saved removal report logged
|
|
@(:sink-failure-ref state)]
|
|
(filter failure?)
|
|
distinct
|
|
vec)
|
|
home (:home state)]
|
|
{:run run
|
|
:home home
|
|
:log-path (:log-path home)
|
|
:report (when-not (failure? report) report)
|
|
:errors causes
|
|
:exit-code (get-exit-code run causes @(:harness-failed? state))}))
|
|
|
|
(defn ^:async execute
|
|
"Executes a prepared selection. Owns host and browser.
|
|
|
|
- `root`: the frontend checkout root.
|
|
- `home`: the reserved output home.
|
|
- `selected-build`: the prepared build.
|
|
- `cases`: the selected cases.
|
|
- `options`: resolved options satisfying `schema:run-options`.
|
|
- `signal`: an optional abort signal.
|
|
|
|
A browser startup failure leaves a valid partial record.
|
|
|
|
Returns the run, home, report, log path, exit code and the failures in
|
|
:errors, a cleanup failure first. :errors includes any failed record or log
|
|
write, including a failure followed by a successful write. An interruption
|
|
is not a failure."
|
|
[root home selected-build cases options signal]
|
|
(check-options options)
|
|
(binding [log/*log-path* (:log-path home)]
|
|
(let [state (create-run-state root home selected-build cases options signal)]
|
|
(persist state)
|
|
(let [session-error (await (execute-session state))
|
|
cleanup-error (await (cleanup-session state))]
|
|
(finish-execution state session-error cleanup-error)))))
|
|
|
|
(defn- ^:async get-selected-build
|
|
[root opts signal]
|
|
(if-let [id (:build-id opts)]
|
|
(artifacts/load-build root id)
|
|
(await (build/prepare
|
|
{:root root
|
|
:features {:default-features? (:default-features opts true)
|
|
:features (or (:features opts) [])}
|
|
:build-timeout-ms (:build-timeout-ms opts)
|
|
:signal signal}))))
|
|
|
|
(defn- get-cases
|
|
[selected-build opts]
|
|
(try
|
|
(catalog/collect selected-build {:master-seed (:seed opts) :filter (:filter opts)})
|
|
(catch :default cause
|
|
(throw (ex-info (errors/message-of cause)
|
|
(assoc (ex-data cause) :build-id (:id selected-build)
|
|
:log-path (:log-path selected-build))
|
|
cause)))))
|
|
|
|
(defn- publish-report
|
|
[result]
|
|
(outcome/publish result
|
|
#(when-let [report (:report result)]
|
|
(log/result (str "Report\n" report)))))
|
|
|
|
(defn ^:async run
|
|
"Prepares or loads a build, collects matching cases and executes one run.
|
|
|
|
- `root`: the frontend checkout root.
|
|
- `options`: resolved options satisfying `schema:run-options`.
|
|
- `signal`: an optional abort signal.
|
|
|
|
Validates options before allocating output. Returns the execution result.
|
|
A build or catalog failure throws with the run log path and build facts."
|
|
[root options signal]
|
|
(let [opts (check-options options)
|
|
home (runs/create-home {:root root :run-id (str (random-uuid))
|
|
:output-dir (:output-dir opts) :remove (:remove opts)})]
|
|
(binding [log/*log-path* (:log-path home)]
|
|
(try
|
|
(log/result (str "Run " (:run-id home)))
|
|
(log/result (str "Output " (:dir home)))
|
|
(let [selected-build (await (get-selected-build root opts signal))
|
|
cases (get-cases selected-build opts)]
|
|
(log/info (str " build " (:id selected-build)))
|
|
(log/info (str " selected " (count cases) " cases"))
|
|
(publish-report (await (execute root home selected-build cases opts signal))))
|
|
(catch :default cause
|
|
(throw (-> cause
|
|
errors/as-failure
|
|
(errors/with-data {:log-path (:log-path home)}))))))))
|