mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-26 22:38:07 -05:00
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.
This commit is contained in:
Ludovic Courtès
parent
6ef61cc4c3
commit
f9a8fce10f
8 changed files with 184 additions and 46 deletions
|
|
@ -395,6 +395,8 @@ (define (set-build-options-from-command-line store opts)
|
|||
#: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 @@ (define %default-options
|
|||
(build-hook? . #t)
|
||||
(print-build-trace? . #t)
|
||||
(print-extended-build-trace? . #t)
|
||||
(multiplexed-build-output? . #t)
|
||||
(verbosity . 0)))
|
||||
|
||||
(define (show-help)
|
||||
|
|
|
|||
|
|
@ -176,6 +176,7 @@ (define %default-options
|
|||
(graft? . #t)
|
||||
(print-build-trace? . #t)
|
||||
(print-extended-build-trace? . #t)
|
||||
(multiplexed-build-output? . #t)
|
||||
(verbosity . 0)))
|
||||
|
||||
(define (tag-package-arg opts arg)
|
||||
|
|
|
|||
|
|
@ -541,6 +541,7 @@ (define %default-options
|
|||
(graft? . #t)
|
||||
(print-build-trace? . #t)
|
||||
(print-extended-build-trace? . #t)
|
||||
(multiplexed-build-output? . #t)
|
||||
(verbosity . 0)
|
||||
(symlinks . ())
|
||||
(compressor . ,(first %compressors))))
|
||||
|
|
|
|||
|
|
@ -296,7 +296,8 @@ (define %default-options
|
|||
(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]...
|
||||
|
|
|
|||
|
|
@ -64,6 +64,7 @@ (define %default-options
|
|||
(build-hook? . #t)
|
||||
(print-build-trace? . #t)
|
||||
(print-extended-build-trace? . #t)
|
||||
(multiplexed-build-output? . #t)
|
||||
(graft? . #t)
|
||||
(verbosity . 0)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1082,6 +1082,7 @@ (define %default-options
|
|||
(build-hook? . #t)
|
||||
(print-build-trace? . #t)
|
||||
(print-extended-build-trace? . #t)
|
||||
(multiplexed-build-output? . #t)
|
||||
(graft? . #t)
|
||||
(verbosity . 0)
|
||||
(file-system-type . "ext4")
|
||||
|
|
|
|||
169
guix/status.scm
169
guix/status.scm
|
|
@ -116,7 +116,10 @@ (define (matching-download item)
|
|||
(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 @@ (define* (compute-status event 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 @@ (define (extended-build-trace-supported?)
|
|||
(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 @@ (define print-log-line
|
|||
(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 @@ (define print-log-line
|
|||
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 @@ (define* (build-status-updater #:optional (on-change (const #t)))
|
|||
;;; 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 @@ (define (maybe-utf8->string bv)
|
|||
(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 @@ (define %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"
|
||||
|
|
|
|||
|
|
@ -22,7 +22,8 @@ (define-module (test-status)
|
|||
#: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 @@ (define-module (test-status)
|
|||
(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 @@ (define-module (test-status)
|
|||
|
||||
(test-equal "current-build-output-port, UTF-8 + garbage"
|
||||
;; What about a mixture of UTF-8 + garbage?
|
||||
'((build-log "garbage: <20>lambda: λ\n"))
|
||||
'((build-log #f "garbage: <20>lambda: λ\n"))
|
||||
(let-values (((port get-status) (build-event-output-port cons '())))
|
||||
(display "garbage: " port)
|
||||
(put-bytevector port #vu8(128))
|
||||
|
|
@ -132,4 +133,48 @@ (define-module (test-status)
|
|||
(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")
|
||||
|
|
|
|||
Loading…
Reference in a new issue