diff options
| -rw-r--r-- | guix-build-coordinator/coordinator.scm | 23 | ||||
| -rw-r--r-- | guix-build-coordinator/datastore.scm | 1 | ||||
| -rw-r--r-- | guix-build-coordinator/datastore/sqlite.scm | 444 |
3 files changed, 372 insertions, 96 deletions
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm index 9bdb3c6..da4ac25 100644 --- a/guix-build-coordinator/coordinator.scm +++ b/guix-build-coordinator/coordinator.scm @@ -69,6 +69,7 @@ submit-build cancel-build + update-build-priority new-agent new-agent-password set-agent-active @@ -520,6 +521,28 @@ 'build-canceled) #t) +(define (update-build-priority build-coordinator uuid new-priority) + (define datastore (build-coordinator-datastore build-coordinator)) + + (datastore-call-with-transaction + datastore + (lambda (db) + (let ((build-details (datastore-find-build datastore uuid))) + (when (assq-ref build-details 'canceled) + (raise-exception + (make-exception-with-message + "cannot update an already canceled build"))) + + (when (assq-ref build-details 'processed) + (raise-exception + (make-exception-with-message + "cannot update an already processed build")))) + + (datastore-update-build-priority datastore + uuid + new-priority))) + #t) + (define* (new-agent datastore #:key requested-uuid diff --git a/guix-build-coordinator/datastore.scm b/guix-build-coordinator/datastore.scm index 156e637..1dc3320 100644 --- a/guix-build-coordinator/datastore.scm +++ b/guix-build-coordinator/datastore.scm @@ -17,6 +17,7 @@ (re-export datastore-store-derivation) (re-export datastore-insert-build) (re-export datastore-cancel-build) +(re-export datastore-update-build-priority) (re-export datastore-new-agent) (re-export datastore-list-agents) (re-export datastore-set-agent-active) diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm index bf90fc5..d65e007 100644 --- a/guix-build-coordinator/datastore/sqlite.scm +++ b/guix-build-coordinator/datastore/sqlite.scm @@ -2,6 +2,7 @@ #:use-module (oop goops) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 threads) @@ -28,6 +29,7 @@ datastore-list-builds-for-derivation-recursive-inputs datastore-insert-build datastore-cancel-build + datastore-update-build-priority datastore-count-builds datastore-for-each-build datastore-find-build @@ -1126,6 +1128,351 @@ DELETE FROM unprocessed_builds_with_derived_priorities (sqlite-reset statement)))) #t) +(define (db-get-build-priority db build-id) + (let ((statement + (sqlite-prepare + db + " +SELECT priority FROM builds WHERE id = :build_id" + #:cache? #t))) + + (sqlite-bind-arguments + statement + #:build_id build-id) + + (let ((result + (vector-ref (sqlite-step statement) + 0))) + (sqlite-reset statement) + + result))) + +(define (get-derived-priority db build-id) + (let ((statement + (sqlite-prepare + db + " +SELECT max(dependent_unprocessed_builds_with_derived_priorities.derived_priority) +FROM builds +INNER JOIN derivation_outputs + ON builds.derivation_id = derivation_outputs.derivation_id +INNER JOIN derivation_outputs AS all_derivation_outputs + ON all_derivation_outputs.output_id = derivation_outputs.output_id +INNER JOIN derivation_inputs + ON derivation_inputs.derivation_output_id = all_derivation_outputs.id +INNER JOIN builds AS dependent_builds + ON dependent_builds.processed = 0 + AND dependent_builds.canceled = 0 + AND dependent_builds.derivation_id = derivation_inputs.derivation_id +INNER JOIN unprocessed_builds_with_derived_priorities + AS dependent_unprocessed_builds_with_derived_priorities + ON dependent_builds.id = + dependent_unprocessed_builds_with_derived_priorities.build_id +WHERE builds.id = :build_id" + #:cache? #t))) + + (sqlite-bind-arguments + statement + #:build_id build-id) + + (let ((result (match (sqlite-step statement) + (#(#f) + (db-get-build-priority db build-id)) + (#(derived-priority) derived-priority)))) + (sqlite-reset statement) + + result))) + +(define (update-unprocessed-builds-with-higher-derived-priorities + db + build-id + derived-priority) + ;; Recursively find builds for all missing outputs that this build takes + ;; as inputs. These builds should have a derived priority of at least the + ;; derived priority of this build + (let ((find-builds-statement + (sqlite-prepare + db + " +WITH RECURSIVE relevant_builds (id) AS ( + VALUES (:build_id) +UNION + SELECT builds.id + FROM relevant_builds + INNER JOIN builds AS relevant_builds_full + ON relevant_builds.id = relevant_builds_full.id + INNER JOIN derivation_inputs + ON relevant_builds_full.derivation_id = derivation_inputs.derivation_id + INNER JOIN derivation_outputs + ON derivation_inputs.derivation_output_id = derivation_outputs.id + INNER JOIN unbuilt_outputs + ON unbuilt_outputs.output_id = derivation_outputs.output_id + INNER JOIN derivation_outputs AS all_derivation_outputs + ON all_derivation_outputs.output_id = unbuilt_outputs.output_id + INNER JOIN builds + ON builds.processed = 0 + AND builds.derivation_id = all_derivation_outputs.derivation_id +) +SELECT build_id +FROM relevant_builds +INNER JOIN unprocessed_builds_with_derived_priorities + ON relevant_builds.id = unprocessed_builds_with_derived_priorities.build_id +WHERE unprocessed_builds_with_derived_priorities.derived_priority < + :derived_priority" + #:cache? #t)) + + (update-derived-priority-statement + (sqlite-prepare + db + " +UPDATE unprocessed_builds_with_derived_priorities +SET derived_priority = :derived_priority +WHERE build_id = :build_id" + #:cache? #t))) + + (sqlite-bind-arguments + find-builds-statement + #:build_id build-id + #:derived_priority derived-priority) + + (let ((builds-to-update + (call-with-delay-logging + (lambda () + (sqlite-map (lambda (row) + (vector-ref row 0)) + find-builds-statement))))) + (sqlite-reset find-builds-statement) + + (map (lambda (id) + (sqlite-bind-arguments update-derived-priority-statement + #:build_id id + #:derived_priority derived-priority) + (sqlite-step update-derived-priority-statement) + (sqlite-reset update-derived-priority-statement)) + builds-to-update)))) + +(define (update-unprocessed-builds-with-lower-derived-priorities + datastore + build-id + priority-lower-bound) + + (define builds-to-consider + (call-with-worker-thread/delay-logging + (slot-ref datastore 'worker-reader-thread-channel) + (lambda (db) + ;; Recursively find builds for all missing outputs that this build + ;; takes as inputs. The order is important here, since we want to + ;; compute the new derived priorities, starting with the root of the + ;; graph (the build-id build) and working down, as each level is + ;; dependent on the derived priorities of the level above. + (let ((statement + (sqlite-prepare + db + (string-append + " +WITH RECURSIVE relevant_builds (id, level) AS ( + VALUES (:build_id, 0) +UNION + SELECT builds.id, level+1 + FROM relevant_builds + INNER JOIN builds AS relevant_builds_full + ON relevant_builds.id = relevant_builds_full.id + INNER JOIN derivation_inputs + ON relevant_builds_full.derivation_id = derivation_inputs.derivation_id + INNER JOIN derivation_outputs + ON derivation_inputs.derivation_output_id = derivation_outputs.id + INNER JOIN unbuilt_outputs + ON unbuilt_outputs.output_id = derivation_outputs.output_id + INNER JOIN derivation_outputs AS all_derivation_outputs + ON all_derivation_outputs.output_id = unbuilt_outputs.output_id + INNER JOIN builds + ON builds.processed = 0 + AND builds.derivation_id = all_derivation_outputs.derivation_id +) +SELECT build_id, MAX(level) +FROM relevant_builds +INNER JOIN unprocessed_builds_with_derived_priorities + ON relevant_builds.id = unprocessed_builds_with_derived_priorities.build_id" + (if priority-lower-bound + " +WHERE unprocessed_builds_with_derived_priorities.derived_priority > + :priority" + "") + " +GROUP BY build_id +ORDER BY level ASC") + #:cache? #t))) + + (if priority-lower-bound + (sqlite-bind-arguments + statement + #:build_id build-id + #:priority priority-lower-bound) + (sqlite-bind-arguments + statement + #:build_id build-id)) + + (let ((builds-to-consider + (call-with-delay-logging + (lambda () + (sqlite-map (lambda (row) + (vector-ref row 0)) + statement))))) + (sqlite-reset statement) + + builds-to-consider))))) + + (for-each + (lambda (build-id) + (datastore-call-with-transaction + datastore + (lambda (db) + (let ((statement + (sqlite-prepare + db + " +UPDATE unprocessed_builds_with_derived_priorities +SET derived_priority = :derived_priority +WHERE build_id = :build_id" + #:cache? #t)) + + (new-derived-priority + (get-derived-priority db build-id))) + + (sqlite-bind-arguments statement + #:build_id build-id + #:derived_priority new-derived-priority) + (sqlite-step statement) + (sqlite-reset statement))))) + builds-to-consider)) + + +(define-method (datastore-update-build-priority + (datastore <sqlite-datastore>) + . + rest) + + (define (db-get-unprocessed-builds-entry db build-id) + (let ((statement + (sqlite-prepare + db + " +SELECT derived_priority, all_inputs_built +FROM unprocessed_builds_with_derived_priorities +WHERE build_id = :build_id" + #:cache? #t))) + + (sqlite-bind-arguments + statement + #:build_id build-id) + + (match (sqlite-step statement) + (#(derived-priority all-inputs-built) + (sqlite-reset statement) + + (values derived-priority + (eq? 1 all-inputs-built)))))) + + (define (db-update-build-priority db build-id new-priority) + (let ((statement + (sqlite-prepare + db + " +UPDATE builds +SET priority = :priority +WHERE id = :build_id" + #:cache? #t))) + + (sqlite-bind-arguments + statement + #:priority new-priority + #:build_id build-id) + + (sqlite-step statement) + (sqlite-reset statement)) + #t) + + (define (db-update-build-derived-priority db build-id new-derived-priority) + (let ((statement + (sqlite-prepare + db + " +UPDATE unprocessed_builds_with_derived_priorities +SET derived_priority = :derived_priority +WHERE build_id = :build_id" + #:cache? #t))) + + (sqlite-bind-arguments + statement + #:derived_priority new-derived-priority + #:build_id build-id) + + (sqlite-step statement) + (sqlite-reset statement)) + #t) + + (apply + (lambda* (uuid new-priority + #:key skip-updating-other-build-derived-priorities) + (let ((build-id + old-priority + (call-with-worker-thread + (slot-ref datastore 'worker-reader-thread-channel) + (lambda (db) + (let ((build-id + (db-find-build-id db uuid))) + (values + build-id + (db-get-build-priority db build-id))))))) + + (unless (eq? old-priority new-priority) + (datastore-call-with-transaction + datastore + (lambda (db) + (db-update-build-priority db + build-id + new-priority) + + (let ((old-derived-priority + all-inputs-built? + (db-get-unprocessed-builds-entry + db + build-id)) + (new-derived-priority + (max new-priority + (get-derived-priority db build-id)))) + + (unless (eq? old-derived-priority + new-derived-priority) + (db-update-build-derived-priority db + build-id + new-derived-priority)) + + (unless (or all-inputs-built? + skip-updating-other-build-derived-priorities) + (when (> new-derived-priority + old-derived-priority) + (update-unprocessed-builds-with-higher-derived-priorities + db + build-id + new-derived-priority)))))) + + ;; Potentially reduce the derived priorities of builds feeding in to + ;; this build. It isn't ideal that this happens outside of the above + ;; transaction, but since there could be lots of builds to update the + ;; priority of, and a new derived priority has to be calculated for + ;; each one, it's better to handle it afterwards. + (when (< new-priority + old-priority) + (update-unprocessed-builds-with-lower-derived-priorities + datastore + build-id + ;; This acts as a lower bound, since builds feeding in to this + ;; build can't have a derived priority less than new-priority + new-priority)))) + #t) + rest)) + (define-method (datastore-remove-build-from-allocation-plan (datastore <sqlite-datastore>) uuid) @@ -3690,39 +4037,6 @@ RETURNING id" id)))) - (define (get-derived-priority db build-id) - (let ((statement - (sqlite-prepare - db - " -SELECT max(dependent_unprocessed_builds_with_derived_priorities.derived_priority) -FROM builds -INNER JOIN derivation_outputs - ON builds.derivation_id = derivation_outputs.derivation_id -INNER JOIN derivation_outputs AS all_derivation_outputs - ON all_derivation_outputs.output_id = derivation_outputs.output_id -INNER JOIN derivation_inputs - ON derivation_inputs.derivation_output_id = all_derivation_outputs.id -INNER JOIN builds AS dependent_builds - ON dependent_builds.processed = 0 - AND dependent_builds.canceled = 0 - AND dependent_builds.derivation_id = derivation_inputs.derivation_id -INNER JOIN unprocessed_builds_with_derived_priorities AS dependent_unprocessed_builds_with_derived_priorities - ON dependent_builds.id = dependent_unprocessed_builds_with_derived_priorities.build_id -WHERE builds.id = :build_id" - #:cache? #t))) - - (sqlite-bind-arguments - statement - #:build_id build-id) - - (let ((result (match (sqlite-step statement) - (#(#f) #f) - (#(derived-priority) derived-priority)))) - (sqlite-reset statement) - - result))) - (define (all-inputs-built? db build-id) (let ((statement (sqlite-prepare @@ -3773,68 +4087,6 @@ VALUES (:build_id, :derived_priority, :all_inputs_built)" (sqlite-step statement) (sqlite-reset statement))) - (define (update-unprocessed-builds-with-derived-priorities db - build-id - derived-priority) - ;; Recursively find builds for all missing outputs that this build takes - ;; as inputs. These builds should have a derived priority of at least the - ;; derived priority of this build - (let ((find-builds-statement - (sqlite-prepare - db - " -WITH RECURSIVE relevant_builds (id) AS ( - VALUES (:build_id) -UNION - SELECT builds.id - FROM relevant_builds - INNER JOIN builds AS relevant_builds_full - ON relevant_builds.id = relevant_builds_full.id - INNER JOIN derivation_inputs - ON relevant_builds_full.derivation_id = derivation_inputs.derivation_id - INNER JOIN derivation_outputs - ON derivation_inputs.derivation_output_id = derivation_outputs.id - INNER JOIN unbuilt_outputs - ON unbuilt_outputs.output_id = derivation_outputs.output_id - INNER JOIN derivation_outputs AS all_derivation_outputs - ON all_derivation_outputs.output_id = unbuilt_outputs.output_id - INNER JOIN builds - ON builds.processed = 0 - AND builds.derivation_id = all_derivation_outputs.derivation_id -) -SELECT build_id -FROM relevant_builds -INNER JOIN unprocessed_builds_with_derived_priorities - ON relevant_builds.id = unprocessed_builds_with_derived_priorities.build_id -WHERE unprocessed_builds_with_derived_priorities.derived_priority < - :derived_priority" - #:cache? #t)) - - (update-derived-priority-statement - (sqlite-prepare - db - " -UPDATE unprocessed_builds_with_derived_priorities -SET derived_priority = :derived_priority -WHERE build_id = :build_id" - #:cache? #t))) - - (let ((builds-to-update - (call-with-delay-logging - (lambda () - (sqlite-map (lambda (row) - (vector-ref row 0)) - find-builds-statement))))) - (sqlite-reset find-builds-statement) - - (map (lambda (id) - (sqlite-bind-arguments update-derived-priority-statement - #:build_id id - #:derived_priority derived-priority) - (sqlite-step update-derived-priority-statement) - (sqlite-reset update-derived-priority-statement)) - builds-to-update)))) - (apply (lambda* (uuid drv-name priority defer-until #:key skip-updating-other-build-derived-priorities) @@ -3860,7 +4112,7 @@ WHERE build_id = :build_id" (unless (or all-inputs-built? skip-updating-other-build-derived-priorities) (call-with-delay-logging - update-unprocessed-builds-with-derived-priorities + update-unprocessed-builds-with-higher-derived-priorities #:args (list db build-id |