diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 22 | ||||
| -rw-r--r-- | guix/scripts/describe.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 117 | ||||
| -rw-r--r-- | guix/scripts/import/cran.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 150 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 66 | ||||
| -rw-r--r-- | guix/scripts/perform-download.scm | 17 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 155 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 44 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 37 |
10 files changed, 361 insertions, 251 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 9d38610633..13978abb77 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -45,6 +45,9 @@ #:use-module (srfi srfi-37) #:autoload (gnu packages) (specification->package %package-module-path) #:autoload (guix download) (download-to-store) + #:use-module (guix status) + #:use-module ((guix progress) #:select (current-terminal-columns)) + #:use-module ((guix build syscalls) #:select (terminal-columns)) #:export (%standard-build-options set-build-options-from-command-line set-build-options-from-command-line* @@ -390,6 +393,10 @@ options handled by 'set-build-options-from-command-line', and listed in #:max-silent-time (assoc-ref opts 'max-silent-time) #:timeout (assoc-ref opts 'timeout) #:print-build-trace (assoc-ref opts 'print-build-trace?) + #:print-extended-build-trace? + (assoc-ref opts 'print-extended-build-trace?) + #:multiplexed-build-output? + (assoc-ref opts 'multiplexed-build-output?) #:verbosity (assoc-ref opts 'verbosity))) (define set-build-options-from-command-line* @@ -499,6 +506,8 @@ options handled by 'set-build-options-from-command-line', and listed in (substitutes? . #t) (build-hook? . #t) (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (verbosity . 0))) (define (show-help) @@ -617,7 +626,7 @@ must be one of 'package', 'all', or 'transitive'~%") "Read the arguments from OPTS and return a list of high-level objects to build---packages, gexps, derivations, and so on." (define (validate-type x) - (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x)) + (unless (or (derivation? x) (file-like? x) (gexp? x) (procedure? x)) (leave (G_ "~s: not something we can build~%") x))) (define (ensure-list x) @@ -694,6 +703,10 @@ package '~a' has no source~%") (set-guile-for-build (default-guile)) (proc)) #:system system))) + ((? file-like? obj) + (list (run-with-store store + (lower-object obj system + #:target (assoc-ref opts 'target))))) ((? gexp? gexp) (list (run-with-store store (mbegin %store-monad @@ -733,11 +746,12 @@ needed." ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) - (parameterize ((current-build-output-port + (parameterize ((current-terminal-columns (terminal-columns)) + (current-build-output-port (if quiet? (%make-void-port "w") - (build-output-port #:verbose? #t - #:port (duplicate-port (current-error-port) "w"))))) + (build-event-output-port + (build-status-updater print-build-event))))) (let* ((mode (assoc-ref opts 'build-mode)) (drv (options->derivations store opts)) (urls (map (cut string-append <> "/log") diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index c1a20fe26c..e59502076c 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -158,4 +158,4 @@ in the format specified by FMT." (#f (display-checkout-info format)) (profile - (display-profile-info profile format)))))) + (display-profile-info (canonicalize-profile profile) format)))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 1c04800e42..5965e3426e 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -21,6 +21,7 @@ (define-module (guix scripts environment) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix status) #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) @@ -173,6 +174,9 @@ COMMAND or an interactive shell in that environment.\n")) (substitutes? . #t) (build-hook? . #t) (graft? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (verbosity . 0))) (define (tag-package-arg opts arg) @@ -661,59 +665,60 @@ message if any test fails." (leave (G_ "'--user' cannot be used without '--container'~%"))) (with-store store - (set-build-options-from-command-line store opts) - - ;; Use the bootstrap Guile when requested. - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build - (package-derivation - store - (if bootstrap? - %bootstrap-guile - (canonical-package guile-2.2))))) - (run-with-store store - ;; Containers need a Bourne shell at /bin/sh. - (mlet* %store-monad ((bash (environment-bash container? - bootstrap? - system)) - (prof-drv (manifest->derivation - manifest system bootstrap?)) - (profile -> (derivation->output-path prof-drv)) - (gc-root -> (assoc-ref opts 'gc-root))) - - ;; First build the inputs. This is necessary even for - ;; --search-paths. Additionally, we might need to build bash for - ;; a container. - (mbegin %store-monad - (build-environment (if (derivation? bash) - (list prof-drv bash) - (list prof-drv)) - opts) - (mwhen gc-root - (register-gc-root profile gc-root)) - - (cond - ((assoc-ref opts 'dry-run?) - (return #t)) - ((assoc-ref opts 'search-paths) - (show-search-paths profile manifest #:pure? pure?) - (return #t)) - (container? - (let ((bash-binary - (if bootstrap? - bash - (string-append (derivation->output-path bash) - "/bin/sh")))) - (launch-environment/container #:command command - #:bash bash-binary - #:user user - #:user-mappings mappings - #:profile profile - #:manifest manifest - #:link-profile? link-prof? - #:network? network?))) - (else - (return - (exit/status - (launch-environment/fork command profile manifest - #:pure? pure?))))))))))))) + (with-status-report print-build-event + (set-build-options-from-command-line store opts) + + ;; Use the bootstrap Guile when requested. + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build + (package-derivation + store + (if bootstrap? + %bootstrap-guile + (canonical-package guile-2.2))))) + (run-with-store store + ;; Containers need a Bourne shell at /bin/sh. + (mlet* %store-monad ((bash (environment-bash container? + bootstrap? + system)) + (prof-drv (manifest->derivation + manifest system bootstrap?)) + (profile -> (derivation->output-path prof-drv)) + (gc-root -> (assoc-ref opts 'gc-root))) + + ;; First build the inputs. This is necessary even for + ;; --search-paths. Additionally, we might need to build bash for + ;; a container. + (mbegin %store-monad + (build-environment (if (derivation? bash) + (list prof-drv bash) + (list prof-drv)) + opts) + (mwhen gc-root + (register-gc-root profile gc-root)) + + (cond + ((assoc-ref opts 'dry-run?) + (return #t)) + ((assoc-ref opts 'search-paths) + (show-search-paths profile manifest #:pure? pure?) + (return #t)) + (container? + (let ((bash-binary + (if bootstrap? + bash + (string-append (derivation->output-path bash) + "/bin/sh")))) + (launch-environment/container #:command command + #:bash bash-binary + #:user user + #:user-mappings mappings + #:profile profile + #:manifest manifest + #:link-profile? link-prof? + #:network? network?))) + (else + (return + (exit/status + (launch-environment/fork command profile manifest + #:pure? pure?)))))))))))))) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 30ae6d4342..794fb710cd 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -47,6 +47,8 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 28462d9b8d..13aa8923cd 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -25,6 +25,7 @@ #:use-module (guix gexp) #:use-module (guix utils) #:use-module (guix store) + #:use-module (guix status) #:use-module (guix grafts) #:use-module (guix monads) #:use-module (guix modules) @@ -197,8 +198,11 @@ added to the pack." (with-directory-excursion %root (exit (zero? (apply system* "tar" - "-I" - (string-join '#+(compressor-command compressor)) + #+@(if (compressor-command compressor) + #~("-I" + (string-join + '#+(compressor-command compressor))) + #~()) "--format=gnu" ;; Avoid non-determinism in the archive. Use @@ -538,6 +542,9 @@ please email '~a'~%") (substitutes? . #t) (build-hook? . #t) (graft? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (verbosity . 0) (symlinks . ()) (compressor . ,(first %compressors)))) @@ -684,72 +691,73 @@ Create a bundle of PACKAGE.\n")) (with-error-handling (with-store store - ;; Set the build options before we do anything else. - (set-build-options-from-command-line store opts) - - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2)) - (assoc-ref opts 'system) - #:graft? (assoc-ref opts 'graft?)))) - (let* ((dry-run? (assoc-ref opts 'dry-run?)) - (relocatable? (assoc-ref opts 'relocatable?)) - (manifest (let ((manifest (manifest-from-args store opts))) - ;; Note: We cannot honor '--bootstrap' here because - ;; 'glibc-bootstrap' lacks 'libc.a'. - (if relocatable? - (map-manifest-entries wrapped-package manifest) - manifest))) - (pack-format (assoc-ref opts 'format)) - (name (string-append (symbol->string pack-format) - "-pack")) - (target (assoc-ref opts 'target)) - (bootstrap? (assoc-ref opts 'bootstrap?)) - (compressor (if bootstrap? - bootstrap-xz - (assoc-ref opts 'compressor))) - (archiver (if (equal? pack-format 'squashfs) - squashfs-tools-next - (if bootstrap? - %bootstrap-coreutils&co - tar))) - (symlinks (assoc-ref opts 'symlinks)) - (build-image (match (assq-ref %formats pack-format) - ((? procedure? proc) proc) - (#f - (leave (G_ "~a: unknown pack format~%") - pack-format)))) - (localstatedir? (assoc-ref opts 'localstatedir?))) - (run-with-store store - (mlet* %store-monad ((profile (profile-derivation - manifest - #:relative-symlinks? relocatable? - #:hooks (if bootstrap? - '() - %default-profile-hooks) - #:locales? (not bootstrap?) - #:target target)) - (drv (build-image name profile - #:target - target - #:compressor - compressor - #:symlinks - symlinks - #:localstatedir? - localstatedir? - #:archiver - archiver))) - (mbegin %store-monad - (show-what-to-build* (list drv) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? dry-run?) - (munless dry-run? - (built-derivations (list drv)) - (return (format #t "~a~%" - (derivation->output-path drv)))))) - #:system (assoc-ref opts 'system))))))) + (with-status-report print-build-event + ;; Set the build options before we do anything else. + (set-build-options-from-command-line store opts) + + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2)) + (assoc-ref opts 'system) + #:graft? (assoc-ref opts 'graft?)))) + (let* ((dry-run? (assoc-ref opts 'dry-run?)) + (relocatable? (assoc-ref opts 'relocatable?)) + (manifest (let ((manifest (manifest-from-args store opts))) + ;; Note: We cannot honor '--bootstrap' here because + ;; 'glibc-bootstrap' lacks 'libc.a'. + (if relocatable? + (map-manifest-entries wrapped-package manifest) + manifest))) + (pack-format (assoc-ref opts 'format)) + (name (string-append (symbol->string pack-format) + "-pack")) + (target (assoc-ref opts 'target)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (compressor (if bootstrap? + bootstrap-xz + (assoc-ref opts 'compressor))) + (archiver (if (equal? pack-format 'squashfs) + squashfs-tools-next + (if bootstrap? + %bootstrap-coreutils&co + tar))) + (symlinks (assoc-ref opts 'symlinks)) + (build-image (match (assq-ref %formats pack-format) + ((? procedure? proc) proc) + (#f + (leave (G_ "~a: unknown pack format~%") + pack-format)))) + (localstatedir? (assoc-ref opts 'localstatedir?))) + (run-with-store store + (mlet* %store-monad ((profile (profile-derivation + manifest + #:relative-symlinks? relocatable? + #:hooks (if bootstrap? + '() + %default-profile-hooks) + #:locales? (not bootstrap?) + #:target target)) + (drv (build-image name profile + #:target + target + #:compressor + compressor + #:symlinks + symlinks + #:localstatedir? + localstatedir? + #:archiver + archiver))) + (mbegin %store-monad + (show-what-to-build* (list drv) + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? dry-run?) + (munless dry-run? + (built-derivations (list drv)) + (return (format #t "~a~%" + (derivation->output-path drv)))))) + #:system (assoc-ref opts 'system)))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index c3ed2ac935..5d146b8427 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -24,6 +24,7 @@ (define-module (guix scripts package) #:use-module (guix ui) + #:use-module (guix status) #:use-module (guix store) #:use-module (guix grafts) #:use-module (guix derivations) @@ -67,50 +68,14 @@ (define (ensure-default-profile) "Ensure the default profile symlink and directory exist and are writable." - - (define (rtfm) - (format (current-error-port) - (G_ "Try \"info '(guix) Invoking guix package'\" for \ -more information.~%")) - (exit 1)) + (ensure-profile-directory) ;; Create ~/.guix-profile if it doesn't exist yet. (when (and %user-profile-directory %current-profile (not (false-if-exception (lstat %user-profile-directory)))) - (symlink %current-profile %user-profile-directory)) - - (let ((s (stat %profile-directory #f))) - ;; Attempt to create /…/profiles/per-user/$USER if needed. - (unless (and s (eq? 'directory (stat:type s))) - (catch 'system-error - (lambda () - (mkdir-p %profile-directory)) - (lambda args - ;; Often, we cannot create %PROFILE-DIRECTORY because its - ;; parent directory is root-owned and we're running - ;; unprivileged. - (format (current-error-port) - (G_ "error: while creating directory `~a': ~a~%") - %profile-directory - (strerror (system-error-errno args))) - (format (current-error-port) - (G_ "Please create the `~a' directory, with you as the owner.~%") - %profile-directory) - (rtfm)))) - - ;; Bail out if it's not owned by the user. - (unless (or (not s) (= (stat:uid s) (getuid))) - (format (current-error-port) - (G_ "error: directory `~a' is not owned by you~%") - %profile-directory) - (format (current-error-port) - (G_ "Please change the owner of `~a' to user ~s.~%") - %profile-directory (or (getenv "USER") - (getenv "LOGNAME") - (getuid))) - (rtfm)))) + (symlink %current-profile %user-profile-directory))) (define (delete-generations store profile generations) "Delete GENERATIONS from PROFILE. @@ -330,7 +295,9 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (graft? . #t) (substitutes? . #t) (build-hook? . #t) - (print-build-trace? . #t))) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t))) (define (show-help) (display (G_ "Usage: guix package [OPTION]... @@ -941,15 +908,12 @@ processed, #f otherwise." (or (process-query opts) (parameterize ((%store (open-connection)) (%graft? (assoc-ref opts 'graft?))) - (set-build-options-from-command-line (%store) opts) - - (parameterize ((%guile-for-build - (package-derivation - (%store) - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2)))) - (current-build-output-port - (build-output-port #:verbose? verbose? - #:port (duplicate-port (current-error-port) "w")))) - (process-actions (%store) opts)))))) + (with-status-report print-build-event/quiet + (set-build-options-from-command-line (%store) opts) + (parameterize ((%guile-for-build + (package-derivation + (%store) + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2))))) + (process-actions (%store) opts))))))) diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 18e2fc92f2..df787a9940 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,7 +41,8 @@ (module-use! module (resolve-interface '(guix base32))) module)) -(define* (perform-download drv #:optional output) +(define* (perform-download drv #:optional output + #:key print-build-trace?) "Perform the download described by DRV, a fixed-output derivation, to OUTPUT. @@ -67,6 +68,7 @@ actual output is different from that when we're doing a 'bmCheck' or ;; We're invoked by the daemon, which gives us write access to OUTPUT. (when (url-fetch url output + #:print-build-trace? print-build-trace? #:mirrors (if mirrors (call-with-input-file mirrors read) '()) @@ -98,6 +100,11 @@ allows us to sidestep bootstrapping problems, such downloading the source code of GnuTLS over HTTPS, before we have built GnuTLS. See <http://bugs.gnu.org/22774>." + (define print-build-trace? + (match (getenv "_NIX_OPTIONS") + (#f #f) + (str (string-contains str "print-extended-build-trace=1")))) + ;; This program must be invoked by guix-daemon under an unprivileged UID to ;; prevent things downloading from 'file:///etc/shadow' or arbitrary code ;; execution via the content-addressed mirror procedures. (That means we @@ -107,10 +114,12 @@ of GnuTLS over HTTPS, before we have built GnuTLS. See (((? derivation-path? drv) (? store-path? output)) (assert-low-privileges) (perform-download (read-derivation-from-file drv) - output)) + output + #:print-build-trace? print-build-trace?)) (((? derivation-path? drv)) ;backward compatibility (assert-low-privileges) - (perform-download (read-derivation-from-file drv))) + (perform-download (read-derivation-from-file drv) + #:print-build-trace? print-build-trace?)) (("--version") (show-version-and-exit)) (x diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 10e1a99e54..188237aa90 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -20,6 +20,7 @@ (define-module (guix scripts pull) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix status) #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix config) @@ -61,6 +62,9 @@ `((system . ,(%current-system)) (substitutes? . #t) (build-hook? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (graft? . #t) (verbosity . 0))) @@ -180,9 +184,25 @@ Download and deploy the latest version of Guix.\n")) (define (honor-x509-certificates store) "Use the right X.509 certificates for Git checkouts over HTTPS." - (let ((file (getenv "SSL_CERT_FILE")) + ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of + ;; files (instead of all the certificates) among which "ca-bundle.crt". On + ;; other distros /etc/ssl/certs usually contains the whole set of + ;; certificates along with "ca-certificates.crt". Try to choose the right + ;; one. + (let ((file (letrec-syntax ((choose + (syntax-rules () + ((_ file rest ...) + (let ((f file)) + (if (and f (file-exists? f)) + f + (choose rest ...)))) + ((_) + #f)))) + (choose (getenv "SSL_CERT_FILE") + "/etc/ssl/certs/ca-certificates.crt" + "/etc/ssl/certs/ca-bundle.crt"))) (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs"))) - (if (or (and file (file-exists? file)) + (if (or file (and=> (stat directory #f) (lambda (st) (> (stat:nlink st) 2)))) @@ -208,6 +228,60 @@ Download and deploy the latest version of Guix.\n")) ;;; +;;; Profile. +;;; + +(define %current-profile + ;; The "real" profile under /var/guix. + (string-append %profile-directory "/current-guix")) + +(define %user-profile-directory + ;; The user-friendly name of %CURRENT-PROFILE. + (string-append (config-directory #:ensure? #f) "/current")) + +(define (migrate-generations profile directory) + "Migrate the generations of PROFILE to DIRECTORY." + (format (current-error-port) + (G_ "Migrating profile generations to '~a'...~%") + %profile-directory) + (let ((current (generation-number profile))) + (for-each (lambda (generation) + (let ((source (generation-file-name profile generation)) + (target (string-append directory "/current-guix-" + (number->string generation) + "-link"))) + ;; Note: Don't use 'rename-file' as SOURCE and TARGET might + ;; live on different file systems. + (symlink (readlink source) target) + (delete-file source))) + (profile-generations profile)) + (symlink (string-append "current-guix-" + (number->string current) "-link") + (string-append directory "/current-guix")))) + +(define (ensure-default-profile) + (ensure-profile-directory) + + ;; In 0.15.0+ we'd create ~/.config/guix/current-[0-9]*-link symlinks. Move + ;; them to %PROFILE-DIRECTORY. + (unless (string=? %profile-directory + (dirname (canonicalize-profile %user-profile-directory))) + (migrate-generations %user-profile-directory %profile-directory)) + + ;; Make sure ~/.config/guix/current points to /var/guix/profiles/…. + (let ((link %user-profile-directory)) + (unless (equal? (false-if-exception (readlink link)) + %current-profile) + (catch 'system-error + (lambda () + (false-if-exception (delete-file link)) + (symlink %current-profile link)) + (lambda args + (leave (G_ "while creating symlink '~a': ~a~%") + link (strerror (system-error-errno args)))))))) + + +;;; ;;; Queries. ;;; @@ -322,11 +396,8 @@ and ALIST2 differ, display HEADING upfront." (display-new/upgraded-packages (package-alist gen1) (package-alist gen2))) -(define (process-query opts) - "Process any query specified by OPTS." - (define profile - (string-append (config-directory) "/current")) - +(define (process-query opts profile) + "Process any query on PROFILE specified by OPTS." (match (assoc-ref opts 'query) (('list-generations pattern) (define (list-generations profile numbers) @@ -422,45 +493,45 @@ Use '~/.config/guix/channels.scm' instead.")) (list %default-options))) (cache (string-append (cache-directory) "/pull")) (channels (channel-list opts)) - (profile (or (assoc-ref opts 'profile) - (string-append (config-directory) "/current")))) - + (profile (or (assoc-ref opts 'profile) %current-profile))) + (ensure-default-profile) (cond ((assoc-ref opts 'query) - (process-query opts)) + (process-query opts profile)) ((assoc-ref opts 'dry-run?) #t) ;XXX: not very useful (else (with-store store - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%repository-cache-directory cache)) - (set-build-options-from-command-line store opts) - (honor-x509-certificates store) - - (let ((instances (latest-channel-instances store channels))) - (format (current-error-port) - (N_ "Building from this channel:~%" - "Building from these channels:~%" - (length instances))) - (for-each (lambda (instance) - (let ((channel - (channel-instance-channel instance))) - (format (current-error-port) - " ~10a~a\t~a~%" - (channel-name channel) - (channel-url channel) - (string-take - (channel-instance-commit instance) - 7)))) - instances) - (parameterize ((%guile-for-build - (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2))))) - (run-with-store store - (build-and-install instances profile - #:verbose? - (assoc-ref opts 'verbose?))))))))))))) + (with-status-report print-build-event + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%repository-cache-directory cache)) + (set-build-options-from-command-line store opts) + (honor-x509-certificates store) + + (let ((instances (latest-channel-instances store channels))) + (format (current-error-port) + (N_ "Building from this channel:~%" + "Building from these channels:~%" + (length instances))) + (for-each (lambda (instance) + (let ((channel + (channel-instance-channel instance))) + (format (current-error-port) + " ~10a~a\t~a~%" + (channel-name channel) + (channel-url channel) + (string-take + (channel-instance-commit instance) + 7)))) + instances) + (parameterize ((%guile-for-build + (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2))))) + (run-with-store store + (build-and-install instances profile + #:verbose? + (assoc-ref opts 'verbose?)))))))))))))) ;;; pull.scm ends here diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 6d31dfdaa4..eb82224016 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -837,8 +837,17 @@ REPORTER, which should be a <progress-reporter> object." (make-custom-binary-input-port "progress-port-proc" read! #f #f (lambda () - (close-connection port) - (stop))))))) + ;; XXX: Kludge! When used through + ;; 'decompressed-port', this port ends + ;; up being closed twice: once in a + ;; child process early on, and at the + ;; end in the parent process. Ignore + ;; the early close so we don't output + ;; a spurious "download-succeeded" + ;; trace. + (unless (zero? total) + (stop)) + (close-port port))))))) (define-syntax with-networking (syntax-rules () @@ -930,7 +939,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 +952,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 +966,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 +1074,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-extended-build-trace") + (find-daemon-option "print-extended-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 @@ -1111,7 +1134,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/scripts/system.scm b/guix/scripts/system.scm index 69bd05b516..f9af38b7c5 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -23,6 +23,7 @@ (define-module (guix scripts system) #:use-module (guix config) #:use-module (guix ui) + #:use-module (guix status) #:use-module (guix store) #:autoload (guix store database) (register-path) #:use-module (guix grafts) @@ -310,9 +311,9 @@ names of services to load (upgrade), and the list of names of services to unload." (match (current-services) ((services ...) - (let-values (((to-unload to-load) + (let-values (((to-unload to-restart) (shepherd-service-upgrade services new-services))) - (mproc to-load + (mproc to-restart (map (compose first live-service-provision) to-unload)))) (#f @@ -335,25 +336,32 @@ bring the system down." ;; Arrange to simply emit a warning if the service upgrade fails. (with-shepherd-error-handling (call-with-service-upgrade-info new-services - (lambda (to-load to-unload) + (lambda (to-restart to-unload) (for-each (lambda (unload) (info (G_ "unloading service '~a'...~%") unload) (unload-service unload)) to-unload) (with-monad %store-monad - (munless (null? to-load) - (let ((to-load-names (map shepherd-service-canonical-name to-load)) - (to-start (filter shepherd-service-auto-start? to-load))) - (info (G_ "loading new services:~{ ~a~}...~%") to-load-names) + (munless (null? new-services) + (let ((new-service-names (map shepherd-service-canonical-name new-services)) + (to-restart-names (map shepherd-service-canonical-name to-restart)) + (to-start (filter shepherd-service-auto-start? new-services))) + (info (G_ "loading new services:~{ ~a~}...~%") new-service-names) + (unless (null? to-restart-names) + ;; Listing TO-RESTART-NAMES in the message below wouldn't help + ;; because many essential services cannot be meaningfully + ;; restarted. See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>. + (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop, +upgrade, and restart each service that was not automatically restarted.\n"))) (mlet %store-monad ((files (mapm %store-monad (compose lower-object shepherd-service-file) - to-load))) + new-services))) ;; Here we assume that FILES are exactly those that were computed ;; as part of the derivation that built OS, which is normally the ;; case. - (load-services (map derivation->output-path files)) + (load-services/safe (map derivation->output-path files)) (for-each start-service (map shepherd-service-canonical-name to-start)) @@ -1072,6 +1080,9 @@ Some ACTIONS support additional ARGS.\n")) `((system . ,(%current-system)) (substitutes? . #t) (build-hook? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (graft? . #t) (verbosity . 0) (file-system-type . "ext4") @@ -1246,9 +1257,11 @@ argument list and OPTS is the option alist." parse-sub-command)) (args (option-arguments opts)) (command (assoc-ref opts 'action))) - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (current-terminal-columns (terminal-columns))) - (process-command command args opts))))) + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (with-status-report (if (memq command '(init reconfigure)) + print-build-event/quiet + print-build-event) + (process-command command args opts)))))) ;;; Local Variables: ;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1) |