From 73a8681a16869a2b3a9da1c7ba9434e07a204e19 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 27 Jan 2019 22:33:16 +0100
Subject: 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 +++++++++++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 58 insertions(+), 4 deletions(-)

(limited to 'guix')

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 @@ (define-record-type* <build-status> build-status make-build-status
 
 ;; 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 @@ (define (matching-download item)
   (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 @@ (define* (compute-status event status
                                          (current-time time-monotonic))
                                      #:transferred transferred)
                            downloads)))))
+    (('build-log (? integer? pid) line)
+     (update-build status pid line))
     (_
      status)))
 
-- 
cgit v1.2.3