aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/status.scm62
-rw-r--r--tests/status.scm31
2 files changed, 89 insertions, 4 deletions
diff --git a/guix/status.scm b/guix/status.scm
index 0a5ff59236..0435d14d6a 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -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)))
diff --git a/tests/status.scm b/tests/status.scm
index e3ea768968..f3afadfcd0 100644
--- a/tests/status.scm
+++ b/tests/status.scm
@@ -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")