mirror of
git://git.savannah.gnu.org/guix/guix-cuirass.git
synced 2024-12-29 11:40:16 +01:00
Register all new outputs in one worker.
Make sure that all registration queries are done from within a single database worker. Otherwise, when builds from multiple evaluations are registered at the same time, some contention occurs communicating with workers. * src/cuirass/base.scm (new-outputs?, build-packages): Move build registration to ... * src/cuirass/database.scm (db-register-builds): ... this new procedure. (with-db-worker-thread-no-timeout): New procedure. Use it in "db-register-builds" to avoid timeout messages.
This commit is contained in:
Mathieu Othacehe
parent
39f6e930ba
commit
ce624ea720
2 changed files with 57 additions and 44 deletions
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue