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

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 73a8681a16869a2b3a9da1c7ba9434e07a204e19
Author: Ludovic Courtès <address@hidden>
Date:   Sun Jan 27 22:33:16 2019 +0100

    status: Keep track of build completion as reported by build tools.
    
    * 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.
---
 guix/status.scm  | 62 ++++++++++++++++++++++++++++++++++++++++++++++++++++----
 tests/status.scm | 31 ++++++++++++++++++++++++++++
 2 files changed, 89 insertions(+), 4 deletions(-)

diff --git a/guix/status.scm b/guix/status.scm
index 0a5ff59..0435d14 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 e3ea768..f3afadf 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")