rekahsoft
/
guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

status: Keep track of the current build phase. 

* guix/status.scm (<build>)[phase]: New field.
(%phase-start-rx): New variable.
(update-build): Add clause to match %PHASE-START-RX and adjust the
'phase' field accordingly.
* tests/status.scm ("compute-status, build phase"): Add test
This commit is contained in:
Ludovic Courtès 2019-02-05 11:24:44 +01:00
parent c7465dcb96
commit ba514b601b
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 58 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
guix/status.scm
View File

@ -55,6 +55,9 @@
build
build-derivation
build-system
build-log-file
build-phase
build-completion
download?
download
@ -102,18 +105,20 @@
;; On-going or completed build.
(define-immutable-record-type <build>
(%build derivation id system log-file completion)
(%build derivation id system log-file phase 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
(phase build-phase ;#f | symbol
set-build-phase)
(completion build-completion ;#f | integer (percentage)
set-build-completion))
(define* (build derivation system #:key id log-file completion)
(define* (build derivation system #:key id log-file phase completion)
"Return a new build."
(%build derivation id system log-file completion))
(%build derivation id system log-file phase completion))
;; On-going or completed downloads. Downloads can be stem from substitutes
;; and from "builtin:download" fixed-output derivations.
@ -144,6 +149,10 @@
(lambda (download)
(string=? item (download-item download))))
(define %phase-start-rx
;; Match the "starting phase" message emitted by 'gnu-build-system'.
(make-regexp "^starting phase [`']([^']+)'"))
(define %percentage-line-rx
;; Things like CMake write lines like "[ 10%] gcc -c …". This regexp
;; matches them.
@ -185,6 +194,19 @@ a completion indication."
(let ((done (string->number (match:substring match 1)))
(total (string->number (match:substring match 3))))
(update (* 100. (/ done total))))))
((regexp-exec %phase-start-rx line)
=>
(lambda (match)
(let ((phase (match:substring match 1))
(build (find-build)))
(if build
(build-status
(inherit status)
(building
(cons (set-build-phase (set-build-completion build #f)
(string->symbol phase))
(delq build (build-status-building status)))))
status))))
(else
status)))

33
tests/status.scm
View File

@ -211,4 +211,37 @@
(display "@ build-succeeded foo.drv\n" port)
(list first second third (get-status)))))))
(test-equal "compute-status, build phase"
(list (build-status
(building (list (build "foo.drv" "x86_64-linux" #:id 121
#:phase 'configure))))
(build-status
(building (list (build "foo.drv" "x86_64-linux" #:id 121
#:phase 'configure
#:completion 50.))))
(build-status
(building (list (build "foo.drv" "x86_64-linux" #:id 121
#:phase 'install))))
(build-status
(builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121
#:phase 'install)))))
(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 27\nstarting phase `configure'\n" port)
(display "@ build-log 121 6\nabcde!" port)
(let ((first (get-status)))
(display "@ build-log 121 20\n[50/100] building Y\n" port)
(display "@ build-log 121 6\nfghik!" port)
(let ((second (get-status)))
(display "@ build-log 121 21\n[100/100] building Z\n" port)
(display "@ build-log 121 25\nstarting phase `install'\n" port)
(display "@ build-log 121 6\nlmnop!" port)
(let ((third (get-status)))
(display "@ build-succeeded foo.drv\n" port)
(list first second third (get-status)))))))
(test-end "status")