From ba514b601ba6be15b823e0a12d4b6e42f9d2489e Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 5 Feb 2019 11:24:44 +0100
Subject: 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
---
 guix/status.scm  | 28 +++++++++++++++++++++++++---
 tests/status.scm | 33 +++++++++++++++++++++++++++++++++
 2 files changed, 58 insertions(+), 3 deletions(-)

diff --git a/guix/status.scm b/guix/status.scm
index 070071d46f..c3c219219d 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -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)))
 
diff --git a/tests/status.scm b/tests/status.scm
index f3afadfcd0..01a61f7345 100644
--- a/tests/status.scm
+++ b/tests/status.scm
@@ -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")
-- 
cgit v1.2.3