[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/02: DRAFT Add (guix status).
|
From: |
Ludovic Courtès |
|
Subject: |
01/02: DRAFT Add (guix status). |
|
Date: |
Wed, 12 Sep 2018 16:48:46 -0400 (EDT) |
civodul pushed a commit to branch wip-ui
in repository guix.
commit ce2a6192b8ffe5f7e400094424d448a6b3f5c30e
Author: Ludovic Courtès <address@hidden>
Date: Wed Jan 18 23:21:29 2017 +0100
DRAFT Add (guix status).
---
Makefile.am | 1 +
guix/progress.scm | 24 ++-
guix/scripts/build.scm | 10 +-
guix/scripts/perform-download.scm | 1 +
guix/scripts/substitute.scm | 36 +++--
guix/status.scm | 304 ++++++++++++++++++++++++++++++++++++++
guix/store.scm | 9 +-
guix/ui.scm | 108 +-------------
nix/libstore/builtins.cc | 2 +
9 files changed, 373 insertions(+), 122 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 5c8639d..72a3de7 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -131,6 +131,7 @@ MODULES = \
guix/svn-download.scm \
guix/i18n.scm \
guix/ui.scm \
+ guix/status.scm \
guix/build/android-ndk-build-system.scm \
guix/build/ant-build-system.scm \
guix/build/download.scm \
diff --git a/guix/progress.scm b/guix/progress.scm
index c9c3cd1..ee7955d 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Sou Bunnbu <address@hidden>
;;; Copyright © 2015 Steve Sprang <address@hidden>
-;;; Copyright © 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2017, 2018 Ludovic Courtès <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -38,7 +38,10 @@
progress-reporter/silent
progress-reporter/file
progress-reporter/bar
+ progress-reporter/trace
+ erase-current-line
+ progress-bar
byte-count->string
current-terminal-columns
@@ -269,6 +272,25 @@ tasks is performed. Write PREFIX at the beginning of the
line."
(newline port))
(force-output port)))))
+(define* (progress-reporter/trace file url size
+ #:optional (log-port (current-output-port)))
+ "Like 'progress-reporter/file', but instead of returning human-readable
+progress reports, write \"build trace\" lines to be processed elsewhere."
+ (define (report-progress transferred)
+ (define message
+ (format #f "@ download-progress ~a ~a ~a ~a~%"
+ file (or url "-") (or size "-")
+ transferred))
+
+ (display message log-port) ;should be atomic
+ (flush-output-port log-port))
+
+ (progress-reporter
+ (start (const #t))
+ (report report-progress)
+ (stop (lambda ()
+ (force-output log-port)))))
+
;; TODO: replace '(@ (guix build utils) dump-port))'.
(define* (dump-port* in out
#:key (buffer-size 16384)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 3fa3c2c..5ccd931 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -45,6 +45,7 @@
#:use-module (srfi srfi-37)
#:autoload (gnu packages) (specification->package %package-module-path)
#:autoload (guix download) (download-to-store)
+ #:use-module (guix status)
#:export (%standard-build-options
set-build-options-from-command-line
set-build-options-from-command-line*
@@ -733,9 +734,12 @@ needed."
;; Set the build options before we do anything else.
(set-build-options-from-command-line store opts)
- (parameterize ((current-build-output-port (if quiet?
- (%make-void-port "w")
- (build-output-port
#:verbose? #t))))
+ (parameterize ((current-build-output-port
+ (if quiet?
+ (%make-void-port "w")
+ (build-event-output-port
+ (build-status-updater print-build-event)
+ (build-status)))))
(let* ((mode (assoc-ref opts 'build-mode))
(drv (options->derivations store opts))
(urls (map (cut string-append <> "/log")
diff --git a/guix/scripts/perform-download.scm
b/guix/scripts/perform-download.scm
index 18e2fc9..9f6ecc0 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -48,6 +48,7 @@ OUTPUT.
Note: Unless OUTPUT is #f, we don't read the value of 'out' in DRV since the
actual output is different from that when we're doing a 'bmCheck' or
'bmRepair' build."
+ ;; TODO: Use 'trace-progress-proc' when possible.
(derivation-let drv ((url "url")
(output* "out")
(executable "executable")
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 6d31dfd..2c2245c 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -906,7 +906,7 @@ expected by the daemon."
(or (narinfo-size narinfo) 0)))
(define* (process-query command
- #:key cache-urls acl)
+ #:key cache-urls acl print-build-trace?)
"Reply to COMMAND, a query as written by the daemon to this process's
standard input. Use ACL as the access-control list against which to check
authorized substitutes."
@@ -930,7 +930,7 @@ authorized substitutes."
(error "unknown `--query' command" wtf))))
(define* (process-substitution store-item destination
- #:key cache-urls acl)
+ #:key cache-urls acl print-build-trace?)
"Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
DESTINATION as a nar file. Verify the substitute against ACL."
(let* ((narinfo (lookup-narinfo cache-urls store-item
@@ -943,8 +943,10 @@ DESTINATION as a nar file. Verify the substitute against
ACL."
;; Tell the daemon what the expected hash of the Nar itself is.
(format #t "~a~%" (narinfo-hash narinfo))
- (format (current-error-port)
- (G_ "Downloading ~a...~%") (uri->string uri))
+ (unless print-build-trace?
+ (format (current-error-port)
+ (G_ "Downloading ~a...~%") (uri->string uri)))
+
(let*-values (((raw download-size)
;; Note that Hydra currently generates Nars on the fly
;; and doesn't specify a Content-Length, so
@@ -955,10 +957,15 @@ DESTINATION as a nar file. Verify the substitute against
ACL."
(dl-size (or download-size
(and (equal? comp "none")
(narinfo-size narinfo))))
- (reporter (progress-reporter/file
- (uri->string uri) dl-size
- (current-error-port)
- #:abbreviation nar-uri-abbreviation)))
+ (reporter (if print-build-trace?
+ (progress-reporter/trace
+ destination
+ (uri->string uri) dl-size
+ (current-error-port))
+ (progress-reporter/file
+ (uri->string uri) dl-size
+ (current-error-port)
+ #:abbreviation
nar-uri-abbreviation))))
(progress-report-port reporter raw)))
((input pids)
;; NOTE: This 'progress' port of current process will be
@@ -1058,6 +1065,13 @@ default value."
(define (guix-substitute . args)
"Implement the build daemon's substituter protocol."
+ (define print-build-trace?
+ (match (or (find-daemon-option "untrusted-print-build-trace")
+ (find-daemon-option "print-build-trace"))
+ (#f #f)
+ ((= string->number number) (> number 0))
+ (_ #f)))
+
(mkdir-p %narinfo-cache-directory)
(maybe-remove-expired-cache-entries %narinfo-cache-directory
cached-narinfo-files
@@ -1102,7 +1116,8 @@ default value."
(begin
(process-query command
#:cache-urls (substitute-urls)
- #:acl acl)
+ #:acl acl
+ #:print-build-trace? print-build-trace?)
(loop (read-line)))))))
(("--substitute" store-path destination)
;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
@@ -1111,7 +1126,8 @@ default value."
(parameterize ((current-terminal-columns (client-terminal-columns)))
(process-substitution store-path destination
#:cache-urls (substitute-urls)
- #:acl (current-acl))))
+ #:acl (current-acl)
+ #:print-build-trace? print-build-trace?)))
((or ("-V") ("--version"))
(show-version-and-exit "guix substitute"))
(("--help")
diff --git a/guix/status.scm b/guix/status.scm
new file mode 100644
index 0000000..dae6163
--- /dev/null
+++ b/guix/status.scm
@@ -0,0 +1,304 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017, 2018 Ludovic Courtès <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix status)
+ #:use-module (guix records)
+ #:use-module (guix i18n)
+ #:use-module ((guix ui) #:select (colorize-string))
+ #:use-module (guix progress)
+ #:use-module ((guix build syscalls) #:select (terminal-columns))
+ #:use-module ((guix store) #:select (log-file))
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (rnrs bytevectors)
+ #:use-module ((system foreign)
+ #:select (bytevector->pointer pointer->bytevector))
+ #:export (build-event-output-port
+
+ build-status
+ build-status?
+
+ build-status-updater
+ print-build-event
+ print-build-status))
+
+(define %newline
+ (char-set #\return #\newline))
+
+(define (build-event-output-port proc seed)
+ "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
+event. Build events passed to PROC are tuples corresponding to the \"build
+traces\" produced by the daemon:
+
+ (build-started \"/gnu/store/...-foo.drv\" ...)
+ (substituter-started \"/gnu/store/...-foo\" ...)
+
+and so on. "
+ (define %fragments
+ ;; Line fragments received so far.
+ '())
+
+ (define %state
+ ;; Current state for PROC.
+ seed)
+
+ (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 (cons 'build-log line)
+ %state))))
+
+ (define (bytevector-range bv offset count)
+ (let ((ptr (bytevector->pointer bv offset)))
+ (pointer->bytevector ptr count)))
+
+ (define (write! bv offset count)
+ (let loop ((str (utf8->string (bytevector-range bv offset count))))
+ (match (string-index str %newline)
+ ((? integer? cr)
+ (let ((tail (string-take str 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))))
+
+ (define port
+ (make-custom-binary-output-port "filtering-input-port"
+ write!
+ #f #f
+ #f))
+
+ ;; The build port actually receives Unicode strings.
+ (set-port-encoding! port "UTF-8")
+ (setvbuf port 'line)
+ port)
+
+
+;;;
+;;; Build status tracking.
+;;;
+
+;; 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
+ (default '()))
+ (substituting build-status-substituting ;list of <ongoing-download>
+ (default '()))
+ (builds-completed build-status-builds-completed ;list of drv
+ (default '()))
+ (substitutes-completed build-status-substitutes-completed ;list of store
items
+ (default '())))
+
+(define-record-type <ongoing-download>
+ (ongoing-download item uri size start transferred)
+ ongoing-download?
+ (item ongoing-download-item) ;store item
+ (uri ongoing-download-uri) ;string | #f
+ (size ongoing-download-size) ;integer | #f
+ (start ongoing-download-start) ;<time>
+ (transferred ongoing-download-transferred)) ;integer
+
+(define (matching-download item)
+ (lambda (ongoing)
+ (string=? item (ongoing-download-item ongoing))))
+
+(define (compute-status event status)
+ "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)))))
+ (((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)))))
+ (('substituter-started item _ ...)
+ (build-status
+ (inherit status)
+ (substituting (cons (ongoing-download item #f #f (current-time) 0)
+ (build-status-substituting status)))))
+ (('substituter-succeeded item _ ...)
+ (build-status
+ (inherit status)
+ (substituting (remove (matching-download item)
+ (build-status-substituting status)))
+ (substitutes-completed
+ (cons item (build-status-substitutes-completed status)))))
+ (('download-progress item uri
+ (= string->number size)
+ (= string->number transferred))
+ (let ((downloads (remove (matching-download item)
+ (build-status-substituting status)))
+ (current (find (matching-download item)
+ (build-status-substituting status))))
+ ;; XXX: If ITEM results is a fixed-output derivation, then it's part of
+ ;; the "building" category of STATUS.
+ (if current
+ (build-status
+ (inherit status)
+ (substituting (cons (ongoing-download item uri size
+ (ongoing-download-start
current)
+ transferred)
+ downloads)))
+ status)))
+ (_
+ status)))
+
+(define (simultaneous-jobs status)
+ (+ (length (build-status-building status))
+ (length (build-status-substituting status))))
+
+(define (cursor-up n port)
+ (format port "\r\x1b[K\x1b~a[A" n) ;erase in line + up
+ (force-output port))
+
+(define* (print-build-status event old-status status #:optional
+ (port (current-error-port)))
+ (define (new-download? download)
+ (zero? (ongoing-download-transferred download)))
+
+ ;; (let loop ((n (lines-printed old-status)))
+ ;; (when (> n 1)
+ ;; (cursor-up port)))
+
+ (match event
+ (('substituter-succeeded _ ...)
+ (newline port))
+ (_ #t))
+
+ (match (build-status-building status)
+ (() #t)
+ ((building ...)
+ (format port (colorize-string (G_ "building~{ ~a~}~%")
+ 'BLUE 'BOLD)
+ building)))
+
+ (match (build-status-substituting status)
+ (() #t)
+ ((download rest ...)
+ (if (and (<= (simultaneous-jobs old-status) 1)
+ (= 1 (simultaneous-jobs status)))
+ (let* ((now (current-time))
+ (elapsed (time-difference now
+ (ongoing-download-start download)))
+ (throughput (if (zero? (time-second elapsed))
+ 0
+ (/ (ongoing-download-transferred download)
+ 1024.
+ (time-second elapsed)))))
+ (if (zero? (ongoing-download-transferred download))
+ (format port "downloading ~a..."
+ (ongoing-download-item download))
+ (format port "\r\x1b[K~a ~a KiB | ~6,1f KiB/s"
+ (ongoing-download-uri download)
+ (ongoing-download-transferred download)
+ throughput))
+ (force-output port))
+ (let ((downloads (filter new-download? (cons download rest))))
+ (unless (null? downloads)
+ (format port "downloading ~{ ~a~}~%"
+ (map ongoing-download-item downloads))
+ (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* (print-build-event event old-status status #:optional
+ (port (current-error-port))
+ #:key
+ (colorize? (color-output? port)))
+ (define info
+ (if colorize?
+ (cut colorize-string <> 'BLUE 'BOLD)
+ identity))
+
+ (define success
+ (if colorize?
+ (cut colorize-string <> 'GREEN 'BOLD)
+ identity))
+
+ (define failure
+ (if colorize?
+ (cut colorize-string <> 'RED 'BOLD)
+ identity))
+
+ (match event
+ (('build-started drv . _)
+ (format port (info (G_ "building ~a...~%"))
+ drv))
+ (('build-succeeded drv . _)
+ (format port (success (G_ "successfully built ~a~%"))
+ drv))
+ (('build-failed drv . _)
+ (format port (failure (G_ "build of ~a failed~%")) drv)
+ (format port (G_ "View build log at '~a'.~%")
+ (log-file #f drv)))
+ (('substituter-started item _ ...)
+ (format port (info (G_ "downloading ~a...~%")) item))
+ (('download-progress item uri
+ (= string->number size)
+ (= string->number transferred))
+ (when (= 1 (simultaneous-jobs status))
+ (let ((width (- (terminal-columns) 10)))
+ (unless (< width 5)
+ (erase-current-line port)
+ (format port " ~a ~a"
+ (byte-count->string size)
+ (progress-bar (* 100. (/ transferred size 1.))
+ width))
+ (when (= transferred size)
+ (newline port))
+ (force-output port)))))
+ (('substituter-succeeded item _ ...)
+ (unless (= 1 (simultaneous-jobs status))
+ (format port (success (G_ "download of ~a complete~%")) item)))
+ (('substituter-failed item _ ...)
+ (format port (failure (G_ "download of ~a failed~%")) item))
+ (_
+ event)))
+
+(define* (build-status-updater #:optional (on-change (const #t)))
+ (lambda (event status)
+ (let ((new (compute-status event status)))
+ (on-change event status new)
+ new)))
+
+;; (define current-build-output-port
+;; ;; The port where build output is sent.
+;; (make-parameter (filtering-output-port (current-error-port))))
diff --git a/guix/store.scm b/guix/store.scm
index af7f698..0f56eda 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -725,7 +725,14 @@ encoding conversion errors."
(when (>= (nix-server-minor-version server) 10)
(send (boolean use-substitutes?)))
(when (>= (nix-server-minor-version server) 12)
- (let ((pairs `(,@(if timeout
+ (let ((pairs `(;; This 'print-build-trace' option is honored by 'guix
+ ;; substitute' et al.
+ ,@(if print-build-trace
+ `(("print-build-trace"
+ . ,(if print-build-trace "1" "0")))
+ '())
+
+ ,@(if timeout
`(("build-timeout" . ,(number->string timeout)))
'())
,@(if max-silent-time
diff --git a/guix/ui.scm b/guix/ui.scm
index 1bbd37c..96f403a 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -119,7 +119,7 @@
warning
info
guix-main
- build-output-port))
+ colorize-string))
;;; Commentary:
;;;
@@ -1676,110 +1676,4 @@ be reset such that subsequent output will not have any
colors in effect."
str
(color 'RESET)))
-(define* (build-output-port #:key
- (colorize? #t)
- verbose?
- (port (current-error-port)))
- "Return a soft port that processes build output. By default it colorizes
-phase announcements and replaces any other output with a spinner."
- (define spun? #f)
- (define spin!
- (let ((steps (circular-list "\\" "|" "/" "-")))
- (lambda ()
- (match steps
- ((first . rest)
- (set! steps rest)
- (set! spun? #t) ; remember to erase spinner
- first)))))
-
- (define use-color?
- (and colorize?
- (not (or (getenv "NO_COLOR")
- (getenv "INSIDE_EMACS")
- (not (isatty? port))))))
-
- (define handle-string
- (let* ((proc (if use-color?
- colorize-string
- (lambda (s . _) s)))
- (rules `(("^(@ build-started) (.*) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Building " 'BLUE 'BOLD)
- (match:substring m 2) "\n")))
- ("^(@ build-failed) (.*) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Build failed: " 'RED 'BOLD)
- (match:substring m 2) "\n")))
- ("^(@ build-succeeded) (.*) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Built " 'GREEN 'BOLD)
- (match:substring m 2) "\n")))
- ("^(@ substituter-started) (.*) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Substituting " 'BLUE 'BOLD)
- (match:substring m 2) "\n")))
- ("^(@ substituter-failed) (.*) (.*) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Substituter failed: " 'RED 'BOLD)
- (match:substring m 2) "\n"
- (match:substring m 3) ": "
- (match:substring m 4) "\n")))
- ("^(@ substituter-succeeded) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Substituted " 'GREEN 'BOLD)
- (match:substring m 2) "\n")))
- ("^(starting phase )(.*)"
- BLUE GREEN)
- ("^(phase)(.*)(succeeded after)(.*)(seconds)(.*)"
- GREEN BLUE GREEN BLUE GREEN BLUE)
- ("^(phase)(.*)(failed after)(.*)(seconds)(.*)"
- RED BLUE RED BLUE RED BLUE))))
- (lambda (str)
- (let ((processed
- (any (match-lambda
- ((pattern #:transform transform)
- (and=> (string-match pattern str)
- transform))
- ((pattern . colors)
- (and=> (string-match pattern str)
- (lambda (m)
- (let ((substrings
- (map (cut match:substring m <>)
- (iota (- (match:count m) 1) 1))))
- (string-join (map proc substrings colors)
""))))))
- rules)))
- (when spun?
- (display (string #\backspace) port))
- (if processed
- (begin
- (display processed port)
- (set! spun? #f))
- ;; Print unprocessed line, or replace with spinner
- (display (if verbose? str (spin!)) port))))))
- (make-soft-port
- (vector
- ;; procedure accepting one character for output
- (cut write <> port)
- ;; procedure accepting a string for output
- handle-string
- ;; thunk for flushing output
- (lambda () (force-output port))
- ;; thunk for getting one character
- (const #t)
- ;; thunk for closing port (not by garbage collection)
- (lambda () (close port)))
- "w"))
-
;;; ui.scm ends here
diff --git a/nix/libstore/builtins.cc b/nix/libstore/builtins.cc
index a5ebb47..31b0943 100644
--- a/nix/libstore/builtins.cc
+++ b/nix/libstore/builtins.cc
@@ -53,6 +53,8 @@ static void builtinDownload(const Derivation &drv,
const string subdir = getenv("GUIX_UNINSTALLED") != NULL
? "" : "/guix";
+ setenv("_NIX_OPTIONS", settings.pack().c_str(), 1);
+
const string program = settings.nixLibexecDir + subdir + "/download";
execv(program.c_str(), (char *const *) argv);