From 7d2be1277b44de9d0528d9d3015443b40cb3b104 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Jan 2019 15:41:12 +0100 Subject: packages: 'package-input-rewriting' can take a promise. * guix/packages.scm (package-input-rewriting): Allow REPLACEMENTS to be a promise. * gnu/packages/guile.scm (package-for-guile-2.0): Delay the first argument to 'package-input-rewriting'. --- guix/packages.scm | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index f191327718..8515bb7c6f 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -855,19 +855,27 @@ when CUT? returns true for a given package." #:optional (rewrite-name identity)) "Return a procedure that, when passed a package, replaces its direct and indirect dependencies (but not its implicit inputs) according to REPLACEMENTS. -REPLACEMENTS is a list of package pairs; the first element of each pair is the -package to replace, and the second one is the replacement. +REPLACEMENTS is a list of package pairs or a promise thereof; the first +element of each pair is the package to replace, and the second one is the +replacement. Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a package and returns its new name after rewrite." (define (rewrite p) - (match (assq-ref replacements p) + (match (assq-ref (if (promise? replacements) + (force replacements) + replacements) + p) (#f (package (inherit p) (name (rewrite-name (package-name p))))) (new new))) - (package-mapping rewrite (cut assq <> replacements))) + (package-mapping rewrite + (lambda (package) + (assq package (if (promise? replacements) + (force replacements) + replacements))))) (define-syntax-rule (package/inherit p overrides ...) "Like (package (inherit P) OVERRIDES ...), except that the same -- cgit v1.2.3 From 3a8c4860fbccc840b28227dbe44cfffb128a91e0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Jan 2019 22:42:48 +0100 Subject: channels: Turn off deprecation warnings when loading 'build-self.scm'. * guix/channels.scm (build-from-source): Parameterize DEPRECATION-WARNING-PORT when loading SCRIPT. --- guix/channels.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index 10345c1ce5..f386d18b74 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -27,6 +27,7 @@ #:use-module (guix profiles) #:use-module (guix derivations) #:use-module (guix combinators) + #:use-module (guix deprecation) #:use-module (guix store) #:use-module (guix i18n) #:use-module ((guix utils) @@ -275,7 +276,12 @@ package modules under SOURCE using CORE, an instance of Guix." (if (file-exists? script) (let ((build (save-module-excursion (lambda () - (primitive-load script))))) + ;; Disable deprecation warnings; it's OK for SCRIPT to + ;; use deprecated APIs and the user doesn't have to know + ;; about it. + (parameterize ((deprecation-warning-port + (%make-void-port "w"))) + (primitive-load script)))))) ;; BUILD must be a monadic procedure of at least one argument: the ;; source tree. ;; -- cgit v1.2.3 From d1d72830f2d60b2853460c443081683ef2f7d5c4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Jan 2019 23:03:38 +0100 Subject: pull: Don't trigger 'hash guix' hint needlessly. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Previously if ~/.config/guix/current/bin was in $PATH, we'd still suggest to run 'hash guix' because we'd compare (which "guix") against /var/guix/profiles/per-user/…. * guix/scripts/pull.scm (build-and-install): Check whether (which "guix") matches PROFILE or its user-friendly variant. --- guix/scripts/pull.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 41c7fb289a..6cecf8c2e1 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -197,11 +197,13 @@ true, display what would be built without actually building it." (match (which "guix") (#f (return #f)) (str - (let ((command (string-append profile "/bin/guix"))) - (unless (string=? command str) + (let ((new (map (cut string-append <> "/bin/guix") + (list (user-friendly-profile profile) + profile)))) + (unless (member str new) (display-hint (format #f (G_ "After setting @code{PATH}, run @command{hash guix} to make sure your shell refers to @file{~a}.") - command))) + (first new)))) (return #f)))))))) (define (honor-lets-encrypt-certificates! store) -- cgit v1.2.3 From f674bc6620ec2aad35dad455c55fd7dea79236e2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Jan 2019 11:58:50 +0100 Subject: channels: Do not offload package cache derivation. * guix/channels.scm (package-cache-file): Pass #:local-build? to 'gexp->derivation-in-inferior'. --- guix/channels.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index f386d18b74..96d62ce062 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -478,7 +478,8 @@ be used as a profile hook." (gexp->derivation-in-inferior "guix-package-cache" build profile #:properties '((type . profile-hook) - (hook . package-cache))))) + (hook . package-cache)) + #:local-build? #t))) (define %channel-profile-hooks ;; The default channel profile hooks. -- cgit v1.2.3 From 976ef2d97887d16eab8d4eb9dad811786b04d690 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Jan 2019 22:10:13 +0100 Subject: status: Record more information about builds. * guix/status.scm (): New record type. (build, matching-build): New procedures. (compute-status): Adjust to manipulate records instead of derivation file names in 'build-status-builds-completed' and 'build-status-building'. (build-event-output-port)[process-line]: Use 'string-split' to preserve spaces. * tests/status.scm ("compute-status, builds + substitutes") ("compute-status, missing events"): Adjust to expect records. Produce complete "build-started" events. ("compute-status, multiplexed build output"): Likewise, and remove "bar.drv" from 'builds-completed'. --- guix/status.scm | 76 +++++++++++++++++++++++++++++++++++++++++++------------- tests/status.scm | 28 +++++++++++---------- 2 files changed, 74 insertions(+), 30 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 93e119bed1..0a5ff59236 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -50,6 +50,11 @@ build-status-builds-completed build-status-downloads-completed + build? + build + build-derivation + build-system + download? download download-item @@ -85,15 +90,28 @@ ;; Builds and substitutions performed by the daemon. (define-record-type* build-status make-build-status build-status? - (building build-status-building ;list of drv + (building build-status-building ;list of (default '())) (downloading build-status-downloading ;list of (default '())) - (builds-completed build-status-builds-completed ;list of drv + (builds-completed build-status-builds-completed ;list of (default '())) - (downloads-completed build-status-downloads-completed ;list of store items + (downloads-completed build-status-downloads-completed ;list of (default '()))) +;; On-going or completed build. +(define-record-type + (%build derivation id system log-file) + build? + (derivation build-derivation) ;string (.drv file name) + (id build-id) ;#f | integer + (system build-system) ;string + (log-file build-log-file)) ;#f | string + +(define* (build derivation system #:key id log-file) + "Return a new build." + (%build derivation id system log-file)) + ;; On-going or completed downloads. Downloads can be stem from substitutes ;; and from "builtin:download" fixed-output derivations. (define-record-type @@ -113,6 +131,11 @@ "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) @@ -126,15 +149,29 @@ "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 @@ -146,10 +183,11 @@ compute a new status based on STATUS." ;; because ITEM is different from DRV's output. (build-status (inherit status) - (building (remove (lambda (drv) - (equal? (false-if-exception - (derivation-path->output-path 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)) @@ -394,7 +432,7 @@ addition to build events." (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 . _) (format port (failure (G_ "build of ~a failed")) drv) (newline port) @@ -570,7 +608,11 @@ The second return value is a thunk to retrieve the current state." (define (process-line line) (cond ((string-prefix? "@ " line) - (match (string-tokenize (string-drop line 2)) + ;; 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 '()) diff --git a/tests/status.scm b/tests/status.scm index 08a3153218..e3ea768968 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -36,18 +36,18 @@ (test-equal "compute-status, builds + substitutes" (list (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux"))) (downloading (list (download "bar" "http://example.org/bar" #:size 500 #:start 'now)))) (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux"))) (downloading (list (download "bar" "http://example.org/bar" #:size 500 #:transferred 42 #:start 'now)))) (build-status - (builds-completed '("foo.drv")) + (builds-completed (list (build "foo.drv" "x86_64-linux"))) (downloads-completed (list (download "bar" "http://example.org/bar" #:size 500 #:transferred 500 @@ -58,7 +58,7 @@ (compute-status event status #:current-time (const 'now)))))) - (display "@ build-started foo.drv\n" port) + (display "@ build-started foo.drv - x86_64-linux \n" port) (display "@ substituter-started bar\n" port) (display "@ download-started bar http://example.org/bar 500\n" port) (display "various\nthings\nget\nwritten\n" port) @@ -76,7 +76,8 @@ (test-equal "compute-status, missing events" (list (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux" + #:log-file "foo.log"))) (downloading (list (download "baz" "http://example.org/baz" #:size 500 #:transferred 42 @@ -86,7 +87,8 @@ #:transferred 0 #:start 'now)))) (build-status - (builds-completed '("foo.drv")) + (builds-completed (list (build "foo.drv" "x86_64-linux" + #:log-file "foo.log"))) (downloads-completed (list (download "baz" "http://example.org/baz" #:size 500 #:transferred 500 @@ -103,7 +105,7 @@ (compute-status event status #:current-time (const 'now)))))) - (display "@ build-started foo.drv\n" port) + (display "@ build-started foo.drv - x86_64-linux foo.log\n" port) (display "@ download-started bar http://example.org/bar 999\n" port) (display "various\nthings\nget\nwritten\n" port) (display "@ download-progress baz http://example.org/baz 500 42\n" @@ -136,19 +138,19 @@ (test-equal "compute-status, multiplexed build output" (list (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux" #:id 121))) (downloading (list (download "bar" "http://example.org/bar" #:size 999 #:start 'now)))) (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux" #:id 121))) (downloading (list (download "bar" "http://example.org/bar" #:size 999 #:transferred 42 #:start 'now)))) (build-status - ;; XXX: Should "bar.drv" be present twice? - (builds-completed '("bar.drv" "foo.drv")) + ;; "bar" is now only listed as a download. + (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121))) (downloads-completed (list (download "bar" "http://example.org/bar" #:size 999 #:transferred 999 @@ -162,8 +164,8 @@ #:derivation-path->output-path (match-lambda ("bar.drv" "bar"))))))) - (display "@ build-started foo.drv 121\n" port) - (display "@ build-started bar.drv 144\n" port) + (display "@ build-started foo.drv - x86_64-linux 121\n" port) + (display "@ build-started bar.drv - armhf-linux bar.log 144\n" port) (display "@ build-log 121 6\nHello!" port) (display "@ build-log 144 50 @ download-started bar http://example.org/bar 999\n" port) -- cgit v1.2.3 From 73a8681a16869a2b3a9da1c7ba9434e07a204e19 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Jan 2019 22:33:16 +0100 Subject: status: Keep track of build completion as reported by build tools. * guix/status.scm ()[completion]: New field. (build): Add #:completion parameter. (%percentage-line-rx, %fraction-line-rx): New variables. (update-build): New procedure. (compute-status): Add 'build-log' case. * tests/status.scm ("compute-status, build completion"): New test. --- guix/status.scm | 62 ++++++++++++++++++++++++++++++++++++++++++++++++++++---- tests/status.scm | 31 ++++++++++++++++++++++++++++ 2 files changed, 89 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 0a5ff59236..0435d14d6a 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -101,16 +101,17 @@ ;; On-going or completed build. (define-record-type - (%build derivation id system log-file) + (%build derivation id system log-file 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 + (log-file build-log-file) ;#f | string + (completion build-completion)) ;#f | integer (percentage) -(define* (build derivation system #:key id log-file) +(define* (build derivation system #:key id log-file completion) "Return a new build." - (%build derivation id system log-file)) + (%build derivation id system log-file completion)) ;; On-going or completed downloads. Downloads can be stem from substitutes ;; and from "builtin:download" fixed-output derivations. @@ -141,6 +142,57 @@ (lambda (download) (string=? item (download-item download)))) +(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 (set-completion b %) + (build (build-derivation b) + (build-system b) + #:id (build-id b) + #:log-file (build-log-file b) + #:completion %)) + + (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-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)))))) + (else + status))) + (define* (compute-status event status #:key (current-time current-time) @@ -242,6 +294,8 @@ compute a new status based on STATUS." (current-time time-monotonic)) #:transferred transferred) downloads))))) + (('build-log (? integer? pid) line) + (update-build status pid line)) (_ status))) diff --git a/tests/status.scm b/tests/status.scm index e3ea768968..f3afadfcd0 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -180,4 +180,35 @@ (display "@ build-succeeded bar.drv\n" port) (list first second (get-status)))))) +(test-equal "compute-status, build completion" + (list (build-status + (building (list (build "foo.drv" "x86_64-linux" #:id 121)))) + (build-status + (building (list (build "foo.drv" "x86_64-linux" #:id 121 + #:completion 0.)))) + (build-status + (building (list (build "foo.drv" "x86_64-linux" #:id 121 + #:completion 50.)))) + (build-status + (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121 + #:completion 100.))))) + (let-values (((port get-status) + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now)))))) + (display "@ build-started foo.drv - x86_64-linux 121\n" port) + (display "@ build-log 121 6\nHello!" port) + (let ((first (get-status))) + (display "@ build-log 121 20\n[ 0/100] building X\n" port) + (display "@ build-log 121 6\nHello!" port) + (let ((second (get-status))) + (display "@ build-log 121 20\n[50/100] building Y\n" port) + (display "@ build-log 121 6\nHello!" port) + (let ((third (get-status))) + (display "@ build-log 121 21\n[100/100] building Z\n" port) + (display "@ build-log 121 6\nHello!" port) + (display "@ build-succeeded foo.drv\n" port) + (list first second third (get-status))))))) + (test-end "status") -- cgit v1.2.3 From 3854c6429c648df5b5ab23f871de9ec3c466f61b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Jan 2019 22:44:34 +0100 Subject: status: Print a progress bar for on-going builds when possible. * guix/status.scm (print-build-event)[report-build-progress]: New procedure. [print-log-line]: Add ID parameter. Call 'report-build-progress' when appropriate. Adjust callers. --- guix/status.scm | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 0435d14d6a..e3375816c5 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -441,14 +441,29 @@ addition to build events." (cut colorize-string <> 'RED 'BOLD) identity)) + (define (report-build-progress %) + (let ((% (min (max % 0) 100))) ;sanitize + (erase-current-line port) + (format port "~3d% " (inexact->exact (round %))) + (display (progress-bar % (- (current-terminal-columns) 5)) + 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 %)) + (_ (spin! port)))) + (_ + (spin! port)))))) (unless print-log? (display "\r" port)) ;erase the spinner @@ -552,7 +567,7 @@ addition to build events." ;; through. (display line port) (force-output port)) - (print-log-line 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 @@ -565,7 +580,7 @@ addition to build events." (display (info (string-trim-right line)) port) (newline)) (else - (print-log-line line))))) + (print-log-line pid line))))) (_ event))) -- cgit v1.2.3 From 35dcaa119e2b24343e76aa2a4213a3cc1fb69049 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Jan 2019 18:15:05 +0100 Subject: self: Produce progress reports compatible with (guix status). * guix/self.scm (compiled-modules)[build](report-load) (report-compilation): Write "[M/N]" progress reports. Use line-buffering. --- guix/self.scm | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index d1b8256802..f028bdbfdd 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -856,13 +856,23 @@ containing MODULE-FILES and possibly other files as well." (define (report-load file total completed) (display #\cr) (format #t - "loading...\t~5,1f% of ~d files" ;FIXME: i18n + "[~3@a/~3@a] loading...\t~5,1f% of ~d files" + + ;; Note: Multiply TOTAL by two to account for the + ;; compilation phase that follows. + completed (* total 2) + (* 100. (/ completed total)) total) (force-output)) (define (report-compilation file total completed) (display #\cr) - (format #t "compiling...\t~5,1f% of ~d files" ;FIXME: i18n + (format #t "[~3@a/~3@a] compiling...\t~5,1f% of ~d files" + + ;; Add TOTAL to account for the load phase that came + ;; before. + (+ total completed) (* total 2) + (* 100. (/ completed total)) total) (force-output)) @@ -874,8 +884,8 @@ containing MODULE-FILES and possibly other files as well." #:report-load report-load #:report-compilation report-compilation))) - (setvbuf (current-output-port) 'none) - (setvbuf (current-error-port) 'none) + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) (set! %load-path (cons #+module-tree %load-path)) (set! %load-path -- cgit v1.2.3 From 2790b6670b60a5f541df4d01afac6bf9335a5252 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Jan 2019 18:16:25 +0100 Subject: pull: Default to verbosity level 1. * guix/scripts/pull.scm (%default-options): Change 'verbosity to 1. --- guix/scripts/pull.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 6cecf8c2e1..683ab3f059 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -69,7 +69,7 @@ (multiplexed-build-output? . #t) (graft? . #t) (debug . 0) - (verbosity . 2))) + (verbosity . 1))) (define (show-help) (display (G_ "Usage: guix pull [OPTION]... -- cgit v1.2.3