;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (guix status)
#:use-module (guix records)
#:use-module (guix i18n)
- #:use-module ((guix ui) #:select (colorize-string))
+ #:use-module (guix colors)
#:use-module (guix progress)
#:autoload (guix build syscalls) (terminal-columns)
#:use-module ((guix build download)
#:select (nar-uri-abbreviation))
#:use-module (guix store)
#:use-module (guix derivations)
+ #:use-module (guix memoization)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (ice-9 regex)
build-status-builds-completed
build-status-downloads-completed
+ build?
+ build
+ build-derivation
+ build-system
+ build-log-file
+ build-phase
+ build-completion
+
download?
download
download-item
print-build-event/quiet
print-build-status
- with-status-report))
+ with-status-report
+ with-status-verbosity))
;;; Commentary:
;;;
;; Builds and substitutions performed by the daemon.
(define-record-type* <build-status> build-status make-build-status
build-status?
- (building build-status-building ;list of drv
+ (building build-status-building ;list of <build>
(default '()))
(downloading build-status-downloading ;list of <download>
(default '()))
- (builds-completed build-status-builds-completed ;list of drv
+ (builds-completed build-status-builds-completed ;list of <build>
(default '()))
- (downloads-completed build-status-downloads-completed ;list of store items
+ (downloads-completed build-status-downloads-completed ;list of <download>
(default '())))
+;; On-going or completed build.
+(define-immutable-record-type <build>
+ (%build derivation id system log-file phase completion)
+ build?
+ (derivation build-derivation) ;string (.drv file name)
+ (id build-id) ;#f | integer
+ (system build-system) ;string
+ (log-file build-log-file) ;#f | string
+ (phase build-phase ;#f | symbol
+ set-build-phase)
+ (completion build-completion ;#f | integer (percentage)
+ set-build-completion))
+
+(define* (build derivation system #:key id log-file phase completion)
+ "Return a new build."
+ (%build derivation id system log-file phase completion))
+
;; On-going or completed downloads. Downloads can be stem from substitutes
;; and from "builtin:download" fixed-output derivations.
(define-record-type <download>
"Return a new download."
(%download item uri size start end transferred))
+(define (matching-build drv)
+ "Return a predicate that matches builds of DRV."
+ (lambda (build)
+ (string=? drv (build-derivation build))))
+
(define (matching-download item)
"Return a predicate that matches downloads of ITEM."
(lambda (download)
(string=? item (download-item download))))
+(define %phase-start-rx
+ ;; Match the "starting phase" message emitted by 'gnu-build-system'.
+ (make-regexp "^starting phase [`']([^']+)'"))
+
+(define %percentage-line-rx
+ ;; Things like CMake write lines like "[ 10%] gcc -c …". This regexp
+ ;; matches them.
+ (make-regexp "^[[:space:]]*\\[ *([0-9]+)%\\]"))
+
+(define %fraction-line-rx
+ ;; The 'compiled-modules' derivations and Ninja produce reports like
+ ;; "[ 1/32]" at the beginning of each line, while GHC prints "[ 6 of 45]".
+ ;; This regexp matches these.
+ (make-regexp "^[[:space:]]*\\[ *([0-9]+) *(/|of) *([0-9]+)\\]"))
+
+(define (update-build status id line)
+ "Update STATUS based on LINE, a build output line for ID that might contain
+a completion indication."
+ (define (find-build)
+ (find (lambda (build)
+ (and (build-id build)
+ (= (build-id build) id)))
+ (build-status-building status)))
+
+ (define (update %)
+ (let ((build (find-build)))
+ (build-status
+ (inherit status)
+ (building (cons (set-build-completion build %)
+ (delq build (build-status-building status)))))))
+
+ (cond ((string-any #\nul line)
+ ;; Don't try to match a regexp here.
+ status)
+ ((regexp-exec %percentage-line-rx line)
+ =>
+ (lambda (match)
+ (let ((% (string->number (match:substring match 1))))
+ (update %))))
+ ((regexp-exec %fraction-line-rx line)
+ =>
+ (lambda (match)
+ (let ((done (string->number (match:substring match 1)))
+ (total (string->number (match:substring match 3))))
+ (update (* 100. (/ done total))))))
+ ((regexp-exec %phase-start-rx line)
+ =>
+ (lambda (match)
+ (let ((phase (match:substring match 1))
+ (build (find-build)))
+ (if build
+ (build-status
+ (inherit status)
+ (building
+ (cons (set-build-phase (set-build-completion build #f)
+ (string->symbol phase))
+ (delq build (build-status-building status)))))
+ status))))
+ (else
+ status)))
+
(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
- (('build-started drv _ ...)
- (build-status
- (inherit status)
- (building (cons drv (build-status-building status)))))
+ (('build-started drv "-" system log-file . rest)
+ (let ((build (build drv system
+ #:id (match rest
+ ((pid . _) (string->number pid))
+ (_ #f))
+ #:log-file (if (string-null? log-file)
+ #f
+ log-file))))
+ (build-status
+ (inherit status)
+ (building (cons build (build-status-building status))))))
(((or 'build-succeeded 'build-failed) drv _ ...)
- (build-status
- (inherit status)
- (building (delete drv (build-status-building status)))
- (builds-completed (cons drv (build-status-builds-completed status)))))
+ (let ((build (find (matching-build drv)
+ (build-status-building status))))
+ ;; If BUILD is #f, this may be because DRV corresponds to a
+ ;; fixed-output derivation that is listed as a download.
+ (if build
+ (build-status
+ (inherit status)
+ (building (delq build (build-status-building status)))
+ (builds-completed
+ (cons build (build-status-builds-completed status))))
+ status)))
;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because
;; they're not as informative as 'download-started' and
;; because ITEM is different from DRV's output.
(build-status
(inherit status)
- (building (remove (lambda (drv)
- (equal? (false-if-exception
- (derivation->output-path
- (read-derivation-from-file drv)))
- item))
+ (building (remove (lambda (build)
+ (let ((drv (build-derivation build)))
+ (equal? (false-if-exception
+ (derivation-path->output-path drv))
+ item)))
(build-status-building status)))
(downloading (cons (download item uri #:size size
#:start (current-time time-monotonic))
(current-time time-monotonic))
#:transferred transferred)
downloads)))))
+ (('build-log (? integer? pid) line)
+ (update-build status pid line))
(_
status)))
(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)
- "Display a spinner on PORT."
- (match steps
- ((first . rest)
- (set! steps rest)
- (display "\r\x1b[K" port)
- (display first port)
- (force-output port))))))
-
-(define (color-output? port)
- "Return true if we should write colored output to PORT."
- (and (not (getenv "INSIDE_EMACS"))
- (not (getenv "NO_COLOR"))
- (isatty? port)))
-
-(define-syntax color-rules
- (syntax-rules ()
- "Return a procedure that colorizes the string it is passed according to
-the given rules. Each rule has the form:
-
- (REGEXP COLOR1 COLOR2 ...)
-
-where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
-on."
- ((_ (regexp colors ...) rest ...)
- (let ((next (color-rules rest ...))
- (rx (make-regexp regexp)))
- (lambda (str)
- (if (string-index str #\nul)
- str
- (match (regexp-exec rx str)
- (#f (next str))
- (m (let loop ((n 1)
- (c '(colors ...))
- (result '()))
- (match c
- (()
- (string-concatenate-reverse result))
- ((first . tail)
- (loop (+ n 1) tail
- (cons (colorize-string (match:substring m n)
- first)
- result)))))))))))
- ((_)
- (lambda (str)
- str))))
+ (lambda (phase port)
+ "Display a spinner on PORT. If PHASE is true, display it as a hint of
+the current build phase."
+ (when (isatty?* port)
+ (match steps
+ ((first . rest)
+ (set! steps rest)
+ (display "\r\x1b[K" port)
+ (display first port)
+ (when phase
+ (display " " port)
+ ;; TRANSLATORS: The word "phase" here denotes a "build phase";
+ ;; "~a" is a placeholder for the untranslated name of the current
+ ;; build phase--e.g., 'configure' or 'build'.
+ (format port (G_ "'~a' phase") phase))
+ (force-output port)))))))
(define colorize-log-line
;; Take a string and return a possibly colorized string according to the
("^(.*)(warning)([[:blank:]]*)(:)(.*)"
RESET MAGENTA BOLD BOLD BOLD)))
+(define (hook-message hook-type)
+ "Return a human-readable string for the profile hook type HOOK-TYPE."
+ (match hook-type
+ ('info-dir
+ (G_ "building directory of Info manuals..."))
+ ('ghc-package-cache
+ (G_ "building GHC package cache..."))
+ ('ca-certificate-bundle
+ (G_ "building CA certificate bundle..."))
+ ('glib-schemas
+ (G_ "generating GLib schema cache..."))
+ ('gtk-icon-themes
+ (G_ "creating GTK+ icon theme cache..."))
+ ('gtk-im-modules
+ (G_ "building cache files for GTK+ input methods..."))
+ ('xdg-desktop-database
+ (G_ "building XDG desktop file cache..."))
+ ('xdg-mime-database
+ (G_ "building XDG MIME database..."))
+ ('fonts-dir
+ (G_ "building fonts directory..."))
+ ('texlive-configuration
+ (G_ "building TeX Live configuration..."))
+ ('manual-database
+ (G_ "building database for manual pages..."))
+ ('package-cache ;package cache generated by 'guix pull'
+ (G_ "building package cache..."))
+ (_ #f)))
+
(define* (print-build-event event old-status status
#:optional (port (current-error-port))
#:key
addition to build events."
(define info
(if colorize?
- (cut colorize-string <> 'BOLD)
+ (cute colorize-string <> (color BOLD))
identity))
(define success
(if colorize?
- (cut colorize-string <> 'GREEN 'BOLD)
+ (cute colorize-string <> (color GREEN BOLD))
identity))
(define failure
(if colorize?
- (cut colorize-string <> 'RED 'BOLD)
+ (cute colorize-string <> (color RED BOLD))
identity))
+ (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 print-log-line
(if print-log?
(if colorize?
- (lambda (line)
+ (lambda (id line)
(display (colorize-log-line line) port))
- (cut display <> port))
- (lambda (line)
- (spin! 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))))))
+
+ (define erase-current-line*
+ (if (and (not print-log?) (isatty?* port))
+ (lambda ()
+ (erase-current-line port)
+ (force-output port))
+ (const #t)))
- (display "\r" port) ;erase the spinner
(match event
(('build-started drv . _)
- (format port (info (G_ "building ~a...")) drv)
+ (erase-current-line*)
+ (let ((properties (derivation-properties
+ (read-derivation-from-file drv))))
+ (match (assq-ref properties 'type)
+ ('graft
+ (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 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)))
+ ('profile-hook
+ (let ((hook-type (assq-ref properties 'hook)))
+ (or (and=> (hook-message hook-type)
+ (lambda (msg)
+ (format port (info msg))))
+ (format port (info (G_ "running profile hook of type '~a'..."))
+ hook-type))))
+ (_
+ (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))
(N_ "The following build is still in progress:~%~{ ~a~%~}~%"
"The following builds are still in progress:~%~{ ~a~%~}~%"
(length ongoing))
- ongoing))))
+ (map build-derivation ongoing)))))
(('build-failed drv . _)
+ (erase-current-line*) ;erase spinner or progress bar
(format port (failure (G_ "build of ~a failed")) drv)
(newline port)
(match (derivation-log-file drv)
(format port (info (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)
(newline port)))
(('download-started item uri _ ...)
- (format port (info (G_ "downloading from ~a...")) uri)
+ (erase-current-line*)
+ (format port (info (G_ "downloading from ~a ...")) uri)
(newline port))
(('download-progress item uri
(= string->number size)
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-remote drv host _ ...)
+ (format port (info (G_ "offloading build of ~a to '~a'")) drv host)
+ (newline port))
+ (('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 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.
+ (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 pid line)))))
(_
event)))
;;; 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."
(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
;; 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)
+ ;; Note: Drop the trailing \n, and use 'string-split' to preserve
+ ;; spaces (the log file part of 'build-started' events can be the
+ ;; empty string.)
+ (match (string-split (string-drop (string-drop-right line 1) 2)
+ #\space)
+ (("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"
;; The build port actually receives Unicode strings.
(set-port-encoding! port "UTF-8")
- (setvbuf port (cond-expand (guile-2.2 'line) (else _IOLBF)))
-
+ (setvbuf port 'line)
(values port (lambda () %state)))
(define (call-with-status-report on-event thunk)
"Set up build status reporting to the user using the ON-EVENT procedure;
evaluate EXP... in that context."
(call-with-status-report on-event (lambda () exp ...)))
+
+(define (logger-for-level level)
+ "Return the logging procedure that corresponds to LEVEL."
+ (cond ((<= level 0) (const #t))
+ ((= level 1) print-build-event/quiet)
+ (else print-build-event)))
+
+(define (call-with-status-verbosity level thunk)
+ (call-with-status-report (logger-for-level level) thunk))
+
+(define-syntax-rule (with-status-verbosity level exp ...)
+ "Set up build status reporting to the user at the given LEVEL: 0 means
+silent, 1 means quiet, 2 means verbose. Evaluate EXP... in that context."
+ (call-with-status-verbosity level (lambda () exp ...)))