diff options
author | Efraim Flashner <efraim@flashner.co.il> | 2023-01-30 11:33:18 +0200 |
---|---|---|
committer | Efraim Flashner <efraim@flashner.co.il> | 2023-01-30 12:39:40 +0200 |
commit | 4cf1acc7f3033b50b0bf19e02c9f522d522d338c (patch) | |
tree | 9fd64956ee60304c15387eb394cd649e49f01467 /guix/scripts | |
parent | edb8c09addd186d9538d43b12af74d6c7aeea082 (diff) | |
parent | 595b53b74e3ef57a1c0c96108ba86d38a170a241 (diff) | |
download | guix-patches-4cf1acc7f3033b50b0bf19e02c9f522d522d338c.tar guix-patches-4cf1acc7f3033b50b0bf19e02c9f522d522d338c.tar.gz |
Merge remote-tracking branch 'origin/master' into core-updates
Conflicts:
doc/guix.texi
gnu/local.mk
gnu/packages/admin.scm
gnu/packages/base.scm
gnu/packages/chromium.scm
gnu/packages/compression.scm
gnu/packages/databases.scm
gnu/packages/diffoscope.scm
gnu/packages/freedesktop.scm
gnu/packages/gnome.scm
gnu/packages/gnupg.scm
gnu/packages/guile.scm
gnu/packages/inkscape.scm
gnu/packages/llvm.scm
gnu/packages/openldap.scm
gnu/packages/pciutils.scm
gnu/packages/ruby.scm
gnu/packages/samba.scm
gnu/packages/sqlite.scm
gnu/packages/statistics.scm
gnu/packages/syndication.scm
gnu/packages/tex.scm
gnu/packages/tls.scm
gnu/packages/version-control.scm
gnu/packages/xml.scm
guix/build-system/copy.scm
guix/scripts/home.scm
Diffstat (limited to 'guix/scripts')
-rw-r--r-- | guix/scripts/archive.scm | 1 | ||||
-rw-r--r-- | guix/scripts/build.scm | 13 | ||||
-rw-r--r-- | guix/scripts/challenge.scm | 1 | ||||
-rw-r--r-- | guix/scripts/deploy.scm | 3 | ||||
-rw-r--r-- | guix/scripts/describe.scm | 3 | ||||
-rw-r--r-- | guix/scripts/environment.scm | 462 | ||||
-rw-r--r-- | guix/scripts/gc.scm | 11 | ||||
-rw-r--r-- | guix/scripts/graph.scm | 14 | ||||
-rw-r--r-- | guix/scripts/home.scm | 9 | ||||
-rw-r--r-- | guix/scripts/import.scm | 4 | ||||
-rw-r--r-- | guix/scripts/import/cran.scm | 21 | ||||
-rw-r--r-- | guix/scripts/offload.scm | 40 | ||||
-rw-r--r-- | guix/scripts/pack.scm | 205 | ||||
-rw-r--r-- | guix/scripts/package.scm | 1 | ||||
-rw-r--r-- | guix/scripts/publish.scm | 25 | ||||
-rw-r--r-- | guix/scripts/pull.scm | 1 | ||||
-rw-r--r-- | guix/scripts/refresh.scm | 140 | ||||
-rw-r--r-- | guix/scripts/repl.scm | 14 | ||||
-rw-r--r-- | guix/scripts/shell.scm | 105 | ||||
-rw-r--r-- | guix/scripts/size.scm | 1 | ||||
-rw-r--r-- | guix/scripts/style.scm | 16 | ||||
-rwxr-xr-x | guix/scripts/substitute.scm | 169 | ||||
-rw-r--r-- | guix/scripts/system.scm | 14 | ||||
-rw-r--r-- | guix/scripts/system/reconfigure.scm | 20 | ||||
-rw-r--r-- | guix/scripts/system/search.scm | 4 | ||||
-rw-r--r-- | guix/scripts/weather.scm | 1 |
26 files changed, 847 insertions, 451 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 1e961c84e6..3b2bdee835 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -26,7 +26,6 @@ #:select (fold-archive restore-file)) #:use-module (guix store) #:use-module ((guix status) #:select (with-status-verbosity)) - #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix monads) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 06d9ad1f0c..b4437172d7 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -28,10 +28,7 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix memoization) - #:use-module (guix grafts) - #:use-module (guix utils) - #:use-module (guix monads) #:use-module (guix gexp) #:use-module (guix profiles) @@ -383,8 +380,9 @@ use '--no-offload' instead~%"))) (format #f (G_ "Did you mean @code{~a}? Try @option{--list-targets} to view available targets.~%") closest)) - (display-hint (G_ "\ -Try @option{--list-targets} to view available targets.~%"))) + (display-hint + (format #f (G_ "\ +Try @option{--list-targets} to view available targets.~%")))) (exit 1)))))))) (define %standard-native-build-options @@ -409,8 +407,9 @@ Try @option{--list-targets} to view available targets.~%"))) (format #f (G_ "Did you mean @code{~a}? Try @option{--list-systems} to view available system types.~%") closest)) - (display-hint (G_ "\ -Try @option{--list-systems} to view available system types.~%"))) + (display-hint + (format #f (G_ "\ +Try @option{--list-systems} to view available system types.~%")))) (exit 1)))))))) diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index f1e5f67dab..620a1762a1 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -22,7 +22,6 @@ #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix grafts) #:use-module (guix monads) #:use-module (guix base32) #:use-module (guix packages) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 2c76645173..ef6f9acc86 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -27,7 +27,6 @@ #:use-module (guix gexp) #:use-module (guix ui) #:use-module (guix utils) - #:use-module (guix grafts) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix diagnostics) #:use-module (guix i18n) @@ -256,7 +255,7 @@ otherwise." (leave (G_ "missing deployment file argument~%"))) (when (and (pair? command) (not execute-command?)) - (leave (G_ "'--' was used by '-x' was not specified~%"))) + (leave (G_ "'--' was used, but '-x' was not specified~%"))) (with-status-verbosity (assoc-ref opts 'verbosity) (with-store store diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 0c310e3da8..80cd0ce00a 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2020 Ekaitz Zarraga <ekaitz@elenq.tech> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2022 jgart <jgart@dismail.de> ;;; ;;; This file is part of GNU Guix. ;;; @@ -119,6 +120,7 @@ Display information about the channels currently in use.\n")) (let ((intro (channel-introduction channel))) `((name . ,(channel-name channel)) (url . ,(channel-url channel)) + (branch . ,(channel-branch channel)) (commit . ,(channel-commit channel)) ,@(if intro `((introduction @@ -135,6 +137,7 @@ Display information about the channels currently in use.\n")) (format port "name: ~a~%" (channel-name channel)) (format port "url: ~a~%" (channel-url channel)) + (format port "branch: ~a~%" (channel-branch channel)) (format port "commit: ~a~%" (channel-commit channel)) (when intro (format port "introductioncommit: ~a~%" diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 2493134470..46435ae48e 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org> -;;; Copyright © 2015-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org> +;;; Copyright © 2022, 2023 John Kehayias <john.kehayias@protonmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,7 +24,6 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module ((guix status) #:select (with-status-verbosity)) - #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) @@ -33,8 +33,10 @@ #:use-module ((guix gexp) #:select (lower-object)) #:use-module (guix scripts) #:use-module (guix scripts build) + #:autoload (guix scripts pack) (symlink-spec-option-parser) #:use-module (guix transformations) #:autoload (ice-9 ftw) (scandir) + #:use-module (gnu build install) #:autoload (gnu build linux-container) (call-with-container %namespaces user-namespace-supported? unprivileged-user-namespace-supported? @@ -120,6 +122,9 @@ shell'." --expose=SPEC for containers, expose read-only host file system according to SPEC")) (display (G_ " + -S, --symlink=SPEC for containers, add symlinks to the profile according + to SPEC, e.g. \"/usr/bin/env=bin/env\".")) + (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " --bootstrap use bootstrap binaries to build the environment"))) @@ -157,6 +162,7 @@ COMMAND or an interactive shell in that environment.\n")) (define %default-options `((system . ,(%current-system)) (substitutes? . #t) + (symlinks . ()) (offload? . #t) (graft? . #t) (print-build-trace? . #t) @@ -256,6 +262,7 @@ use '--preserve' instead~%")) (alist-cons 'file-system-mapping (specification->file-system-mapping arg #f) result))) + (option '(#\S "symlink") #t #f symlink-spec-option-parser) (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) @@ -375,6 +382,65 @@ requisite store items i.e. the union closure of all the inputs." input->requisites inputs))) (return (delete-duplicates (concatenate reqs))))) +(define (setup-fhs profile) + "Setup the FHS container by creating and linking expected directories from +PROFILE (other bind mounts are done in LAUNCH-ENVIRONMENT/CONTAINER), +providing a symlink for CC if GCC is in the container PROFILE, and writing +/etc/ld.so.conf." + ;; Additional symlinks for an FHS container. + (define fhs-symlinks + `(("/lib" . "/usr/lib") + ,(if (target-64bit?) + '("/lib" . "/lib64") + '("/lib" . "/lib32")) + ("/bin" . "/usr/bin") + ("/sbin" . "/usr/sbin"))) + + ;; A procedure to symlink the contents (at the top level) of a directory, + ;; excluding the directory itself and parent, along with any others provided + ;; in EXCLUDE. + (define* (link-contents dir #:key (exclude '())) + (for-each (lambda (file) + (symlink (string-append profile dir "/" file) + (string-append dir "/" file))) + (scandir (string-append profile dir) + (negate (cut member <> + (append exclude '("." ".." ))))))) + + ;; The FHS container sets up the expected filesystem through MAPPINGS with + ;; FHS-MAPPINGS (in LAUNCH-ENVIRONMENT/CONTAINER), the symlinks through + ;; FHS-SYMLINKS, and linking the contents of PROFILE/bin and PROFILE/etc + ;; using LINK-CONTENTS, as these both have or will have contents for a + ;; non-FHS container so must be handled separately. + (mkdir-p "/usr") + (for-each (lambda (link) + (if (file-exists? (car link)) + (symlink (car link) (cdr link)))) + fhs-symlinks) + (link-contents "/bin" #:exclude '("sh")) + (mkdir-p "/etc") + (link-contents "/etc") + + ;; Provide a frequently expected 'cc' symlink to gcc (in case it is in + ;; PROFILE), though this could also be done by the user in the container, + ;; e.g. in $HOME/.local/bin and adding that to $PATH. Note: we do this in + ;; /bin since that already has the sh symlink and the other (optional) FHS + ;; bin directories will link to /bin. + (let ((gcc-path (string-append profile "/bin/gcc"))) + (if (file-exists? gcc-path) + (symlink gcc-path "/bin/cc"))) + + ;; Guix's ldconfig doesn't search in FHS default locations, so provide a + ;; minimal ld.so.conf. + (call-with-output-file "/etc/ld.so.conf" + (lambda (port) + (for-each (lambda (directory) + (display directory port) + (newline port)) + ;; /lib/nss is needed as Guix's nss puts libraries + ;; there rather than in the lib directory. + '("/lib" "/lib/nss"))))) + (define (status->exit-code status) "Compute the exit code made from STATUS, a value as returned by 'waitpid', and suitable for 'exit'." @@ -386,11 +452,13 @@ and suitable for 'exit'." (define primitive-exit/status (compose primitive-exit status->exit-code)) (define* (launch-environment command profile manifest - #:key pure? (white-list '())) - "Run COMMAND in a new environment containing INPUTS, using the native search -paths defined by the list PATHS. When PURE?, pre-existing environment -variables are cleared before setting the new ones, except those matching the -regexps in WHITE-LIST." + #:key pure? (white-list '()) + emulate-fhs?) + "Load the environment of PROFILE, which corresponds to MANIFEST, and execute +COMMAND. When PURE?, pre-existing environment variables are cleared before +setting the new ones, except those matching the regexps in WHITE-LIST. When +EMULATE-FHS?, first set up an FHS environment with $PATH and generate the LD +cache." ;; Properly handle SIGINT, so pressing C-c in an interactive terminal ;; application works. (sigaction SIGINT SIG_DFL) @@ -406,6 +474,15 @@ regexps in WHITE-LIST." ((program . args) (catch 'system-error (lambda () + (when emulate-fhs? + ;; When running in a container with EMULATE-FHS?, augment $PATH + ;; (optional, but to better match FHS expectations), and generate + ;; /etc/ld.so.cache. + (setenv "PATH" (string-append "/bin:/usr/bin:/sbin:/usr/sbin" + (if (getenv "PATH") + (string-append ":" (getenv "PATH")) + ""))) + (invoke "ldconfig" "-X")) (apply execlp program program args)) (lambda _ ;; Report the error from here because the parent process cannot @@ -527,7 +604,12 @@ environment~%"))) (match (vhash-assoc "PS1" actual) (#f #f) ((_ . str) - (when (and (getenv "PS1") (string=? str (getenv "PS1"))) + (when (and (getenv "PS1") (string=? str (getenv "PS1")) + + ;; 'PS1' might be conditional on 'GUIX_ENVIRONMENT', as + ;; shown in the hint below. + (not (or (string-contains str "$GUIX_ENVIRONMENT") + (string-contains str "${GUIX_ENVIRONMENT")))) (warning (G_ "'PS1' is the same in sub-shell~%")) (display-hint (G_ "Consider setting a different prompt for environment shells to make them distinguishable. @@ -536,10 +618,7 @@ If you are using Bash, you can do that by adding these lines to @file{~/.bashrc}: @example -if [ -n \"$GUIX_ENVIRONMENT\" ] -then - export PS1=\"\\u@@\\h \\w [env]\\$ \" -fi +PS1='\\u@@\\h \\w${GUIX_ENVIRONMENT:+ [env]}\\$ ' @end example ")))))) @@ -604,16 +683,27 @@ regexps in WHITE-LIST." (define* (launch-environment/container #:key command bash user user-mappings profile manifest link-profile? network? - map-cwd? (white-list '())) + map-cwd? emulate-fhs? (setup-hook #f) + (symlinks '()) (white-list '())) "Run COMMAND within a container that features the software in PROFILE. -Environment variables are set according to the search paths of MANIFEST. -The global shell is BASH, a file name for a GNU Bash binary in the -store. When NETWORK?, access to the host system network is permitted. -USER-MAPPINGS, a list of file system mappings, contains the user-specified -host file systems to mount inside the container. If USER is not #f, each -target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER -will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from -~/.guix-profile to the environment profile. +Environment variables are set according to the search paths of MANIFEST. The +global shell is BASH, a file name for a GNU Bash binary in the store. When +NETWORK?, access to the host system network is permitted. USER-MAPPINGS, a +list of file system mappings, contains the user-specified host file systems to +mount inside the container. If USER is not #f, each target of USER-MAPPINGS +will be re-written relative to '/home/USER', and USER will be used for the +passwd entry. + +When EMULATE-FHS?, set up the container to follow the Filesystem Hierarchy +Standard and provide a glibc that reads the cache from /etc/ld.so.cache. +SETUP-HOOK is an additional setup procedure to be called, currently only used +with the EMULATE-FHS? option. + +LINK-PROFILE? creates a symbolic link from ~/.guix-profile to the +environment profile. + +SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be +added to the container. Preserve environment variables whose name matches the one of the regexps in WHILE-LIST." @@ -621,6 +711,21 @@ WHILE-LIST." (and (file-exists? (file-system-mapping-source mapping)) (file-system-mapping->bind-mount mapping))) + ;; File system mappings for an FHS container, where the entire directory can + ;; be mapped. Others (bin and etc) will already have contents and need to + ;; use LINK-CONTENTS (defined in SETUP-FHS) to symlink the directory + ;; contents. + (define fhs-mappings + (map (lambda (mapping) + (file-system-mapping + (source (string-append profile (car mapping))) + (target (cdr mapping)))) + '(("/lib" . "/lib") + ("/include" . "/usr/include") + ("/sbin" . "/sbin") + ("/libexec" . "/usr/libexec") + ("/share" . "/usr/share")))) + (mlet %store-monad ((reqs (inputs->requisites (list (direct-store-path bash) profile)))) (return @@ -628,14 +733,21 @@ WHILE-LIST." (home (getenv "HOME")) (uid (if user 1000 (getuid))) (gid (if user 1000 (getgid))) - (passwd (let ((pwd (getpwuid (getuid)))) + + ;; On a foreign distro, the name service switch might be + ;; dysfunctional and 'getpwuid' throws. Don't let that hamper + ;; operations. + (passwd (let ((pwd (false-if-exception (getpwuid (getuid))))) (password-entry - (name (or user (passwd:name pwd))) - (real-name (if user + (name (or user + (and=> pwd passwd:name) + (getenv "USER") + "charlie")) + (real-name (if (or user (not pwd)) "" (passwd:gecos pwd))) (uid uid) (gid gid) (shell bash) - (directory (if user + (directory (if (or user (not pwd)) (string-append "/home/" user) (passwd:dir pwd)))))) (groups (list (group-entry (name "users") (gid gid)) @@ -675,6 +787,11 @@ WHILE-LIST." (filter-map optional-mapping->fs %network-file-mappings) '()) + ;; Mappings for an FHS container. + (if emulate-fhs? + (filter-map optional-mapping->fs + fhs-mappings) + '()) (map file-system-mapping->bind-mount mappings)))) (exit/status @@ -702,6 +819,19 @@ WHILE-LIST." (mkdir-p home-dir) (setenv "HOME" home-dir) + ;; Create symlinks. + (let ((symlink->directives + (match-lambda + ((source '-> target) + `((directory ,(dirname source)) + (,source -> ,(string-append profile "/" target))))))) + (for-each (cut evaluate-populate-directive <> ".") + (append-map symlink->directives symlinks))) + + ;; Call an additional setup procedure, if provided. + (when setup-hook + (setup-hook profile)) + ;; If requested, link $GUIX_ENVIRONMENT to $HOME/.guix-profile; ;; this allows programs expecting that path to continue working as ;; expected within a container. @@ -743,7 +873,8 @@ WHILE-LIST." (if link-profile? (string-append home-dir "/.guix-profile") profile) - manifest #:pure? #f))) + manifest #:pure? #f + #:emulate-fhs? emulate-fhs?))) #:guest-uid uid #:guest-gid gid #:namespaces (if network? @@ -861,147 +992,158 @@ message if any test fails." (category development) (synopsis "spawn one-off software environments (deprecated)") - (guix-environment* (parse-args args))) + (with-error-handling + (guix-environment* (parse-args args)))) (define (guix-environment* opts) "Run the 'guix environment' command on OPTS, an alist resulting for command-line option processing with 'parse-command-line'." - (with-error-handling - (let* ((pure? (assoc-ref opts 'pure)) - (container? (assoc-ref opts 'container?)) - (link-prof? (assoc-ref opts 'link-profile?)) - (network? (assoc-ref opts 'network?)) - (no-cwd? (assoc-ref opts 'no-cwd?)) - (user (assoc-ref opts 'user)) - (bootstrap? (assoc-ref opts 'bootstrap?)) - (system (assoc-ref opts 'system)) - (profile (assoc-ref opts 'profile)) - (command (or (assoc-ref opts 'exec) - ;; Spawn a shell if the user didn't specify - ;; anything in particular. - (if container? - ;; The user's shell is likely not available - ;; within the container. - '("/bin/sh") - (list %default-shell)))) - (mappings (pick-all opts 'file-system-mapping)) - (white-list (pick-all opts 'inherit-regexp))) - - (define store-needed? - ;; Whether connecting to the daemon is needed. - (or container? (not profile))) - - (define-syntax-rule (with-store/maybe store exp ...) - ;; Evaluate EXP... with STORE bound to a connection, unless - ;; STORE-NEEDED? is false, in which case STORE is bound to #f. - (let ((proc (lambda (store) exp ...))) - (if store-needed? - (with-store s - (set-build-options-from-command-line s opts) - (with-build-handler (build-notifier #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:verbosity - (assoc-ref opts 'verbosity) - #:dry-run? - (assoc-ref opts 'dry-run?)) - (proc s))) - (proc #f)))) - - (when container? (assert-container-features)) - - (when (and (not container?) link-prof?) + (let* ((pure? (assoc-ref opts 'pure)) + (container? (assoc-ref opts 'container?)) + (link-prof? (assoc-ref opts 'link-profile?)) + (symlinks (assoc-ref opts 'symlinks)) + (network? (assoc-ref opts 'network?)) + (no-cwd? (assoc-ref opts 'no-cwd?)) + (emulate-fhs? (assoc-ref opts 'emulate-fhs?)) + (user (assoc-ref opts 'user)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (system (assoc-ref opts 'system)) + (profile (assoc-ref opts 'profile)) + (command (or (assoc-ref opts 'exec) + ;; Spawn a shell if the user didn't specify + ;; anything in particular. + (if container? + ;; The user's shell is likely not available + ;; within the container. + '("/bin/sh") + (list %default-shell)))) + (mappings (pick-all opts 'file-system-mapping)) + (white-list (pick-all opts 'inherit-regexp))) + + (define store-needed? + ;; Whether connecting to the daemon is needed. + (or container? (not profile))) + + (define-syntax-rule (with-store/maybe store exp ...) + ;; Evaluate EXP... with STORE bound to a connection, unless + ;; STORE-NEEDED? is false, in which case STORE is bound to #f. + (let ((proc (lambda (store) exp ...))) + (if store-needed? + (with-store s + (set-build-options-from-command-line s opts) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (proc s))) + (proc #f)))) + + (when container? (assert-container-features)) + + (when (not container?) + (when link-prof? (leave (G_ "'--link-profile' cannot be used without '--container'~%"))) - (when (and (not container?) user) + (when user (leave (G_ "'--user' cannot be used without '--container'~%"))) - (when (and (not container?) no-cwd?) - (leave (G_ "--no-cwd cannot be used without --container~%"))) - - - (with-store/maybe store - (with-status-verbosity (assoc-ref opts 'verbosity) - (define manifest-from-opts - (options/resolve-packages store opts)) - - (define manifest - (if profile - (profile-manifest profile) - manifest-from-opts)) - - (when (and profile - (> (length (manifest-entries manifest-from-opts)) 0)) - (leave (G_ "'--profile' cannot be used with package options~%"))) - - (when (null? (manifest-entries manifest)) - (warning (G_ "no packages specified; creating an empty environment~%"))) - - ;; Use the bootstrap Guile when requested. - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build - (and store-needed? - (package-derivation - store - (if bootstrap? - %bootstrap-guile - (default-guile)))))) - (run-with-store store - ;; Containers need a Bourne shell at /bin/sh. - (mlet* %store-monad ((bash (environment-bash container? - bootstrap? - system)) - (prof-drv (if profile - (return #f) - (manifest->derivation - manifest system bootstrap?))) - (profile -> (if profile - (readlink* 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 - (mwhen store-needed? - (built-derivations (append - (if prof-drv (list prof-drv) '()) - (if (derivation? bash) (list bash) '())))) - (mwhen gc-root - (register-gc-root profile gc-root)) - - (mwhen (assoc-ref opts 'check?) - (return - (if container? - (warning (G_ "'--check' is unnecessary \ + (when no-cwd? + (leave (G_ "--no-cwd cannot be used without '--container'~%"))) + (when emulate-fhs? + (leave (G_ "'--emulate-fhs' cannot be used without '--container~%'"))) + (when (pair? symlinks) + (leave (G_ "'--symlink' cannot be used without '--container~%'")))) + + (with-store/maybe store + (with-status-verbosity (assoc-ref opts 'verbosity) + (define manifest-from-opts + (options/resolve-packages store opts)) + + (define manifest + (if profile + (profile-manifest profile) + manifest-from-opts)) + + (when (and profile + (> (length (manifest-entries manifest-from-opts)) 0)) + (leave (G_ "'--profile' cannot be used with package options~%"))) + + (when (null? (manifest-entries manifest)) + (warning (G_ "no packages specified; creating an empty environment~%"))) + + ;; Use the bootstrap Guile when requested. + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build + (and store-needed? + (package-derivation + store + (if bootstrap? + %bootstrap-guile + (default-guile)))))) + (run-with-store store + ;; Containers need a Bourne shell at /bin/sh. + (mlet* %store-monad ((bash (environment-bash container? + bootstrap? + system)) + (prof-drv (if profile + (return #f) + (manifest->derivation + manifest system bootstrap?))) + (profile -> (if profile + (readlink* 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 + (mwhen store-needed? + (built-derivations (append + (if prof-drv (list prof-drv) '()) + (if (derivation? bash) (list bash) '())))) + (mwhen gc-root + (register-gc-root profile gc-root)) + + (mwhen (assoc-ref opts 'check?) + (return + (if container? + (warning (G_ "'--check' is unnecessary \ when using '--container'; doing nothing~%")) - (validate-child-shell-environment profile manifest)))) - - (cond - ((assoc-ref opts 'search-paths) - (show-search-paths profile manifest #:pure? pure?) - (return #t)) - (container? - (let ((bash-binary - (if bootstrap? - (derivation->output-path 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 - #:white-list white-list - #:link-profile? link-prof? - #:network? network? - #:map-cwd? (not no-cwd?)))) - - (else - (return - (exit/status - (launch-environment/fork command profile manifest - #:white-list white-list - #:pure? pure?)))))))))))))) + (validate-child-shell-environment profile manifest)))) + + (cond + ((assoc-ref opts 'search-paths) + (show-search-paths profile manifest #:pure? pure?) + (return #t)) + (container? + (let ((bash-binary + (if bootstrap? + (derivation->output-path 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 + #:white-list white-list + #:link-profile? link-prof? + #:network? network? + #:map-cwd? (not no-cwd?) + #:emulate-fhs? emulate-fhs? + #:symlinks symlinks + #:setup-hook + (and emulate-fhs? + setup-fhs)))) + + (else + (return + (exit/status + (launch-environment/fork command profile manifest + #:white-list white-list + #:pure? pure?))))))))))))) ;;; Local Variables: ;;; eval: (put 'with-store/maybe 'scheme-indent-function 1) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 65cd4bdf8b..5e775c5cdb 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012-2013, 2015-2020, 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +28,7 @@ generation-number) #:autoload (guix scripts package) (delete-generations) #:autoload (gnu home) (home-generation-base) + #:autoload (guix store database) (vacuum-database) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) @@ -87,6 +89,10 @@ Invoke the garbage collector.\n")) --clear-failures remove PATHS from the set of cached failures")) (newline) (display (G_ " + --vacuum-database repack the sqlite database tracking the store + using less space")) + (newline) + (display (G_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) @@ -131,6 +137,11 @@ current one." (lambda args (show-version-and-exit "guix gc"))) + (option '("vacuum-database") #f #f + (lambda args + (vacuum-database) + (exit 0))) + (option '(#\C "collect-garbage") #f #t (lambda (opt name arg result) (let ((result (alist-cons 'action 'collect-garbage diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 2f102180c9..6847dd1962 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -569,6 +569,12 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (category packaging) (synopsis "view and query package dependency graphs") + (define (shorter? str1 str2) + (< (string-length str1) (string-length str2))) + + (define length-sorted + (cut sort <> shorter?)) + (with-error-handling (define opts (parse-command-line args %options @@ -598,13 +604,17 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (run-with-store store ;; XXX: Since grafting can trigger unsolicited builds, disable it. - (mlet %store-monad ((_ (set-grafting #f)) + (mlet %store-monad ((_g (set-grafting #f)) (nodes (mapm %store-monad (node-type-convert type) (reverse items)))) (if (assoc-ref opts 'path?) + ;; Sort by string length such that, in case of multiple + ;; outputs, the shortest one (which corresponds to "out") is + ;; picked (yup, a hack). (match nodes - (((node1 _ ...) (node2 _ ...)) + (((= length-sorted (node1 _ ...)) + (= length-sorted (node2 _ ...))) (display-path node1 node2 type)) (_ (leave (G_ "'--path' option requires exactly two \ diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index ae830d0b48..a37f059711 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Pierre Langlois <pierre.langlois@gmx.com> ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com> -;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2022 Antero Mejr <antero@mailbox.org> ;;; @@ -48,7 +48,6 @@ #:use-module (guix derivations) #:use-module (guix ui) #:autoload (guix colors) (supports-hyperlinks? file-hyperlink) - #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix store) @@ -173,7 +172,7 @@ Some ACTIONS support additional ARGS.\n")) (alist-cons 'dry-run? #t result))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix show"))) + (show-version-and-exit "guix home"))) (option '(#\v "verbosity") #t #f (lambda (opt name arg result) (let ((level (string->number* arg))) @@ -477,7 +476,7 @@ resulting from command-line parsing." (define (ensure-home-environment file-or-exp obj) (ensure-profile-directory) (unless (home-environment? obj) - (leave (G_ "'~a' does not return a home environment ~%") + (leave (G_ "'~a' does not return a home environment~%") file-or-exp)) obj) @@ -707,7 +706,7 @@ deploy the home environment described by these files.\n") (define (service-type-description-string type) "Return the rendered and localised description of TYPE, a service type." (and=> (service-type-description type) - (compose texi->plain-text P_))) + (compose texi->plain-text G_))) (define %service-type-metrics ;; Metrics used to estimate the relevance of a search result. diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index bd3cfd2dc3..2bca927d63 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -97,7 +97,9 @@ Run IMPORTER with ARGS.\n")) ((? list? expressions) (for-each (lambda (expr) (print expr) - (newline)) + ;; Two newlines: one after the closing paren, and + ;; one to leave a blank line. + (newline) (newline)) expressions)) (x (leave (G_ "'~a' import failed~%") importer)))) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 2934d4300a..5298f059f2 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -53,6 +53,9 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (display (G_ " -s, --style=STYLE choose output style, either specification or variable")) (display (G_ " + -p, --license-prefix=PREFIX + add custom prefix to licenses")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -74,6 +77,10 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (lambda (opt name arg result) (alist-cons 'style (string->symbol arg) (alist-delete 'style result)))) + (option '(#\p "license-prefix") #t #f + (lambda (opt name arg result) + (alist-cons 'license-prefix arg + (alist-delete 'license-prefix result)))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'recursive #t result))) @@ -95,7 +102,13 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (('argument . value) value) (_ #f)) - (reverse opts)))) + (reverse opts))) + (prefix (assoc-ref opts 'license-prefix)) + (prefix-proc (if (string? prefix) + (lambda (symbol) + (string->symbol + (string-append prefix (symbol->string symbol)))) + identity))) (parameterize ((%input-style (assoc-ref opts 'style))) (match args ((spec) @@ -107,11 +120,13 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (filter identity (cran-recursive-import name #:version version - #:repo (or (assoc-ref opts 'repo) 'cran))))) + #:repo (or (assoc-ref opts 'repo) 'cran) + #:license-prefix prefix-proc)))) ;; Single import (let ((sexp (cran->guix-package name #:version version - #:repo (or (assoc-ref opts 'repo) 'cran)))) + #:repo (or (assoc-ref opts 'repo) 'cran) + #:license-prefix prefix-proc))) (unless sexp (leave (G_ "failed to download description for package '~a'~%") name)) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 925325ef5f..578b3b9888 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -25,7 +25,7 @@ #:autoload (ssh auth) (userauth-public-key!) #:autoload (ssh session) (make-session connect! get-error - disconnect! session-set!) + disconnect! session-set! session-get) #:autoload (ssh version) (zlib-support?) #:use-module (guix config) #:use-module (guix records) @@ -34,7 +34,8 @@ send-files retrieve-files retrieve-files* remote-inferior report-guile-error) #:use-module (guix store) - #:autoload (guix inferior) (inferior-eval close-inferior inferior?) + #:autoload (guix inferior) (inferior-eval close-inferior + inferior? inferior-protocol-error?) #:autoload (guix derivations) (read-derivation-from-file derivation-file-name build-derivations) @@ -111,7 +112,7 @@ ;; A #f value tells the offload scheduler to disregard the load of the build ;; machine when selecting the best offload machine. (overload-threshold build-machine-overload-threshold ; inexact real between - (default 0.6)) ; 0.0 and 1.0 | #f + (default 0.8)) ; 0.0 and 1.0 | #f (parallel-builds build-machine-parallel-builds ; number (default 1)) (speed build-machine-speed ; inexact real @@ -473,6 +474,15 @@ logical cores available, to give a rough estimation of CPU usage. Return (vector-set! vec j (vector-ref vec (- i 1))) (loop (cons val result) (- i 1)))))))) +(define (remote-inferior* session) + "Like 'remote-inferior', but upon error return #f." + (or (guard (c ((inferior-protocol-error? c) #f)) + (remote-inferior session)) + (begin + (warning (G_ "failed to run 'guix repl' on machine '~a'~%") + (session-get session 'host)) + #f))) + (define (choose-build-machine machines) "Return two values: the best machine among MACHINES and its build slot (which must later be released with 'release-build-slot'), or #f and #f." @@ -511,7 +521,7 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; too costly to call it once for every machine. (let* ((session (false-if-exception (open-ssh-session best %short-timeout))) - (node (and session (remote-inferior session))) + (node (and session (remote-inferior* session))) (load (and node (node-load node))) (threshold (build-machine-overload-threshold best)) (space (and node (node-free-disk-space node)))) @@ -708,6 +718,11 @@ machine." (and (string=? (build-machine-name m1) (build-machine-name m2)) (= (build-machine-port m1) (build-machine-port m2)))) + (define (if-true proc) + (lambda args + (when (every ->bool args) + (apply proc args)))) + ;; A given build machine may appear several times (e.g., once for ;; "x86_64-linux" and a second time for "i686-linux"); test them only once. (let ((machines (filter pred @@ -718,12 +733,12 @@ machine." (let* ((names (map build-machine-name machines)) (sockets (map build-machine-daemon-socket machines)) (sessions (map (cut open-ssh-session <> %short-timeout) machines)) - (nodes (map remote-inferior sessions))) - (for-each assert-node-has-guix nodes names) - (for-each assert-node-repl nodes names) - (for-each assert-node-can-import sessions nodes names sockets) - (for-each assert-node-can-export sessions nodes names sockets) - (for-each close-inferior nodes) + (nodes (map remote-inferior* sessions))) + (for-each (if-true assert-node-has-guix) nodes names) + (for-each (if-true assert-node-repl) nodes names) + (for-each (if-true assert-node-can-import) sessions nodes names sockets) + (for-each (if-true assert-node-can-export) sessions nodes names sockets) + (for-each (if-true close-inferior) nodes) (for-each disconnect! sessions)))) (define (check-machine-status machine-file pred) @@ -743,10 +758,9 @@ machine." (define session (open-ssh-session machine %short-timeout)) - (match (remote-inferior session) + (match (remote-inferior* session) (#f - (warning (G_ "failed to run 'guix repl' on machine '~a'~%") - (build-machine-name machine))) + #f) ((? inferior? inferior) (let ((now (car (gettimeofday)))) (match (inferior-eval '(list (uname) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 78b6978c92..f65642fb85 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> @@ -33,7 +33,6 @@ #:use-module (guix store) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix self) #:select (make-config.scm)) - #:use-module (guix grafts) #:autoload (guix inferior) (inferior-package? inferior-package-name inferior-package-version) @@ -43,6 +42,7 @@ #:use-module (guix profiles) #:use-module (guix describe) #:use-module (guix derivations) + #:use-module (guix diagnostics) #:use-module (guix search-paths) #:use-module (guix build-system gnu) #:use-module (guix scripts build) @@ -60,9 +60,12 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) - #:export (self-contained-tarball + #:export (symlink-spec-option-parser + + self-contained-tarball debian-archive docker-image squashfs-image @@ -161,6 +164,36 @@ its source property." ((_) str) ((names ... _) (loop names)))))) +(define (symlink-spec-option-parser opt name arg result) + "A SRFI-37 option parser for the --symlink option. The symlink spec accepts +the link file name as its left-hand side value and its target as its +right-hand side value. The target must be a relative link." + ;; Note: Using 'string-split' allows us to handle empty + ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is + ;; a symlink to the profile) correctly. + (match (string-split arg #\=) + ((source target) + (when (string-prefix? "/" target) + (raise-exception + (make-compound-condition + (formatted-message (G_ "symlink target is absolute: '~a'~%") target) + (condition + (&fix-hint (hint (format #f (G_ "The target of the symlink must be +relative rather than absolute, as it is relative to the profile created. +Perhaps the source and target components of the symlink spec were inverted? +Below is a valid example, where the @file{/usr/bin/env} symbolic link is to +target the profile's @file{bin/env} file: +@example +--symlink=/usr/bin/env=bin/env +@end example")))))))) + (let ((symlinks (assoc-ref result 'symlinks))) + (alist-cons 'symlinks + `((,source -> ,target) ,@symlinks) + (alist-delete 'symlinks result eq?)))) + (x + (leave (G_ "~a: invalid symlink specification~%") + arg)))) + ;;; ;;; Tarball format. @@ -227,8 +260,9 @@ its source property." `(,@(if (string=? parent "/") '() `((directory ,parent))) - (,source - -> ,(relative-file-name parent target))))))) + ;; Use a relative file name for compatibility with + ;; relocatable packs. + (,source -> ,(relative-file-name parent target))))))) (define directives ;; Fully-qualified symlinks. @@ -668,7 +702,6 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) (guix build utils) (guix profiles) (ice-9 match) - ((oop goops) #:select (get-keyword)) (srfi srfi-1)) (define machine-type @@ -729,15 +762,20 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) (copy-file #+data-tarball data-tarball-file-name) + (define (keyword-ref lst keyword) + (match (memq keyword lst) + ((_ value . _) value) + (#f #f))) + ;; Generate the control archive. (define control-file - (get-keyword #:control-file '#$extra-options)) + (keyword-ref '#$extra-options #:control-file)) (define postinst-file - (get-keyword #:postinst-file '#$extra-options)) + (keyword-ref '#$extra-options #:postinst-file)) (define triggers-file - (get-keyword #:triggers-file '#$extra-options)) + (keyword-ref '#$extra-options #:triggers-file)) (define control-tarball-file-name (string-append "control.tar" @@ -1209,20 +1247,7 @@ last resort for relocation." (lambda (opt name arg result) (alist-cons 'compressor (lookup-compressor arg) result))) - (option '(#\S "symlink") #t #f - (lambda (opt name arg result) - ;; Note: Using 'string-split' allows us to handle empty - ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is - ;; a symlink to the profile) correctly. - (match (string-split arg (char-set #\=)) - ((source target) - (let ((symlinks (assoc-ref result 'symlinks))) - (alist-cons 'symlinks - `((,source -> ,target) ,@symlinks) - (alist-delete 'symlinks result eq?)))) - (x - (leave (G_ "~a: invalid symlink specification~%") - arg))))) + (option '(#\S "symlink") #t #f symlink-spec-option-parser) (option '("save-provenance") #f #f (lambda (opt name arg result) (alist-cons 'save-provenance? #t result))) @@ -1322,74 +1347,74 @@ Create a bundle of PACKAGE.\n")) (category development) (synopsis "create application bundles") - (define opts - (parse-command-line args %options (list %default-options))) - - (define maybe-package-argument - ;; Given an option pair, return a package, a package/output tuple, or #f. - (match-lambda - (('argument . spec) - (call-with-values - (lambda () - (specification->package+output spec)) - list)) - (('expression . exp) - (read/eval-package-expression exp)) - (x #f))) - - (define (manifest-from-args store opts) - (let* ((transform (options->transformation opts)) - (packages (map (match-lambda - (((? package? package) output) - (list (transform package) output)) - ((? package? package) - (list (transform package) "out"))) - (reverse - (filter-map maybe-package-argument opts)))) - (manifests (filter-map (match-lambda - (('manifest . file) file) - (_ #f)) - opts))) - (define with-provenance - (if (assoc-ref opts 'save-provenance?) - (lambda (manifest) - (map-manifest-entries - (lambda (entry) - (let ((entry (manifest-entry-with-provenance entry))) - (unless (assq 'provenance (manifest-entry-properties entry)) - (warning (G_ "could not determine provenance of package ~a~%") - (manifest-entry-name entry))) - entry)) - manifest)) - identity)) - - (with-provenance - (cond - ((and (not (null? manifests)) (not (null? packages))) - (leave (G_ "both a manifest and a package list were given~%"))) - ((not (null? manifests)) - (concatenate-manifests - (map (lambda (file) - (let ((user-module (make-user-module - '((guix profiles) (gnu))))) - (load* file user-module))) - manifests))) - (else - (packages->manifest packages)))))) - - (define (process-file-arg opts name) - ;; Validate that the file exists and return it as a <local-file> object, - ;; else #f. - (let ((value (assoc-ref opts name))) - (match value - ((and (? string?) (not (? file-exists?))) - (leave (G_ "file provided with option ~a does not exist: ~a~%") - (string-append "--" (symbol->string name)) value)) - ((? string?) - (local-file value)) - (#f #f)))) - (with-error-handling + (define opts + (parse-command-line args %options (list %default-options))) + + (define maybe-package-argument + ;; Given an option pair, return a package, a package/output tuple, or #f. + (match-lambda + (('argument . spec) + (call-with-values + (lambda () + (specification->package+output spec)) + list)) + (('expression . exp) + (read/eval-package-expression exp)) + (x #f))) + + (define (manifest-from-args store opts) + (let* ((transform (options->transformation opts)) + (packages (map (match-lambda + (((? package? package) output) + (list (transform package) output)) + ((? package? package) + (list (transform package) "out"))) + (reverse + (filter-map maybe-package-argument opts)))) + (manifests (filter-map (match-lambda + (('manifest . file) file) + (_ #f)) + opts))) + (define with-provenance + (if (assoc-ref opts 'save-provenance?) + (lambda (manifest) + (map-manifest-entries + (lambda (entry) + (let ((entry (manifest-entry-with-provenance entry))) + (unless (assq 'provenance (manifest-entry-properties entry)) + (warning (G_ "could not determine provenance of package ~a~%") + (manifest-entry-name entry))) + entry)) + manifest)) + identity)) + + (with-provenance + (cond + ((and (not (null? manifests)) (not (null? packages))) + (leave (G_ "both a manifest and a package list were given~%"))) + ((not (null? manifests)) + (concatenate-manifests + (map (lambda (file) + (let ((user-module (make-user-module + '((guix profiles) (gnu))))) + (load* file user-module))) + manifests))) + (else + (packages->manifest packages)))))) + + (define (process-file-arg opts name) + ;; Validate that the file exists and return it as a <local-file> object, + ;; else #f. + (let ((value (assoc-ref opts name))) + (match value + ((and (? string?) (not (? file-exists?))) + (leave (G_ "file provided with option ~a does not exist: ~a~%") + (string-append "--" (symbol->string name)) value)) + ((? string?) + (local-file value)) + (#f #f)))) + (with-store store (with-status-verbosity (assoc-ref opts 'verbosity) ;; Set the build options before we do anything else. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 134337b13e..2f774621bb 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -34,7 +34,6 @@ #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix build syscalls) #:select (terminal-rows)) #:use-module (guix store) - #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 3bf3bd9c7c..6307ae54bb 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -4,7 +4,7 @@ ;;; Copyright © 2015-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> -;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org> +;;; Copyright © 2021, 2022 Mathieu Othacehe <othacehe@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -375,14 +375,28 @@ References: ~a~%" compression))) compressions)))) +;; Custom header to indicate that baking is in progress. +(declare-opaque-header! "X-Baking") + (define* (not-found request - #:key (phrase "Resource not found") + #:key + baking? + (phrase "Resource not found") ttl) "Render 404 response for REQUEST." + (format #t "-> ~a ~a: 404~a~%" + (request-method request) + (uri-path (request-uri request)) + (if baking? " (baking)" "")) (values (build-response #:code 404 - #:headers (if ttl - `((cache-control (max-age . ,ttl))) - '())) + #:headers + (append + (if ttl + `((cache-control (max-age . ,ttl))) + '()) + (if baking? + '((x-baking . "1")) + '()))) (string-append phrase ": " (uri-path (request-uri request))))) @@ -587,6 +601,7 @@ requested using POOL." #:nar-path nar-path #:compressions compressions) (not-found request + #:baking? #t #:phrase "We're baking it" #:ttl 300))) ;should be available within 5m (else diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 19224cf70b..7b6c58dbc3 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -31,7 +31,6 @@ #:use-module (guix derivations) #:use-module (guix profiles) #:use-module (guix gexp) - #:use-module (guix grafts) #:use-module (guix memoization) #:use-module (guix monads) #:use-module (guix channels) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 14329751f8..6498d73c2b 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -46,6 +47,7 @@ #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (srfi srfi-71) @@ -181,9 +183,31 @@ specified with `--select'.\n")) (newline) (show-bug-report-information)) -(define (options->packages opts) - "Return the list of packages requested by OPTS, honoring options like -'--recursive'." + +;;; +;;; Utilities. +;;; + +(define-record-type <update-spec> + (%update-spec package version) + update? + (package update-spec-package) + (version update-spec-version)) + +(define* (update-spec package #:optional version) + (%update-spec package version)) + +(define (update-specification->update-spec spec) + "Given SPEC, a package name like \"guile@2.0=2.0.8\", return a <update> +record with two fields: the package to upgrade, and the target version." + (match (string-rindex spec #\=) + (#f (update-spec (specification->package spec) #f)) + (idx (update-spec (specification->package (substring spec 0 idx)) + (substring spec (1+ idx)))))) + +(define (options->update-specs opts) + "Return the list of <update-spec> records requested by OPTS, honoring +options like '--recursive'." (define core-package? (let* ((input->package (match-lambda ((name (? package? package) _ ...) package) @@ -218,41 +242,43 @@ update would trigger a complete rebuild." (_ (cons package lst))))) - (define args-packages - ;; Packages explicitly passed as command-line arguments. - (match (filter-map (match-lambda + (define update-specs + ;; Update specs explicitly passed as command-line arguments. + (match (append-map (match-lambda (('argument . spec) ;; Take either the specified version or the ;; latest one. - (specification->package spec)) + (list (update-specification->update-spec spec))) (('expression . exp) - (read/eval-package-expression exp)) - (_ #f)) + (list (update-spec (read/eval-package-expression exp)))) + (('manifest . manifest) + (map update-spec (packages-from-manifest manifest))) + (_ + '())) opts) (() ;default to all packages (let ((select? (match (assoc-ref opts 'select) ('core core-package?) ('non-core (negate core-package?)) (_ (const #t))))) - (fold-packages (lambda (package result) - (if (select? package) - (keep-newest package result) - result)) - '()))) + (map update-spec + (fold-packages (lambda (package result) + (if (select? package) + (keep-newest package result) + result)) + '())))) (some ;user-specified packages some))) - (define packages - (match (assoc-ref opts 'manifest) - (#f args-packages) - ((? string? file) (packages-from-manifest file)))) - (if (assoc-ref opts 'recursive?) - (mlet %store-monad ((edges (node-edges %bag-node-type - (all-packages)))) - (return (node-transitive-edges packages edges))) + (mlet* %store-monad ((edges (node-edges %bag-node-type (all-packages))) + (packages -> (node-transitive-edges + (map update-spec-package update-specs) + edges))) + ;; FIXME: The 'version' field of each update spec is lost. + (return (map update-spec packages))) (with-monad %store-monad - (return packages)))) + (return update-specs)))) ;;; @@ -298,7 +324,7 @@ update would trigger a complete rebuild." (G_ "no updater for ~a~%") (package-name package))) -(define* (update-package store package updaters +(define* (update-package store package version updaters #:key (key-download 'interactive) warn?) "Update the source file that defines PACKAGE with the new version. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed @@ -307,7 +333,7 @@ warn about packages that have no matching updater." (if (lookup-updater package updaters) (let ((version output source (package-update store package updaters - #:key-download key-download)) + #:key-download key-download #:version version)) (loc (or (package-field-location package 'version) (package-location package)))) (when version @@ -361,10 +387,15 @@ downloaded and authenticated; not updating~%") (when warn? (warn-no-updater package)))) -(define* (check-for-package-update package updaters #:key warn?) - "Check whether an update is available for PACKAGE and print a message. When -WARN? is true and no updater exists for PACKAGE, print a warning." - (match (package-latest-release package updaters) +(define* (check-for-package-update update-spec updaters #:key warn?) + "Check whether UPDATE-SPEC is feasible, and print a message. +When WARN? is true and no updater exists for PACKAGE, print a warning." + (define package + (update-spec-package update-spec)) + + (match (package-latest-release package updaters + #:version + (update-spec-version update-spec)) ((? upstream-source? source) (let ((loc (or (package-field-location package 'version) (package-location package)))) @@ -382,23 +413,34 @@ WARN? is true and no updater exists for PACKAGE, print a warning." (package-version package) (package-name package)))) (else - (when warn? - (warning loc - (G_ "~a is greater than \ + (if (update-spec-version update-spec) + (info loc + (G_ "~a would be downgraded from ~a to ~a~%") + (package-name package) + (package-version package) + (upstream-source-version source)) + (when warn? + (warning loc + (G_ "~a is greater than \ the latest known version of ~a (~a)~%") - (package-version package) - (package-name package) - (upstream-source-version source))))))) + (package-version package) + (package-name package) + (upstream-source-version source)))))))) (#f (when warn? ;; Distinguish between "no updater" and "failing updater." (match (lookup-updater package updaters) ((? upstream-updater? updater) - (warning (package-location package) - (G_ "'~a' updater failed to determine available \ + (if (update-spec-version update-spec) + (warning (G_ "'~a' updater failed to find version ~a of '~a'~%") + (upstream-updater-name updater) + (update-spec-version update-spec) + (package-name package)) + (warning (package-location package) + (G_ "'~a' updater failed to determine available \ releases for ~a~%") - (upstream-updater-name updater) - (package-name package))) + (upstream-updater-name updater) + (package-name package)))) (#f (warn-no-updater package))))))) @@ -540,12 +582,12 @@ all are dependent packages: ~{~a~^ ~}~%") (with-error-handling (with-store store (run-with-store store - (mlet %store-monad ((packages (options->packages opts))) + (mlet %store-monad ((update-specs (options->update-specs opts))) (cond (list-dependent? - (list-dependents packages)) + (list-dependents (map update-spec-package update-specs))) (list-transitive? - (list-transitive packages)) + (list-transitive (map update-spec-package update-specs))) (update? (parameterize ((%openpgp-key-server (or (assoc-ref opts 'key-server) @@ -558,13 +600,17 @@ all are dependent packages: ~{~a~^ ~}~%") (string-append (config-directory) "/upstream/trustedkeys.kbx")))) (for-each - (cut update-package store <> updaters - #:key-download key-download - #:warn? warn?) - packages) + (lambda (update) + (update-package store + (update-spec-package update) + (update-spec-version update) + updaters + #:key-download key-download + #:warn? warn?)) + update-specs) (return #t))) (else (for-each (cut check-for-package-update <> updaters #:warn? warn?) - packages) + update-specs) (return #t))))))))) diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index 50d18c7760..787c63d48e 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -52,12 +52,19 @@ (option '(#\t "type") #t #f (lambda (opt name arg result) (alist-cons 'type (string->symbol arg) result))) + (option '("list-types") #f #f + (lambda (opt name arg result) + (display (string-join '("guile" "machine") "\n" 'suffix)) + (exit 0))) (option '("listen") #t #f (lambda (opt name arg result) (alist-cons 'listen arg result))) (option '(#\q) #f #f (lambda (opt name arg result) (alist-cons 'ignore-dot-guile? #t result))) + (option '(#\i "interactive") #f #f + (lambda (opt name arg result) + (alist-cons 'interactive? #t result))) (option '(#\L "load-path") #t #f (lambda (opt name arg result) ;; XXX: Imperatively modify the search paths. @@ -71,6 +78,8 @@ In the Guix execution environment, run FILE as a Guile script with command-line arguments ARGS. If no FILE is given, start a Guile REPL.\n")) (display (G_ " + --list-types display REPL types and exit")) + (display (G_ " -t, --type=TYPE start a REPL of the given TYPE")) (display (G_ " --listen=ENDPOINT listen to ENDPOINT instead of standard input")) @@ -78,6 +87,9 @@ command-line arguments ARGS. If no FILE is given, start a Guile REPL.\n")) -q inhibit loading of ~/.guile")) (newline) (display (G_ " + -i, --interactive launch REPL after evaluating FILE")) + (newline) + (display (G_ " -L, --load-path=DIR prepend DIR to the package module search path")) (newline) (display (G_ " @@ -190,7 +202,7 @@ call THUNK." ;; file in %LOAD-PATH. Thus, pass (getcwd) instead of ".". (load-in-vicinity (getcwd) (car script))))) - (when (null? script) + (when (or (null? script) (assoc-ref opts 'interactive?)) ;; Start REPL (let ((type (assoc-ref opts 'type))) (call-with-connection (assoc-ref opts 'listen) diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm index c115a00320..64b5c2e8e9 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -20,7 +20,8 @@ #:use-module (guix ui) #:use-module ((guix diagnostics) #:select (location)) #:use-module (guix scripts environment) - #:autoload (guix scripts build) (show-build-options-help) + #:autoload (guix scripts build) (show-build-options-help + show-native-build-options-help) #:autoload (guix transformations) (options->transformation transformation-option-key? show-transformation-options-help) @@ -68,11 +69,16 @@ interactive shell in that environment.\n")) --rebuild-cache rebuild cached environment, if any")) (display (G_ " --export-manifest print a manifest for the given options")) + (display (G_ " + -F, --emulate-fhs for containers, emulate the Filesystem Hierarchy + Standard (FHS)")) (show-environment-options-help) (newline) (show-build-options-help) (newline) + (show-native-build-options-help) + (newline) (show-transformation-options-help) (newline) (display (G_ " @@ -136,7 +142,11 @@ interactive shell in that environment.\n")) (alist-cons 'explicit-loading? #t result))) (option '("rebuild-cache") #f #f (lambda (opt name arg result) - (alist-cons 'rebuild-cache? #t result)))) + (alist-cons 'rebuild-cache? #t result))) + + (option '(#\F "emulate-fhs") #f #f + (lambda (opt name arg result) + (alist-cons 'emulate-fhs? #t result)))) (filter-map (lambda (opt) (and (not (any (lambda (name) (member name to-remove)) @@ -157,8 +167,18 @@ interactive shell in that environment.\n")) ;; The '--' token is used to separate the command to run from the rest of ;; the operands. (let ((args command (break (cut string=? "--" <>) args))) - (let ((opts (parse-command-line args %options (list %default-options) - #:argument-handler handle-argument))) + (let* ((args-parsed (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument)) + ;; For an FHS-container, add the (hidden) package glibc-for-fhs + ;; which uses the global cache at /etc/ld.so.cache. We handle + ;; adding this package here to ensure it will always appear in the + ;; container as it is the first package in OPTS. + (opts (if (assoc-ref args-parsed 'emulate-fhs?) + (alist-cons 'expression + '(ad-hoc-package + "(@@ (gnu packages base) glibc-for-fhs)") + args-parsed) + args-parsed))) (options-with-caching (auto-detect-manifest (match command @@ -517,43 +537,44 @@ concatenates MANIFESTS, a list of expressions." (category development) (synopsis "spawn one-off software environments") - (define (cache-entries directory) - (filter-map (match-lambda - ((or "." "..") #f) - (file (string-append directory "/" file))) - (or (scandir directory) '()))) - - (define* (entry-expiration file) - ;; Return the time at which FILE, a cached profile, is considered expired. - (match (false-if-exception (lstat file)) - (#f 0) ;FILE may have been deleted in the meantime - (st (+ (stat:atime st) (* 60 60 24 7))))) - - (define opts - (parse-args args)) - - (define interactive? - (not (assoc-ref opts 'exec))) - - (if (assoc-ref opts 'check?) - (record-hint 'shell-check) - (when (and interactive? - (not (hint-given? 'shell-check)) - (not (assoc-ref opts 'container?)) - (not (assoc-ref opts 'search-paths))) - (display-hint (G_ "Consider passing the @option{--check} option once + (with-error-handling + (define (cache-entries directory) + (filter-map (match-lambda + ((or "." "..") #f) + (file (string-append directory "/" file))) + (or (scandir directory) '()))) + + (define* (entry-expiration file) + ;; Return the time at which FILE, a cached profile, is considered expired. + (match (false-if-exception (lstat file)) + (#f 0) ;FILE may have been deleted in the meantime + (st (+ (stat:atime st) (* 60 60 24 7))))) + + (define opts + (parse-args args)) + + (define interactive? + (not (assoc-ref opts 'exec))) + + (if (assoc-ref opts 'check?) + (record-hint 'shell-check) + (when (and interactive? + (not (hint-given? 'shell-check)) + (not (assoc-ref opts 'container?)) + (not (assoc-ref opts 'search-paths))) + (display-hint (G_ "Consider passing the @option{--check} option once to make sure your shell does not clobber environment variables."))) ) - ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use - ;; of cached profiles, and (2) cleanup actually happens, even when - ;; 'guix-environment*' calls 'exit'. - (add-hook! exit-hook - (lambda _ - (maybe-remove-expired-cache-entries - (%profile-cache-directory) - cache-entries - #:entry-expiration entry-expiration))) - - (if (assoc-ref opts 'export-manifest?) - (export-manifest opts (current-output-port)) - (guix-environment* opts))) + ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use + ;; of cached profiles, and (2) cleanup actually happens, even when + ;; 'guix-environment*' calls 'exit'. + (add-hook! exit-hook + (lambda _ + (maybe-remove-expired-cache-entries + (%profile-cache-directory) + cache-entries + #:entry-expiration entry-expiration))) + + (if (assoc-ref opts 'export-manifest?) + (export-manifest opts (current-output-port)) + (guix-environment* opts)))) diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index 5bb970443c..48b8ecc881 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -24,7 +24,6 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix combinators) - #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (gnu packages) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index c0b9ea1a28..fa7175fb16 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -335,13 +335,15 @@ PACKAGE." (define* (format-whole-file file #:rest rest) "Reformat all of FILE." - (let ((lst (call-with-input-file file read-with-comments/sequence))) - (with-atomic-file-output file - (lambda (port) - (apply pretty-print-with-comments/splice port lst - #:format-comment canonicalize-comment - #:format-vertical-space canonicalize-vertical-space - rest))))) + (with-fluids ((%default-port-encoding "UTF-8")) + (let ((lst (call-with-input-file file read-with-comments/sequence + #:guess-encoding #t))) + (with-atomic-file-output file + (lambda (port) + (apply pretty-print-with-comments/splice port lst + #:format-comment canonicalize-comment + #:format-vertical-space canonicalize-vertical-space + rest)))))) ;;; diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index cdf591ac4d..fedb33019d 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2020 Christopher Baines <mail@cbaines.net> @@ -366,7 +366,7 @@ authorized substitutes." When FRESH? is true, delete any cached connections for URI and open a new one. Return #f if URI's scheme is 'file' or #f. -When true, TIMEOUT is the maximum number of milliseconds to wait for +When true, TIMEOUT is the maximum number of seconds to wait for connection establishment. When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (define host (uri-host uri)) @@ -437,20 +437,13 @@ server certificates." "Bind PORT with EXP... to a socket connected to URI." (call-with-cached-connection uri (lambda (port) exp ...))) -(define* (process-substitution port store-item destination - #:key cache-urls acl - deduplicate? 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, and verify its -hash against what appears in the narinfo. When DEDUPLICATE? is true, and if -DESTINATION is in the store, deduplicate its files. Print a status line to -PORT." - (define narinfo - (lookup-narinfo cache-urls store-item - (if (%allow-unauthenticated-substitutes?) - (const #t) - (cut valid-narinfo? <> acl)))) - +(define* (download-nar narinfo destination + #:key status-port + deduplicate? print-build-trace?) + "Download the nar prescribed in NARINFO, which is assumed to be authentic +and authorized, and write it to DESTINATION. When DEDUPLICATE? is true, and +if DESTINATION is in the store, deduplicate its files. Print a status line to +STATUS-PORT." (define destination-in-store? (string-prefix? (string-append (%store-prefix) "/") destination)) @@ -467,33 +460,24 @@ PORT." (let ((port (open-file (uri-path uri) "r0b"))) (values port (stat:size (stat port))))) ((http https) - (guard (c ((http-get-error? c) - (leave (G_ "download from '~a' failed: ~a, ~s~%") - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)))) - ;; Test this with: - ;; sudo tc qdisc add dev eth0 root netem delay 1500ms - ;; and then cancel with: - ;; sudo tc qdisc del dev eth0 root - (with-timeout %fetch-timeout - (begin - (warning (G_ "while fetching ~a: server is somewhat slow~%") - (uri->string uri)) - (warning (G_ "try `--no-substitutes' if the problem persists~%"))) - (with-cached-connection uri port - (http-fetch uri #:text? #f - #:port port - #:keep-alive? #t - #:buffered? #f))))) + ;; Test this with: + ;; sudo tc qdisc add dev eth0 root netem delay 1500ms + ;; and then cancel with: + ;; sudo tc qdisc del dev eth0 root + (with-timeout %fetch-timeout + (begin + (warning (G_ "while fetching ~a: server is somewhat slow~%") + (uri->string uri)) + (warning (G_ "try `--no-substitutes' if the problem persists~%"))) + (with-cached-connection uri port + (http-fetch uri #:text? #f + #:port port + #:keep-alive? #t + #:buffered? #f)))) (else (leave (G_ "unsupported substitute URI scheme: ~a~%") (uri->string uri))))) - (unless narinfo - (leave (G_ "no valid substitute for '~a'~%") - store-item)) - (let ((uri compression file-size (narinfo-best-uri narinfo #:fast-decompression? @@ -575,14 +559,109 @@ PORT." (let ((actual (get-hash))) (if (bytevector=? actual expected) ;; Tell the daemon that we're done. - (format port "success ~a ~a~%" + (format status-port "success ~a ~a~%" (narinfo-hash narinfo) (narinfo-size narinfo)) ;; The actual data has a different hash than that in NARINFO. - (format port "hash-mismatch ~a ~a ~a~%" + (format status-port "hash-mismatch ~a ~a ~a~%" (hash-algorithm-name algorithm) (bytevector->nix-base32-string expected) (bytevector->nix-base32-string actual))))))) +(define system-error? + (let ((kind-and-args? (exception-predicate &exception-with-kind-and-args))) + (lambda (exception) + "Return true if EXCEPTION is a Guile 'system-error exception." + (and (kind-and-args? exception) + (eq? 'system-error (exception-kind exception)))))) + +(define network-error? + (let ((kind-and-args? (exception-predicate &exception-with-kind-and-args))) + (lambda (exception) + "Return true if EXCEPTION denotes a networking error." + (or (and (system-error? exception) + (let ((errno (system-error-errno + (cons 'system-error (exception-args exception))))) + (memv errno (list ECONNRESET ECONNABORTED + ECONNREFUSED EHOSTUNREACH + ENOENT)))) ;for "file://" + (and (kind-and-args? exception) + (memq (exception-kind exception) + '(gnutls-error getaddrinfo-error))) + (and (http-get-error? exception) + (begin + (warning (G_ "download from '~a' failed: ~a, ~s~%") + (uri->string (http-get-error-uri exception)) + (http-get-error-code exception) + (http-get-error-reason exception)) + #t)))))) + +(define* (process-substitution/fallback port narinfo destination + #:key cache-urls acl + deduplicate? print-build-trace?) + "Attempt to substitute NARINFO, which is assumed to be authorized or +equivalent, by trying to download its nar from each entry in CACHE-URLS. + +This can be less efficient than 'lookup-narinfo', which stops at the first +entry that provides a valid narinfo, but it makes sure we eventually find a +way to download the nar." + ;; Note: Keep NARINFO's uri-base in CACHE-URLS: that lets us retry in case + ;; this was a transient issue. + (let loop ((cache-urls cache-urls)) + (match cache-urls + (() + (leave (G_ "failed to find alternative substitute for '~a'~%") + (narinfo-path narinfo))) + ((cache-url rest ...) + (match (lookup-narinfos cache-url + (list (narinfo-path narinfo)) + #:open-connection + open-connection-for-uri/cached) + ((alternate) + (if (or (equivalent-narinfo? narinfo alternate) + (valid-narinfo? alternate acl) + (%allow-unauthenticated-substitutes?)) + (guard (c ((network-error? c) (loop rest))) + (download-nar alternate destination + #:status-port port + #:deduplicate? deduplicate? + #:print-build-trace? print-build-trace?)) + (loop rest))) + (() + (loop rest))))))) + +(define* (process-substitution port store-item destination + #:key cache-urls acl + deduplicate? 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, and verify its +hash against what appears in the narinfo. When DEDUPLICATE? is true, and if +DESTINATION is in the store, deduplicate its files. Print a status line to +PORT." + (define narinfo + (lookup-narinfo cache-urls store-item + (if (%allow-unauthenticated-substitutes?) + (const #t) + (cut valid-narinfo? <> acl)))) + + (unless narinfo + (leave (G_ "no valid substitute for '~a'~%") + store-item)) + + (guard (c ((network-error? c) + (format (current-error-port) + (G_ "retrying download of '~a' with other substitute URLs...~%") + store-item) + (process-substitution/fallback port narinfo destination + #:cache-urls cache-urls + #:acl acl + #:deduplicate? deduplicate? + #:print-build-trace? + print-build-trace?))) + (download-nar narinfo destination + #:status-port port + #:deduplicate? deduplicate? + #:print-build-trace? print-build-trace?))) + ;;; ;;; Entry point. @@ -627,10 +706,12 @@ substitutes may be unavailable\n"))))) (string-drop option=value (+ 1 equal-sign)))))) (string-tokenize newline-separated %not-newline))))) -(define (find-daemon-option option) - "Return the value of build daemon option OPTION, or #f if it could not be +(define find-daemon-option + (let ((options (delay (daemon-options)))) + (lambda (option) + "Return the value of build daemon option OPTION, or #f if it could not be found." - (assoc-ref (daemon-options) option)) + (assoc-ref (force options) option)))) (define %default-substitute-urls (match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 4bcf789703..6fd915cb5e 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -38,7 +38,6 @@ (sqlite-register store-database-file call-with-database) #:autoload (guix build store-copy) (copy-store-item) #:use-module (guix describe) - #:use-module (guix grafts) #:use-module (guix gexp) #:use-module (guix derivations) #:use-module (guix diagnostics) @@ -92,6 +91,7 @@ #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:export (guix-system + read-operating-system service-node-type shepherd-service-node-type)) @@ -107,6 +107,11 @@ (gnu services) (gnu system shadow)))) +;; Note: The procedure below is used in external projects such as Emacs-Guix. +(define (read-operating-system file) + "Read the operating-system declaration from FILE and return it." + (load* file %user-module)) + ;;; ;;; Installation. @@ -837,7 +842,10 @@ static checks." (check-mapped-devices os) (when (zero? (getuid)) (check-file-system-availability (operating-system-file-systems os)) - (check-initrd-modules os))) + (unless (%current-target-system) + ;; Skip the check if the user is making use of --target, as it cannot + ;; be checked against the running kernel. + (check-initrd-modules os)))) (mlet* %store-monad ((sys (system-derivation-for-action image action @@ -1040,7 +1048,7 @@ Some ACTIONS support additional ARGS.\n")) (newline) (display (G_ " --graph-backend=BACKEND - use BACKEND for 'extension-graphs' and 'shepherd-graph'")) + use BACKEND for 'extension-graph' and 'shepherd-graph'")) (newline) (display (G_ " -I, --list-installed[=REGEXP] diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index f12bc2db88..9948df0ca6 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -41,9 +41,9 @@ #:use-module (guix diagnostics) #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) #:use-module ((guix config) #:select (%guix-package-name)) #:export (switch-system-program switch-to-system @@ -186,8 +186,8 @@ services as defined by OS." #:target-type shepherd-root-service-type)))) (mlet* %store-monad ((live-services (running-services eval))) - (let*-values (((to-unload to-restart) - (shepherd-service-upgrade live-services target-services))) + (let ((to-unload to-restart + (shepherd-service-upgrade live-services target-services))) (let* ((to-unload (map live-service-canonical-name to-unload)) (to-restart (map shepherd-service-canonical-name to-restart)) (running (map live-service-canonical-name @@ -349,14 +349,12 @@ to commits of channels in NEW." (channel-name old))) new))) (and new - (let-values (((checkout commit relation) - (update-cached-checkout - (channel-url new) - #:ref - `(commit . ,(channel-commit new)) - #:starting-commit - (channel-commit old) - #:check-out? #f))) + (let ((checkout commit relation + (update-cached-checkout + (channel-url new) + #:ref `(commit . ,(channel-commit new)) + #:starting-commit (channel-commit old) + #:check-out? #f))) (list new (channel-commit old) (channel-commit new) relation))))) diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm index 44f00194cd..d978884518 100644 --- a/guix/scripts/system/search.scm +++ b/guix/scripts/system/search.scm @@ -127,7 +127,7 @@ procedure that may return a colorized version of its argument." (parameterize ((%text-width width*)) (texi->plain-text (string-append "description: " - (or (and=> (service-type-description type) P_) + (or (and=> (service-type-description type) G_) "")))) #\newline))))) @@ -144,7 +144,7 @@ procedure that may return a colorized version of its argument." (define (service-type-description-string type) "Return the rendered and localised description of TYPE, a service type." (and=> (service-type-description type) - (compose texi->plain-text P_))) + (compose texi->plain-text G_))) (define %service-type-metrics ;; Metrics used to estimate the relevance of a search result. diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index f46c11b1a5..dc27f81984 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -29,7 +29,6 @@ #:use-module (guix progress) #:use-module (guix monads) #:use-module (guix store) - #:use-module (guix grafts) #:use-module (guix gexp) #:use-module (guix colors) #:use-module ((guix build syscalls) #:select (terminal-columns)) |