[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Mathieu Othacehe |
|
Date: |
Thu, 1 Oct 2020 12:36:30 -0400 (EDT) |
branch: master
commit ce624ea72016d8e41a09798f91570fbf8ee74433
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Tue Sep 29 14:34:14 2020 +0200
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.
---
src/cuirass/base.scm | 46 ++--------------------------------------
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