guix/guix
3
5
Fork 0
mirror of git://git.savannah.gnu.org/guix.git synced 2023-12-14 03:33:07 +01:00
Code Issues Releases Wiki Activity

status: Keep track of build completion as reported by build tools.

Browse source 
* guix/status.scm (<build>)[completion]: New field.
(build): Add #:completion parameter.
(%percentage-line-rx, %fraction-line-rx): New variables.
(update-build): New procedure.
(compute-status): Add 'build-log' case.
* tests/status.scm ("compute-status, build completion"): New test.
This commit is contained in:
Ludovic Courtès 2019-01-27 22:33:16 +01:00
parent 976ef2d978
commit 73a8681a16
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 89 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

62
guix/status.scm
View file

@ -101,16 +101,17 @@
;; On-going or completed build.
(define-record-type <build>
(%build derivation id system log-file)
(%build derivation id system log-file completion)
build?
(derivation build-derivation) ;string (.drv file name)
(id build-id) ;#f | integer
(system build-system) ;string
(log-file build-log-file)) ;#f | string
(log-file build-log-file) ;#f | string
(completion build-completion)) ;#f | integer (percentage)
(define* (build derivation system #:key id log-file)
(define* (build derivation system #:key id log-file completion)
"Return a new build."
(%build derivation id system log-file))
(%build derivation id system log-file completion))
;; On-going or completed downloads. Downloads can be stem from substitutes
;; and from "builtin:download" fixed-output derivations.
@ -141,6 +142,57 @@
(lambda (download)
(string=? item (download-item download))))
(define %percentage-line-rx
;; Things like CMake write lines like "[ 10%] gcc -c …". This regexp
;; matches them.
(make-regexp "^[[:space:]]*\\[ *([0-9]+)%\\]"))
(define %fraction-line-rx
;; The 'compiled-modules' derivations and Ninja produce reports like
;; "[ 1/32]" at the beginning of each line, while GHC prints "[ 6 of 45]".
;; This regexp matches these.
(make-regexp "^[[:space:]]*\\[ *([0-9]+) *(/|of) *([0-9]+)\\]"))
(define (update-build status id line)
"Update STATUS based on LINE, a build output line for ID that might contain
a completion indication."
(define (set-completion b %)
(build (build-derivation b)
(build-system b)
#:id (build-id b)
#:log-file (build-log-file b)
#:completion %))
(define (find-build)
(find (lambda (build)
(and (build-id build)
(= (build-id build) id)))
(build-status-building status)))
(define (update %)
(let ((build (find-build)))
(build-status
(inherit status)
(building (cons (set-completion build %)
(delq build (build-status-building status)))))))
(cond ((string-any #\nul line)
;; Don't try to match a regexp here.
status)
((regexp-exec %percentage-line-rx line)
=>
(lambda (match)
(let ((% (string->number (match:substring match 1))))
(update %))))
((regexp-exec %fraction-line-rx line)
=>
(lambda (match)
(let ((done (string->number (match:substring match 1)))
(total (string->number (match:substring match 3))))
(update (* 100. (/ done total))))))
(else
status)))
(define* (compute-status event status
#:key
(current-time current-time)
@ -242,6 +294,8 @@ compute a new status based on STATUS."
(current-time time-monotonic))
#:transferred transferred)
downloads)))))
(('build-log (? integer? pid) line)
(update-build status pid line))
(_
status)))

31
tests/status.scm
View file

@ -180,4 +180,35 @@
(display "@ build-succeeded bar.drv\n" port)
(list first second (get-status))))))
(test-equal "compute-status, build completion"
(list (build-status
(building (list (build "foo.drv" "x86_64-linux" #:id 121))))
(build-status
(building (list (build "foo.drv" "x86_64-linux" #:id 121
#:completion 0.))))
(build-status
(building (list (build "foo.drv" "x86_64-linux" #:id 121
#:completion 50.))))
(build-status
(builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121
#:completion 100.)))))
(let-values (((port get-status)
(build-event-output-port (lambda (event status)
(compute-status event status
#:current-time
(const 'now))))))
(display "@ build-started foo.drv - x86_64-linux 121\n" port)
(display "@ build-log 121 6\nHello!" port)
(let ((first (get-status)))
(display "@ build-log 121 20\n[ 0/100] building X\n" port)
(display "@ build-log 121 6\nHello!" port)
(let ((second (get-status)))
(display "@ build-log 121 20\n[50/100] building Y\n" port)
(display "@ build-log 121 6\nHello!" port)
(let ((third (get-status)))
(display "@ build-log 121 21\n[100/100] building Z\n" port)
(display "@ build-log 121 6\nHello!" port)
(display "@ build-succeeded foo.drv\n" port)
(list first second third (get-status)))))))
(test-end "status")