diff options
| -rw-r--r-- | guix/status.scm | 76 | ||||
| -rw-r--r-- | tests/status.scm | 28 |
2 files changed, 74 insertions, 30 deletions
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 @@ build-status-builds-completed build-status-downloads-completed + build? + build + build-derivation + build-system + download? download download-item @@ -85,15 +90,28 @@ ;; Builds and substitutions performed by the daemon. (define-record-type* <build-status> build-status make-build-status build-status? - (building build-status-building ;list of drv + (building build-status-building ;list of <build> (default '())) (downloading build-status-downloading ;list of <download> (default '())) - (builds-completed build-status-builds-completed ;list of drv + (builds-completed build-status-builds-completed ;list of <build> (default '())) - (downloads-completed build-status-downloads-completed ;list of store items + (downloads-completed build-status-downloads-completed ;list of <download> (default '()))) +;; On-going or completed build. +(define-record-type <build> + (%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 <download> @@ -113,6 +131,11 @@ "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 @@ "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 @@ compute a new status based on 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 @@ addition to build events." (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 @@ The second return value is a thunk to retrieve the current state." (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 '()) diff --git a/tests/status.scm b/tests/status.scm index 08a3153218..e3ea768968 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -36,18 +36,18 @@ (test-equal "compute-status, builds + substitutes" (list (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux"))) (downloading (list (download "bar" "http://example.org/bar" #:size 500 #:start 'now)))) (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux"))) (downloading (list (download "bar" "http://example.org/bar" #:size 500 #:transferred 42 #:start 'now)))) (build-status - (builds-completed '("foo.drv")) + (builds-completed (list (build "foo.drv" "x86_64-linux"))) (downloads-completed (list (download "bar" "http://example.org/bar" #:size 500 #:transferred 500 @@ -58,7 +58,7 @@ (compute-status event status #:current-time (const 'now)))))) - (display "@ build-started foo.drv\n" port) + (display "@ build-started foo.drv - x86_64-linux \n" port) (display "@ substituter-started bar\n" port) (display "@ download-started bar http://example.org/bar 500\n" port) (display "various\nthings\nget\nwritten\n" port) @@ -76,7 +76,8 @@ (test-equal "compute-status, missing events" (list (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux" + #:log-file "foo.log"))) (downloading (list (download "baz" "http://example.org/baz" #:size 500 #:transferred 42 @@ -86,7 +87,8 @@ #:transferred 0 #:start 'now)))) (build-status - (builds-completed '("foo.drv")) + (builds-completed (list (build "foo.drv" "x86_64-linux" + #:log-file "foo.log"))) (downloads-completed (list (download "baz" "http://example.org/baz" #:size 500 #:transferred 500 @@ -103,7 +105,7 @@ (compute-status event status #:current-time (const 'now)))))) - (display "@ build-started foo.drv\n" port) + (display "@ build-started foo.drv - x86_64-linux foo.log\n" port) (display "@ download-started bar http://example.org/bar 999\n" port) (display "various\nthings\nget\nwritten\n" port) (display "@ download-progress baz http://example.org/baz 500 42\n" @@ -136,19 +138,19 @@ (test-equal "compute-status, multiplexed build output" (list (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux" #:id 121))) (downloading (list (download "bar" "http://example.org/bar" #:size 999 #:start 'now)))) (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux" #:id 121))) (downloading (list (download "bar" "http://example.org/bar" #:size 999 #:transferred 42 #:start 'now)))) (build-status - ;; XXX: Should "bar.drv" be present twice? - (builds-completed '("bar.drv" "foo.drv")) + ;; "bar" is now only listed as a download. + (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121))) (downloads-completed (list (download "bar" "http://example.org/bar" #:size 999 #:transferred 999 @@ -162,8 +164,8 @@ #:derivation-path->output-path (match-lambda ("bar.drv" "bar"))))))) - (display "@ build-started foo.drv 121\n" port) - (display "@ build-started bar.drv 144\n" port) + (display "@ build-started foo.drv - x86_64-linux 121\n" port) + (display "@ build-started bar.drv - armhf-linux bar.log 144\n" port) (display "@ build-log 121 6\nHello!" port) (display "@ build-log 144 50 @ download-started bar http://example.org/bar 999\n" port) |