mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
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
parent
f674bc6620
commit
976ef2d978
2 changed files with 74 additions and 30 deletions
|
|
@ -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> 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 @@ (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 '())
|
||||
|
|
|
|||
|
|
@ -36,18 +36,18 @@ (define-module (test-status)
|
|||
|
||||
(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 @@ (define-module (test-status)
|
|||
(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 @@ (define-module (test-status)
|
|||
|
||||
(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 @@ (define-module (test-status)
|
|||
#: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 @@ (define-module (test-status)
|
|||
(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 @@ (define-module (test-status)
|
|||
|
||||
(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 @@ (define-module (test-status)
|
|||
#: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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue