[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/02: status: Build upon multiplexed build output.
|
From: |
Ludovic Court鑣 |
|
Subject: |
02/02: status: Build upon multiplexed build output. |
|
Date: |
Mon, 15 Oct 2018 17:25:01 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit f9a8fce10f2d99efec7cb1dd0f6c5f0df9d1b2df
Author: Ludovic Court猫s <address@hidden>
Date: Mon Oct 15 23:06:55 2018 +0200
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.
---
guix/scripts/build.scm | 3 +
guix/scripts/environment.scm | 1 +
guix/scripts/pack.scm | 1 +
guix/scripts/package.scm | 3 +-
guix/scripts/pull.scm | 1 +
guix/scripts/system.scm | 1 +
guix/status.scm | 169 ++++++++++++++++++++++++++++++++-----------
tests/status.scm | 51 ++++++++++++-
8 files changed, 184 insertions(+), 46 deletions(-)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index f3aa551..13978ab 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -395,6 +395,8 @@ options handled by 'set-build-options-from-command-line',
and listed in
#:print-build-trace (assoc-ref opts 'print-build-trace?)
#:print-extended-build-trace?
(assoc-ref opts 'print-extended-build-trace?)
+ #:multiplexed-build-output?
+ (assoc-ref opts 'multiplexed-build-output?)
#:verbosity (assoc-ref opts 'verbosity)))
(define set-build-options-from-command-line*
@@ -505,6 +507,7 @@ options handled by 'set-build-options-from-command-line',
and listed in
(build-hook? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
(verbosity . 0)))
(define (show-help)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 9fc7edc..5965e34 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -176,6 +176,7 @@ COMMAND or an interactive shell in that environment.\n"))
(graft? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
(verbosity . 0)))
(define (tag-package-arg opts arg)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 163f5b1..fb3c505 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -541,6 +541,7 @@ please email '~a'~%")
(graft? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
(verbosity . 0)
(symlinks . ())
(compressor . ,(first %compressors))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index e588ff8..5d146b8 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -296,7 +296,8 @@ ENTRIES, a list of manifest entries, in the context of
PROFILE."
(substitutes? . #t)
(build-hook? . #t)
(print-build-trace? . #t)
- (print-extended-build-trace? . #t)))
+ (print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)))
(define (show-help)
(display (G_ "Usage: guix package [OPTION]...
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index d3fd624..188237a 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -64,6 +64,7 @@
(build-hook? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
(graft? . #t)
(verbosity . 0)))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index f9d6b9e..f9af38b 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1082,6 +1082,7 @@ Some ACTIONS support additional ARGS.\n"))
(build-hook? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
(graft? . #t)
(verbosity . 0)
(file-system-type . "ext4")
diff --git a/guix/status.scm b/guix/status.scm
index d8d761d..8e05d4e 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -116,7 +116,10 @@
(string=? item (download-item download))))
(define* (compute-status event status
- #:key (current-time current-time))
+ #:key
+ (current-time current-time)
+ (derivation-path->output-path
+ derivation-path->output-path))
"Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...),
compute a new status based on STATUS."
(match event
@@ -142,8 +145,7 @@ compute a new status based on STATUS."
(inherit status)
(building (remove (lambda (drv)
(equal? (false-if-exception
- (derivation->output-path
- (read-derivation-from-file drv)))
+ (derivation-path->output-path drv))
item))
(build-status-building status)))
(downloading (cons (download item uri #:size size
@@ -219,6 +221,12 @@ build traces\" such as \"@ download-progress\" traces."
(and (current-store-protocol-version)
(>= (current-store-protocol-version) #x162)))
+(define (multiplexed-output-supported?)
+ "Return true if the daemon supports \"multiplexed output\"--i.e., \"@
+build-log\" traces."
+ (and (current-store-protocol-version)
+ (>= (current-store-protocol-version) #x163)))
+
(define spin!
(let ((steps (circular-list "\\" "|" "/" "-")))
(lambda (port)
@@ -313,7 +321,8 @@ addition to build events."
(lambda (line)
(spin! port))))
- (display "\r" port) ;erase the spinner
+ (unless print-log?
+ (display "\r" port)) ;erase the spinner
(match event
(('build-started drv . _)
(format port (info (G_ "building ~a...")) drv)
@@ -384,21 +393,28 @@ addition to build events."
expected hash: ~a
actual hash: ~a~%"))
expected actual))
- (('build-log line)
- ;; TODO: Better distinguish daemon messages and build log lines.
- (cond ((string-prefix? "substitute: " line)
- ;; The daemon prefixes early messages coming with 'guix
- ;; substitute' with "substitute:". These are useful ("updating
- ;; substitutes from URL"), so let them through.
- (format port line)
- (force-output port))
- ((string-prefix? "waiting for locks" line)
- ;; This is when a derivation is already being built and we're just
- ;; waiting for the build to complete.
- (display (info (string-trim-right line)) port)
- (newline))
- (else
- (print-log-line line))))
+ (('build-log pid line)
+ (if (multiplexed-output-supported?)
+ (if (not pid)
+ (begin
+ ;; LINE comes from the daemon, not from builders. Let it
+ ;; through.
+ (display line port)
+ (force-output port))
+ (print-log-line line))
+ (cond ((string-prefix? "substitute: " line)
+ ;; The daemon prefixes early messages coming with 'guix
+ ;; substitute' with "substitute:". These are useful ("updating
+ ;; substitutes from URL"), so let them through.
+ (display line port)
+ (force-output port))
+ ((string-prefix? "waiting for locks" line)
+ ;; This is when a derivation is already being built and we're
just
+ ;; waiting for the build to complete.
+ (display (info (string-trim-right line)) port)
+ (newline))
+ (else
+ (print-log-line line)))))
(_
event)))
@@ -428,9 +444,6 @@ ON-CHANGE can display the build status, build events, etc."
;;; Build port.
;;;
-(define %newline
- (char-set #\return #\newline))
-
(define (maybe-utf8->string bv)
"Attempt to decode BV as UTF-8 string and return it. Gracefully handle the
case where BV does not contain only valid UTF-8."
@@ -447,6 +460,28 @@ case where BV does not contain only valid UTF-8."
(close-port port)
str)))))
+(define (bytevector-index bv number offset count)
+ "Search for NUMBER in BV starting from OFFSET and reading up to COUNT bytes;
+return the offset where NUMBER first occurs or #f if it could not be found."
+ (let loop ((offset offset)
+ (count count))
+ (cond ((zero? count) #f)
+ ((= (bytevector-u8-ref bv offset) number) offset)
+ (else (loop (+ 1 offset) (- count 1))))))
+
+(define (split-lines str)
+ "Split STR into lines in a way that preserves newline characters."
+ (let loop ((str str)
+ (result '()))
+ (if (string-null? str)
+ (reverse result)
+ (match (string-index str #\newline)
+ (#f
+ (loop "" (cons str result)))
+ (index
+ (loop (string-drop str (+ index 1))
+ (cons (string-take str (+ index 1)) result)))))))
+
(define* (build-event-output-port proc #:optional (seed (build-status)))
"Return an output port for use as 'current-build-output-port' that calls
PROC with its current state value, initialized with SEED, on every build
@@ -467,33 +502,83 @@ The second return value is a thunk to retrieve the
current state."
;; Current state for PROC.
seed)
+ ;; When true, this represents the current state while reading a
+ ;; "@ build-log" trace: the current builder PID, the previously-read
+ ;; bytevectors, and the number of bytes that remain to be read.
+ (define %build-output-pid #f)
+ (define %build-output '())
+ (define %build-output-left #f)
+
(define (process-line line)
- (if (string-prefix? "@ " line)
- (match (string-tokenize (string-drop line 2))
- (((= string->symbol event-name) args ...)
- (set! %state
- (proc (cons event-name args)
- %state))))
- (set! %state (proc (list 'build-log line)
- %state))))
+ (cond ((string-prefix? "@ " line)
+ (match (string-tokenize (string-drop line 2))
+ (("build-log" (= string->number pid) (= string->number len))
+ (set! %build-output-pid pid)
+ (set! %build-output '())
+ (set! %build-output-left len))
+ (((= string->symbol event-name) args ...)
+ (set! %state
+ (proc (cons event-name args)
+ %state)))))
+ (else
+ (set! %state (proc (list 'build-log #f line)
+ %state)))))
+
+ (define (process-build-output pid output)
+ ;; Transform OUTPUT in 'build-log' events or download events as generated
+ ;; by extended build traces.
+ (define (line->event line)
+ (match (and (string-prefix? "@ " line)
+ (string-tokenize (string-drop line 2)))
+ ((type . args)
+ (if (or (string-prefix? "download-" type)
+ (string=? "build-remote" type))
+ (cons (string->symbol type) args)
+ `(build-log ,pid ,line)))
+ (_
+ `(build-log ,pid ,line))))
+
+ (let* ((lines (split-lines output))
+ (events (map line->event lines)))
+ (set! %state (fold proc %state events))))
(define (bytevector-range bv offset count)
(let ((ptr (bytevector->pointer bv offset)))
(pointer->bytevector ptr count)))
(define (write! bv offset count)
- (let loop ((str (maybe-utf8->string (bytevector-range bv offset count))))
- (match (string-index str %newline)
- ((? integer? cr)
- (let ((tail (string-take str (+ 1 cr))))
- (process-line (string-concatenate-reverse
- (cons tail %fragments)))
- (set! %fragments '())
- (loop (string-drop str (+ 1 cr)))))
- (#f
- (unless (string-null? str)
- (set! %fragments (cons str %fragments)))
- count))))
+ (if %build-output-pid
+ (let ((keep (min count %build-output-left)))
+ (set! %build-output
+ (let ((bv* (make-bytevector keep)))
+ (bytevector-copy! bv offset bv* 0 keep)
+ (cons bv* %build-output)))
+ (set! %build-output-left
+ (- %build-output-left keep))
+
+ (when (zero? %build-output-left)
+ (process-build-output %build-output-pid
+ (string-concatenate-reverse
+ (map maybe-utf8->string %build-output)))
;XXX
+ (set! %build-output '())
+ (set! %build-output-pid #f))
+ keep)
+ (match (bytevector-index bv (char->integer #\newline)
+ offset count)
+ ((? integer? cr)
+ (let* ((tail (maybe-utf8->string
+ (bytevector-range bv offset (- cr -1 offset))))
+ (line (string-concatenate-reverse
+ (cons tail %fragments))))
+ (process-line line)
+ (set! %fragments '())
+ (- cr -1 offset)))
+ (#f
+ (unless (zero? count)
+ (let ((str (maybe-utf8->string
+ (bytevector-range bv offset count))))
+ (set! %fragments (cons str %fragments))))
+ count))))
(define port
(make-custom-binary-output-port "filtering-input-port"
diff --git a/tests/status.scm b/tests/status.scm
index 486ad04..3b74946 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: 锟絣ambda: 位\n"))
+ '((build-log #f "garbage: 锟絣ambda: 位\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")