mirror of
https://github.com/penpot/penpot.git
synced 2026-10-30 22:40:33 +00:00
🚧 WIP 29.2, refactor feature comparisons
This commit is contained in:
Miguel de Benito Delgado
parent
9beb37fc2b
commit
08a335b035
@ -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))))))
|
||||
|
||||
@ -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)]
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user