[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: DRAFT Add (guix status).
|
From: |
Ludovic Courtès |
|
Subject: |
01/01: DRAFT Add (guix status). |
|
Date: |
Sun, 28 May 2017 17:03:49 -0400 (EDT) |
civodul pushed a commit to branch wip-ui
in repository guix.
commit c367549b4779591844cfbf2975301e4d8ae70b92
Author: Ludovic Courtès <address@hidden>
Date: Wed Jan 18 23:21:29 2017 +0100
DRAFT Add (guix status).
---
guix/build/download.scm | 11 ++
guix/scripts/build.scm | 10 +-
guix/scripts/perform-download.scm | 1 +
guix/scripts/substitute.scm | 53 ++++++----
guix/status.scm | 217 ++++++++++++++++++++++++++++++++++++++
guix/store.scm | 9 +-
nix/libstore/builtins.cc | 2 +
7 files changed, 281 insertions(+), 22 deletions(-)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index ce4708a..3c3d175 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -45,6 +45,7 @@
byte-count->string
current-terminal-columns
progress-proc
+ trace-progress-proc
uri-abbreviation
nar-uri-abbreviation
store-path-abbreviation))
@@ -207,6 +208,16 @@ used to shorten FILE for display."
(flush-output-port log-port)
(cont))))))))
+(define* (trace-progress-proc file url size
+ #:optional (log-port (current-output-port)))
+ "Like 'progress-proc', but instead of returning human-readable progress
+reports, write \"build trace\" lines to be processed elsewhere."
+ (lambda (transferred cont)
+ (format log-port "@ download-progress ~a ~a ~a ~a~%"
+ file (or url "-") (or size "-") transferred)
+ (flush-output-port log-port)
+ (cont)))
+
(define* (uri-abbreviation uri #:optional (max-length 42))
"If URI's string representation is larger than MAX-LENGTH, return an
abbreviation of URI showing the scheme, host, and basename of the file."
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 558e8e7..0dd78f4 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -682,6 +682,7 @@ needed."
;;; Entry point.
;;;
+(use-modules (guix status))
(define (guix-build . args)
(define opts
(parse-command-line args %options
@@ -698,9 +699,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")
- (current-error-port))))
+ (parameterize ((current-build-output-port
+ (if quiet?
+ (%make-void-port "w")
+ (build-event-output-port
+ (build-status-updater print-build-status)
+ (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 aee506a..d65b123 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 73d4f6e..6b1d184 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -34,6 +34,7 @@
#:use-module ((guix build utils) #:select (mkdir-p dump-port))
#:use-module ((guix build download)
#:select (current-terminal-columns
+ trace-progress-proc
progress-proc uri-abbreviation nar-uri-abbreviation
(open-connection-for-uri
. guix:open-connection-for-uri)
@@ -836,7 +837,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."
@@ -860,7 +861,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))
@@ -871,31 +872,38 @@ 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)
- ;; TRANSLATORS: The second part of this message looks like
- ;; "(4.1MiB installed)"; it shows the size of the package once
- ;; installed.
- (G_ "Downloading ~a~:[~*~; (~a installed)~]...~%")
- (uri->string uri)
- ;; Use the Nar size as an estimate of the installed size.
- (narinfo-size narinfo)
- (and=> (narinfo-size narinfo)
- (cute byte-count->string <>)))
+ (unless print-build-trace?
+ (format (current-error-port)
+ ;; TRANSLATORS: The second part of this message looks like
+ ;; "(4.1MiB installed)"; it shows the size of the package once
+ ;; installed.
+ (G_ "Downloading ~a~:[~*~; (~a installed)~]...~%")
+ (uri->string uri)
+ ;; Use the Nar size as an estimate of the installed size.
+ (narinfo-size narinfo)
+ (and=> (narinfo-size narinfo)
+ (cute byte-count->string <>))))
(let*-values (((raw download-size)
;; Note that Hydra currently generates Nars on the fly
;; and doesn't specify a Content-Length, so
;; DOWNLOAD-SIZE is #f in practice.
(fetch uri #:buffered? #f #:timeout? #f))
+ ((progress-proc)
+ (if print-build-trace?
+ trace-progress-proc
+ (lambda (destination uri size port)
+ (progress-proc uri size port
+ #:abbreviation
+ nar-uri-abbreviation))))
((progress)
(let* ((comp (narinfo-compression narinfo))
(dl-size (or download-size
(and (equal? comp "none")
(narinfo-size narinfo))))
- (progress (progress-proc (uri->string uri)
+ (progress (progress-proc destination
+ (uri->string uri)
dl-size
- (current-error-port)
- #:abbreviation
- nar-uri-abbreviation)))
+ (current-error-port))))
(progress-report-port progress raw)))
((input pids)
(decompressed-port (and=> (narinfo-compression narinfo)
@@ -986,6 +994,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
@@ -1025,7 +1040,8 @@ default value."
(begin
(process-query command
#:cache-urls %cache-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.
@@ -1034,7 +1050,8 @@ default value."
(parameterize ((current-terminal-columns (client-terminal-columns)))
(process-substitution store-path destination
#:cache-urls %cache-urls
- #:acl (current-acl))))
+ #:acl (current-acl)
+ #:print-build-trace? print-build-trace?)))
(("--version")
(show-version-and-exit "guix substitute"))
(("--help")
diff --git a/guix/status.scm b/guix/status.scm
new file mode 100644
index 0000000..cd6f09d
--- /dev/null
+++ b/guix/status.scm
@@ -0,0 +1,217 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 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 (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-19)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (rnrs bytevectors)
+ #:export (build-event-output-port
+
+ build-status
+ build-status?
+
+ build-status-updater
+ 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)
+ (when (string-prefix? "@ " line)
+ (match (string-tokenize (string-drop line 2))
+ (((= string->symbol event-name) args ...)
+ (set! %state
+ (proc (cons event-name args)
+ %state))))))
+
+ (define (write! bv offset count)
+ (let loop ((str (utf8->string bv)))
+ (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
+ (set! %fragments (cons str %fragments))
+ count))))
+
+ (make-custom-binary-output-port "filtering-input-port"
+ write!
+ #f #f
+ #f))
+
+
+;;;
+;;; 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)))))
+ (('build-succeeded 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))))
+ (build-status
+ (inherit status)
+ (substituting (cons (ongoing-download item uri size
+ (ongoing-download-start current)
+ transferred)
+ downloads)))))
+ (_
+ (pk 'unhandled event)
+ 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 "building~{ ~a~}~%" 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* (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 c94dfea..99151c5 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -685,7 +685,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/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);