[bug#34228] [PATCH 0/5] Display a progress bar for on-going builds

[bug#34228] [PATCH 0/5] Display a progress bar for on-going builds

[Ludovic Courtès]

Hello Guix!

Some build tools (CMake, Ninja, GHC, etc.) emit progress reports
like “[ 3/42]”.  This patch series is about making use of them
to display a progress bar for on-going builds on --verbosity=1.

This can be tested for example with ‘ghc-libmpd’, ‘hugin’,
‘libinput’, or with our ‘module-import-compiled.drv’.  With
‘libinput’ and ‘hugin’ you get a second progress bar starting
anew for the tests, but that’s reasonable I think.  Eventually,
we could prefix the progress bar by the name of the build phase.

The completion percentage is kept in <build> records referenced
by the <build-status> record.  Then we simply display it as
needed.  (guix self) will now also emit appropriate progress
reports so that ‘guix pull -v1’ is able to print progress bars.

(I had initially implemented it with <build-status> unchanged
and arranged to do the regexp-matching dance only upon ‘-v1’,
but the implementation turned out to be somewhat ugly and it’s
probably OK to regexp-exec build output lines in general—we
already do it for colorization anyway.)

Feedback welcome!

Ludo’.

Ludovic Courtès (5):
  status: Record more information about builds.
  status: Keep track of build completion as reported by build tools.
  status: Print a progress bar for on-going builds when possible.
  self: Produce progress reports compatible with (guix status).
  pull: Default to verbosity level 1.

 guix/scripts/pull.scm |   2 +-
 guix/self.scm         |  18 +++--
 guix/status.scm       | 157 +++++++++++++++++++++++++++++++++++-------
 tests/status.scm      |  59 ++++++++++++----
 4 files changed, 195 insertions(+), 41 deletions(-)

-- 
2.20.1

[bug#34228] [PATCH 1/5] status: Record more information about builds.

[Ludovic Courtès]

* guix/status.scm (<build>): New record type.
(build, matching-build): New procedures.
(compute-status): Adjust to manipulate <build> records instead of
derivation file names in 'build-status-builds-completed' and
'build-status-building'.
(build-event-output-port)[process-line]: Use 'string-split' to preserve
spaces.
* tests/status.scm ("compute-status, builds + substitutes")
("compute-status, missing events"): Adjust to expect <build> records.
Produce complete "build-started" events.
("compute-status, multiplexed build output"): Likewise, and remove
"bar.drv" from 'builds-completed'.
---
 guix/status.scm  | 76 +++++++++++++++++++++++++++++++++++++-----------
 tests/status.scm | 28 +++++++++---------
 2 files changed, 74 insertions(+), 30 deletions(-)

diff --git a/guix/status.scm b/guix/status.scm
index 93e119bed1..0a5ff59236 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -50,6 +50,11 @@
             build-status-builds-completed
             build-status-downloads-completed
 
+            build?
+            build
+            build-derivation
+            build-system
+
             download?
             download
             download-item
@@ -85,15 +90,28 @@
 ;; Builds and substitutions performed by the daemon.
 (define-record-type* <build-status> build-status make-build-status
   build-status?
-  (building     build-status-building             ;list of drv
+  (building     build-status-building             ;list of <build>
                 (default '()))
   (downloading  build-status-downloading          ;list of <download>
                 (default '()))
-  (builds-completed build-status-builds-completed ;list of drv
+  (builds-completed build-status-builds-completed ;list of <build>
                     (default '()))
-  (downloads-completed build-status-downloads-completed ;list of store items
+  (downloads-completed build-status-downloads-completed ;list of <download>
                        (default '())))
 
+;; On-going or completed build.
+(define-record-type <build>
+  (%build derivation id system log-file)
+  build?
+  (derivation  build-derivation)                ;string (.drv file name)
+  (id          build-id)                        ;#f | integer
+  (system      build-system)                    ;string
+  (log-file    build-log-file))                 ;#f | string
+
+(define* (build derivation system #:key id log-file)
+  "Return a new build."
+  (%build derivation id system log-file))
+
 ;; On-going or completed downloads.  Downloads can be stem from substitutes
 ;; and from "builtin:download" fixed-output derivations.
 (define-record-type <download>
@@ -113,6 +131,11 @@
   "Return a new download."
   (%download item uri size start end transferred))
 
+(define (matching-build drv)
+  "Return a predicate that matches builds of DRV."
+  (lambda (build)
+    (string=? drv (build-derivation build))))
+
 (define (matching-download item)
   "Return a predicate that matches downloads of ITEM."
   (lambda (download)
@@ -126,15 +149,29 @@
   "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...),
 compute a new status based on STATUS."
   (match event
-    (('build-started drv _ ...)
-     (build-status
-      (inherit status)
-      (building (cons drv (build-status-building status)))))
+    (('build-started drv "-" system log-file . rest)
+     (let ((build (build drv system
+                         #:id (match rest
+                                ((pid . _) (string->number pid))
+                                (_ #f))
+                         #:log-file (if (string-null? log-file)
+                                        #f
+                                        log-file))))
+       (build-status
+        (inherit status)
+        (building (cons build (build-status-building status))))))
     (((or 'build-succeeded 'build-failed) drv _ ...)
-     (build-status
-      (inherit status)
-      (building (delete drv (build-status-building status)))
-      (builds-completed (cons drv (build-status-builds-completed status)))))
+     (let ((build (find (matching-build drv)
+                        (build-status-building status))))
+       ;; If BUILD is #f, this may be because DRV corresponds to a
+       ;; fixed-output derivation that is listed as a download.
+       (if build
+           (build-status
+            (inherit status)
+            (building (delq build (build-status-building status)))
+            (builds-completed
+             (cons build (build-status-builds-completed status))))
+           status)))
 
     ;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because
     ;; they're not as informative as 'download-started' and
@@ -146,10 +183,11 @@ compute a new status based on STATUS."
      ;; because ITEM is different from DRV's output.
      (build-status
       (inherit status)
-      (building (remove (lambda (drv)
-                          (equal? (false-if-exception
-                                   (derivation-path->output-path drv))
-                                  item))
+      (building (remove (lambda (build)
+                          (let ((drv (build-derivation build)))
+                            (equal? (false-if-exception
+                                     (derivation-path->output-path drv))
+                                    item)))
                         (build-status-building status)))
       (downloading (cons (download item uri #:size size
                                    #:start (current-time time-monotonic))
@@ -394,7 +432,7 @@ addition to build events."
                 (N_ "The following build is still in progress:~%~{  ~a~%~}~%"
                     "The following builds are still in progress:~%~{  ~a~%~}~%"
                     (length ongoing))
-                ongoing))))
+                (map build-derivation ongoing)))))
     (('build-failed drv . _)
      (format port (failure (G_ "build of ~a failed")) drv)
      (newline port)
@@ -570,7 +608,11 @@ The second return value is a thunk to retrieve the current state."
 
   (define (process-line line)
     (cond ((string-prefix? "@ " line)
-           (match (string-tokenize (string-drop line 2))
+           ;; Note: Drop the trailing \n, and use 'string-split' to preserve
+           ;; spaces (the log file part of 'build-started' events can be the
+           ;; empty string.)
+           (match (string-split (string-drop (string-drop-right line 1) 2)
+                                #\space)
              (("build-log" (= string->number pid) (= string->number len))
               (set! %build-output-pid pid)
               (set! %build-output '())
diff --git a/tests/status.scm b/tests/status.scm
index 08a3153218..e3ea768968 100644
--- a/tests/status.scm
+++ b/tests/status.scm
@@ -36,18 +36,18 @@
 
 (test-equal "compute-status, builds + substitutes"
   (list (build-status
-         (building '("foo.drv"))
+         (building (list (build "foo.drv" "x86_64-linux")))
          (downloading (list (download "bar" "http://example.org/bar"
                                       #:size 500
                                       #:start 'now))))
         (build-status
-         (building '("foo.drv"))
+         (building (list (build "foo.drv" "x86_64-linux")))
          (downloading (list (download "bar" "http://example.org/bar"
                                       #:size 500
                                       #:transferred 42
                                       #:start 'now))))
         (build-status
-         (builds-completed '("foo.drv"))
+         (builds-completed (list (build "foo.drv" "x86_64-linux")))
          (downloads-completed (list (download "bar" "http://example.org/bar"
                                               #:size 500
                                               #:transferred 500
@@ -58,7 +58,7 @@
                                            (compute-status event status
                                                            #:current-time
                                                            (const 'now))))))
-    (display "@ build-started foo.drv\n" port)
+    (display "@ build-started foo.drv - x86_64-linux \n" port)
     (display "@ substituter-started bar\n" port)
     (display "@ download-started bar http://example.org/bar 500\n" port)
     (display "various\nthings\nget\nwritten\n" port)
@@ -76,7 +76,8 @@
 
 (test-equal "compute-status, missing events"
   (list (build-status
-         (building '("foo.drv"))
+         (building (list (build "foo.drv" "x86_64-linux"
+                                #:log-file "foo.log")))
          (downloading (list (download "baz" "http://example.org/baz"
                                       #:size 500
                                       #:transferred 42
@@ -86,7 +87,8 @@
                                       #:transferred 0
                                       #:start 'now))))
         (build-status
-         (builds-completed '("foo.drv"))
+         (builds-completed (list (build "foo.drv" "x86_64-linux"
+                                        #:log-file "foo.log")))
          (downloads-completed (list (download "baz" "http://example.org/baz"
                                               #:size 500
                                               #:transferred 500
@@ -103,7 +105,7 @@
                                            (compute-status event status
                                                            #:current-time
                                                            (const 'now))))))
-    (display "@ build-started foo.drv\n" port)
+    (display "@ build-started foo.drv - x86_64-linux foo.log\n" port)
     (display "@ download-started bar http://example.org/bar 999\n" port)
     (display "various\nthings\nget\nwritten\n" port)
     (display "@ download-progress baz http://example.org/baz 500 42\n"
@@ -136,19 +138,19 @@
 
 (test-equal "compute-status, multiplexed build output"
   (list (build-status
-         (building '("foo.drv"))
+         (building (list (build "foo.drv" "x86_64-linux" #:id 121)))
          (downloading (list (download "bar" "http://example.org/bar"
                                       #:size 999
                                       #:start 'now))))
         (build-status
-         (building '("foo.drv"))
+         (building (list (build "foo.drv" "x86_64-linux" #:id 121)))
          (downloading (list (download "bar" "http://example.org/bar"
                                       #:size 999
                                       #:transferred 42
                                       #:start 'now))))
         (build-status
-         ;; XXX: Should "bar.drv" be present twice?
-         (builds-completed '("bar.drv" "foo.drv"))
+         ;; "bar" is now only listed as a download.
+         (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121)))
          (downloads-completed (list (download "bar" "http://example.org/bar"
                                               #:size 999
                                               #:transferred 999
@@ -162,8 +164,8 @@
                                                            #:derivation-path->output-path
                                                            (match-lambda
                                                              ("bar.drv" "bar")))))))
-    (display "@ build-started foo.drv 121\n" port)
-    (display "@ build-started bar.drv 144\n" port)
+    (display "@ build-started foo.drv - x86_64-linux  121\n" port)
+    (display "@ build-started bar.drv - armhf-linux bar.log 144\n" port)
     (display "@ build-log 121 6\nHello!" port)
     (display "@ build-log 144 50
 @ download-started bar http://example.org/bar 999\n" port)
-- 
2.20.1

[bug#34228] [PATCH 2/5] status: Keep track of build completion as reported by build tools.

[Ludovic Courtès]

* 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 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")
-- 
2.20.1

[bug#34228] [PATCH 3/5] status: Print a progress bar for on-going builds when possible.

[Ludovic Courtès]

* guix/status.scm (print-build-event)[report-build-progress]: New
procedure.
[print-log-line]: Add ID parameter.  Call 'report-build-progress' when
appropriate.
Adjust callers.
---
 guix/status.scm | 27 +++++++++++++++++++++------
 1 file changed, 21 insertions(+), 6 deletions(-)

diff --git a/guix/status.scm b/guix/status.scm
index 0435d14d6a..e3375816c5 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -441,14 +441,29 @@ addition to build events."
         (cut colorize-string <> 'RED 'BOLD)
         identity))
 
+  (define (report-build-progress %)
+    (let ((% (min (max % 0) 100)))                ;sanitize
+      (erase-current-line port)
+      (format port "~3d% " (inexact->exact (round %)))
+      (display (progress-bar % (- (current-terminal-columns) 5))
+               port)
+      (force-output port)))
+
   (define print-log-line
     (if print-log?
         (if colorize?
-            (lambda (line)
+            (lambda (id line)
               (display (colorize-log-line line) port))
-            (cut display <> port))
-        (lambda (line)
-          (spin! port))))
+            (lambda (id line)
+              (display line port)))
+        (lambda (id line)
+          (match (build-status-building status)
+            ((build)                              ;single job
+             (match (build-completion build)
+               ((? number? %) (report-build-progress %))
+               (_ (spin! port))))
+            (_
+             (spin! port))))))
 
   (unless print-log?
     (display "\r" port))                          ;erase the spinner
@@ -552,7 +567,7 @@ addition to build events."
                ;; through.
                (display line port)
                (force-output port))
-             (print-log-line line))
+             (print-log-line pid line))
          (cond ((string-prefix? "substitute: " line)
                 ;; The daemon prefixes early messages coming with 'guix
                 ;; substitute' with "substitute:".  These are useful ("updating
@@ -565,7 +580,7 @@ addition to build events."
                 (display (info (string-trim-right line)) port)
                 (newline))
                (else
-                (print-log-line line)))))
+                (print-log-line pid line)))))
     (_
      event)))
 
-- 
2.20.1

[bug#34228] [PATCH 4/5] self: Produce progress reports compatible with (guix status).

[Ludovic Courtès]

* guix/self.scm (compiled-modules)[build](report-load)
(report-compilation): Write "[M/N]" progress reports.
Use line-buffering.
---
 guix/self.scm | 18 ++++++++++++++----
 1 file changed, 14 insertions(+), 4 deletions(-)

diff --git a/guix/self.scm b/guix/self.scm
index d1b8256802..f028bdbfdd 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -856,13 +856,23 @@ containing MODULE-FILES and possibly other files as well."
           (define (report-load file total completed)
             (display #\cr)
             (format #t
-                    "loading...\t~5,1f% of ~d files" ;FIXME: i18n
+                    "[~3@a/~3@a] loading...\t~5,1f% of ~d files"
+
+                    ;; Note: Multiply TOTAL by two to account for the
+                    ;; compilation phase that follows.
+                    completed (* total 2)
+
                     (* 100. (/ completed total)) total)
             (force-output))
 
           (define (report-compilation file total completed)
             (display #\cr)
-            (format #t "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
+            (format #t "[~3@a/~3@a] compiling...\t~5,1f% of ~d files"
+
+                    ;; Add TOTAL to account for the load phase that came
+                    ;; before.
+                    (+ total completed) (* total 2)
+
                     (* 100. (/ completed total)) total)
             (force-output))
 
@@ -874,8 +884,8 @@ containing MODULE-FILES and possibly other files as well."
                              #:report-load report-load
                              #:report-compilation report-compilation)))
 
-          (setvbuf (current-output-port) 'none)
-          (setvbuf (current-error-port) 'none)
+          (setvbuf (current-output-port) 'line)
+          (setvbuf (current-error-port) 'line)
 
           (set! %load-path (cons #+module-tree %load-path))
           (set! %load-path
-- 
2.20.1

[bug#34228] [PATCH 5/5] pull: Default to verbosity level 1.

[Ludovic Courtès]

* guix/scripts/pull.scm (%default-options): Change 'verbosity to 1.
---
 guix/scripts/pull.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 41c7fb289a..32d55f5357 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -69,7 +69,7 @@
     (multiplexed-build-output? . #t)
     (graft? . #t)
     (debug . 0)
-    (verbosity . 2)))
+    (verbosity . 1)))
 
 (define (show-help)
   (display (G_ "Usage: guix pull [OPTION]...
-- 
2.20.1

bug#34228: [PATCH 0/5] Display a progress bar for on-going builds

[Ludovic Courtès]

Ludovic Courtès <ludo@gnu.org> skribis:

> Some build tools (CMake, Ninja, GHC, etc.) emit progress reports
> like “[ 3/42]”.  This patch series is about making use of them
> to display a progress bar for on-going builds on --verbosity=1.

Pushed!

  2790b6670b pull: Default to verbosity level 1.
  35dcaa119e self: Produce progress reports compatible with (guix status).
  3854c6429c status: Print a progress bar for on-going builds when possible.
  73a8681a16 status: Keep track of build completion as reported by build tools.
  976ef2d978 status: Record more information about builds.

Ludo'.

[bug#34228] [PATCH 0/5] Display a progress bar for on-going builds

[Ricardo Wurmus]

Ludovic Courtès <ludo@gnu.org> writes:

> Ludovic Courtès <ludo@gnu.org> skribis:
>
>> Some build tools (CMake, Ninja, GHC, etc.) emit progress reports
>> like “[ 3/42]”.  This patch series is about making use of them
>> to display a progress bar for on-going builds on --verbosity=1.
>
> Pushed!
>
>   2790b6670b pull: Default to verbosity level 1.
>   35dcaa119e self: Produce progress reports compatible with (guix status).
>   3854c6429c status: Print a progress bar for on-going builds when possible.
>   73a8681a16 status: Keep track of build completion as reported by build tools.
>   976ef2d978 status: Record more information about builds.

This is great!  Thank you!

-- 
Ricardo