From f9a8fce10f2d99efec7cb1dd0f6c5f0df9d1b2df Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 15 Oct 2018 23:06:55 +0200
Subject: status: Build upon multiplexed build output.

This allows for more accurate status tracking and parsing of extended
build traces.

* guix/status.scm (multiplexed-output-supported?): New procedure.
(print-build-event): Don't print \r when PRINT-LOG? is true.
Adjust 'build-log' handling for when 'multiplexed-output-supported?'
returns true.
(bytevector-index, split-lines): New procedures.
(build-event-output-port)[%build-output-pid, %build-output]
[%build-output-left]: New variables.
[process-line]: Handle "@ build-output" traces.
[process-build-output]: New procedure.
[write!]: Add case for when %BUILD-OUTPUT-PID is true.  Use
'bytevector-index' rather than 'string-index'.
(compute-status): Add #:derivation-path->output-path.  Use it.
* tests/status.scm ("compute-status, multiplexed build output"):
New test.
("build-output-port, UTF-8")
("current-build-output-port, UTF-8 + garbage"): Adjust to new
'build-log' output.
* guix/scripts/build.scm (set-build-options-from-command-line):
Pass #:multiplexed-build-output?.
(%default-options): Add 'multiplexed-build-output?'.
* guix/scripts/environment.scm (%default-options): Likewise.
* guix/scripts/pack.scm (%default-options): Likewise.
* guix/scripts/package.scm (%default-options): Likewise.
* guix/scripts/pull.scm (%default-options): Likewise.
* guix/scripts/system.scm (%default-options): Likewise.
---
 tests/status.scm | 51 ++++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 48 insertions(+), 3 deletions(-)

(limited to 'tests/status.scm')

diff --git a/tests/status.scm b/tests/status.scm
index 486ad04dd2..3b74946673 100644
--- a/tests/status.scm
+++ b/tests/status.scm
@@ -22,7 +22,8 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs bytevectors)
-  #:use-module (rnrs io ports))
+  #:use-module (rnrs io ports)
+  #:use-module (ice-9 match))
 
 (test-begin "status")
 
@@ -115,7 +116,7 @@
       (list first (get-status)))))
 
 (test-equal "build-output-port, UTF-8"
-  '((build-log "lambda is λ!\n"))
+  '((build-log #f "lambda is λ!\n"))
   (let-values (((port get-status) (build-event-output-port cons '()))
                ((bv)              (string->utf8 "lambda is λ!\n")))
     (put-bytevector port bv)
@@ -124,7 +125,7 @@
 
 (test-equal "current-build-output-port, UTF-8 + garbage"
   ;; What about a mixture of UTF-8 + garbage?
-  '((build-log "garbage: �lambda: λ\n"))
+  '((build-log #f "garbage: �lambda: λ\n"))
   (let-values (((port get-status) (build-event-output-port cons '())))
     (display "garbage: " port)
     (put-bytevector port #vu8(128))
@@ -132,4 +133,48 @@
     (force-output port)
     (get-status)))
 
+(test-equal "compute-status, multiplexed build output"
+  (list (build-status
+         (building '("foo.drv"))
+         (downloading (list (download "bar" "http://example.org/bar"
+                                      #:size 999
+                                      #:start 'now))))
+        (build-status
+         (building '("foo.drv"))
+         (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"))
+         (downloads-completed (list (download "bar" "http://example.org/bar"
+                                              #:size 999
+                                              #:transferred 999
+                                              #:start 'now
+                                              #:end 'now)))))
+  (let-values (((port get-status)
+                (build-event-output-port (lambda (event status)
+                                           (compute-status event status
+                                                           #:current-time
+                                                           (const 'now)
+                                                           #: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-log 121 6\nHello!" port)
+    (display "@ build-log 144 50
+@ download-started bar http://example.org/bar 999\n" port)
+    (let ((first (get-status)))
+      (display "@ build-log 121 30\n@ build-started FAKE!.drv 555\n")
+      (display "@ build-log 144 54
+@ download-progress bar http://example.org/bar 999 42\n"
+               port)
+      (let ((second (get-status)))
+        (display "@ download-succeeded bar http://example.org/bar 999\n" port)
+        (display "@ build-succeeded foo.drv\n" port)
+        (display "@ build-succeeded bar.drv\n" port)
+        (list first second (get-status))))))
+
 (test-end "status")
-- 
cgit v1.2.3