nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

status: Record more information about builds. 

* guix/status.scm (<build>): New record type.
(build, matching-build): New procedures.
(compute-status): Adjust to manipulate <build> 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 <build> records.
Produce complete "build-started" events.
("compute-status, multiplexed build output"): Likewise, and remove
"bar.drv" from 'builds-completed'.
This commit is contained in:
Ludovic Courtès 2019-01-27 22:10:13 +01:00
parent f674bc6620
commit 976ef2d978
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 74 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
guix/status.scm
View File

@ -50,6 +50,11 @@
build-status-builds-completed build-status-builds-completed
build-status-downloads-completed build-status-downloads-completed
build?
build
build-derivation
build-system
download? download?
download download
download-item download-item
@ -85,15 +90,28 @@
;; Builds and substitutions performed by the daemon. ;; Builds and substitutions performed by the daemon.
(define-record-type* <build-status> build-status make-build-status (define-record-type* <build-status> build-status make-build-status
build-status? build-status?
(building build-status-building ;list of drv (building build-status-building ;list of <build>
(default '())) (default '()))
(downloading build-status-downloading ;list of <download> (downloading build-status-downloading ;list of <download>
(default '())) (default '()))
(builds-completed build-status-builds-completed ;list of drv (builds-completed build-status-builds-completed ;list of <build>
(default '())) (default '()))
(downloads-completed build-status-downloads-completed ;list of store items (downloads-completed build-status-downloads-completed ;list of <download>
(default '()))) (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 ;; On-going or completed downloads. Downloads can be stem from substitutes
;; and from "builtin:download" fixed-output derivations. ;; and from "builtin:download" fixed-output derivations.
(define-record-type <download> (define-record-type <download>
@ -113,6 +131,11 @@
"Return a new download." "Return a new download."
(%download item uri size start end transferred)) (%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) (define (matching-download item)
"Return a predicate that matches downloads of ITEM." "Return a predicate that matches downloads of ITEM."
(lambda (download) (lambda (download)
@ -126,15 +149,29 @@
"Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...), "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...),
compute a new status based on STATUS." compute a new status based on STATUS."
(match event (match event
(('build-started drv _ ...) (('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 (build-status
(inherit status) (inherit status)
(building (cons drv (build-status-building status))))) (building (cons build (build-status-building status))))))
(((or 'build-succeeded 'build-failed) drv _ ...) (((or 'build-succeeded 'build-failed) drv _ ...)
(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 (build-status
(inherit status) (inherit status)
(building (delete drv (build-status-building status))) (building (delq build (build-status-building status)))
(builds-completed (cons drv (build-status-builds-completed status))))) (builds-completed
(cons build (build-status-builds-completed status))))
status)))
;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because ;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because
;; they're not as informative as 'download-started' and ;; 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. ;; because ITEM is different from DRV's output.
(build-status (build-status
(inherit status) (inherit status)
(building (remove (lambda (drv) (building (remove (lambda (build)
(let ((drv (build-derivation build)))
(equal? (false-if-exception (equal? (false-if-exception
(derivation-path->output-path drv)) (derivation-path->output-path drv))
item)) item)))
(build-status-building status))) (build-status-building status)))
(downloading (cons (download item uri #:size size (downloading (cons (download item uri #:size size
#:start (current-time time-monotonic)) #:start (current-time time-monotonic))
@ -394,7 +432,7 @@ addition to build events."
(N_ "The following build is still in progress:~%~{ ~a~%~}~%" (N_ "The following build is still in progress:~%~{ ~a~%~}~%"
"The following builds are still in progress:~%~{ ~a~%~}~%" "The following builds are still in progress:~%~{ ~a~%~}~%"
(length ongoing)) (length ongoing))
ongoing)))) (map build-derivation ongoing)))))
(('build-failed drv . _) (('build-failed drv . _)
(format port (failure (G_ "build of ~a failed")) drv) (format port (failure (G_ "build of ~a failed")) drv)
(newline port) (newline port)
@ -570,7 +608,11 @@ The second return value is a thunk to retrieve the current state."
(define (process-line line) (define (process-line line)
(cond ((string-prefix? "@ " 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)) (("build-log" (= string->number pid) (= string->number len))
(set! %build-output-pid pid) (set! %build-output-pid pid)
(set! %build-output '()) (set! %build-output '())

28
tests/status.scm
View File

@ -36,18 +36,18 @@
(test-equal "compute-status, builds + substitutes" (test-equal "compute-status, builds + substitutes"
(list (build-status (list (build-status
(building '("foo.drv")) (building (list (build "foo.drv" "x86_64-linux")))
(downloading (list (download "bar" "http://example.org/bar" (downloading (list (download "bar" "http://example.org/bar"
#:size 500 #:size 500
#:start 'now)))) #:start 'now))))
(build-status (build-status
(building '("foo.drv")) (building (list (build "foo.drv" "x86_64-linux")))
(downloading (list (download "bar" "http://example.org/bar" (downloading (list (download "bar" "http://example.org/bar"
#:size 500 #:size 500
#:transferred 42 #:transferred 42
#:start 'now)))) #:start 'now))))
(build-status (build-status
(builds-completed '("foo.drv")) (builds-completed (list (build "foo.drv" "x86_64-linux")))
(downloads-completed (list (download "bar" "http://example.org/bar" (downloads-completed (list (download "bar" "http://example.org/bar"
#:size 500 #:size 500
#:transferred 500 #:transferred 500
@ -58,7 +58,7 @@
(compute-status event status (compute-status event status
#:current-time #:current-time
(const 'now)))))) (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 "@ substituter-started bar\n" port)
(display "@ download-started bar http://example.org/bar 500\n" port) (display "@ download-started bar http://example.org/bar 500\n" port)
(display "various\nthings\nget\nwritten\n" port) (display "various\nthings\nget\nwritten\n" port)
@ -76,7 +76,8 @@
(test-equal "compute-status, missing events" (test-equal "compute-status, missing events"
(list (build-status (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" (downloading (list (download "baz" "http://example.org/baz"
#:size 500 #:size 500
#:transferred 42 #:transferred 42
@ -86,7 +87,8 @@
#:transferred 0 #:transferred 0
#:start 'now)))) #:start 'now))))
(build-status (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" (downloads-completed (list (download "baz" "http://example.org/baz"
#:size 500 #:size 500
#:transferred 500 #:transferred 500
@ -103,7 +105,7 @@
(compute-status event status (compute-status event status
#:current-time #:current-time
(const 'now)))))) (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 "@ download-started bar http://example.org/bar 999\n" port)
(display "various\nthings\nget\nwritten\n" port) (display "various\nthings\nget\nwritten\n" port)
(display "@ download-progress baz http://example.org/baz 500 42\n" (display "@ download-progress baz http://example.org/baz 500 42\n"
@ -136,19 +138,19 @@
(test-equal "compute-status, multiplexed build output" (test-equal "compute-status, multiplexed build output"
(list (build-status (list (build-status
(building '("foo.drv")) (building (list (build "foo.drv" "x86_64-linux" #:id 121)))
(downloading (list (download "bar" "http://example.org/bar" (downloading (list (download "bar" "http://example.org/bar"
#:size 999 #:size 999
#:start 'now)))) #:start 'now))))
(build-status (build-status
(building '("foo.drv")) (building (list (build "foo.drv" "x86_64-linux" #:id 121)))
(downloading (list (download "bar" "http://example.org/bar" (downloading (list (download "bar" "http://example.org/bar"
#:size 999 #:size 999
#:transferred 42 #:transferred 42
#:start 'now)))) #:start 'now))))
(build-status (build-status
;; XXX: Should "bar.drv" be present twice? ;; "bar" is now only listed as a download.
(builds-completed '("bar.drv" "foo.drv")) (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121)))
(downloads-completed (list (download "bar" "http://example.org/bar" (downloads-completed (list (download "bar" "http://example.org/bar"
#:size 999 #:size 999
#:transferred 999 #:transferred 999
@ -162,8 +164,8 @@
#:derivation-path->output-path #:derivation-path->output-path
(match-lambda (match-lambda
("bar.drv" "bar"))))))) ("bar.drv" "bar")))))))
(display "@ build-started foo.drv 121\n" port) (display "@ build-started foo.drv - x86_64-linux 121\n" port)
(display "@ build-started bar.drv 144\n" port) (display "@ build-started bar.drv - armhf-linux bar.log 144\n" port)
(display "@ build-log 121 6\nHello!" port) (display "@ build-log 121 6\nHello!" port)
(display "@ build-log 144 50 (display "@ build-log 144 50
@ download-started bar http://example.org/bar 999\n" port) @ download-started bar http://example.org/bar 999\n" port)