* [bug#60408] [PATCH wip] guix: Support showing status in parallel.
@ 2022-12-29 18:42 Julien Lepiller
0 siblings, 0 replies; only message in thread
From: Julien Lepiller @ 2022-12-29 18:42 UTC (permalink / raw)
To: 60408
[-- Attachment #1: Type: text/plain, Size: 1881 bytes --]
Hi Guix!
The attached patch allows showing more detailed status in parallel.
One of the reasons for doing that is for supporting another of my
patches, that allows specifying download tasks and build tasks numbers
separately, with a default of 1 for each (so 2 tasks in parallel by
default).
With verbosity level 2, all messages from all builds are shown
(interleaved, obviously), and messages for other levels are the same.
When only one build is performed, no changes are visible.
When multiple builds are happening in parallel, this patch shows one
line per running job (whether build or download), and messages above.
This will look like this:
module-import-compiled.drv 75% ▕█████████████████████████ ▏
openjdk-9.181-jdk 337.6MiB 4.3MiB/s 00:07 ▕█▌ ▏ 8.8%
If there is no progress lines in the output of a build, it doesn't show
a spinner (yet), so no feedback that something is happening, but that's
planned for v2. One other issue is probably caused by having lots of
events (caused by build log output), that make status lines blink.
Another issue is when you ^C, the cursor is on the first status line.
My ideas for this patch are:
First, it's possible to go back a few lines with an ANSI escape code,
so basically print all status lines, then go back to the first line.
When an even needs to print a new line, let it do it from the first
status line, and print the status lines from below it.
Sometimes, an event will contain an incomplete line (for instance, it
ends with \r instead of \n), so I want to record the line to prevent it
from being overwritten by a status line. It's printed together with the
status lines, so we can go back to that line and print the rest of the
line when we get more of it.
Thoughts, ideas?
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-guix-Support-showing-status-in-parallel.patch --]
[-- Type: text/x-patch, Size: 22216 bytes --]
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(-)
diff --git a/guix/status.scm b/guix/status.scm
index 2c69f49fb5..5eb3ebc46b 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -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
^ permalink raw reply related [flat|nested] only message in thread
only message in thread, other threads:[~2022-12-29 18:56 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2022-12-29 18:42 [bug#60408] [PATCH wip] guix: Support showing status in parallel Julien Lepiller
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).