From 08a335b03528f2a95da92300577fdc5f81500e24 Mon Sep 17 00:00:00 2001 From: Miguel de Benito Delgado Date: Fri, 30 Oct 2026 10:29:34 +0100 Subject: [PATCH] :construction: WIP 29.2, refactor feature comparisons --- .../render_wasm/node/feature_comparison.cljs | 821 +++++++++--------- .../render_wasm/feature_comparison_test.cljs | 226 ++++- 2 files changed, 631 insertions(+), 416 deletions(-) diff --git a/frontend/performance/benches/render_wasm/node/feature_comparison.cljs b/frontend/performance/benches/render_wasm/node/feature_comparison.cljs index 774fb03c55..a6c9d601cc 100644 --- a/frontend/performance/benches/render_wasm/node/feature_comparison.cljs +++ b/frontend/performance/benches/render_wasm/node/feature_comparison.cljs @@ -129,14 +129,20 @@ cause)) (defn- storage-error? + ([cause] + (storage-error? cause 0)) + ([cause depth] + (cond + (nil? cause) false + (contains? #{::storage-error ::log/storage-error} (:type (data-of cause))) true + (>= depth 8) false + :else (storage-error? (ex-cause cause) (inc depth))))) + +(defn- operation-error [cause] - (loop [cause cause - depth 0] - (cond - (nil? cause) false - (contains? #{::storage-error ::log/storage-error} (:type (data-of cause))) true - (>= depth 8) false - :else (recur (ex-cause cause) (inc depth))))) + (if (storage-error? cause) + (throw cause) + {:error cause})) (defn- change-config [record slug f] @@ -208,16 +214,13 @@ (some? failure) (assoc :failure failure)))))) (defn- mark-configs-unattempted - [state from-index reason] - (loop [index from-index] - (when (< index (count (:configurations @(:record-ref state)))) - (let [configuration (nth (:configurations @(:record-ref state)) index)] - (when (= :planned (:status configuration)) - (persist state - (fn [record] - (change-config record (:slug configuration) - #(assoc % :status :unattempted :reason reason))))) - (recur (inc index)))))) + [state configurations reason] + (when-let [[configuration & pending] (seq configurations)] + (let [slug (:slug configuration)] + (when (= :planned (:status (config-by-slug @(:record-ref state) slug))) + (persist state #(change-config % slug (fn [entry] + (assoc entry :status :unattempted :reason reason))))) + (mark-configs-unattempted state pending reason)))) (defn- mark-edge [state edge status data] @@ -227,10 +230,13 @@ #(merge % (assoc data :status status)))))) (defn- mark-edges-unattempted - [state reason] - (doseq [edge (:edges @(:record-ref state))] - (when (= :planned (:status edge)) - (mark-edge state edge :unattempted {:reason reason})))) + ([state reason] + (mark-edges-unattempted state (:edges @(:record-ref state)) reason)) + ([state edges reason] + (when-let [[edge & pending] (seq edges)] + (when (= :planned (:status edge)) + (mark-edge state edge :unattempted {:reason reason})) + (mark-edges-unattempted state pending reason)))) (defn- finish [state status exit-code error interrupted?] @@ -255,10 +261,20 @@ (defn- interrupt-comparison [state signal error] (let [reason (str "interrupted by " signal)] - (mark-configs-unattempted state 0 reason) + (mark-configs-unattempted state (:configurations @(:record-ref state)) reason) (mark-edges-unattempted state reason) (finish state :interrupted (signal-exit signal) error true))) +(defn- record-created-build + [state slug build] + (persist state + #(change-config % slug + (fn [configuration] + (-> configuration + (assoc :status :building + :build (select-keys build [:id :manifest-path :log-path])) + (dissoc :failure :reason)))))) + (defn- ^:async prepare-build [state slug selection] (try @@ -267,22 +283,10 @@ :selection selection :build-timeout-ms (get-in state [:options :build-timeout-ms]) :signal (:signal state) - :on-created - (fn [build] - (persist state - (fn [record] - (change-config - record slug - #(-> % - (assoc :status :building - :build (select-keys build - [:id :manifest-path :log-path])) - (dissoc :failure :reason))))))}))] + :on-created (partial record-created-build state slug)}))] {:build selected}) (catch :default cause - (if (storage-error? cause) - (throw cause) - {:error cause})))) + (operation-error cause)))) (defn- load-run [path] @@ -293,261 +297,246 @@ (throw (ex-info "expected a saved run record" {:type ::invalid-run :path path}))) record)) +(defn- stop-outcome + [slug reason cause] + {:stop? true + :reason (str "not attempted after " reason " in configuration " slug) + :error cause}) + +(defn- fail-configuration + [state slug phase reason cause] + (fail-config state slug phase cause) + (stop-outcome slug reason cause)) + +(defn- interrupt-configuration + [state slug signal phase cause] + (interrupt-config state slug signal (when cause (failure-evidence phase cause))) + (cond-> {:interrupted? true :signal signal} + cause (assoc :error cause))) + +(defn- fail-or-interrupt + [state slug phase cause] + (if-let [signal (signal-name (:signal state))] + (interrupt-configuration state slug signal phase cause) + (fail-configuration state slug phase (str (name phase) " failure") cause))) + +(defn- begin-configuration + [state configuration] + (let [slug (:slug configuration)] + (if-let [signal (signal-name (:signal state))] + {:configuration configuration + :outcome (interrupt-configuration state slug signal nil nil)} + (do + (persist state #(change-config % slug (fn [entry] + (-> entry (assoc :status :building) + (dissoc :failure :reason))))) + {:configuration configuration})))) + +(defn- accept-build + [state flow selected] + (let [{:keys [slug selection]} (:configuration flow) + effective (get-in selected [:manifest :functional :features]) + saved-selection (get-in selected [:manifest :provenance :feature-selection]) + valid-features? (and (vector? effective) (every? string? effective))] + (if (and (= selection saved-selection) valid-features?) + (do + (persist state #(change-config % slug (fn [entry] + (assoc entry :status :ready :effective-features effective)))) + (log/info (str "Configuration " slug " built")) + (assoc flow :build selected)) + (let [cause (ex-info "renderer build manifest disagrees with the planned selection" + {:type ::invalid-build :log-path (:log-path selected) + :selection selection :saved-selection saved-selection})] + (assoc flow :outcome (fail-configuration state slug :build "build failure" cause)))))) + +(defn- ^:async build-configuration + [state flow] + (if (:outcome flow) + flow + (let [{:keys [slug selection]} (:configuration flow) + prepared (await (prepare-build state slug selection)) + signal (signal-name (:signal state))] + (cond + (:error prepared) + (assoc flow :outcome (fail-or-interrupt state slug :build (:error prepared))) + + signal + (assoc flow :outcome (interrupt-configuration state slug signal nil nil)) + + :else (accept-build state flow (:build prepared)))))) + +(defn- collect-build-cases + [state selected] + (try + (let [collected ((:collect-catalog (:services state)) selected + {:master-seed (get-in state [:options :seed]) + :filter (get-in state [:options :filter])})] + {:mismatch (not= collected (:cases state))}) + (catch :default cause + (update (operation-error cause) :error with-log-path (:log-path selected))))) + +(defn- check-catalog + [state flow] + (if (:outcome flow) + flow + (let [slug (get-in flow [:configuration :slug]) + result (collect-build-cases state (:build flow)) + signal (signal-name (:signal state)) + outcome (cond + (:error result) (fail-or-interrupt state slug :catalog (:error result)) + signal (interrupt-configuration state slug signal nil nil) + (:mismatch result) + (fail-configuration state slug :catalog "catalog mismatch" + (ex-info "build catalog disagrees with the prepared cases" + {:type ::catalog-mismatch + :log-path (get-in flow [:build :log-path]) + :configuration slug})))] + (cond-> flow outcome (assoc :outcome outcome))))) + +(defn- create-config-home + [state slug] + (try + {:home ((:create-run-home (:services state)) + {:root (:root state) :run-id (str (random-uuid)) + :output-dir (path/join (get-in state [:home :dir]) "configs" slug)})} + (catch :default cause + (operation-error cause)))) + +(defn- allocate-run + [state flow] + (if (:outcome flow) + flow + (let [slug (get-in flow [:configuration :slug]) + result (create-config-home state slug)] + (if-let [cause (:error result)] + (assoc flow :outcome (fail-configuration state slug :run-home "run-home failure" cause)) + (assoc flow :run-home (:home result)))))) + +(defn- ^:async execute-run + [state flow] + (try + (await ((:execute-run (:services state)) + (:root state) (:run-home flow) (:build flow) (:cases state) + (select-keys (:options state) (sm/keys run/schema:run-options)) + (:signal state))) + (catch :default cause + (operation-error cause)))) + +(defn- get-evidence-error + [slug home response] + (or (:storage-error response) + (try + (when-not (= (get-in response [:run :run-id]) (:run-id (load-run (:record-path home)))) + (throw (ex-info "saved run identity disagrees with execution result" + {:type ::invalid-run :configuration slug}))) + nil + (catch :default cause cause)))) + +(defn- get-run-evidence + [slug home response] + (let [run (:run response) + home (or (:home response) home) + evidence-error (get-evidence-error slug home response) + error (when-let [cause (or evidence-error (:error response))] + (with-log-path cause (:log-path home)))] + {:run run + :home home + :evidence-error evidence-error + :error error + :gpu-failure (some #(when (= :gpu (:stage %)) %) (get-in run [:metadata :diagnostics :failures])) + :run-ref {:run-id (:run-id run) :record-path (:record-path home) + :log-path (:log-path home) :exit-code (:exit-code response)}})) + +(defn- get-run-failure + [{:keys [run evidence-error gpu-failure error]}] + (cond + evidence-error (failure-evidence :run-evidence evidence-error) + gpu-failure gpu-failure + (map? (get-in run [:termination :failure])) (get-in run [:termination :failure]) + error (failure-evidence :run error))) + +(defn- classify-run + [signal evidence] + (let [termination (get-in evidence [:run :termination :reason]) + completed (and (nil? (:evidence-error evidence)) (= :completed termination) + (zero? (get-in evidence [:run-ref :exit-code]))) + interrupted (or signal (when (= :interrupted termination) + (or (get-in evidence [:run :termination :signal]) "SIGINT"))) + failure (get-run-failure evidence) + reason (or interrupted (when (and (not completed) (nil? failure)) "run did not complete"))] + (assoc evidence :completed completed :signal interrupted :failure failure :reason reason))) + +(defn- record-run-result + [state slug {:keys [completed run-ref reason failure]}] + (persist state + #(change-config % slug + (fn [entry] + (if completed + (-> entry (assoc :status :completed :run run-ref) (dissoc :failure :reason)) + (cond-> (assoc entry :status :failed :run run-ref) + (some? reason) (assoc :reason reason) + (some? failure) (assoc :failure failure))))))) + +(defn- zero-attempt-outcome + [slug home] + (stop-outcome slug "a run with no attempts" + (ex-info "configuration run made no attempts" + {:type ::zero-attempts :log-path (:log-path home) :configuration slug}))) + +(defn- config-run-outcome + [slug {:keys [run home completed signal reason error evidence-error gpu-failure]}] + (cond + completed + (if (empty? (:attempts run)) + (zero-attempt-outcome slug home) + (do (log/info (str "Configuration " slug " completed")) {:stop? false})) + + signal {:interrupted? true :signal reason :error error} + evidence-error (stop-outcome slug "run evidence failure" error) + gpu-failure (stop-outcome slug "GPU failure" + (ex-info (:message gpu-failure) + {:type ::gpu-required :log-path (:log-path home) :configuration slug})) + (empty? (:attempts run)) (zero-attempt-outcome slug home) + :else (do (log/warn (str "Configuration " slug " failed")) {:stop? false :error error}))) + +(defn- finish-config-run + [state flow response] + (let [slug (get-in flow [:configuration :slug]) + facts (get-run-evidence slug (:run-home flow) response) + evidence (classify-run (signal-name (:signal state)) facts)] + (record-run-result state slug evidence) + (config-run-outcome slug evidence))) + +(defn- ^:async run-configuration + [state flow] + (if (:outcome flow) + flow + (let [slug (get-in flow [:configuration :slug]) + home (:run-home flow)] + (persist state #(change-config % slug (fn [entry] + (assoc entry :status :running + :run {:run-id (:run-id home) + :record-path (:record-path home) + :log-path (:log-path home)})))) + (log/info (str "Configuration " slug " running")) + (let [response (await (execute-run state flow)) + outcome (if (:run response) + (finish-config-run state flow response) + (fail-configuration state slug :run "run failure" + (with-log-path + (or (:error response) + (ex-info "run executor returned no record" {:type ::missing-run})) + (:log-path home))))] + (assoc flow :outcome outcome))))) + (defn- ^:async execute-config [state configuration] - (let [slug (:slug configuration) - selection (:selection configuration) - signal (:signal state) - options (:options state) - cases (:cases state) - root (:root state) - home (:home state) - services (:services state)] - (if-let [interrupted (signal-name signal)] - (do - (interrupt-config state slug interrupted nil) - {:interrupted? true :signal interrupted}) - (do - (persist state - (fn [record] - (change-config record slug - #(-> % (assoc :status :building) - (dissoc :failure :reason))))) - (let [prepared (await (prepare-build state slug selection))] - (cond - (:error prepared) - (if-let [interrupted (signal-name signal)] - (do - (interrupt-config state slug interrupted - (failure-evidence :build (:error prepared))) - {:interrupted? true :signal interrupted :error (:error prepared)}) - (do - (fail-config state slug :build (:error prepared)) - {:stop? true - :reason (str "not attempted after build failure in configuration " slug) - :error (:error prepared)})) - - (signal-name signal) - (let [interrupted (signal-name signal)] - (interrupt-config state slug interrupted nil) - {:interrupted? true :signal interrupted}) - - :else - (let [selected (:build prepared) - manifest (:manifest selected) - effective (get-in manifest [:functional :features]) - saved-selection (get-in manifest [:provenance :feature-selection]) - valid-features? (and (vector? effective) (every? string? effective))] - (if-not (and (= selection saved-selection) valid-features?) - (let [cause (ex-info "renderer build manifest disagrees with the planned selection" - {:type ::invalid-build - :log-path (:log-path selected) - :selection selection - :saved-selection saved-selection})] - (fail-config state slug :build cause) - {:stop? true - :reason (str "not attempted after build failure in configuration " slug) - :error cause}) - (do - (persist state - (fn [record] - (change-config record slug - #(assoc % :status :ready - :effective-features effective)))) - (log/info (str "Configuration " slug " built")) - (let [catalog-result - (try - (let [collected ((:collect-catalog services) - selected - {:master-seed (:seed options) - :filter (:filter options)})] - (if (= collected cases) - {:cases collected} - {:mismatch true})) - (catch :default cause - (if (storage-error? cause) - (throw cause) - {:error (with-log-path cause (:log-path selected))})))] - (cond - (:error catalog-result) - (if-let [interrupted (signal-name signal)] - (do - (interrupt-config state slug interrupted - (failure-evidence :catalog (:error catalog-result))) - {:interrupted? true :signal interrupted :error (:error catalog-result)}) - (do - (fail-config state slug :catalog (:error catalog-result)) - {:stop? true - :reason (str "not attempted after catalog failure in configuration " slug) - :error (:error catalog-result)})) - - (signal-name signal) - (let [interrupted (signal-name signal)] - (interrupt-config state slug interrupted nil) - {:interrupted? true :signal interrupted}) - - (:mismatch catalog-result) - (let [cause (ex-info "build catalog disagrees with the prepared cases" - {:type ::catalog-mismatch - :log-path (:log-path selected) - :configuration slug})] - (fail-config state slug :catalog cause) - {:stop? true - :reason (str "not attempted after catalog mismatch in configuration " slug) - :error cause}) - - :else - (let [run-id (str (random-uuid)) - run-home-result (try - {:home ((:create-run-home services) - {:root root - :run-id run-id - :output-dir (path/join (:dir home) "configs" slug)})} - (catch :default cause - (if (storage-error? cause) - (throw cause) - {:error cause})))] - (if-let [cause (:error run-home-result)] - (do - (fail-config state slug :run-home cause) - {:stop? true - :reason (str "not attempted after run-home failure in configuration " slug) - :error cause}) - (let [run-home (:home run-home-result)] - (persist state - (fn [record] - (change-config - record slug - #(assoc % :status :running - :run {:run-id (:run-id run-home) - :record-path (:record-path run-home) - :log-path (:log-path run-home)})))) - (log/info (str "Configuration " slug " running")) - (let [run-result - (try - (await ((:execute-run services) - root run-home selected cases - (select-keys options (sm/keys run/schema:run-options)) - signal)) - (catch :default cause - (if (storage-error? cause) - (throw cause) - {:error cause})))] - (if-let [run-record (:run run-result)] - (let [returned-home (:home run-result) - run-home (or returned-home run-home) - exit-code (:exit-code run-result) - termination (get-in run-record [:termination :reason]) - attempts (:attempts run-record) - gpu-failure (some #(when (= :gpu (:stage %)) %) - (get-in run-record [:metadata :diagnostics :failures])) - evidence-error - (or (:storage-error run-result) - (try - (when-not (= (:run-id run-record) - (:run-id (load-run (:record-path run-home)))) - (throw (ex-info "saved run identity disagrees with execution result" - {:type ::invalid-run - :configuration slug}))) - nil - (catch :default cause cause))) - run-error (when-let [cause (or evidence-error (:error run-result))] - (with-log-path cause (:log-path run-home))) - interrupted (or (signal-name signal) - (= :interrupted termination)) - completed (and (nil? evidence-error) - (= :completed termination) - (zero? exit-code)) - run-failure (cond - (some? evidence-error) - (failure-evidence :run-evidence evidence-error) - - (some? gpu-failure) - gpu-failure - - (map? (get-in run-record [:termination :failure])) - (get-in run-record [:termination :failure]) - - (some? run-error) - (failure-evidence :run run-error)) - reason (cond - interrupted - (or (signal-name signal) - (get-in run-record [:termination :signal]) - "SIGINT") - - (not completed) - (when-not run-failure "run did not complete")) - run-ref {:run-id (:run-id run-record) - :record-path (:record-path run-home) - :log-path (:log-path run-home) - :exit-code exit-code}] - (if completed - (do - (persist state - (fn [record] - (change-config - record slug - #(-> % (assoc :status :completed :run run-ref) - (dissoc :failure :reason))))) - (if (empty? attempts) - (let [cause (ex-info "configuration run made no attempts" - {:type ::zero-attempts - :log-path (:log-path run-home) - :configuration slug})] - {:stop? true - :reason (str "not attempted after a run with no attempts in configuration " - slug) - :error cause}) - (do - (log/info (str "Configuration " slug " completed")) - {:stop? false}))) - (do - (persist state - (fn [record] - (change-config - record slug - #(cond-> (assoc % :status :failed :run run-ref) - (some? reason) (assoc :reason reason) - (some? run-failure) (assoc :failure run-failure))))) - (cond - interrupted - {:interrupted? true :signal reason :error run-error} - - (some? evidence-error) - {:stop? true - :reason (str "not attempted after run evidence failure in configuration " slug) - :error run-error} - - (some? gpu-failure) - {:stop? true - :reason (str "not attempted after GPU failure in configuration " slug) - :error (ex-info (:message gpu-failure) - {:type ::gpu-required - :log-path (:log-path run-home) - :configuration slug})} - - :else - (if (empty? attempts) - (let [cause (ex-info "configuration run made no attempts" - {:type ::zero-attempts - :log-path (:log-path run-home) - :configuration slug})] - {:stop? true - :reason (str "not attempted after a run with no attempts in configuration " - slug) - :error cause}) - (do - (log/warn (str "Configuration " slug " failed")) - {:stop? false :error run-error})))))) - (let [cause (with-log-path - (or (:error run-result) - (ex-info "run executor returned no record" {:type ::missing-run})) - (:log-path run-home))] - (fail-config state slug :run cause) - {:stop? true - :reason (str "not attempted after run failure in configuration " slug) - :error cause}))))))))))))))))) + (let [started (begin-configuration state configuration) + built (await (build-configuration state started)) + catalogued (check-catalog state built) + allocated (allocate-run state catalogued) + executed (await (run-configuration state allocated))] + (:outcome executed))) (defn- sorted-features [features] @@ -586,6 +575,14 @@ (reduce + 0 (map (fn [pair] (count (remove :waived? (:mismatches pair)))) (:pairs comparison)))) +(defn- get-comparison-options + [record facts] + (assoc (:permissions record) + :expected-feature-change (select-keys facts [:feature :baseline-features + :candidate-features :added :removed]) + :edge facts + :on-unallowed-difference :record)) + (defn- analyze-edge [state edge] (try @@ -595,19 +592,7 @@ baseline (load-run (get-in baseline-config [:run :record-path])) candidate (load-run (get-in candidate-config [:run :record-path])) facts (edge-facts baseline candidate edge) - expected (select-keys facts [:feature :baseline-features - :candidate-features :added :removed]) - comparison (compare/compare-runs - baseline candidate - {:allow-build-differences - (get-in record [:permissions :allow-build-differences]) - :allow-scene-differences - (get-in record [:permissions :allow-scene-differences]) - :allow-all-differences - (get-in record [:permissions :allow-all-differences]) - :expected-feature-change expected - :edge facts - :on-unallowed-difference :record}) + comparison (compare/compare-runs baseline candidate (get-comparison-options record facts)) path (path/join (get-in state [:home :dir]) "comparisons" (str (:from edge) "__" (:to edge) ".transit"))] @@ -619,87 +604,134 @@ {:storage-error cause} {:error cause})))) +(defn- record-edge-outcome + [state edge result error] + (cond + (:storage-error result) + (do + (mark-edge state edge :failed {:failure (failure-evidence :comparison-storage (:storage-error result))}) + (mark-edges-unattempted state "not attempted after comparison storage failure") + {:storage (:storage-error result)}) + + (:error result) + (do + (mark-edge state edge :failed {:failure (failure-evidence :comparison (:error result))}) + {:error (or error (:error result))}) + + (pos? (:unacknowledged result)) + (do + (log/warn (str "Comparison " (:from edge) " -> " (:to edge) + " has " (:unacknowledged result) " unacknowledged differences")) + (mark-edge state edge :failed {:path (:path result) + :failure {:unacknowledged-differences (:unacknowledged result)}}) + {:error error}) + + :else + (do + (mark-edge state edge :completed {:path (:path result)}) + {:error error}))) + +(defn- ^:async analyze-edges + [state edges error] + (await (timers/setImmediate)) + (if-let [signal (signal-name (:signal state))] + (do + (mark-edges-unattempted state (str "interrupted by " signal)) + {:interrupted signal :error error}) + (if-let [[edge & pending] (seq edges)] + (let [outcome (record-edge-outcome state edge (analyze-edge state edge) error)] + (if (:storage outcome) + outcome + (analyze-edges state pending (:error outcome)))) + {:done true :error error}))) + +(defn- create-comparison-directory + [state] + (try + (fs/mkdirSync (path/join (get-in state [:home :dir]) "comparisons") #js {:recursive true}) + (catch :default cause + (throw (storage-error cause (get-in state [:home :log-path])))))) + (defn- ^:async run-edges [state error] - (if-let [interrupted (signal-name (:signal state))] - (interrupt-comparison state interrupted error) - (let [comparisons (path/join (get-in state [:home :dir]) "comparisons")] - (try - (fs/mkdirSync comparisons #js {:recursive true}) - (catch :default cause - (throw (storage-error cause (get-in state [:home :log-path]))))) - (let [outcome - (loop [edges (:edges @(:record-ref state)) - error error] - (await (timers/setImmediate)) - (if-let [interrupted (signal-name (:signal state))] - (do - (mark-edges-unattempted state (str "interrupted by " interrupted)) - {:interrupted interrupted :error error}) - (if-let [edge (first edges)] - (let [result (analyze-edge state edge)] - (cond - (:storage-error result) - (do - (mark-edge state edge :failed - {:failure (failure-evidence :comparison-storage - (:storage-error result))}) - (mark-edges-unattempted state - "not attempted after comparison storage failure") - {:storage (:storage-error result)}) - - (:error result) - (do - (mark-edge state edge :failed - {:failure (failure-evidence :comparison (:error result))}) - (recur (rest edges) (or error (:error result)))) - - (pos? (:unacknowledged result)) - (do - (log/warn (str "Comparison " (:from edge) " -> " (:to edge) - " has " (:unacknowledged result) " unacknowledged differences")) - (mark-edge state edge :failed - {:path (:path result) - :failure {:unacknowledged-differences (:unacknowledged result)}}) - (recur (rest edges) error)) - - :else - (do - (mark-edge state edge :completed {:path (:path result)}) - (recur (rest edges) error)))) - {:done true :error error})))] + (if-let [signal (signal-name (:signal state))] + (interrupt-comparison state signal error) + (do + (create-comparison-directory state) + (let [outcome (await (analyze-edges state (:edges @(:record-ref state)) error))] (cond - (:interrupted outcome) - (interrupt-comparison state (:interrupted outcome) (:error outcome)) - - (:storage outcome) - (finish state :failed 1 (:storage outcome) false) - - :else - (finish-root state (:error outcome))))))) + (:interrupted outcome) (interrupt-comparison state (:interrupted outcome) (:error outcome)) + (:storage outcome) (finish state :failed 1 (:storage outcome) false) + :else (finish-root state (:error outcome))))))) (defn- ^:async run-comparisons + [state configurations] + (if-let [signal (signal-name (:signal state))] + (interrupt-comparison state signal nil) + (if-let [[configuration & pending] (seq configurations)] + (let [outcome (await (execute-config state configuration))] + (cond + (:interrupted? outcome) + (interrupt-comparison state (:signal outcome) (:error outcome)) + + (:stop? outcome) + (do + (mark-configs-unattempted state pending (:reason outcome)) + (run-edges state (:error outcome))) + + :else (run-comparisons state pending))) + (run-edges state nil)))) + +(defn- create-comparison-state + [root prepared signal services home comparison-id] + {:root root + :home home + :options (:options prepared) + :cases (:cases prepared) + :signal signal + :services services + :record-ref (atom (initial-record prepared comparison-id (now))) + :saved-ref (atom nil)}) + +(defn- initialize-comparison [state] - (loop [index 0] - (if (>= index (count (:configurations @(:record-ref state)))) - (if-let [interrupted (signal-name (:signal state))] - (interrupt-comparison state interrupted nil) - (run-edges state nil)) - (if-let [interrupted (signal-name (:signal state))] - (interrupt-comparison state interrupted nil) - (let [configuration (nth (:configurations @(:record-ref state)) index) - outcome (await (execute-config state configuration))] - (cond - (:interrupted? outcome) - (interrupt-comparison state (:signal outcome) (:error outcome)) + (let [initial @(:record-ref state) + home (:home state)] + (log/result (str "Comparison " (:comparison-id initial))) + (log/result (str "Output " (:dir home))) + (let [saved (write-record home initial)] + (reset! (:record-ref state) saved) + (reset! (:saved-ref state) saved)))) - (:stop? outcome) - (do - (mark-configs-unattempted state (inc index) (:reason outcome)) - (run-edges state (:error outcome))) +(defn- publish-status + [outcome] + (try + (log/result (str "Status " (cond + (:interrupted? outcome) "interrupted" + (zero? (:exit-code outcome)) "completed" + :else "failed"))) + outcome + (catch :default cause + (assoc outcome :error (or (:error outcome) cause) + :storage-error cause + :exit-code (if (:interrupted? outcome) (:exit-code outcome) 1))))) - :else - (recur (inc index)))))))) +(defn- ^:async execute-comparison + [state] + (let [home (:home state)] + (binding [log/*log-path* (:log-path home)] + (let [outcome (try + (initialize-comparison state) + (await (run-comparisons state (:configurations @(:record-ref state)))) + (catch :default cause + {:comparison @(:saved-ref state) + :home home + :log-path (:log-path home) + :tail-log (:log-path (data-of cause)) + :exit-code 1 + :error cause + :interrupted? false}))] + (publish-status outcome))))) (defn ^:async execute "Executes a prepared feature comparison and owns builds, runs and reports. @@ -723,41 +755,4 @@ :exit-code 1 :error cause :interrupted? false} - (let [started (now) - initial (initial-record prepared comparison-id started) - record-ref (atom initial) - saved-ref (atom nil) - state {:root root - :home home - :options (:options prepared) - :cases (:cases prepared) - :signal signal - :services services - :record-ref record-ref - :saved-ref saved-ref}] - (binding [log/*log-path* (:log-path home)] - (let [outcome (try - (log/result (str "Comparison " comparison-id)) - (log/result (str "Output " (:dir home))) - (let [saved (write-record home initial)] - (reset! record-ref saved) - (reset! saved-ref saved)) - (await (run-comparisons state)) - (catch :default cause - {:comparison @saved-ref - :home home - :log-path (:log-path home) - :tail-log (:log-path (data-of cause)) - :exit-code 1 - :error cause - :interrupted? false}))] - (try - (log/result (str "Status " (cond - (:interrupted? outcome) "interrupted" - (zero? (:exit-code outcome)) "completed" - :else "failed"))) - outcome - (catch :default cause - (assoc outcome :error (or (:error outcome) cause) - :storage-error cause - :exit-code (if (:interrupted? outcome) (:exit-code outcome) 1)))))))))) + (await (execute-comparison (create-comparison-state root prepared signal services home comparison-id)))))) diff --git a/frontend/test/performance_tests/render_wasm/feature_comparison_test.cljs b/frontend/test/performance_tests/render_wasm/feature_comparison_test.cljs index 4de6e680f1..6807059f25 100644 --- a/frontend/test/performance_tests/render_wasm/feature_comparison_test.cljs +++ b/frontend/test/performance_tests/render_wasm/feature_comparison_test.cljs @@ -428,13 +428,14 @@ :provenance {:feature-selection selection}}}) (defn- build-service - [{:keys [extra-features fail-on inspect] + [{:keys [extra-features fail-on inspect build-fn] :or {extra-features (constantly []) - fail-on (constantly false)}}] + fail-on (constantly false) + build-fn fake-build}}] (fn [request] (when inspect (inspect request)) (let [selection (get request :selection) - build (fake-build selection (extra-features selection))] + build (build-fn selection (extra-features selection))] (when-let [on-created (:on-created request)] (on-created build)) (if (fail-on selection) @@ -532,6 +533,225 @@ :collect-catalog (or collect-catalog (fn [_ _] [(fixture-case)])) :execute-run execute-run}) +(defn- saved-comparison + [outcome] + (result/decode (fs/readFileSync (get-in outcome [:home :record-path]) "utf8"))) + +(t/deftest ^:async invalid-build-selection-or-features-stops-later-configurations + (create-frontend-root) + (doseq [[field value] [[[:provenance :feature-selection] {:default-features? false :features ["other"]}] + [[:functional :features] #{"a"}] + [[:functional :features] [:invalid]]]] + (let [prepared (comparison-prepared ["a"] {:output-dir (path/join @temporary-root (str (random-uuid)))}) + outcome (await (feature-comparison/execute + (frontend-root) prepared nil + {:services (comparison-services + {:prepare-build (build-service + {:build-fn (fn [selection extra] + (assoc-in (fake-build selection extra) + (into [:manifest] field) value))}) + :execute-run (execute-service {})})})) + record (saved-comparison outcome)] + (t/is (= 1 (:exit-code outcome))) + (t/is (= :failed (:status record))) + (t/is (= [:failed :unattempted] (mapv :status (:configurations record)))) + (t/is (= "build" (get-in record [:configurations 0 :failure :phase]))) + (t/is (str/includes? (get-in record [:configurations 0 :failure :message]) + "disagrees with the planned selection"))))) + +(t/deftest ^:async operational-failures-save-the-stage-and-stop-later-configurations + (create-frontend-root) + (doseq [[boundary phase message] [[:catalog "catalog" "catalog rejected"] + [:run-home "run-home" "already exists"] + [:run "run" "run rejected"] + [:missing-run "run" "run executor returned no record"]]] + (let [prepared (comparison-prepared ["a"] {:output-dir (path/join @temporary-root (str (random-uuid)))}) + base (comparison-services {:prepare-build (build-service {}) :execute-run (execute-service {})}) + services (case boundary + :catalog (assoc base :collect-catalog (fn [_ _] (throw (js/Error. "catalog rejected")))) + :run-home (assoc base :prepare-build + (build-service {:inspect (fn [_] + (fs/mkdirSync (path/join (:output-dir prepared) "configs" "0") + #js {:recursive true}))})) + :run (assoc base :execute-run (fn [& _] (js/Promise.reject (js/Error. "run rejected")))) + :missing-run (assoc base :execute-run (fn [& _] (js/Promise.resolve {:exit-code 1})))) + outcome (await (feature-comparison/execute (frontend-root) prepared nil {:services services})) + record (saved-comparison outcome)] + (t/is (= 1 (:exit-code outcome))) + (t/is (= :failed (:status record))) + (t/is (= [:failed :unattempted] (mapv :status (:configurations record)))) + (t/is (= phase (get-in record [:configurations 0 :failure :phase]))) + (t/is (str/includes? (get-in record [:configurations 0 :failure :message]) message))))) + +(t/deftest ^:async unavailable-or-mismatched-run-evidence-stops-later-configurations + (create-frontend-root) + (doseq [[kind message] [[:missing "run record is missing"] + [:mismatch "saved run identity disagrees with execution result"]]] + (let [prepared (comparison-prepared ["a"] {:output-dir (path/join @temporary-root (str (random-uuid)))}) + execute (execute-service {}) + outcome (await (feature-comparison/execute + (frontend-root) prepared nil + {:services (comparison-services + {:prepare-build (build-service {}) + :execute-run + (^:async fn [root home build cases options signal] + (let [response (await (execute root home build cases options signal))] + (if (= kind :missing) + (fs/unlinkSync (:record-path home)) + (files/atomic-write (:record-path home) + (result/encode (assoc (:run response) :run-id (str (random-uuid)))))) + response))})})) + record (saved-comparison outcome)] + (t/is (= 1 (:exit-code outcome))) + (t/is (= [:failed :unattempted] (mapv :status (:configurations record)))) + (t/is (= "run-evidence" (get-in record [:configurations 0 :failure :phase]))) + (t/is (str/includes? (get-in record [:configurations 0 :failure :message]) message))))) + +(t/deftest ^:async returned-storage-failure-wins-over-readable-evidence-and-executor-errors + (create-frontend-root) + (doseq [[signal code] [[nil 1] ["SIGINT" 130] ["SIGTERM" 143]]] + (let [controller (js/AbortController.) + prepared (comparison-prepared ["a"] {:output-dir (path/join @temporary-root (str (random-uuid)))}) + execute (execute-service {}) + outcome (await (feature-comparison/execute + (frontend-root) prepared (.-signal controller) + {:services (comparison-services + {:prepare-build (build-service {}) + :execute-run + (^:async fn [root home build cases options signal-object] + (let [response (await (execute root home build cases options signal-object))] + (when signal (.abort controller signal)) + (assoc response :exit-code 1 + :error (js/Error. "executor failure") + :storage-error (js/Error. "recovered write failure"))))})})) + record (saved-comparison outcome) + run (result/decode (fs/readFileSync (get-in record [:configurations 0 :run :record-path]) "utf8"))] + (t/is (= code (:exit-code outcome))) + (t/is (= (if signal :interrupted :failed) (:status record))) + (t/is (= :completed (get-in run [:termination :reason]))) + (t/is (= [:failed :unattempted] (mapv :status (:configurations record)))) + (t/is (= "run-evidence" (get-in record [:configurations 0 :failure :phase]))) + (t/is (= "recovered write failure" (get-in record [:configurations 0 :failure :message]))) + (t/is (= "recovered write failure" (ex-message (:error outcome))))))) + +(t/deftest ^:async pre-aborted-comparison-preserves-all-work-as-unattempted + (create-frontend-root) + (doseq [[signal code] [["SIGINT" 130] ["SIGTERM" 143]]] + (let [controller (js/AbortController.) + _ (.abort controller signal) + prepared (comparison-prepared ["a" "b"] {:output-dir (path/join @temporary-root (str (random-uuid)))}) + outcome (await (feature-comparison/execute + (frontend-root) prepared (.-signal controller) + {:services (comparison-services {:prepare-build (build-service {}) + :execute-run (execute-service {})})})) + record (saved-comparison outcome)] + (t/is (= code (:exit-code outcome))) + (t/is (true? (:interrupted? outcome))) + (t/is (= :interrupted (:status record))) + (t/is (some? (:ended-at record))) + (t/is (every? #(= :unattempted (:status %)) (concat (:configurations record) (:edges record)))) + (t/is (every? #(= (str "interrupted by " signal) (:reason %)) + (concat (:configurations record) (:edges record))))))) + +(t/deftest ^:async interrupted-build-and-catalog-preserve-stage-failures + (create-frontend-root) + (doseq [boundary [:build :catalog] + rejected [false true] + [signal code] [["SIGINT" 130] ["SIGTERM" 143]]] + (let [controller (js/AbortController.) + prepared (comparison-prepared ["a"] {:output-dir (path/join @temporary-root (str (random-uuid)))}) + build (build-service {}) + stop (fn [] + (.abort controller signal) + (when rejected (throw (js/Error. "interrupted work")))) + services (comparison-services + {:prepare-build (if (= boundary :build) + (^:async fn [request] + (let [selected (await (build request))] + (stop) + selected)) + build) + :collect-catalog (fn [_ _] + (when (= boundary :catalog) (stop)) + (:cases prepared)) + :execute-run (execute-service {})}) + outcome (await (feature-comparison/execute (frontend-root) prepared (.-signal controller) + {:services services})) + record (saved-comparison outcome)] + (t/is (= code (:exit-code outcome))) + (t/is (true? (:interrupted? outcome))) + (t/is (= :interrupted (:status record))) + (t/is (= [:failed :unattempted] (mapv :status (:configurations record)))) + (t/is (= signal (get-in record [:configurations 0 :reason]))) + (t/is (= (if rejected [(name boundary)] []) + (mapv :phase (keep :failure (:configurations record))))) + (t/is (every? #(= :unattempted (:status %)) (:edges record)))))) + +(t/deftest ^:async edge-report-storage-failure-preserves-failed-and-unattempted-edges + (create-frontend-root) + (let [prepared (comparison-prepared ["a" "b"]) + outcome (await (feature-comparison/execute + (frontend-root) prepared nil + {:services (comparison-services + {:prepare-build (build-service + {:inspect (fn [_] + (fs/mkdirSync + (path/join (:output-dir prepared) "comparisons" "00__10.transit") + #js {:recursive true}))}) + :execute-run (execute-service {})})})) + record (saved-comparison outcome)] + (t/is (= 1 (:exit-code outcome))) + (t/is (= :failed (:status record))) + (t/is (every? #(= :completed (:status %)) (:configurations record))) + (t/is (= [:failed :unattempted :unattempted :unattempted] (mapv :status (:edges record)))) + (t/is (= "comparison-storage" (get-in record [:edges 0 :failure :phase]))) + (t/is (= (get-in outcome [:home :log-path]) (:tail-log outcome))))) + +(t/deftest ^:async edge-analysis-failures-allow-independent-comparisons-to-complete + (create-frontend-root) + (let [prepared (comparison-prepared ["a" "b"]) + removed (path/join (:output-dir prepared) "configs" "00" "run.transit") + outcome (await (feature-comparison/execute + (frontend-root) prepared nil + {:services (comparison-services + {:prepare-build (build-service + {:inspect (fn [{:keys [selection]}] + (when (= ["b"] (:features selection)) + (fs/unlinkSync removed)))}) + :execute-run (execute-service {})})})) + record (saved-comparison outcome)] + (t/is (= 1 (:exit-code outcome))) + (t/is (every? #(= :completed (:status %)) (:configurations record))) + (t/is (= [:failed :failed :completed :completed] (mapv :status (:edges record)))) + (t/is (= ["comparison" "comparison"] (mapv #(get-in % [:failure :phase]) (take 2 (:edges record))))) + (doseq [edge (drop 2 (:edges record))] + (t/is (= :comparison (:type (result/decode (fs/readFileSync (:path edge) "utf8")))))))) + +(t/deftest ^:async post-run-persistence-failure-retains-the-running-configuration + (create-frontend-root) + (let [prepared (comparison-prepared ["a"]) + path (path/join (:output-dir prepared) "feature-comparison.transit") + prior (str path ".saved") + execute (execute-service {}) + outcome (await (feature-comparison/execute + (frontend-root) prepared nil + {:services (comparison-services + {:prepare-build (build-service {}) + :execute-run + (^:async fn [root home build cases options signal] + (let [response (await (execute root home build cases options signal))] + (fs/renameSync path prior) + (fs/mkdirSync path) + response))})})) + record (result/decode (fs/readFileSync prior "utf8")) + run (result/decode (fs/readFileSync (get-in record [:configurations 0 :run :record-path]) "utf8"))] + (t/is (= 1 (:exit-code outcome))) + (t/is (= record (:comparison outcome))) + (t/is (= :running (:status record))) + (t/is (= [:running :planned] (mapv :status (:configurations record)))) + (t/is (= :completed (get-in run [:termination :reason]))) + (t/is (= (get-in outcome [:home :log-path]) (:tail-log outcome))))) + (t/deftest create-home-creates-only-a-fresh-home (create-frontend-root) (let [home (feature-comparison/create-home (frontend-root) "comparison-a" nil)]