From c40fc712dec93299657e916907bc603d30178327 Mon Sep 17 00:00:00 2001
Message-Id: <c40fc712dec93299657e916907bc603d30178327.1672338241.git.julien@lepiller.eu>
From: Julien Lepiller <julien@lepiller.eu>
Date: Thu, 29 Dec 2022 19:20:34 +0100
Subject: [PATCH] guix: Support showing status in parallel.
* guix/status.scm (build-status): Add `last-daemon-line` field.
(build): Add `last-line` and `start` fields.
(update-build): Record partial lines (not ending with \n) in the
last-line field of the new build or status record.
(print-build-event): Always print status of all current builds and
downloads at the end. Update all status lines.
---
guix/status.scm | 358 +++++++++++++++++++++++++++++++++---------------
1 file changed, 245 insertions(+), 113 deletions(-)
@@ -49,6 +49,7 @@ (define-module (guix status)
build-status-downloading
build-status-builds-completed
build-status-downloads-completed
+ build-status-last-daemon-line
build?
build
@@ -57,6 +58,8 @@ (define-module (guix status)
build-log-file
build-phase
build-completion
+ build-start
+ build-last-line
download?
download
@@ -100,11 +103,13 @@ (define-record-type* <build-status> build-status make-build-status
(builds-completed build-status-builds-completed ;list of <build>
(default '()))
(downloads-completed build-status-downloads-completed ;list of <download>
- (default '())))
+ (default '()))
+ (last-daemon-line build-status-last-daemon-line ;string
+ (default "")))
;; On-going or completed build.
(define-immutable-record-type <build>
- (%build derivation id system log-file phase completion)
+ (%build derivation id system log-file phase completion start last-line)
build?
(derivation build-derivation) ;string (.drv file name)
(id build-id) ;#f | integer
@@ -113,11 +118,17 @@ (define-immutable-record-type <build>
(phase build-phase ;#f | symbol
set-build-phase)
(completion build-completion ;#f | integer (percentage)
- set-build-completion))
+ set-build-completion)
+ (start build-start ;<time>
+ set-build-start)
+ (last-line build-last-line ;#f | string
+ set-build-last-line))
-(define* (build derivation system #:key id log-file phase completion)
+(define* (build derivation system #:key id log-file phase completion
+ (start (current-time time-monotonic))
+ (last-line ""))
"Return a new build."
- (%build derivation id system log-file phase completion))
+ (%build derivation id system log-file phase completion start last-line))
;; On-going or completed downloads. Downloads can be stem from substitutes
;; and from "builtin:download" fixed-output derivations.
@@ -166,6 +177,12 @@ (define %fraction-line-rx
(define (update-build status id line)
"Update STATUS based on LINE, a build output line for ID that might contain
a completion indication."
+ (define (last-line str)
+ (last (string-split str #\newline)))
+
+ (define (update-last-line build)
+ (set-build-last-line build (last-line (string-append (build-last-line build) line))))
+
(define (find-build)
(find (lambda (build)
(and (build-id build)
@@ -173,15 +190,27 @@ (define (update-build status id line)
(build-status-building status)))
(define (update %)
- (let ((build (find-build)))
+ (let ((build (find-build))
+ (new-build (update-last-line (find-build))))
(build-status
(inherit status)
- (building (cons (set-build-completion build %)
+ (building (cons (set-build-completion new-build %)
(delq build (build-status-building status)))))))
- (cond ((string-any #\nul line)
+ (cond ((not id)
+ (build-status
+ (inherit status)
+ (last-daemon-line (string-append (build-status-last-daemon-line status) line))))
+ ((string-any #\nul line)
;; Don't try to match a regexp here.
- status)
+ (let ((build (find-build)))
+ (if build
+ (build-status
+ (inherit status)
+ (building
+ (cons (update-last-line build)
+ (delq build (build-status-building status)))))
+ status)))
((regexp-exec %percentage-line-rx line)
=>
(lambda (match)
@@ -202,12 +231,20 @@ (define (update-build status id line)
(build-status
(inherit status)
(building
- (cons (set-build-phase (set-build-completion build #f)
- (string->symbol phase))
+ (cons (update-last-line
+ (set-build-phase (set-build-completion build #f)
+ (string->symbol phase)))
(delq build (build-status-building status)))))
status))))
(else
- status)))
+ (let ((build (find-build)))
+ (if build
+ (build-status
+ (inherit status)
+ (building
+ (cons (update-last-line build)
+ (delq build (build-status-building status)))))
+ status)))))
(define* (compute-status event status
#:key
@@ -436,48 +473,170 @@ (define* (print-build-event event old-status status
(define tty?
(isatty?* port))
- (define (report-build-progress phase %)
- (let ((% (min (max % 0) 100))) ;sanitize
- (erase-current-line port)
- (let* ((prefix (format #f "~3d% ~@['~a' ~]"
- (inexact->exact (round %))
- (case phase
- ((build) #f) ;not useful to display it
- (else phase))))
- (length (string-length prefix)))
- (display prefix port)
- (display (progress-bar % (- (current-terminal-columns) length))
- port))
- (force-output port)))
+ (define (report-build-progress name phase %)
+ (if %
+ (let ((% (min (max % 0) 100))) ;sanitize
+ (erase-current-line port)
+ (let* ((prefix (format #f "~a ~3d% ~@['~a' ~]"
+ (string-join (cdr (string-split (basename name) #\-)) "-")
+ (inexact->exact (round %))
+ (case phase
+ ((build) #f) ;not useful to display it
+ (else phase))))
+ (length (string-length prefix)))
+ (display prefix port)
+ (display (progress-bar % (- (current-terminal-columns) length))
+ port)
+ (newline port)))
+ (erase-format port "~a…~%" name))
+ (force-output port))
+
+ (define (find-build id status)
+ (find
+ (lambda (build)
+ (and id (build-id build)
+ (= (build-id build) id)))
+ (build-status-building status)))
+
+ (define (get-line id line)
+ (define (remove-last lst)
+ (match lst
+ (() '())
+ ((_) '())
+ ((e lst ...) (cons e (remove-last lst)))))
+
+ (let ((old-build (find-build id old-status)))
+ (cond
+ ((not id)
+ (let ((commited-lines
+ (remove-last
+ (string-split (string-append (build-status-last-daemon-line old-status) line)
+ #\newline))))
+ (if (null? commited-lines)
+ ""
+ (string-append (string-join commited-lines "\n") "\n"))))
+ (old-build
+ (let ((commited-lines
+ (remove-last
+ (string-split (string-append (build-last-line old-build) line)
+ #\newline))))
+ (if (null? commited-lines)
+ ""
+ (string-append (string-join commited-lines "\n") "\n"))))
+ (else line))))
(define print-log-line
- (if print-log?
- (if colorize?
- (lambda (id line)
- (display (colorize-log-line line) 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 (build-phase build) %))
- (_
- (spin! (build-phase build) port))))
- (_
- (spin! #f port))))))
+ (lambda (id line)
+ (print-log-line* (get-line id line))))
+
+ (define (print-log-line* line)
+ (define (print-lines lines)
+ (match lines
+ ((line) (print-line line))
+ ((line lines ...)
+ (print-line (string-append line "\n")))))
+
+ (define (print-line line)
+ (erase-current-line*)
+ (if colorize?
+ (display (colorize-log-line line) port)
+ (display line port)))
+
+ (when print-log?
+ (print-lines (string-split line #\newline))))
(define erase-current-line*
- (if (and (not print-log?) (isatty?* port))
+ (if (isatty?* port)
(lambda ()
(erase-current-line port)
(force-output port))
(const #t)))
+ (define (go-back n)
+ (when (and (isatty?* port) (> n 0))
+ (format port "\r\x1b[~dA" n)))
+
+ (define (build<? build1 build2)
+ (match (list (build-start build1) (build-start build2))
+ ((#f #f) (string<? (build-derivation build1) (build-derivation build2)))
+ ((_ #f) #t)
+ ((#f _) #f)
+ ((t1 t2) (time<? t1 t2))))
+
+ (define (download<? download1 download2)
+ (match (list (download-start download1) (download-start download2))
+ ((#f #f) (string<? (download-uri download1) (download-uri download2)))
+ ((_ #f) #t)
+ ((#f _) #f)
+ ((t1 t2) (time<? t1 t2))))
+
+ (define (print-progress)
+ (unless (string-null? (build-status-last-daemon-line status))
+ (pk 'daemon-partial (build-status-last-daemon-line status))
+ #;(erase-current-line*)
+ #;(print-log-line* (build-status-last-daemon-line status))
+ #;(newline port))
+
+ (when print-log?
+ (for-each
+ (lambda (build)
+ (unless (or (not (build-last-line build))
+ (string-null? (build-last-line build)))
+ (erase-current-line*)
+ (print-log-line* (build-last-line build))
+ (newline port)))
+ (sort (build-status-building status)
+ build<?)))
+
+ (for-each
+ (lambda (build)
+ (report-build-progress (build-derivation build) (build-phase build)
+ (build-completion build)))
+ (sort (build-status-building status)
+ build<?))
+ (for-each
+ (lambda (download)
+ (let ((uri (if (string-contains (download-uri download) "/nar/")
+ (nar-uri-abbreviation (download-uri download))
+ (basename (download-uri download)))))
+ (display-download-progress uri (download-size download)
+ #:tty? tty?
+ #:start-time
+ (download-start download)
+ #:transferred (download-transferred download))
+ (newline port)))
+ (sort (build-status-downloading status)
+ download<?))
+
+ (go-back (+ (length (build-status-building status))
+ (if print-log?
+ (length (filter
+ (lambda (build)
+ (let ((last-line (build-last-line build)))
+ (and last-line (not (string-null? last-line)))))
+ (build-status-building status)))
+ 0)
+ (length (build-status-downloading status))
+ (if (string-null? (build-status-last-daemon-line status)) 0 1)))
+ (force-output port))
+
+ (define* (erase-format port msg . args)
+ (define (print-lines lines)
+ (match lines
+ (() #t)
+ ((line)
+ (erase-current-line*)
+ (format port line))
+ ((line lines ...)
+ (erase-current-line*)
+ (format port line)
+ (newline port)
+ (print-lines lines))))
+ (let ((str (apply format #f msg args)))
+ (print-lines (string-split str #\newline))))
+
(match event
(('build-started drv . _)
- (erase-current-line*)
(let ((properties (derivation-properties
(read-derivation-from-file drv))))
(match (assq-ref properties 'type)
@@ -485,120 +644,91 @@ (define* (print-build-event event old-status status
(let ((count (match (assq-ref properties 'graft)
(#f 0)
(lst (or (assq-ref lst 'count) 0)))))
- (format port (info (N_ "applying ~a graft for ~a ..."
- "applying ~a grafts for ~a ..."
- count))
- count
- (string-drop-right (store-path-package-name drv)
- (string-length ".drv")))))
+ (erase-format port (info (N_ "applying ~a graft for ~a ..."
+ "applying ~a grafts for ~a ..."
+ count))
+ count
+ (string-drop-right (store-path-package-name drv)
+ (string-length ".drv")))))
('profile
(let ((count (match (assq-ref properties 'profile)
(#f 0)
(lst (or (assq-ref lst 'count) 0)))))
- (format port (info (N_ "building profile with ~a package..."
- "building profile with ~a packages..."
- count))
- count)))
+ (erase-format port (info (N_ "building profile with ~a package..."
+ "building profile with ~a packages..."
+ count))
+ count)))
('profile-hook
(let ((hook-type (assq-ref properties 'hook)))
(or (and=> (hook-message hook-type)
(lambda (msg)
(display (info msg) port)))
- (format port (info (G_ "running profile hook of type '~a'..."))
- hook-type))))
+ (erase-format port (info (G_ "running profile hook of type '~a'..."))
+ hook-type))))
(_
- (format port (info (G_ "building ~a...")) drv))))
- (newline port))
+ (erase-format port (info (G_ "building ~a...")) drv)))
+ (newline port)))
(('build-succeeded drv . _)
- (erase-current-line*) ;erase spinner or progress bar
(when (or print-log? (not (extended-build-trace-supported?)))
- (format port (success (G_ "successfully built ~a")) drv)
- (newline port))
- (match (build-status-building status)
- (() #t)
- (ongoing ;when max-jobs > 1
- (format port
- (N_ "The following build is still in progress:~%~{ ~a~%~}~%"
- "The following builds are still in progress:~%~{ ~a~%~}~%"
- (length ongoing))
- (map build-derivation ongoing)))))
+ (erase-format port (success (G_ "successfully built ~a")) drv)
+ (newline port)))
(('build-failed drv . _)
- (erase-current-line*) ;erase spinner or progress bar
- (format port (failure (G_ "build of ~a failed")) drv)
+ (erase-format port (failure (G_ "build of ~a failed")) drv)
(newline port)
(match (derivation-log-file drv)
(#f
- (format port (failure (G_ "Could not find build log for '~a'."))
- drv))
+ (erase-format port (failure (G_ "Could not find build log for '~a'."))
+ drv)
+ (newline port))
(log
- (format port (emph (G_ "View build log at '~a'.")) log)))
- (newline port))
+ (erase-format port (emph (G_ "View build log at '~a'.")) log)
+ (newline port))))
(('substituter-started item _ ...)
- (erase-current-line*)
(when (or print-log? (not (extended-build-trace-supported?)))
- (format port (info (G_ "substituting ~a...")) item)
+ (erase-format port (info (G_ "substituting ~a...")) item)
(newline port)))
(('download-started item uri _ ...)
(when print-urls?
- (erase-current-line*)
- (format port (info (G_ "downloading from ~a ...")) uri)
+ (erase-format port (info (G_ "downloading from ~a ...")) uri)
(newline port)))
(('download-progress item uri
(= string->number size)
(= string->number transferred))
- ;; Print a progress bar, but only if there's only one on-going
- ;; job--otherwise the output would be intermingled.
- (when (= 1 (simultaneous-jobs status))
- (match (find (matching-download item)
- (build-status-downloading status))
- (#f #f) ;shouldn't happen!
- (download
- ;; XXX: It would be nice to memoize the abbreviation.
- (let ((uri (if (string-contains uri "/nar/")
- (nar-uri-abbreviation uri)
- (basename uri))))
- (display-download-progress uri size
- #:tty? tty?
- #:start-time
- (download-start download)
- #:transferred transferred))))))
+ ;; ignore event, since progress is shown after messages
+ event)
(('substituter-succeeded item _ ...)
(when (extended-build-trace-supported?)
- ;; If there are no jobs running, we already reported download completion
- ;; so there's nothing left to do.
- (unless (zero? (simultaneous-jobs status))
- (format port (success (G_ "substitution of ~a complete")) item)
- (newline port))
-
- (when (and print-urls? (zero? (simultaneous-jobs status)))
- ;; Leave a blank line after the "downloading ..." line and the
- ;; progress bar (that's three lines in total).
- (newline port))))
+ (erase-format port (success (G_ "substitution of ~a complete")) item)
+ (newline port)))
(('substituter-failed item _ ...)
- (format port (failure (G_ "substitution of ~a failed")) item)
+ (erase-format port (failure (G_ "substitution of ~a failed")) item)
(newline port))
(('hash-mismatch item algo expected actual _ ...)
;; TRANSLATORS: The final string looks like "sha256 hash mismatch for
;; /gnu/store/…-sth:", where "sha256" is the hash algorithm.
- (format port (failure (G_ "~a hash mismatch for ~a:")) algo item)
+ (erase-format port (failure (G_ "~a hash mismatch for ~a:")) algo item)
(newline port)
- (format port (emph (G_ "\
+ (erase-format port (emph (G_ "\
expected hash: ~a
actual hash: ~a~%"))
- expected actual))
+ expected actual)
+ (newline port))
(('build-remote drv host _ ...)
- (format port (emph (G_ "offloading build of ~a to '~a'")) drv host)
+ (erase-format port (emph (G_ "offloading build of ~a to '~a'")) drv host)
(newline port))
(('build-log pid line)
+ ;(pk '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)
+ ;; through, but only full lines. Partial lines are printed in
+ ;; print-progress
+ (erase-format port (get-line pid line))
(force-output port))
(print-log-line pid line))
- (cond ((string-prefix? "substitute: " 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
;; substitutes from URL"), so let them through.
@@ -612,7 +742,9 @@ (define* (print-build-event event old-status status
(else
(print-log-line pid line)))))
(_
- event)))
+ event))
+
+ (print-progress))
(define* (print-build-event/quiet event old-status status
#:optional
--
2.38.1