From 976ef2d97887d16eab8d4eb9dad811786b04d690 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Jan 2019 22:10:13 +0100 Subject: status: Record more information about builds. * guix/status.scm (): New record type. (build, matching-build): New procedures. (compute-status): Adjust to manipulate records instead of derivation file names in 'build-status-builds-completed' and 'build-status-building'. (build-event-output-port)[process-line]: Use 'string-split' to preserve spaces. * tests/status.scm ("compute-status, builds + substitutes") ("compute-status, missing events"): Adjust to expect records. Produce complete "build-started" events. ("compute-status, multiplexed build output"): Likewise, and remove "bar.drv" from 'builds-completed'. --- guix/status.scm | 76 ++++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 59 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 93e119bed1..0a5ff59236 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -50,6 +50,11 @@ (define-module (guix status) build-status-builds-completed build-status-downloads-completed + build? + build + build-derivation + build-system + download? download download-item @@ -85,15 +90,28 @@ (define-module (guix status) ;; Builds and substitutions performed by the daemon. (define-record-type* build-status make-build-status build-status? - (building build-status-building ;list of drv + (building build-status-building ;list of (default '())) (downloading build-status-downloading ;list of (default '())) - (builds-completed build-status-builds-completed ;list of drv + (builds-completed build-status-builds-completed ;list of (default '())) - (downloads-completed build-status-downloads-completed ;list of store items + (downloads-completed build-status-downloads-completed ;list of (default '()))) +;; On-going or completed build. +(define-record-type + (%build derivation id system log-file) + build? + (derivation build-derivation) ;string (.drv file name) + (id build-id) ;#f | integer + (system build-system) ;string + (log-file build-log-file)) ;#f | string + +(define* (build derivation system #:key id log-file) + "Return a new build." + (%build derivation id system log-file)) + ;; On-going or completed downloads. Downloads can be stem from substitutes ;; and from "builtin:download" fixed-output derivations. (define-record-type @@ -113,6 +131,11 @@ (define* (download item uri "Return a new download." (%download item uri size start end transferred)) +(define (matching-build drv) + "Return a predicate that matches builds of DRV." + (lambda (build) + (string=? drv (build-derivation build)))) + (define (matching-download item) "Return a predicate that matches downloads of ITEM." (lambda (download) @@ -126,15 +149,29 @@ (define* (compute-status event status "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...), compute a new status based on STATUS." (match event - (('build-started drv _ ...) - (build-status - (inherit status) - (building (cons drv (build-status-building status))))) + (('build-started drv "-" system log-file . rest) + (let ((build (build drv system + #:id (match rest + ((pid . _) (string->number pid)) + (_ #f)) + #:log-file (if (string-null? log-file) + #f + log-file)))) + (build-status + (inherit status) + (building (cons build (build-status-building status)))))) (((or 'build-succeeded 'build-failed) drv _ ...) - (build-status - (inherit status) - (building (delete drv (build-status-building status))) - (builds-completed (cons drv (build-status-builds-completed status))))) + (let ((build (find (matching-build drv) + (build-status-building status)))) + ;; If BUILD is #f, this may be because DRV corresponds to a + ;; fixed-output derivation that is listed as a download. + (if build + (build-status + (inherit status) + (building (delq build (build-status-building status))) + (builds-completed + (cons build (build-status-builds-completed status)))) + status))) ;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because ;; they're not as informative as 'download-started' and @@ -146,10 +183,11 @@ (define* (compute-status event status ;; because ITEM is different from DRV's output. (build-status (inherit status) - (building (remove (lambda (drv) - (equal? (false-if-exception - (derivation-path->output-path drv)) - item)) + (building (remove (lambda (build) + (let ((drv (build-derivation build))) + (equal? (false-if-exception + (derivation-path->output-path drv)) + item))) (build-status-building status))) (downloading (cons (download item uri #:size size #:start (current-time time-monotonic)) @@ -394,7 +432,7 @@ (define print-log-line (N_ "The following build is still in progress:~%~{ ~a~%~}~%" "The following builds are still in progress:~%~{ ~a~%~}~%" (length ongoing)) - ongoing)))) + (map build-derivation ongoing))))) (('build-failed drv . _) (format port (failure (G_ "build of ~a failed")) drv) (newline port) @@ -570,7 +608,11 @@ (define %build-output-left #f) (define (process-line line) (cond ((string-prefix? "@ " line) - (match (string-tokenize (string-drop line 2)) + ;; Note: Drop the trailing \n, and use 'string-split' to preserve + ;; spaces (the log file part of 'build-started' events can be the + ;; empty string.) + (match (string-split (string-drop (string-drop-right line 1) 2) + #\space) (("build-log" (= string->number pid) (= string->number len)) (set! %build-output-pid pid) (set! %build-output '()) -- cgit v1.2.3