diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/cuirass/base.scm | 46 | ||||
-rw-r--r-- | src/cuirass/database.scm | 55 |
2 files changed, 57 insertions, 44 deletions
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm index d672177..ad15ef9 100644 --- a/src/cuirass/base.scm +++ b/src/cuirass/base.scm @@ -686,53 +686,11 @@ by PRODUCT-SPECS." (#:path . ,product)))))) product-specs)) -(define (new-outputs? outputs) - "Return #t if OUTPUTS contains at least one unregistered output and #f -otherwise." - (let ((new-outputs - (filter-map (match-lambda - ((name . path) - (let ((drv (db-get-output path))) - (and (not drv) path)))) - outputs))) - (not (null? new-outputs)))) - (define (build-packages store jobs eval-id) "Build JOBS and return a list of Build results." - (define (register job) - (let* ((name (assq-ref job #:job-name)) - (drv (assq-ref job #:derivation)) - (job-name (assq-ref job #:job-name)) - (system (assq-ref job #:system)) - (nix-name (assq-ref job #:nix-name)) - ;; XXX: How to keep logs from several attempts? - (log (log-file store drv)) - (outputs (filter-map (lambda (res) - (match res - ((name . path) - `(,name . ,path)))) - (derivation-path->output-paths drv))) - (cur-time (time-second (current-time time-utc)))) - (and (new-outputs? outputs) - (let ((build `((#:derivation . ,drv) - (#:eval-id . ,eval-id) - (#:job-name . ,job-name) - (#:system . ,system) - (#:nix-name . ,nix-name) - - ;; XXX: We'd leave LOG to #f (i.e., NULL) but that - ;; currently violates the non-NULL constraint. - (#:log . ,(or log "")) - - (#:status . ,(build-status scheduled)) - (#:outputs . ,outputs) - (#:timestamp . ,cur-time) - (#:starttime . 0) - (#:stoptime . 0)))) - (db-add-build build))))) - (define derivations - (with-time-logging "registration" (filter-map register jobs))) + (with-time-logging "registration" + (db-register-builds store jobs eval-id))) (log-message "evaluation ~a registered ~a new derivations" eval-id (length derivations)) diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index c67a234..4de94f4 100644 --- a/src/cuirass/database.scm +++ b/src/cuirass/database.scm @@ -22,6 +22,8 @@ ;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>. (define-module (cuirass database) + #:use-module (guix derivations) + #:use-module (guix store) #:use-module (cuirass logging) #:use-module (cuirass config) #:use-module (cuirass utils) @@ -58,6 +60,7 @@ build-status db-add-build db-add-build-product + db-register-builds db-update-build-status! db-get-output db-get-inputs @@ -204,6 +207,14 @@ connection." (format #f "Database worker unresponsive for ~a seconds." (number->string timeout))))))) +(define-syntax-rule (with-db-worker-thread-no-timeout db exp ...) + "This is similar to WITH-DB-WORKER-THREAD but it does not setup a timeout. +This should be used with care as blocking too long in EXP can lead to workers +starvation." + (call-with-worker-thread + (%db-channel) + (lambda (db) exp ...))) + (define (read-sql-file file-name) "Return a list of string containing SQL instructions from FILE-NAME." (call-with-input-file file-name @@ -632,6 +643,50 @@ path) VALUES (" (assq-ref product #:path) ");") (last-insert-rowid db))) +(define (db-register-builds store jobs eval-id) + (define (new-outputs? outputs) + (let ((new-outputs + (filter-map (match-lambda + ((name . path) + (let ((drv (db-get-output path))) + (and (not drv) path)))) + outputs))) + (not (null? new-outputs)))) + + (define (register job) + (let* ((name (assq-ref job #:job-name)) + (drv (assq-ref job #:derivation)) + (job-name (assq-ref job #:job-name)) + (system (assq-ref job #:system)) + (nix-name (assq-ref job #:nix-name)) + ;; XXX: How to keep logs from several attempts? + (log (log-file store drv)) + (outputs (filter-map (lambda (res) + (match res + ((name . path) + `(,name . ,path)))) + (derivation-path->output-paths drv))) + (cur-time (time-second (current-time time-utc)))) + (and (new-outputs? outputs) + (let ((build `((#:derivation . ,drv) + (#:eval-id . ,eval-id) + (#:job-name . ,job-name) + (#:system . ,system) + (#:nix-name . ,nix-name) + + ;; XXX: We'd leave LOG to #f (i.e., NULL) but that + ;; currently violates the non-NULL constraint. + (#:log . ,(or log "")) + + (#:status . ,(build-status scheduled)) + (#:outputs . ,outputs) + (#:timestamp . ,cur-time) + (#:starttime . 0) + (#:stoptime . 0)))) + (db-add-build build))))) + + (with-db-worker-thread-no-timeout db (filter-map register jobs))) + (define* (db-update-build-status! drv status #:key log-file) "Update the database so that DRV's status is STATUS. This also updates the 'starttime' or 'stoptime' fields. If LOG-FILE is true, record it as the build |