diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/challenge.scm | 95 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 471 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/hash.scm | 116 | ||||
| -rw-r--r-- | guix/scripts/home.scm | 52 | ||||
| -rw-r--r-- | guix/scripts/home/import.scm | 309 | ||||
| -rw-r--r-- | guix/scripts/import/cran.scm | 35 | ||||
| -rw-r--r-- | guix/scripts/import/egg.scm | 34 | ||||
| -rw-r--r-- | guix/scripts/import/go.scm | 69 | ||||
| -rw-r--r-- | guix/scripts/import/pypi.scm | 32 | ||||
| -rw-r--r-- | guix/scripts/import/texlive.scm | 18 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 58 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 29 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 52 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 82 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 62 | ||||
| -rw-r--r-- | guix/scripts/shell.scm | 444 | ||||
| -rw-r--r-- | guix/scripts/style.scm | 854 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 67 |
20 files changed, 2273 insertions, 610 deletions
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 69c2781abb..c29d5105ae 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -35,10 +35,10 @@ #:use-module (gcrypt hash) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 format) @@ -196,65 +196,68 @@ taken since we do not import the archives." (define (port-sha256* port size) ;; Like 'port-sha256', but limited to SIZE bytes. - (let-values (((out get) (open-sha256-port))) + (let ((out get (open-sha256-port))) (dump-port* port out size) (close-port out) (get))) (define (archive-contents port) - "Return a list representing the files contained in the nar read from PORT." - (fold-archive (lambda (file type contents result) - (match type - ((or 'regular 'executable) - (match contents - ((port . size) - (cons `(,file ,type ,(port-sha256* port size)) - result)))) - ('directory result) - ('directory-complete result) - ('symlink - (cons `(,file ,type ,contents) result)))) - '() - port - "")) + "Return a list representing the files contained in the nar read from PORT. +The list is sorted in canonical order--i.e., the order in which entries appear +in the nar." + (reverse + (fold-archive (lambda (file type contents result) + (match type + ((or 'regular 'executable) + (match contents + ((port . size) + (cons `(,file ,type ,(port-sha256* port size)) + result)))) + ('directory result) + ('directory-complete result) + ('symlink + (cons `(,file ,type ,contents) result)))) + '() + port + ""))) (define (store-item-contents item) "Return a list of files and contents for ITEM in the same format as 'archive-contents'." - (file-system-fold (const #t) ;enter? - (lambda (file stat result) ;leaf - (define short - (string-drop file (string-length item))) + (let loop ((file item)) + (define stat + (lstat file)) - (match (stat:type stat) - ('regular - (let ((size (stat:size stat)) - (type (if (zero? (logand (stat:mode stat) - #o100)) - 'regular - 'executable))) - (cons `(,short ,type - ,(call-with-input-file file - (cut port-sha256* <> size))) - result))) - ('symlink - (cons `(,short symlink ,(readlink file)) - result)))) - (lambda (directory stat result) result) ;down - (lambda (directory stat result) result) ;up - (lambda (file stat result) result) ;skip - (lambda (file stat errno result) result) ;error - '() - item - lstat)) + (define short + (string-drop file (string-length item))) + + (match (stat:type stat) + ('regular + (let ((size (stat:size stat)) + (type (if (zero? (logand (stat:mode stat) + #o100)) + 'regular + 'executable))) + `((,short ,type + ,(call-with-input-file file + (cut port-sha256* <> size)))))) + ('symlink + `((,short symlink ,(readlink file)))) + ('directory + (append-map (match-lambda + ((or "." "..") + '()) + (entry + (loop (string-append file "/" entry)))) + ;; Traverse entries in canonical order, the same as the + ;; order of entries in nars. + (scandir file (const #t) string<?)))))) (define (call-with-nar narinfo proc) "Call PROC with an input port from which it can read the nar pointed to by NARINFO." - (let*-values (((uri compression size) - (narinfo-best-uri narinfo)) - ((port actual-size) - (http-fetch uri))) + (let* ((uri compression size (narinfo-best-uri narinfo)) + (port actual-size (http-fetch uri))) (define reporter (progress-reporter/file (narinfo-path narinfo) (and size diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 6958bd6238..ec071402f4 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org> -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -34,23 +34,33 @@ #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (guix transformations) - #:use-module (gnu build linux-container) - #:use-module (gnu build accounts) - #:use-module ((guix build syscalls) #:select (set-network-interface-up)) - #:use-module (gnu system linux-container) + #:autoload (ice-9 ftw) (scandir) + #:autoload (gnu build linux-container) (call-with-container %namespaces + user-namespace-supported? + unprivileged-user-namespace-supported? + setgroups-supported?) + #:autoload (gnu build accounts) (password-entry group-entry + password-entry-name password-entry-directory + write-passwd write-group) + #:autoload (guix build syscalls) (set-network-interface-up openpty login-tty) #:use-module (gnu system file-systems) - #:use-module (gnu packages) - #:use-module (gnu packages bash) - #:use-module ((gnu packages bootstrap) - #:select (bootstrap-executable %bootstrap-guile)) + #:autoload (gnu packages) (specification->package+output) + #:autoload (gnu packages bash) (bash) + #:autoload (gnu packages bootstrap) (bootstrap-executable %bootstrap-guile) #:use-module (ice-9 match) + #:autoload (ice-9 rdelim) (read-line) + #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (srfi srfi-98) #:export (assert-container-features - guix-environment)) + guix-environment + guix-environment* + show-environment-options-help + (%options . %environment-options) + (%default-options . %environment-default-options))) (define %default-shell (or (getenv "SHELL") "/bin/sh")) @@ -66,41 +76,18 @@ do not augment existing environment variables with additional search paths." (newline))) (profile-search-paths profile manifest))) -(define (input->manifest-entry input) - "Return a manifest entry for INPUT, or #f if INPUT does not correspond to a -package." - (match input - ((_ (? package? package)) - (package->manifest-entry package)) - ((_ (? package? package) output) - (package->manifest-entry package output)) - (_ - #f))) - -(define (package-environment-inputs package) - "Return a list of manifest entries corresponding to the transitive input -packages for PACKAGE." - ;; Remove non-package inputs such as origin records. - (filter-map input->manifest-entry - (bag-transitive-inputs (package->bag package)))) - -(define (show-help) - (display (G_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] -Build an environment that includes the dependencies of PACKAGE and execute -COMMAND or an interactive shell in that environment.\n")) +(define (show-environment-options-help) + "Print help about options shared between 'guix environment' and 'guix +shell'." (display (G_ " -e, --expression=EXPR create environment for the package that EXPR evaluates to")) (display (G_ " - -l, --load=FILE create environment for the package that the code within - FILE evaluates to")) - (display (G_ " -m, --manifest=FILE create environment with the manifest from FILE")) (display (G_ " -p, --profile=PATH create environment from profile at PATH")) (display (G_ " - --ad-hoc include all specified packages in the environment instead - of only their inputs")) + --check check if the shell clobbers environment variables")) (display (G_ " --pure unset existing environment variables")) (display (G_ " @@ -136,7 +123,24 @@ COMMAND or an interactive shell in that environment.\n")) (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " - --bootstrap use bootstrap binaries to build the environment")) + --bootstrap use bootstrap binaries to build the environment"))) + +(define (show-help) + (display (G_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] +Build an environment that includes the dependencies of PACKAGE and execute +COMMAND or an interactive shell in that environment.\n")) + (warning (G_ "This command is deprecated in favor of 'guix shell'.\n")) + (newline) + + ;; These two options are left out in 'guix shell'. + (display (G_ " + -l, --load=FILE create environment for the package that the code within + FILE evaluates to")) + (display (G_ " + --ad-hoc include all specified packages in the environment instead + of only their inputs")) + + (show-environment-options-help) (newline) (show-build-options-help) (newline) @@ -179,6 +183,9 @@ COMMAND or an interactive shell in that environment.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix environment"))) + (option '("check") #f #f + (lambda (opt name arg result) + (alist-cons 'check? #t result))) (option '("pure") #f #f (lambda (opt name arg result) (alist-cons 'pure #t result))) @@ -297,11 +304,11 @@ for the corresponding packages." ((? package? package) (if (eq? mode 'ad-hoc-package) (list (package->manifest-entry* package)) - (package-environment-inputs package))) + (manifest-entries (package->development-manifest package)))) (((? package? package) (? string? output)) (if (eq? mode 'ad-hoc-package) (list (package->manifest-entry* package output)) - (package-environment-inputs package))) + (manifest-entries (package->development-manifest package)))) ((lst ...) (append-map (cut packages->outputs <> mode) lst)))) @@ -313,8 +320,9 @@ for the corresponding packages." (specification->package+output spec))) (list (package->manifest-entry* package output)))) (('package 'package (? string? spec)) - (package-environment-inputs - (transform (specification->package+output spec)))) + (manifest-entries + (package->development-manifest + (transform (specification->package+output spec))))) (('expression mode str) ;; Add all the outputs of the package STR evaluates to. (packages->outputs (read/eval str) mode)) @@ -394,7 +402,193 @@ regexps in WHITE-LIST." (match command ((program . args) - (apply execlp program program args)))) + (catch 'system-error + (lambda () + (apply execlp program program args)) + (lambda _ + ;; Following established convention, exit with 127 upon ENOENT. + (primitive-_exit 127)))))) + +(define (child-shell-environment shell profile manifest) + "Create a child process, load PROFILE and MANIFEST, and then run SHELL in +interactive mode in it. Return a name/value vhash for all the variables shown +by running 'set' in the shell." + (define-values (controller inferior) + (openpty)) + + (define script + ;; Script to obtain the list of environment variable values. On a POSIX + ;; shell we can rely on 'set', but on fish we have to use 'env' (fish's + ;; 'set' truncates values and prints them in a different format.) + "env || /usr/bin/env || set; echo GUIX-CHECK-DONE; read x; exit\n") + + (define lines + (match (primitive-fork) + (0 + (catch #t + (lambda () + (load-profile profile manifest #:pure? #t) + (setenv "GUIX_ENVIRONMENT" profile) + (close-fdes controller) + (login-tty inferior) + (execl shell shell)) + (lambda _ + (primitive-exit 127)))) + (pid + (close-fdes inferior) + (let* ((port (fdopen controller "r+l")) + (result (begin + (display script port) + (let loop ((lines '())) + (match (read-line port) + ((? eof-object?) (reverse lines)) + ("GUIX-CHECK-DONE\r" + (display "done\n" port) + (reverse lines)) + (line + ;; Drop the '\r' from LINE. + (loop (cons (string-drop-right line 1) + lines)))))))) + (close-port port) + (waitpid pid) + result)))) + + (fold (lambda (line table) + ;; Note: 'set' in fish outputs "NAME VALUE" instead of "NAME=VALUE" + ;; but it also truncates values anyway, so don't try to support it. + (let ((index (string-index line #\=))) + (if index + (vhash-cons (string-take line index) + (string-drop line (+ 1 index)) + table) + table))) + vlist-null + lines)) + +(define* (validate-child-shell-environment profile manifest + #:optional (shell %default-shell)) + "Run SHELL in interactive mode in an environment for PROFILE and MANIFEST +and report clobbered environment variables." + (define warned? #f) + (define-syntax-rule (warn exp ...) + (begin + (set! warned? #t) + (warning exp ...))) + + (info (G_ "checking the environment variables visible from shell '~a'...~%") + shell) + (let ((actual (child-shell-environment shell profile manifest))) + (when (vlist-null? actual) + (leave (G_ "failed to determine environment of shell '~a'~%") + shell)) + (for-each (match-lambda + ((spec . expected) + (let ((name (search-path-specification-variable spec))) + (match (vhash-assoc name actual) + (#f + (warn (G_ "variable '~a' is missing from shell \ +environment~%") + name)) + ((_ . actual) + (cond ((string=? expected actual) + #t) + ((string-prefix? expected actual) + (warn (G_ "variable '~a' has unexpected \ +suffix '~a'~%") + name + (string-drop actual + (string-length expected)))) + (else + (warn (G_ "variable '~a' is clobbered: '~a'~%") + name actual)))))))) + (profile-search-paths profile manifest)) + + ;; Special case. + (match (vhash-assoc "GUIX_ENVIRONMENT" actual) + (#f + (warn (G_ "'GUIX_ENVIRONMENT' is missing from the shell \ +environment~%"))) + ((_ . value) + (unless (string=? value profile) + (warn (G_ "'GUIX_ENVIRONMENT' is set to '~a' instead of '~a'~%") + value profile)))) + + ;; Check the prompt unless we have more important warnings. + (unless warned? + (match (vhash-assoc "PS1" actual) + (#f #f) + ((_ . str) + (when (and (getenv "PS1") (string=? str (getenv "PS1"))) + (warning (G_ "'PS1' is the same in sub-shell~%")) + (display-hint (G_ "Consider setting a different prompt for +environment shells to make them distinguishable. + +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 +@end example +")))))) + + (if warned? + (begin + (display-hint (G_ "One or more environment variables have a +different value in the shell than the one we set. This means that you may +find yourself running code in an environment different from the one you asked +Guix to prepare. + +This usually indicates that your shell startup files are unexpectedly +modifying those environment variables. For example, if you are using Bash, +make sure that environment variables are set or modified in +@file{~/.bash_profile} and @emph{not} in @file{~/.bashrc}. For more +information on Bash startup files, run: + +@example +info \"(bash) Bash Startup Files\" +@end example + +Alternatively, you can avoid the problem by passing the @option{--container} +or @option{-C} option. That will give you a fully isolated environment +running in a \"container\", immune to the issue described above.")) + (exit 1)) + (info (G_ "All is good! The shell gets correct environment \ +variables.~%"))))) + +(define (suggest-command-name profile command) + "COMMAND was not found in PROFILE so display a hint suggesting the closest +command name." + (define not-dot? + (match-lambda + ((or "." "..") #f) + (_ #t))) + + (match (scandir (string-append profile "/bin") not-dot?) + ((or #f ()) #f) + (available + (match command + ((executable _ ...) + ;; Look for a suggestion with a high threshold: a suggestion is + ;; usually better than no suggestion. + (let ((closest (string-closest executable available + #:threshold 12))) + (unless (or (not closest) (string=? closest executable)) + (display-hint (format #f (G_ "Did you mean '~a'?~%") + closest))))))))) + +(define (validate-exit-status profile command status) + "When STATUS, an integer as returned by 'waitpid', is 127, raise a \"command +not found\" error. Otherwise return STATUS." + ;; Most likely, exit value 127 means ENOENT. + (when (eqv? (status:exit-val status) 127) + (report-error (G_ "~a: command not found~%") + (first command)) + (suggest-command-name profile command) + (exit 1)) + status) (define* (launch-environment/fork command profile manifest #:key pure? (white-list '())) @@ -407,7 +601,8 @@ regexps in WHITE-LIST." #:pure? pure? #:white-list white-list)) (pid (match (waitpid pid) - ((_ . status) status))))) + ((_ . status) + (validate-exit-status profile command status)))))) (define* (launch-environment/container #:key command bash user user-mappings profile manifest link-profile? network? @@ -428,6 +623,9 @@ WHILE-LIST." (and (file-exists? (file-system-mapping-source mapping)) (file-system-mapping->bind-mount mapping))) + (define (exit/status* status) + (exit/status (validate-exit-status profile command status))) + (mlet %store-monad ((reqs (inputs->requisites (list (direct-store-path bash) profile)))) (return @@ -484,7 +682,7 @@ WHILE-LIST." '()) (map file-system-mapping->bind-mount mappings)))) - (exit/status + (exit/status* (call-with-container file-systems (lambda () ;; Setup global shell. @@ -666,11 +864,15 @@ message if any test fails." (define-command (guix-environment . args) (category development) - (synopsis "spawn one-off software environments") + (synopsis "spawn one-off software environments (deprecated)") + (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* ((opts (parse-args args)) - (pure? (assoc-ref opts 'pure)) + (let* ((pure? (assoc-ref opts 'pure)) (container? (assoc-ref opts 'container?)) (link-prof? (assoc-ref opts 'link-profile?)) (network? (assoc-ref opts 'network?)) @@ -690,6 +892,26 @@ message if any test fails." (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?) @@ -700,85 +922,92 @@ message if any test fails." (leave (G_ "--no-cwd cannot be used without --container~%"))) - (with-store store - (with-build-handler (build-notifier #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:verbosity - (assoc-ref opts 'verbosity) - #:dry-run? - (assoc-ref opts 'dry-run?)) - (with-status-verbosity (assoc-ref opts 'verbosity) - (define manifest-from-opts - (options/resolve-packages store opts)) + (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)) + (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 (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~%"))) + (when (null? (manifest-entries manifest)) + (warning (G_ "no packages specified; creating an empty environment~%"))) - (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 - (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 (manifest->derivation - manifest system bootstrap?)) - (profile -> (if profile + ;; 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))) + (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)))) - ;; First build the inputs. This is necessary even for - ;; --search-paths. Additionally, we might need to build bash for - ;; a container. - (mbegin %store-monad - (built-derivations (if (derivation? bash) - (list prof-drv bash) - (list prof-drv))) - (mwhen gc-root - (register-gc-root profile gc-root)) + (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?)))) - (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?)))))))))))))) - (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) +;;; End: diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 439fae0b52..8943e87099 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -542,7 +542,7 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (display (G_ " --list-types list the available graph types")) (display (G_ " - --max-depth=DEPTH limit to nodes within distance DEPTH")) + -M, --max-depth=DEPTH limit to nodes within distance DEPTH")) (display (G_ " --path display the shortest path between the given nodes")) (display (G_ " diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index b8622373cc..4e792c6a03 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -1,8 +1,10 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2014, 2016-2017, 2020-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2018 Tim Gesthuizen <tim.gesthuizen@yahoo.de> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +25,7 @@ #:use-module (gcrypt hash) #:use-module (guix serialization) #:use-module (guix ui) + #:use-module (guix hash) #:use-module (guix scripts) #:use-module (guix base16) #:use-module (guix base32) @@ -34,17 +37,47 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) + #:autoload (disarchive git-hash) (git-hash-file git-hash-directory) #:export (guix-hash)) ;;; +;;; Serializers +;;; + +(define* (nar-hash file #:optional + (algorithm (assoc-ref %default-options 'hash-algorithm)) + select?) + (file-hash* file #:algorithm algorithm #:select? select? #:recursive? #true)) + +(define* (default-hash file #:optional + (algorithm (assoc-ref %default-options 'hash-algorithm)) + select?) + (match file + ("-" (port-hash algorithm (current-input-port))) + (_ (file-hash* file #:algorithm algorithm #:recursive? #false)))) + +(define* (git-hash file #:optional + (algorithm (assoc-ref %default-options 'hash-algorithm)) + select?) + (define directory? + (case (stat:type (stat file)) + ((directory) #t) + (else #f))) + (if directory? + (git-hash-directory file algorithm #:select? select?) + (git-hash-file file algorithm))) + + +;;; ;;; Command-line options. ;;; (define %default-options ;; Alist of default option values. `((format . ,bytevector->nix-base32-string) - (hash-algorithm . ,(hash-algorithm sha256)))) + (hash-algorithm . ,(hash-algorithm sha256)) + (serializer . ,default-hash))) (define (show-help) (display (G_ "Usage: guix hash [OPTION] FILE @@ -60,7 +93,7 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (format #t (G_ " -f, --format=FMT write the hash in the given format")) (format #t (G_ " - -r, --recursive compute the hash on FILE recursively")) + -S, --serializer=TYPE compute the hash on FILE according to TYPE serialization")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -101,7 +134,27 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (alist-delete 'format result)))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) - (alist-cons 'recursive? #t result))) + (unless (eqv? name #\r) + (warning (G_ "'--recursive' is deprecated, \ +use '--serializer=nar' instead~%"))) + (alist-cons 'serializer nar-hash + (alist-delete 'serializer result)))) + (option '(#\S "serializer") #t #f + (lambda (opt name arg result) + (define serializer-proc + (match arg + ("none" + default-hash) + ("nar" + nar-hash) + ("git" + git-hash) + (x + (leave (G_ "unsupported serializer type: ~a~%") + arg)))) + + (alist-cons 'serializer serializer-proc + (alist-delete 'serializer result)))) (option '(#\h "help") #f #f (lambda args (show-help) @@ -125,16 +178,6 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (parse-command-line args %options (list %default-options) #:build-options? #f)) - (define (vcs-file? file stat) - (case (stat:type stat) - ((directory) - (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) - ((regular) - ;; Git sub-modules have a '.git' file that is a regular text file. - (string=? (basename file) ".git")) - (else - #f))) - (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) @@ -144,32 +187,29 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (fmt (assq-ref opts 'format)) (select? (if (assq-ref opts 'exclude-vcs?) (negate vcs-file?) - (const #t)))) + (const #t))) + (algorithm (assoc-ref opts 'hash-algorithm)) + (serializer (assoc-ref opts 'serializer))) (define (file-hash file) ;; Compute the hash of FILE. - ;; Catch and gracefully report possible '&nar-error' conditions. - (with-error-handling - (if (assoc-ref opts 'recursive?) - (let-values (((port get-hash) - (open-hash-port (assoc-ref opts 'hash-algorithm)))) - (write-file file port #:select? select?) - (force-output port) - (get-hash)) - (match file - ("-" (port-hash (assoc-ref opts 'hash-algorithm) - (current-input-port))) - (_ (call-with-input-file file - (cute port-hash (assoc-ref opts 'hash-algorithm) - <>))))))) + ;; Catch and gracefully report possible error + (catch 'system-error + (lambda _ + (with-error-handling + (serializer file algorithm select?))) + (lambda args + (leave (G_ "~a ~a~%") + file + (strerror (system-error-errno args)))))) + + (define (formatted-hash thing) + (fmt (file-hash thing))) (match args - ((file) - (catch 'system-error - (lambda () - (format #t "~a~%" (fmt (file-hash file)))) - (lambda args - (leave (G_ "~a~%") - (strerror (system-error-errno args)))))) - (x - (leave (G_ "wrong number of arguments~%")))))) + (() + (leave (G_ "no arguments specified~%"))) + (_ + (for-each + (compose (cute format #t "~a~%" <>) formatted-hash) + args))))) diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index 75df6d707d..2312e4d313 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -1,6 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Pierre Langlois <pierre.langlois@gmx.com> +;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,7 +24,7 @@ #:use-module ((gnu services) #:hide (delete)) #:use-module (gnu packages) #:use-module (gnu home) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (guix channels) #:use-module (guix derivations) #:use-module (guix ui) @@ -38,6 +40,7 @@ #:autoload (guix scripts pull) (channel-commit-hyperlink) #:use-module (guix scripts home import) #:use-module ((guix status) #:select (with-status-verbosity)) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (guix gexp) #:use-module (guix monads) #:use-module (srfi srfi-1) @@ -86,6 +89,9 @@ Some ACTIONS support additional ARGS.\n")) (show-build-options-help) (display (G_ " + -e, --expression=EXPR consider the home-environment EXPR evaluates to + instead of reading FILE, when applicable")) + (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (display (G_ " @@ -99,7 +105,7 @@ Some ACTIONS support additional ARGS.\n")) "Return the verbosity level based on OPTS, the alist of parsed options." (or (assoc-ref opts 'verbosity) (if (eq? (assoc-ref opts 'action) 'build) - 2 1))) + 3 1))) (define %options ;; Specification of the command-line options. @@ -107,6 +113,9 @@ Some ACTIONS support additional ARGS.\n")) (lambda args (show-help) (exit 0))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix show"))) @@ -115,6 +124,9 @@ Some ACTIONS support additional ARGS.\n")) (let ((level (string->number* arg))) (alist-cons 'verbosity level (alist-delete 'verbosity result))))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) %standard-build-options)) (define %default-options @@ -125,7 +137,7 @@ Some ACTIONS support additional ARGS.\n")) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 3) + (verbosity . #f) ;default (debug . 0))) @@ -179,6 +191,7 @@ ACTION must be one of the sub-commands that takes a home environment declaration as an argument (a file name.) OPTS is the raw alist of options 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 ~%") file-or-exp)) @@ -248,19 +261,32 @@ argument list and OPTS is the option alist." (apply search args)) ((import) (let* ((profiles (delete-duplicates - (match (filter-map (match-lambda - (('profile . p) p) - (_ #f)) - opts) - (() (list %current-profile)) - (lst (reverse lst))))) - (manifest (concatenate-manifests - (map profile-manifest profiles)))) - (import-manifest manifest (current-output-port)))) + (match (filter-map (match-lambda + (('profile . p) p) + (_ #f)) + opts) + (() (list %current-profile)) + (lst (reverse lst))))) + (manifest (concatenate-manifests + (map profile-manifest profiles))) + (destination (match args + ((destination) destination) + (_ (leave (G_ "wrong number of arguments~%")))))) + (unless (file-exists? destination) + (mkdir-p destination)) + (call-with-output-file + (string-append destination "/home-configuration.scm") + (cut import-manifest manifest destination <>)) + (info (G_ "'~a' populated with all the Home configuration files~%") + destination) + (display-hint (format #f (G_ "\ +Run @command{guix home reconfigure ~a/home-configuration.scm} to effectively +deploy the home environment described by these files.\n") + destination)))) ((describe) (match (generation-number %guix-home) (0 - (error (G_ "no home environment generation, nothing to describe~%"))) + (leave (G_ "no home environment generation, nothing to describe~%"))) (generation (display-home-environment-generation generation)))) ((list-generations) diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm index 79fb23a2fd..15bd3140ed 100644 --- a/guix/scripts/home/import.scm +++ b/guix/scripts/home/import.scm @@ -1,6 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022 Arjan Adriaanse <arjan@adriaan.se> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,12 +24,19 @@ #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix packages) + #:autoload (guix scripts package) (manifest-entry-version-prefix) #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 popen) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) - #:export (import-manifest)) + #:export (import-manifest + + ;; For tests. + manifest+configuration-files->code)) ;;; Commentary: ;;; @@ -36,202 +45,136 @@ ;;; ;;; Code: +(define (basename+remove-dots file-name) + "Remove the dot from the dotfile FILE-NAME; replace the other dots in +FILE-NAME with \"-\", and return the basename of it." + (string-map (match-lambda + (#\. #\-) + (c c)) + (let ((base (basename file-name))) + (if (string-prefix? "." base) + (string-drop base 1) + base)))) -(define (generate-bash-module+configuration) - (let ((rc (string-append (getenv "HOME") "/.bashrc")) - (profile (string-append (getenv "HOME") "/.bash_profile")) - (logout (string-append (getenv "HOME") "/.bash_logout"))) - `((gnu home-services bash) - (service home-bash-service-type - (home-bash-configuration - ,@(if (file-exists? rc) - `((bashrc - (list (slurp-file-gexp (local-file ,rc))))) - '()) - ,@(if (file-exists? profile) - `((bash-profile - (list (slurp-file-gexp - (local-file ,profile))))) - '()) - ,@(if (file-exists? logout) - `((bash-logout - (list (slurp-file-gexp - (local-file ,logout))))) - '())))))) - - -(define %files-configurations-alist - `((".bashrc" . ,generate-bash-module+configuration) - (".bash_profile" . ,generate-bash-module+configuration) - (".bash_logout" . ,generate-bash-module+configuration))) - -(define (modules+configurations) - (let ((configurations (delete-duplicates - (filter-map (match-lambda - ((file . proc) - (if (file-exists? - (string-append (getenv "HOME") "/" file)) - proc - #f))) - %files-configurations-alist) - (lambda (x y) - (equal? (procedure-name x) (procedure-name y)))))) - (map (lambda (proc) (proc)) configurations))) - -;; Based on `manifest->code' from (guix profiles) -;; MAYBE: Upstream it? -(define* (manifest->code manifest - #:key - (entry-package-version (const "")) - (home-environment? #f)) - "Return an sexp representing code to build an approximate version of -MANIFEST; the code is wrapped in a top-level 'begin' form. If -HOME-ENVIRONMENT? is #t, return an <home-environment> definition. -Call ENTRY-PACKAGE-VERSION to determine the version number to use in -the spec for a given entry; it can be set to 'manifest-entry-version' -for fully-specified version numbers, or to some other procedure to -disambiguate versions for packages for which several versions are -available." - (define (entry-transformations entry) - ;; Return the transformations that apply to ENTRY. - (assoc-ref (manifest-entry-properties entry) 'transformations)) +(define (generate-bash-configuration+modules destination-directory) + (define (destination-append path) + (string-append destination-directory "/" path)) - (define transformation-procedures - ;; List of transformation options/procedure name pairs. - (let loop ((entries (manifest-entries manifest)) - (counter 1) - (result '())) - (match entries - (() result) - ((entry . tail) - (match (entry-transformations entry) - (#f - (loop tail counter result)) - (options - (if (assoc-ref result options) - (loop tail counter result) - (loop tail (+ 1 counter) - (alist-cons options - (string->symbol - (format #f "transform~a" counter)) - result))))))))) + (define (bash-alias->pair line) + (if (string-prefix? "alias" line) + (let ((matched (string-match "alias (.+)=\"?'?([^\"']+)\"?'?" line))) + `(,(match:substring matched 1) . ,(match:substring matched 2))) + '())) + + (define (parse-aliases input) + (let loop ((line (read-line input)) + (result '())) + (if (eof-object? line) + (reverse result) + (loop (read-line input) + (cons (bash-alias->pair line) result))))) - (define (qualified-name entry) - ;; Return the name of ENTRY possibly with "@" followed by a version. - (match (entry-package-version entry) - ("" (manifest-entry-name entry)) - (version (string-append (manifest-entry-name entry) - "@" version)))) + (let ((rc (destination-append ".bashrc")) + (profile (destination-append ".bash_profile")) + (logout (destination-append ".bash_logout"))) + `((service home-bash-service-type + (home-bash-configuration + ,@(if (file-exists? rc) + `((aliases + ',(let* ((port (open-pipe* OPEN_READ "bash" "-i" "-c" "alias")) + (alist (parse-aliases port))) + (close-port port) + (filter (negate null?) alist)))) + '()) + ,@(if (file-exists? rc) + `((bashrc + (list (local-file ,rc + ,(basename+remove-dots rc))))) + '()) + ,@(if (file-exists? profile) + `((bash-profile + (list (local-file ,profile + ,(basename+remove-dots profile))))) + '()) + ,@(if (file-exists? logout) + `((bash-logout + (list (local-file ,logout + ,(basename+remove-dots logout))))) + '()))) + (guix gexp) + (gnu home services shells)))) - (if (null? transformation-procedures) - (let ((specs (map (lambda (entry) - (match (manifest-entry-output entry) - ("out" (qualified-name entry)) - (output (string-append (qualified-name entry) - ":" output)))) - (manifest-entries manifest)))) - (if home-environment? - (let ((modules+configurations (modules+configurations))) - `(begin - (use-modules (gnu home) - (gnu packages) - ,@(map first modules+configurations)) - ,(home-environment-template - #:specs specs - #:services (map second modules+configurations)))) - `(begin - (use-modules (gnu packages)) +(define %files+configurations-alist + `((".bashrc" . ,generate-bash-configuration+modules) + (".bash_profile" . ,generate-bash-configuration+modules) + (".bash_logout" . ,generate-bash-configuration+modules))) - (specifications->manifest - (list ,@specs))))) - (let* ((transform (lambda (options exp) - (if (not options) - exp - (let ((proc (assoc-ref transformation-procedures - options))) - `(,proc ,exp))))) - (packages (map (lambda (entry) - (define options - (entry-transformations entry)) +(define (configurations+modules configuration-directory) + "Return a list of procedures which when called, generate code for a home +service declaration. Copy configuration files to CONFIGURATION-DIRECTORY; the +generated service declarations will refer to those files that have been saved +in CONFIGURATION-DIRECTORY." + (define configurations + (delete-duplicates + (filter-map (match-lambda + ((file . proc) + (let ((absolute-path (string-append (getenv "HOME") + "/" file))) + (and (file-exists? absolute-path) + (begin + (copy-file absolute-path + (string-append + configuration-directory "/" file)) + proc))))) + %files+configurations-alist) + eq?)) - (define name - (qualified-name entry)) + (map (lambda (proc) (proc configuration-directory)) configurations)) - (match (manifest-entry-output entry) - ("out" - (transform options - `(specification->package ,name))) - (output - `(list ,(transform - options - `(specification->package ,name)) - ,output)))) - (manifest-entries manifest))) - (transformations (map (match-lambda - ((options . name) - `(define ,name - (options->transformation ',options)))) - transformation-procedures))) - (if home-environment? - (let ((modules+configurations (modules+configurations))) - `(begin - (use-modules (guix transformations) - (gnu home) - (gnu packages) - ,@(map first modules+configurations)) - - ,@transformations - - ,(home-environment-template - #:packages packages - #:services (map second modules+configurations)))) - `(begin - (use-modules (guix transformations) - (gnu packages)) +(define (manifest+configuration-files->code manifest + configuration-directory) + "Read MANIFEST and the user's configuration files listed in +%FILES+CONFIGURATIONS-ALIST, and return a 'home-environment' sexp. Copy the +user's files to CONFIGURATION-DIRECTORY; the generated sexp refers to them." + (match (manifest->code manifest + #:entry-package-version + manifest-entry-version-prefix) + (('begin ('use-modules profile-modules ...) + definitions ... ('packages->manifest packages)) + (match (configurations+modules configuration-directory) + (((services . modules) ...) + `(begin + (use-modules (gnu home) + (gnu packages) + (gnu services) + ,@(delete-duplicates + (append profile-modules (concatenate modules)))) - ,@transformations + ,@definitions - (packages->manifest - (list ,@packages))))))) + (home-environment + (packages ,packages) + (services (list ,@services))))))) + (('begin ('specifications->manifest packages)) + (match (configurations+modules configuration-directory) + (((services . modules) ...) + `(begin + (use-modules (gnu home) + (gnu packages) + (gnu services) + ,@(delete-duplicates (concatenate modules))) -(define* (home-environment-template #:key (packages #f) (specs #f) services) - "Return an S-exp containing a <home-environment> declaration -containing PACKAGES, or SPECS (package specifications), and SERVICES." - `(home-environment - (packages - ,@(if packages - `((list ,@packages)) - `((map specification->package - (list ,@specs))))) - (services (list ,@services)))) + (home-environment + (packages (map (compose list specification->package+output) + ,packages)) + (services (list ,@services))))))))) (define* (import-manifest - manifest + manifest destination-directory #:optional (port (current-output-port))) "Write to PORT a <home-environment> corresponding to MANIFEST." - (define (version-spec entry) - (let ((name (manifest-entry-name entry))) - (match (map package-version (find-packages-by-name name)) - ((_) - ;; A single version of NAME is available, so do not specify the - ;; version number, even if the available version doesn't match ENTRY. - "") - (versions - ;; If ENTRY uses the latest version, don't specify any version. - ;; Otherwise return the shortest unique version prefix. Note that - ;; this is based on the currently available packages, which could - ;; differ from the packages available in the revision that was used - ;; to build MANIFEST. - (let ((current (manifest-entry-version entry))) - (if (every (cut version>? current <>) - (delete current versions)) - "" - (version-unique-prefix (manifest-entry-version entry) - versions))))))) - - (match (manifest->code manifest - #:entry-package-version version-spec - #:home-environment? #t) + (match (manifest+configuration-files->code manifest + destination-directory) (('begin exp ...) (format port (G_ "\ ;; This \"home-environment\" file can be passed to 'guix home reconfigure' diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 3e4b038cc4..2934d4300a 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -27,8 +27,8 @@ #:use-module (guix import utils) #:use-module (guix scripts import) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-cran)) @@ -98,21 +98,24 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (reverse opts)))) (parameterize ((%input-style (assoc-ref opts 'style))) (match args - ((package-name) - (if (assoc-ref opts 'recursive) - ;; Recursive import - (with-error-handling - (map package->definition - (filter identity - (cran-recursive-import package-name - #:repo (or (assoc-ref opts 'repo) 'cran))))) - ;; Single import - (let ((sexp (cran->guix-package package-name - #:repo (or (assoc-ref opts 'repo) 'cran)))) - (unless sexp - (leave (G_ "failed to download description for package '~a'~%") - package-name)) - sexp))) + ((spec) + (let ((name version (package-name->name+version spec))) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (with-error-handling + (map package->definition + (filter identity + (cran-recursive-import name + #:version version + #:repo (or (assoc-ref opts 'repo) 'cran))))) + ;; Single import + (let ((sexp (cran->guix-package name + #:version version + #:repo (or (assoc-ref opts 'repo) 'cran)))) + (unless sexp + (leave (G_ "failed to download description for package '~a'~%") + name)) + sexp)))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/egg.scm b/guix/scripts/import/egg.scm index 829cdc2ca0..6a9657d12c 100644 --- a/guix/scripts/import/egg.scm +++ b/guix/scripts/import/egg.scm @@ -26,6 +26,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-egg)) @@ -83,21 +84,24 @@ Import and convert the egg package for PACKAGE-NAME.\n")) (_ #f)) (reverse opts)))) (match args - ((package-name) - (if (assoc-ref opts 'recursive) - ;; Recursive import - (map (match-lambda - ((and ('package ('name name) . rest) pkg) - `(define-public ,(string->symbol name) - ,pkg)) - (_ #f)) - (egg-recursive-import package-name)) - ;; Single import - (let ((sexp (egg->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp))) + ((spec) + (let ((name version (package-name->name+version spec))) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (egg-recursive-import name version)) + ;; Single import + (let ((sexp (egg->guix-package name version))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + (if version + (string-append name "@" version) + name))) + sexp)))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/go.scm b/guix/scripts/import/go.scm index f5cfea8683..f1970d3543 100644 --- a/guix/scripts/import/go.scm +++ b/guix/scripts/import/go.scm @@ -87,37 +87,38 @@ that are not yet in Guix")) (parse-command-line args %options (list %default-options) #:build-options? #f)) - (let* ((opts (parse-options)) - (args (filter-map (match-lambda - (('argument . value) - value) - (_ #f)) - (reverse opts))) - ;; Append the full version to the package symbol name when using - ;; pinned versions. - (package->definition* (if (assoc-ref opts 'pin-versions?) - (cut package->definition <> 'full) - package->definition))) - (match args - ((spec) ;e.g., github.com/golang/protobuf@v1.3.1 - (receive (name version) - (package-name->name+version spec) - (let ((arguments (list name - #:goproxy (assoc-ref opts 'goproxy) - #:version version - #:pin-versions? - (assoc-ref opts 'pin-versions?)))) - (if (assoc-ref opts 'recursive) - ;; Recursive import. - (map package->definition* - (apply go-module-recursive-import arguments)) - ;; Single import. - (let ((sexp (apply go-module->guix-package* arguments))) - (unless sexp - (leave (G_ "failed to download meta-data for module '~a'.~%") - name)) - (package->definition* sexp)))))) - (() - (leave (G_ "too few arguments~%"))) - ((many ...) - (leave (G_ "too many arguments~%")))))) + (with-error-handling + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts))) + ;; Append the full version to the package symbol name when using + ;; pinned versions. + (package->definition* (if (assoc-ref opts 'pin-versions?) + (cut package->definition <> 'full) + package->definition))) + (match args + ((spec) ;e.g., github.com/golang/protobuf@v1.3.1 + (receive (name version) + (package-name->name+version spec) + (let ((arguments (list name + #:goproxy (assoc-ref opts 'goproxy) + #:version version + #:pin-versions? + (assoc-ref opts 'pin-versions?)))) + (if (assoc-ref opts 'recursive) + ;; Recursive import. + (map package->definition* + (apply go-module-recursive-import arguments)) + ;; Single import. + (let ((sexp (apply go-module->guix-package* arguments))) + (unless sexp + (leave (G_ "failed to download meta-data for module '~a'.~%") + name)) + (package->definition* sexp)))))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%"))))))) diff --git a/guix/scripts/import/pypi.scm b/guix/scripts/import/pypi.scm index 9170a0b359..a52cd95c93 100644 --- a/guix/scripts/import/pypi.scm +++ b/guix/scripts/import/pypi.scm @@ -27,6 +27,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-pypi)) @@ -83,21 +84,22 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) (_ #f)) (reverse opts)))) (match args - ((package-name) - (if (assoc-ref opts 'recursive) - ;; Recursive import - (map (match-lambda - ((and ('package ('name name) . rest) pkg) - `(define-public ,(string->symbol name) - ,pkg)) - (_ #f)) - (pypi-recursive-import package-name)) - ;; Single import - (let ((sexp (pypi->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp))) + ((spec) + (let ((name version (package-name->name+version spec))) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (pypi-recursive-import name version)) + ;; Single import + (let ((sexp (pypi->guix-package name #:version version))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + name)) + sexp)))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/texlive.scm b/guix/scripts/import/texlive.scm index 6f0818e274..c5dcc07ea1 100644 --- a/guix/scripts/import/texlive.scm +++ b/guix/scripts/import/texlive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2021, 2022 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. @@ -43,8 +43,6 @@ (display (G_ "Usage: guix import texlive PACKAGE-NAME Import and convert the Texlive package for PACKAGE-NAME.\n")) (display (G_ " - -a, --archive=ARCHIVE specify the archive repository")) - (display (G_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) @@ -60,10 +58,6 @@ Import and convert the Texlive package for PACKAGE-NAME.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import texlive"))) - (option '(#\a "archive") #t #f - (lambda (opt name arg result) - (alist-cons 'component arg - (alist-delete 'component result)))) %standard-import-options)) @@ -84,13 +78,11 @@ Import and convert the Texlive package for PACKAGE-NAME.\n")) (_ #f)) (reverse opts)))) (match args - ((package-name) - (let ((sexp (texlive->guix-package package-name - (or (assoc-ref opts 'component) - "latex")))) + ((name) + (let ((sexp (texlive->guix-package name))) (unless sexp - (leave (G_ "failed to download description for package '~a'~%") - package-name)) + (leave (G_ "failed to import package '~a'~%") + name)) sexp)) (() (leave (G_ "too few arguments~%"))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 835078cb97..925325ef5f 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> @@ -20,21 +20,26 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts offload) - #:use-module (ssh key) - #:use-module (ssh auth) - #:use-module (ssh session) - #:use-module (ssh channel) - #:use-module (ssh popen) - #:use-module (ssh version) + #:autoload (ssh key) (private-key-from-file + public-key-from-file) + #:autoload (ssh auth) (userauth-public-key!) + #:autoload (ssh session) (make-session + connect! get-error + disconnect! session-set!) + #:autoload (ssh version) (zlib-support?) #:use-module (guix config) #:use-module (guix records) - #:use-module (guix ssh) + #:autoload (guix ssh) (authenticate-server* + connect-to-remote-daemon + send-files retrieve-files retrieve-files* + remote-inferior report-guile-error) #:use-module (guix store) - #:use-module (guix inferior) - #:use-module (guix derivations) - #:use-module ((guix serialization) - #:select (nar-error? nar-error-file)) - #:use-module (guix nar) + #:autoload (guix inferior) (inferior-eval close-inferior inferior?) + #:autoload (guix derivations) (read-derivation-from-file + derivation-file-name + build-derivations) + #:autoload (guix serialization) (nar-error? nar-error-file) + #:autoload (guix nar) (restore-file-set) #:use-module ((guix utils) #:select (%current-system)) #:use-module ((guix build syscalls) #:select (fcntl-flock set-thread-name)) @@ -47,12 +52,10 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 format) - #:use-module (ice-9 binary-ports) #:export (build-machine build-machine? build-machine-name @@ -228,6 +231,9 @@ number of seconds after which the connection times out." ;; stateless instead. #:knownhosts "/dev/null" + ;; Likewise for ~/.ssh/config. + #:config "/dev/null" + ;; We need lightweight compression when ;; exchanging full archives. #:compression @@ -560,6 +566,15 @@ expired." If TIMEOUT is #f, simply evaluate EXP..." (call-with-timeout timeout drv (lambda () exp ...))) +(define (check-ssh-zlib-support) + "Warn once if libssh lacks zlib support." + ;; We rely on protocol-level compression from libssh to optimize large data + ;; transfers. Warn if it's missing. + (unless (zlib-support?) + (warning (G_ "Guile-SSH lacks zlib support")) + (warning (G_ "data transfers will *not* be compressed!"))) + (set! check-ssh-zlib-support (const #t))) + (define* (process-request wants-local? system drv features #:key print-build-trace? (max-silent-time 3600) @@ -584,7 +599,9 @@ If TIMEOUT is #f, simply evaluate EXP..." (lambda () ;; Offload DRV to MACHINE. (display "# accept\n") - (let ((inputs (string-tokenize (read-line))) + (check-ssh-zlib-support) + (let ((drv (read-derivation-from-file drv)) + (inputs (string-tokenize (read-line))) (outputs (string-tokenize (read-line)))) ;; Even if BUILD-TIMEOUT is honored by MACHINE, there can ;; be issues with the connection or deadlocks that could @@ -782,12 +799,6 @@ machine." (and=> (passwd:dir (getpw (getuid))) (cut setenv "HOME" <>)) - ;; We rely on protocol-level compression from libssh to optimize large data - ;; transfers. Warn if it's missing. - (unless (zlib-support?) - (warning (G_ "Guile-SSH lacks zlib support")) - (warning (G_ "data transfers will *not* be compressed!"))) - (match args ((system max-silent-time print-build-trace? build-timeout) (let ((max-silent-time (string->number max-silent-time)) @@ -803,8 +814,7 @@ machine." (with-error-handling (process-request (equal? (match:substring match 1) "1") (match:substring match 2) ; system - (read-derivation-from-file - (match:substring match 3)) + (match:substring match 3) (string-tokenize (match:substring match 4) not-coma) #:print-build-trace? print-build-trace? diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 9e1f270dfb..38bc021665 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; @@ -27,6 +28,7 @@ #:use-module (guix scripts) #:use-module (guix ui) #:use-module (guix gexp) + #:use-module ((guix build utils) #:select (%xz-parallel-args)) #:use-module (guix utils) #:use-module (guix store) #:use-module ((guix status) #:select (with-status-verbosity)) @@ -79,29 +81,34 @@ compressor? (name compressor-name) ;string (e.g., "gzip") (extension compressor-extension) ;string (e.g., ".lz") - (command compressor-command)) ;gexp (e.g., #~("/gnu/store/…/gzip" "-9n")) + (command compressor-command)) ;gexp (e.g., #~(list "/gnu/store/…/gzip" + ; "-9n" )) (define %compressors ;; Available compression tools. (list (compressor "gzip" ".gz" - #~(#+(file-append gzip "/bin/gzip") "-9n")) + #~(list #+(file-append gzip "/bin/gzip") "-9n")) (compressor "lzip" ".lz" - #~(#+(file-append lzip "/bin/lzip") "-9")) + #~(list #+(file-append lzip "/bin/lzip") "-9")) (compressor "xz" ".xz" - #~(#+(file-append xz "/bin/xz") "-e")) + #~(append (list #+(file-append xz "/bin/xz") + "-e") + (%xz-parallel-args))) (compressor "bzip2" ".bz2" - #~(#+(file-append bzip2 "/bin/bzip2") "-9")) + #~(list #+(file-append bzip2 "/bin/bzip2") "-9")) (compressor "zstd" ".zst" ;; The default level 3 compresses better than gzip in a ;; fraction of the time, while the highest level 19 ;; (de)compresses more slowly and worse than xz. - #~(#+(file-append zstd "/bin/zstd") "-3")) + #~(list #+(file-append zstd "/bin/zstd") "-3")) (compressor "none" "" #f))) ;; This one is only for use in this module, so don't put it in %compressors. (define bootstrap-xz (compressor "bootstrap-xz" ".xz" - #~(#+(file-append %bootstrap-coreutils&co "/bin/xz") "-e"))) + #~(append (list #+(file-append %bootstrap-coreutils&co "/bin/xz") + "-e") + (%xz-parallel-args)))) (define (lookup-compressor name) "Return the compressor object called NAME. Error out if it could not be @@ -298,7 +305,7 @@ its source property." (apply invoke tar "-cvf" #$output "." (tar-base-options #:tar tar - #:compressor '#+(and=> compressor compressor-command))))))) + #:compressor #+(and=> compressor compressor-command))))))) (define* (self-contained-tarball name profile #:key target @@ -574,11 +581,13 @@ the image." ,@(source-module-closure `((guix docker) (guix build store-copy) + (guix build utils) ;for %xz-parallel-args (guix profiles) (guix search-paths)) #:select? not-config?)) #~(begin (use-modules (guix docker) (guix build store-copy) + (guix build utils) (guix profiles) (guix search-paths) (srfi srfi-1) (srfi srfi-19) (ice-9 match)) @@ -625,7 +634,7 @@ the image." #~(list (string-append #$profile "/" #$entry-point))) #:extra-files directives - #:compressor '#+(compressor-command compressor) + #:compressor #+(compressor-command compressor) #:creation-time (make-time time-utc 0 1)))))) (gexp->derivation (string-append name ".tar" @@ -804,7 +813,7 @@ Section: misc (apply invoke tar `(,@(tar-base-options #:tar tar - #:compressor '#+(and=> compressor compressor-command)) + #:compressor #+(and=> compressor compressor-command)) "-cvf" ,control-tarball-file-name "control" ,@(if postinst-file '("postinst") '()) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index a34ecdcb54..9699c70c6d 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> @@ -68,6 +68,7 @@ guix-package search-path-environment-variables + manifest-entry-version-prefix transaction-upgrade-entry ;mostly for testing @@ -138,6 +139,7 @@ denote ranges as interpreted by 'matching-generations'." (define* (build-and-use-profile store profile manifest #:key + dry-run? (hooks %default-profile-hooks) allow-collisions? bootstrap?) @@ -153,6 +155,7 @@ hooks\" run when building the profile." (prof (derivation->output-path prof-drv))) (cond + (dry-run? #t) ((and (file-exists? profile) (and=> (readlink* profile) (cut string=? prof <>))) (format (current-error-port) (G_ "nothing to be done~%"))) @@ -327,31 +330,35 @@ Alternately, see @command{guix package --search-paths -p ~s}.") ;;; Export a manifest. ;;; +(define (manifest-entry-version-prefix entry) + "Search among all the versions of ENTRY's package that are available, and +return the shortest unambiguous version prefix for this package. If only one +version of ENTRY's package is available, return the empty string." + (let ((name (manifest-entry-name entry))) + (match (map package-version (find-packages-by-name name)) + ((_) + ;; A single version of NAME is available, so do not specify the + ;; version number, even if the available version doesn't match ENTRY. + "") + (versions + ;; If ENTRY uses the latest version, don't specify any version. + ;; Otherwise return the shortest unique version prefix. Note that + ;; this is based on the currently available packages, which could + ;; differ from the packages available in the revision that was used + ;; to build MANIFEST. + (let ((current (manifest-entry-version entry))) + (if (every (cut version>? current <>) + (delete current versions)) + "" + (version-unique-prefix (manifest-entry-version entry) + versions))))))) + (define* (export-manifest manifest #:optional (port (current-output-port))) "Write to PORT a manifest corresponding to MANIFEST." - (define (version-spec entry) - (let ((name (manifest-entry-name entry))) - (match (map package-version (find-packages-by-name name)) - ((_) - ;; A single version of NAME is available, so do not specify the - ;; version number, even if the available version doesn't match ENTRY. - "") - (versions - ;; If ENTRY uses the latest version, don't specify any version. - ;; Otherwise return the shortest unique version prefix. Note that - ;; this is based on the currently available packages, which could - ;; differ from the packages available in the revision that was used - ;; to build MANIFEST. - (let ((current (manifest-entry-version entry))) - (if (every (cut version>? current <>) - (delete current versions)) - "" - (version-unique-prefix (manifest-entry-version entry) - versions))))))) - (match (manifest->code manifest - #:entry-package-version version-spec) + #:entry-package-version + manifest-entry-version-prefix) (('begin exp ...) (format port (G_ "\ ;; This \"manifest\" file can be passed to 'guix package -m' to reproduce @@ -1064,6 +1071,7 @@ processed, #f otherwise." trans #:dry-run? dry-run?) (build-and-use-profile store profile new + #:dry-run? dry-run? #:allow-collisions? allow-collisions? #:bootstrap? bootstrap?))))) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 25846b7dc2..6e2b4368da 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -25,6 +25,7 @@ #:use-module ((system repl server) #:prefix repl:) #:use-module (ice-9 binary-ports) #:use-module (ice-9 format) + #:use-module (ice-9 iconv) #:use-module (ice-9 match) #:use-module (ice-9 poll) #:use-module (ice-9 regex) @@ -400,15 +401,18 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs." (let ((store-path (hash-part->path store hash))) (if (string-null? store-path) (not-found request #:phrase "" #:ttl negative-ttl) - (values `((content-type . (application/x-nix-narinfo)) + (values `((content-type . (application/x-nix-narinfo + (charset . "UTF-8"))) + (x-nar-path . ,nar-path) + (x-narinfo-compressions . ,compressions) ,@(if ttl `((cache-control (max-age . ,ttl))) '())) - (cut display - (narinfo-string store store-path - #:nar-path nar-path - #:compressions compressions) - <>))))) + ;; Do not call narinfo-string directly here as it is an + ;; expensive call that could potentially block the main + ;; thread. Instead, create the narinfo string in the + ;; http-write procedure. + store-path)))) (define* (nar-cache-file directory item #:key (compression %no-compression)) @@ -663,19 +667,38 @@ requested using POOL." (link narinfo other))) others)))))) +(define (compression->sexp compression) + "Return the SEXP representation of COMPRESSION." + (match compression + (($ <compression> type level) + `(compression ,type ,level)))) + +(define (sexp->compression sexp) + "Turn the given SEXP into a <compression> record and return it." + (match sexp + (('compression type level) + (compression type level)))) + ;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for ;; internal consumption: it allows us to pass the compression info to ;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>. (declare-header! "X-Nar-Compression" (lambda (str) - (match (call-with-input-string str read) - (('compression type level) - (compression type level)))) + (sexp->compression + (call-with-input-string str read))) compression? (lambda (compression port) - (match compression - (($ <compression> type level) - (write `(compression ,type ,level) port))))) + (write (compression->sexp compression) port))) + +;; This header is used to pass the supported compressions to http-write in +;; order to format on-the-fly narinfo responses. +(declare-header! "X-Narinfo-Compressions" + (lambda (str) + (map sexp->compression + (call-with-input-string str read))) + (cut every compression? <>) + (lambda (compressions port) + (write (map compression->sexp compressions) port))) (define* (render-nar store request store-item #:key (compression %no-compression)) @@ -830,7 +853,8 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." "Return RESPONSE's headers minus 'Content-Length' and our internal headers." (fold alist-delete (response-headers response) - '(content-length x-raw-file x-nar-compression))) + '(content-length x-raw-file x-nar-compression + x-narinfo-compressions x-nar-path))) (define (sans-content-length response) "Return RESPONSE without its 'content-length' header." @@ -964,6 +988,38 @@ blocking." (unless keep-alive? (close-port client))) (values)))))) + (('application/x-nix-narinfo . _) + (let ((compressions (assoc-ref (response-headers response) + 'x-narinfo-compressions)) + (nar-path (assoc-ref (response-headers response) + 'x-nar-path))) + (if nar-path + (begin + (when (keep-alive? response) + (keep-alive client)) + (call-with-new-thread + (lambda () + (set-thread-name "publish narinfo") + (let* ((narinfo + (with-store store + (narinfo-string store (utf8->string body) + #:nar-path nar-path + #:compressions compressions))) + (narinfo-bv (string->bytevector narinfo "UTF-8")) + (narinfo-length + (bytevector-length narinfo-bv)) + (response (write-response + (with-content-length response + narinfo-length) + client)) + (output (response-port response))) + (configure-socket client) + (put-bytevector output narinfo-bv) + (force-output output) + (unless (keep-alive? response) + (close-port output)) + (values))))) + (%http-write server client response body)))) (_ (match (assoc-ref (response-headers response) 'x-raw-file) ((? string? file) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index fb6c52a567..68bb9040d8 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> @@ -8,6 +8,7 @@ ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,7 +27,6 @@ (define-module (guix scripts refresh) #:use-module (guix ui) - #:use-module (gcrypt hash) #:use-module (guix scripts) #:use-module ((guix scripts build) #:select (%standard-build-options)) #:use-module (guix store) @@ -38,6 +38,7 @@ #:use-module (guix scripts graph) #:use-module (guix monads) #:use-module (guix gnupg) + #:use-module (guix hash) #:use-module (gnu packages) #:use-module ((gnu packages commencement) #:select (%final-inputs)) #:use-module (ice-9 match) @@ -314,14 +315,14 @@ KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'interactive' (default), 'always', and 'never'. When WARN? is true, warn about packages that have no matching updater." (if (lookup-updater package updaters) - (let-values (((version tarball source) + (let-values (((version output source) (package-update store package updaters #:key-download key-download)) ((loc) (or (package-field-location package 'version) (package-location package)))) (when version - (if (and=> tarball file-exists?) + (if (and=> output file-exists?) (begin (info loc (G_ "~a: updating from version ~a to version ~a...~%") @@ -329,26 +330,41 @@ warn about packages that have no matching updater." (package-version package) version) (for-each (lambda (change) - (format (current-error-port) - (match (list (upstream-input-change-action change) - (upstream-input-change-type change)) - (('add 'regular) - (G_ "~a: consider adding this input: ~a~%")) - (('add 'native) - (G_ "~a: consider adding this native input: ~a~%")) - (('add 'propagated) - (G_ "~a: consider adding this propagated input: ~a~%")) - (('remove 'regular) - (G_ "~a: consider removing this input: ~a~%")) - (('remove 'native) - (G_ "~a: consider removing this native input: ~a~%")) - (('remove 'propagated) - (G_ "~a: consider removing this propagated input: ~a~%"))) - (package-name package) - (upstream-input-change-name change))) + (define field + (match (upstream-input-change-type change) + ('native 'native-inputs) + ('propagated 'propagated-inputs) + (_ 'inputs))) + + (define name + (package-name package)) + (define loc + (package-field-location package field)) + (define change-name + (upstream-input-change-name change)) + + (match (list (upstream-input-change-action change) + (upstream-input-change-type change)) + (('add 'regular) + (info loc (G_ "~a: consider adding this input: ~a~%") + name change-name)) + (('add 'native) + (info loc (G_ "~a: consider adding this native input: ~a~%") + name change-name)) + (('add 'propagated) + (info loc (G_ "~a: consider adding this propagated input: ~a~%") + name change-name)) + (('remove 'regular) + (info loc (G_ "~a: consider removing this input: ~a~%") + name change-name)) + (('remove 'native) + (info loc (G_ "~a: consider removing this native input: ~a~%") + name change-name)) + (('remove 'propagated) + (info loc (G_ "~a: consider removing this propagated input: ~a~%") + name change-name)))) (upstream-source-input-changes source)) - (let ((hash (call-with-input-file tarball - port-sha256))) + (let ((hash (file-hash* output))) (update-package-source package source hash))) (warning (G_ "~a: version ~a could not be \ downloaded and authenticated; not updating~%") diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm new file mode 100644 index 0000000000..a92932cbc9 --- /dev/null +++ b/guix/scripts/shell.scm @@ -0,0 +1,444 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts shell) + #: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 transformations) (transformation-option-key? + show-transformation-options-help) + #:use-module (guix scripts) + #:use-module (guix packages) + #:use-module (guix profiles) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) + #:use-module (ice-9 match) + #:autoload (ice-9 rdelim) (read-line) + #:autoload (guix base32) (bytevector->base32-string) + #:autoload (rnrs bytevectors) (string->utf8) + #:autoload (guix utils) (config-directory cache-directory) + #:autoload (guix describe) (current-channels) + #:autoload (guix channels) (channel-commit) + #:autoload (gcrypt hash) (sha256) + #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module (guix cache) + #:use-module ((ice-9 ftw) #:select (scandir)) + #:autoload (gnu packages) (cache-is-authoritative?) + #:export (guix-shell)) + +(define (show-help) + (display (G_ "Usage: guix shell [OPTION] PACKAGES... [-- COMMAND...] +Build an environment that includes PACKAGES and execute COMMAND or an +interactive shell in that environment.\n")) + (newline) + + ;; These two options differ from 'guix environment'. + (display (G_ " + -D, --development include the development inputs of the next package")) + (display (G_ " + -f, --file=FILE add to the environment the package FILE evaluates to")) + (display (G_ " + -q inhibit loading of 'guix.scm' and 'manifest.scm'")) + (display (G_ " + --rebuild-cache rebuild cached environment, if any")) + + (show-environment-options-help) + (newline) + (show-build-options-help) + (newline) + (show-transformation-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define (tag-package-arg opts arg) + "Return a two-element list with the form (TAG ARG) that tags ARG with either +'ad-hoc' in OPTS has the 'ad-hoc?' key set to #t, or 'inputs' otherwise." + (if (assoc-ref opts 'ad-hoc?) + `(ad-hoc-package ,arg) + `(package ,arg))) + +(define (ensure-ad-hoc alist) + (if (assq-ref alist 'ad-hoc?) + alist + `((ad-hoc? . #t) ,@alist))) + +(define (wrapped-option opt) + "Wrap OPT, a SRFI-37 option, such that its processor always adds the +'ad-hoc?' flag to the resulting alist." + (option (option-names opt) + (option-required-arg? opt) + (option-optional-arg? opt) + (compose ensure-ad-hoc (option-processor opt)))) + +(define %options + ;; Specification of the command-line options. + (let ((to-remove '("ad-hoc" "inherit" "load" "help" "version"))) + (append + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix shell"))) + + (option '(#\D "development") #f #f + (lambda (opt name arg result) + ;; Temporarily remove the 'ad-hoc?' flag from result. + ;; The next option will put it back thanks to + ;; 'wrapped-option'. + (alist-delete 'ad-hoc? result))) + + ;; For consistency with 'guix package', support '-f' rather than + ;; '-l' like 'guix environment' does. + (option '(#\f "file") #t #f + (lambda (opt name arg result) + (alist-cons 'load (tag-package-arg result arg) + (ensure-ad-hoc result)))) + (option '(#\q) #f #f + (lambda (opt name arg result) + (alist-cons 'explicit-loading? #t result))) + (option '("rebuild-cache") #f #f + (lambda (opt name arg result) + (alist-cons 'rebuild-cache? #t result)))) + (filter-map (lambda (opt) + (and (not (any (lambda (name) + (member name to-remove)) + (option-names opt))) + (wrapped-option opt))) + %environment-options)))) + +(define %default-options + `((ad-hoc? . #t) ;always true + ,@%environment-default-options)) + +(define (parse-args args) + "Parse the list of command line arguments ARGS." + (define (handle-argument arg result) + (alist-cons 'package (tag-package-arg result arg) + (ensure-ad-hoc result))) + + ;; 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))) + (options-with-caching + (auto-detect-manifest + (match command + (() opts) + (("--") opts) + (("--" command ...) (alist-cons 'exec command opts)))))))) + +(define (find-file-in-parent-directories candidates) + "Find one of CANDIDATES in the current directory or one of its ancestors." + (define start (getcwd)) + (define device (stat:dev (stat start))) + + (let loop ((directory start)) + (let ((stat (stat directory))) + (and (= (stat:uid stat) (getuid)) + (= (stat:dev stat) device) + (or (any (lambda (candidate) + (let ((candidate (string-append directory "/" candidate))) + (and (file-exists? candidate) candidate))) + candidates) + (and (not (string=? directory "/")) + (loop (dirname directory)))))))) ;lexical ".." resolution + +(define (authorized-directory-file) + "Return the name of the file listing directories for which 'guix shell' may +automatically load 'guix.scm' or 'manifest.scm' files." + (string-append (config-directory) "/shell-authorized-directories")) + +(define (authorized-shell-directory? directory) + "Return true if DIRECTORY is among the authorized directories for automatic +loading. The list of authorized directories is read from +'authorized-directory-file'; each line must be either: an absolute file name, +a hash-prefixed comment, or a blank line." + (catch 'system-error + (lambda () + (call-with-input-file (authorized-directory-file) + (lambda (port) + (let loop () + (match (read-line port) + ((? eof-object?) #f) + ((= string-trim line) + (cond ((string-prefix? "#" line) ;comment + (loop)) + ((string-prefix? "/" line) ;absolute file name + (or (string=? line directory) + (loop))) + ((string-null? (string-trim-right line)) ;blank line + (loop)) + (else ;bogus line + (let ((loc (location (port-filename port) + (port-line port) + (port-column port)))) + (warning loc (G_ "ignoring invalid file name: '~a'~%") + line)))))))))) + (const #f))) + +(define (options-with-caching opts) + "If OPTS contains only options that allow us to compute a cache key, +automatically add a 'profile' key (when a profile for that file is already in +cache) or a 'gc-root' key (to add the profile to cache)." + ;; Attempt to compute a file name for use as the cached profile GC root. + (let* ((root timestamp (profile-cached-gc-root opts)) + (stat (and root (false-if-exception (lstat root))))) + (if (and (not (assoc-ref opts 'rebuild-cache?)) + stat + (<= timestamp (stat:mtime stat))) + (let ((now (current-time))) + ;; Update the atime on ROOT to reflect usage. + (utime root + now (stat:mtime stat) 0 (stat:mtimensec stat) + AT_SYMLINK_NOFOLLOW) + (alist-cons 'profile root + (remove (match-lambda + (('load . _) #t) + (('manifest . _) #t) + (('package . _) #t) + (('ad-hoc-package . _) #t) + (_ #f)) + opts))) ;load right away + (if (and root (not (assq-ref opts 'gc-root))) + (begin + (if stat + (delete-file root) + (mkdir-p (dirname root))) + (alist-cons 'gc-root root opts)) + opts)))) + +(define (auto-detect-manifest opts) + "If OPTS do not specify packages or a manifest, load a \"guix.scm\" or +\"manifest.scm\" file from the current directory or one of its ancestors. +Return the modified OPTS." + (define (options-contain-payload? opts) + (match opts + (() #f) + ((('package . _) . _) #t) + ((('load . _) . _) #t) + ((('manifest . _) . _) #t) + ((('expression . _) . _) #t) + ((_ . rest) (options-contain-payload? rest)))) + + (define interactive? + (not (assoc-ref opts 'exec))) + + (define disallow-implicit-load? + (assoc-ref opts 'explicit-loading?)) + + (if (or (not interactive?) + disallow-implicit-load? + (options-contain-payload? opts)) + opts + (match (find-file-in-parent-directories '("manifest.scm" "guix.scm")) + (#f + (warning (G_ "no packages specified; creating an empty environment~%")) + opts) + (file + (if (authorized-shell-directory? (dirname file)) + (begin + (info (G_ "loading environment from '~a'...~%") file) + (match (basename file) + ("guix.scm" (alist-cons 'load `(package ,file) opts)) + ("manifest.scm" (alist-cons 'manifest file opts)))) + (begin + (report-error + (G_ "not loading '~a' because not authorized to do so~%") + file) + (display-hint (format #f (G_ "To allow automatic loading of +@file{~a} when running @command{guix shell}, you must explicitly authorize its +directory, like so: + +@example +echo ~a >> ~a +@end example\n") + file + (dirname file) + (authorized-directory-file))) + (exit 1))))))) + + +;;; +;;; Profile cache. +;;; + +(define %profile-cache-directory + ;; Directory where profiles created by 'guix shell' alone (without extra + ;; options) are cached. + (make-parameter (string-append (cache-directory #:ensure? #f) + "/profiles"))) + +(define (profile-cache-primary-key) + "Return the \"primary key\" used when computing keys for the profile cache. +Return #f if no such key can be obtained and caching cannot be +performed--e.g., because the package cache is not authoritative." + (and (cache-is-authoritative?) + (match (current-channels) + (() + #f) + (((= channel-commit commits) ...) + (string-join commits))))) + +(define (profile-file-cache-key file system) + "Return the cache key for the profile corresponding to FILE, a 'guix.scm' or +'manifest.scm' file, or #f if we lack channel information." + (match (profile-cache-primary-key) + (#f #f) + (primary-key + (let ((stat (stat file))) + (bytevector->base32-string + ;; Since FILE is not canonicalized, only include the device/inode + ;; numbers. XXX: In some rare cases involving Btrfs and NFS, this can + ;; be insufficient: <https://lwn.net/Articles/866582/>. + (sha256 (string->utf8 + (string-append primary-key ":" system ":" + (number->string (stat:dev stat)) ":" + (number->string (stat:ino stat)))))))))) + +(define (profile-spec-cache-key specs system) + "Return the cache key corresponding to SPECS built for SYSTEM, where SPECS +is a list of package specs. Return #f if caching is not possible." + (match (profile-cache-primary-key) + (#f #f) + (primary-key + (bytevector->base32-string + (sha256 (string->utf8 + (string-append primary-key ":" system ":" + (object->string specs)))))))) + +(define (profile-cached-gc-root opts) + "Return two values: the file name of a GC root for use as a profile cache +for the options in OPTS, and a timestamp which, if greater than the GC root's +mtime, indicates that the GC root is stale. If OPTS do not permit caching, +return #f and #f." + (define (key->file key) + (string-append (%profile-cache-directory) "/" key)) + + (let loop ((opts opts) + (system (%current-system)) + (file #f) + (specs '())) + (match opts + (() + (if file + (values (and=> (profile-file-cache-key file system) key->file) + (stat:mtime (stat file))) + (values (and=> (profile-spec-cache-key specs system) key->file) + 0))) + (((and spec ('package . _)) . rest) + (if (not file) + (loop rest system file (cons spec specs)) + (values #f #f))) + ((('load . ('package candidate)) . rest) + (if (and (not file) (null? specs)) + (loop rest system candidate specs) + (values #f #f))) + ((('manifest . candidate) . rest) + (if (and (not file) (null? specs)) + (loop rest system candidate specs) + (values #f #f))) + ((('expression . _) . _) + ;; Arbitrary expressions might be non-deterministic or otherwise depend + ;; on external state so do not cache when they're used. + (values #f #f)) + ((((? transformation-option-key?) . _) . _) + ;; Transformation options are potentially "non-deterministic", or at + ;; least depending on external state (with-source, with-commit, etc.), + ;; so do not cache anything when they're used. + (values #f #f)) + ((('system . system) . rest) + (loop rest system file specs)) + ((_ . rest) (loop rest system file specs))))) + + +;;; +;;; One-time hints. +;;; + +(define (hint-directory) + "Return the directory name where previously given hints are recorded." + (string-append (cache-directory #:ensure? #f) "/hints")) + +(define (hint-file hint) + "Return the name of the file that marks HINT as already printed." + (string-append (hint-directory) "/" (symbol->string hint))) + +(define (record-hint hint) + "Mark HINT as already given." + (let ((file (hint-file hint))) + (mkdir-p (dirname file)) + (close-fdes (open-fdes file (logior O_CREAT O_WRONLY))))) + +(define (hint-given? hint) + "Return true if HINT was already given." + (file-exists? (hint-file hint))) + + +(define-command (guix-shell . args) + (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 +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))) + + (guix-environment* opts)) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm new file mode 100644 index 0000000000..fb31c694f2 --- /dev/null +++ b/guix/scripts/style.scm @@ -0,0 +1,854 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; This script updates package definitions so they use the "simplified" style +;;; for input lists, as in: +;;; +;;; (package +;;; ;; ... +;;; (inputs (list foo bar baz))) +;;; +;;; Code: + +(define-module (guix scripts style) + #:autoload (gnu packages) (specification->package fold-packages) + #:use-module (guix scripts) + #:use-module ((guix scripts build) #:select (%standard-build-options)) + #:use-module (guix combinators) + #:use-module (guix ui) + #:use-module (guix packages) + #:use-module (guix utils) + #:use-module (guix i18n) + #:use-module (guix diagnostics) + #:use-module (ice-9 control) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (pretty-print-with-comments + read-with-comments + canonicalize-comment + + guix-style)) + + +;;; +;;; Comment-preserving reader. +;;; + +;; A comment. +(define-record-type <comment> + (comment str margin?) + comment? + (str comment->string) + (margin? comment-margin?)) + +(define (read-with-comments port) + "Like 'read', but include <comment> objects when they're encountered." + ;; Note: Instead of implementing this functionality in 'read' proper, which + ;; is the best approach long-term, this code is a later on top of 'read', + ;; such that we don't have to rely on a specific Guile version. + (let loop ((blank-line? #t) + (return (const 'unbalanced))) + (match (read-char port) + ((? eof-object? eof) + eof) ;oops! + (chr + (cond ((eqv? chr #\newline) + (loop #t return)) + ((char-set-contains? char-set:whitespace chr) + (loop blank-line? return)) + ((memv chr '(#\( #\[)) + (let/ec return + (let liip ((lst '())) + (liip (cons (loop (match lst + (((? comment?) . _) #t) + (_ #f)) + (lambda () + (return (reverse lst)))) + lst))))) + ((memv chr '(#\) #\])) + (return)) + ((eq? chr #\') + (list 'quote (loop #f return))) + ((eq? chr #\`) + (list 'quasiquote (loop #f return))) + ((eq? chr #\,) + (list (match (peek-char port) + (#\@ + (read-char port) + 'unquote-splicing) + (_ + 'unquote)) + (loop #f return))) + ((eqv? chr #\;) + (unread-char chr port) + (comment (read-line port 'concat) + (not blank-line?))) + (else + (unread-char chr port) + (read port))))))) + + +;;; +;;; Comment-preserving pretty-printer. +;;; + +(define-syntax vhashq + (syntax-rules (quote) + ((_) vlist-null) + ((_ (key (quote (lst ...))) rest ...) + (vhash-consq key '(lst ...) (vhashq rest ...))) + ((_ (key value) rest ...) + (vhash-consq key '((() . value)) (vhashq rest ...))))) + +(define %special-forms + ;; Forms that are indented specially. The number is meant to be understood + ;; like Emacs' 'scheme-indent-function' symbol property. When given an + ;; alist instead of a number, the alist gives "context" in which the symbol + ;; is a special form; for instance, context (modify-phases) means that the + ;; symbol must appear within a (modify-phases ...) expression. + (vhashq + ('begin 1) + ('lambda 2) + ('lambda* 2) + ('match-lambda 1) + ('match-lambda* 2) + ('define 2) + ('define* 2) + ('define-public 2) + ('define*-public 2) + ('define-syntax 2) + ('define-syntax-rule 2) + ('define-module 2) + ('define-gexp-compiler 2) + ('let 2) + ('let* 2) + ('letrec 2) + ('letrec* 2) + ('match 2) + ('when 2) + ('unless 2) + ('package 1) + ('origin 1) + ('operating-system 1) + ('modify-inputs 2) + ('modify-phases 2) + ('add-after '(((modify-phases) . 3))) + ('add-before '(((modify-phases) . 3))) + ('replace '(((modify-phases) . 2))) ;different from 'modify-inputs' + ('substitute* 2) + ('substitute-keyword-arguments 2) + ('call-with-input-file 2) + ('call-with-output-file 2) + ('with-output-to-file 2) + ('with-input-from-file 2))) + +(define %newline-forms + ;; List heads that must be followed by a newline. The second argument is + ;; the context in which they must appear. This is similar to a special form + ;; of 1, except that indent is 1 instead of 2 columns. + (vhashq + ('arguments '(package)) + ('sha256 '(origin source package)) + ('base32 '(sha256 origin)) + ('git-reference '(uri origin source)) + ('search-paths '(package)) + ('native-search-paths '(package)) + ('search-path-specification '()))) + +(define (prefix? candidate lst) + "Return true if CANDIDATE is a prefix of LST." + (let loop ((candidate candidate) + (lst lst)) + (match candidate + (() #t) + ((head1 . rest1) + (match lst + (() #f) + ((head2 . rest2) + (and (equal? head1 head2) + (loop rest1 rest2)))))))) + +(define (special-form-lead symbol context) + "If SYMBOL is a special form in the given CONTEXT, return its number of +arguments; otherwise return #f. CONTEXT is a stack of symbols lexically +surrounding SYMBOL." + (match (vhash-assq symbol %special-forms) + (#f #f) + ((_ . alist) + (any (match-lambda + ((prefix . level) + (and (prefix? prefix context) (- level 1)))) + alist)))) + +(define (newline-form? symbol context) + "Return true if parenthesized expressions starting with SYMBOL must be +followed by a newline." + (match (vhash-assq symbol %newline-forms) + (#f #f) + ((_ . prefix) + (prefix? prefix context)))) + +(define (escaped-string str) + "Return STR with backslashes and double quotes escaped. Everything else, in +particular newlines, is left as is." + (list->string + `(#\" + ,@(string-fold-right (lambda (chr lst) + (match chr + (#\" (cons* #\\ #\" lst)) + (#\\ (cons* #\\ #\\ lst)) + (_ (cons chr lst)))) + '() + str) + #\"))) + +(define (string-width str) + "Return the \"width\" of STR--i.e., the width of the longest line of STR." + (apply max (map string-length (string-split str #\newline)))) + +(define (canonicalize-comment c) + "Canonicalize comment C, ensuring it has the \"right\" number of leading +semicolons." + (let ((line (string-trim-both + (string-trim (comment->string c) (char-set #\;))))) + (comment (string-append + (if (comment-margin? c) + ";" + (if (string-null? line) + ";;" ;no trailing space + ";; ")) + line "\n") + (comment-margin? c)))) + +(define* (pretty-print-with-comments port obj + #:key + (format-comment identity) + (indent 0) + (max-width 78) + (long-list 5)) + "Pretty-print OBJ to PORT, attempting to at most MAX-WIDTH character columns +and assuming the current column is INDENT. Comments present in OBJ are +included in the output. + +Lists longer than LONG-LIST are written as one element per line. Comments are +passed through FORMAT-COMMENT before being emitted; a useful value for +FORMAT-COMMENT is 'canonicalize-comment'." + (let loop ((indent indent) + (column indent) + (delimited? #t) ;true if comes after a delimiter + (context '()) ;list of "parent" symbols + (obj obj)) + (define (print-sequence context indent column lst delimited?) + (define long? + (> (length lst) long-list)) + + (let print ((lst lst) + (first? #t) + (delimited? delimited?) + (column column)) + (match lst + (() + column) + ((item . tail) + (define newline? + ;; Insert a newline if ITEM is itself a list, or if TAIL is long, + ;; but only if ITEM is not the first item. Also insert a newline + ;; before a keyword. + (and (or (pair? item) long? + (and (keyword? item) + (not (eq? item #:allow-other-keys)))) + (not first?) (not delimited?) + (not (comment? item)))) + + (when newline? + (newline port) + (display (make-string indent #\space) port)) + (let ((column (if newline? indent column))) + (print tail #f + (comment? item) + (loop indent column + (or newline? delimited?) + context + item))))))) + + (define (sequence-would-protrude? indent lst) + ;; Return true if elements of LST written at INDENT would protrude + ;; beyond MAX-WIDTH. This is implemented as a cheap test with false + ;; negatives to avoid actually rendering all of LST. + (find (match-lambda + ((? string? str) + (>= (+ (string-width str) 2 indent) max-width)) + ((? symbol? symbol) + (>= (+ (string-width (symbol->string symbol)) indent) + max-width)) + ((? boolean?) + (>= (+ 2 indent) max-width)) + (() + (>= (+ 2 indent) max-width)) + (_ ;don't know + #f)) + lst)) + + (define (special-form? head) + (special-form-lead head context)) + + (match obj + ((? comment? comment) + (if (comment-margin? comment) + (begin + (display " " port) + (display (comment->string (format-comment comment)) + port)) + (begin + ;; When already at the beginning of a line, for example because + ;; COMMENT follows a margin comment, no need to emit a newline. + (unless (= column indent) + (newline port) + (display (make-string indent #\space) port)) + (display (comment->string (format-comment comment)) + port))) + (display (make-string indent #\space) port) + indent) + (('quote lst) + (unless delimited? (display " " port)) + (display "'" port) + (loop indent (+ column (if delimited? 1 2)) #t context lst)) + (('quasiquote lst) + (unless delimited? (display " " port)) + (display "`" port) + (loop indent (+ column (if delimited? 1 2)) #t context lst)) + (('unquote lst) + (unless delimited? (display " " port)) + (display "," port) + (loop indent (+ column (if delimited? 1 2)) #t context lst)) + (('unquote-splicing lst) + (unless delimited? (display " " port)) + (display ",@" port) + (loop indent (+ column (if delimited? 2 3)) #t context lst)) + (('gexp lst) + (unless delimited? (display " " port)) + (display "#~" port) + (loop indent (+ column (if delimited? 2 3)) #t context lst)) + (('ungexp obj) + (unless delimited? (display " " port)) + (display "#$" port) + (loop indent (+ column (if delimited? 2 3)) #t context obj)) + (('ungexp-native obj) + (unless delimited? (display " " port)) + (display "#+" port) + (loop indent (+ column (if delimited? 2 3)) #t context obj)) + (('ungexp-splicing lst) + (unless delimited? (display " " port)) + (display "#$@" port) + (loop indent (+ column (if delimited? 3 4)) #t context lst)) + (('ungexp-native-splicing lst) + (unless delimited? (display " " port)) + (display "#+@" port) + (loop indent (+ column (if delimited? 3 4)) #t context lst)) + (((? special-form? head) arguments ...) + ;; Special-case 'let', 'lambda', 'modify-inputs', etc. so the second + ;; and following arguments are less indented. + (let* ((lead (special-form-lead head context)) + (context (cons head context)) + (head (symbol->string head)) + (total (length arguments))) + (unless delimited? (display " " port)) + (display "(" port) + (display head port) + (unless (zero? lead) + (display " " port)) + + ;; Print the first LEAD arguments. + (let* ((indent (+ column 2 + (if delimited? 0 1))) + (column (+ column 1 + (if (zero? lead) 0 1) + (if delimited? 0 1) + (string-length head))) + (initial-indent column)) + (define new-column + (let inner ((n lead) + (arguments (take arguments (min lead total))) + (column column)) + (if (zero? n) + (begin + (newline port) + (display (make-string indent #\space) port) + indent) + (match arguments + (() column) + ((head . tail) + (inner (- n 1) tail + (loop initial-indent column + (= n lead) + context + head))))))) + + ;; Print the remaining arguments. + (let ((column (print-sequence + context indent new-column + (drop arguments (min lead total)) + #t))) + (display ")" port) + (+ column 1))))) + ((head tail ...) + (let* ((overflow? (>= column max-width)) + (column (if overflow? + (+ indent 1) + (+ column (if delimited? 1 2)))) + (newline? (newline-form? head context)) + (context (cons head context))) + (if overflow? + (begin + (newline port) + (display (make-string indent #\space) port)) + (unless delimited? (display " " port))) + (display "(" port) + + (let* ((new-column (loop column column #t context head)) + (indent (if (or (>= new-column max-width) + (not (symbol? head)) + (sequence-would-protrude? + (+ new-column 1) tail) + newline?) + column + (+ new-column 1)))) + (when newline? + ;; Insert a newline right after HEAD. + (newline port) + (display (make-string indent #\space) port)) + + (let ((column + (print-sequence context indent + (if newline? indent new-column) + tail newline?))) + (display ")" port) + (+ column 1))))) + (_ + (let* ((str (if (string? obj) + (escaped-string obj) + (object->string obj))) + (len (string-width str))) + (if (and (> (+ column 1 len) max-width) + (not delimited?)) + (begin + (newline port) + (display (make-string indent #\space) port) + (display str port) + (+ indent len)) + (begin + (unless delimited? (display " " port)) + (display str port) + (+ column (if delimited? 0 1) len)))))))) + +(define (object->string* obj indent . args) + (call-with-output-string + (lambda (port) + (apply pretty-print-with-comments port obj + #:indent indent + args)))) + + +;;; +;;; Simplifying input expressions. +;;; + +(define (label-matches? label name) + "Return true if LABEL matches NAME, a package name." + (or (string=? label name) + (and (string-prefix? "python-" label) + (string-prefix? "python2-" name) + (string=? (string-drop label (string-length "python-")) + (string-drop name (string-length "python2-")))))) + +(define* (simplify-inputs location package str inputs + #:key (label-matches? label-matches?)) + "Simplify the inputs field of PACKAGE (a string) at LOCATION; its current +value is INPUTS the corresponding source code is STR. Return a string to +replace STR." + (define (simplify-input-expression return) + (match-lambda + ((label ('unquote symbol)) symbol) + ((label ('unquote symbol) output) + (list 'quasiquote + (list (list 'unquote symbol) output))) + (_ + ;; Expression doesn't look like a simple input. + (warning location (G_ "~a: complex expression, \ +bailing out~%") + package) + (return str)))) + + (define (simplify-input exp input return) + (define package* package) + + (match input + ((or ((? string? label) (? package? package)) + ((? string? label) (? package? package) + (? string?))) + ;; If LABEL doesn't match PACKAGE's name, then simplifying would incur + ;; a rebuild, and perhaps it would break build-side code relying on + ;; this specific label. + (if (label-matches? label (package-name package)) + ((simplify-input-expression return) exp) + (begin + (warning location (G_ "~a: input label \ +'~a' does not match package name, bailing out~%") + package* label) + (return str)))) + (_ + (warning location (G_ "~a: non-trivial input, \ +bailing out~%") + package*) + (return str)))) + + (define (simplify-expressions exp inputs return) + ;; Simplify the expressions in EXP, which correspond to INPUTS, and return + ;; a list of expressions. Call RETURN with a string when bailing out. + (let loop ((result '()) + (exp exp) + (inputs inputs)) + (match exp + (((? comment? head) . rest) + (loop (cons head result) rest inputs)) + ((head . rest) + (match inputs + ((input . inputs) + ;; HEAD (an sexp) and INPUT (an input tuple) are correlated. + (loop (cons (simplify-input head input return) result) + rest inputs)) + (() + ;; If EXP and INPUTS have a different length, that + ;; means EXP is a non-trivial input list, for example + ;; with input-splicing, conditionals, etc. + (warning location (G_ "~a: input expression is too short~%") + package) + (return str)))) + (() + ;; It's possible for EXP to contain fewer elements than INPUTS, for + ;; example in the case of input splicing. No bailout here. (XXX) + (reverse result))))) + + (define inputs-exp + (call-with-input-string str read-with-comments)) + + (match inputs-exp + (('list _ ...) ;already done + str) + (('modify-inputs _ ...) ;already done + str) + (('quasiquote ;prepending inputs + (exp ... + ('unquote-splicing + ((and symbol (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg)))) + (let/ec return + (object->string* + (let ((things (simplify-expressions exp inputs return))) + `(modify-inputs (,symbol ,arg) + (prepend ,@things))) + (location-column location)))) + (('quasiquote ;replacing an input + ((and exp ((? string? to-delete) ('unquote replacement))) + ('unquote-splicing + ('alist-delete (? string? to-delete) + ((and symbol + (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg))))) + (let/ec return + (object->string* + (let ((things (simplify-expressions (list exp) + (list (car inputs)) + return))) + `(modify-inputs (,symbol ,arg) + (replace ,to-delete ,replacement))) + (location-column location)))) + + (('quasiquote ;removing an input + (exp ... + ('unquote-splicing + ('alist-delete (? string? to-delete) + ((and symbol + (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg))))) + (let/ec return + (object->string* + (let ((things (simplify-expressions exp inputs return))) + `(modify-inputs (,symbol ,arg) + (delete ,to-delete) + (prepend ,@things))) + (location-column location)))) + (('fold 'alist-delete ;removing several inputs + ((and symbol + (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg) + ('quote ((? string? to-delete) ...))) + (object->string* + `(modify-inputs (,symbol ,arg) + (delete ,@to-delete)) + (location-column location))) + (('quasiquote ;removing several inputs and adding others + (exp ... + ('unquote-splicing + ('fold 'alist-delete + ((and symbol + (or 'package-inputs 'package-native-inputs + 'package-propagated-inputs)) + arg) + ('quote ((? string? to-delete) ...)))))) + (let/ec return + (object->string* + (let ((things (simplify-expressions exp inputs return))) + `(modify-inputs (,symbol ,arg) + (delete ,@to-delete) + (prepend ,@things))) + (location-column location)))) + (('quasiquote (exp ...)) + (let/ec return + (object->string* + `(list ,@(simplify-expressions exp inputs return)) + (location-column location)))) + (_ + (warning location (G_ "~a: unsupported input style, \ +bailing out~%") + package) + str))) + +(define (edit-expression/dry-run properties rewrite-string) + "Like 'edit-expression' but display what would be edited without actually +doing it." + (edit-expression properties + (lambda (str) + (unless (string=? (rewrite-string str) str) + (info (source-properties->location properties) + (G_ "would be edited~%"))) + str))) + +(define (absolute-location loc) + "Replace the file name in LOC by an absolute location." + (location (if (string-prefix? "/" (location-file loc)) + (location-file loc) + (search-path %load-path (location-file loc))) + (location-line loc) + (location-column loc))) + +(define* (simplify-package-inputs package + #:key (policy 'silent) + (edit-expression edit-expression)) + "Edit the source code of PACKAGE to simplify its inputs field if needed. +POLICY is a symbol that defines whether to simplify inputs; it can one of +'silent (change only if the resulting derivation is the same), 'safe (change +only if semantics are known to be unaffected), and 'always (fearlessly +simplify inputs!). Call EDIT-EXPRESSION to actually edit the source of +PACKAGE." + (for-each (lambda (field-name field) + (match (field package) + (() + #f) + (inputs + (match (package-field-location package field-name) + (#f + ;; If the location of FIELD-NAME is not found, it may be + ;; that PACKAGE inherits from another package. + #f) + (location + (edit-expression + (location->source-properties (absolute-location location)) + (lambda (str) + (define matches? + (match policy + ('silent + ;; Simplify inputs only when the label matches + ;; perfectly, such that the resulting derivation + ;; is unchanged. + label-matches?) + ('safe + ;; If PACKAGE has no arguments, labels are known + ;; to have no effect: this is a "safe" change, but + ;; it may change the derivation. + (if (null? (package-arguments package)) + (const #t) + label-matches?)) + ('always + ;; Assume it's gonna be alright. + (const #t)))) + + (simplify-inputs location + (package-name package) + str inputs + #:label-matches? matches?)))))))) + '(inputs native-inputs propagated-inputs) + (list package-inputs package-native-inputs + package-propagated-inputs))) + + +;;; +;;; Formatting package definitions. +;;; + +(define* (format-package-definition package + #:key policy + (edit-expression edit-expression)) + "Reformat the definition of PACKAGE." + (unless (package-definition-location package) + (leave (package-location package) + (G_ "no definition location for package ~a~%") + (package-full-name package))) + + (edit-expression + (location->source-properties + (absolute-location (package-definition-location package))) + (lambda (str) + (let ((exp (call-with-input-string str + read-with-comments))) + (object->string* exp + (location-column + (package-definition-location package)) + #:format-comment canonicalize-comment))))) + +(define (package-location<? p1 p2) + "Return true if P1's location is \"before\" P2's." + (let ((loc1 (package-location p1)) + (loc2 (package-location p2))) + (and loc1 loc2 + (if (string=? (location-file loc1) (location-file loc2)) + (< (location-line loc1) (location-line loc2)) + (string<? (location-file loc1) (location-file loc2)))))) + + +;;; +;;; Options. +;;; + +(define %options + ;; Specification of the command-line options. + (list (find (lambda (option) + (member "load-path" (option-names option))) + %standard-build-options) + + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) + (option '(#\S "styling") #t #f + (lambda (opt name arg result) + (alist-cons 'styling-procedure + (match arg + ("inputs" simplify-package-inputs) + ("format" format-package-definition) + (_ (leave (G_ "~a: unknown styling~%") + arg))) + result))) + (option '("input-simplification") #t #f + (lambda (opt name arg result) + (let ((symbol (string->symbol arg))) + (unless (memq symbol '(silent safe always)) + (leave (G_ "~a: invalid input simplification policy~%") + arg)) + (alist-cons 'input-simplification-policy symbol + result)))) + + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix style"))))) + +(define (show-help) + (display (G_ "Usage: guix style [OPTION]... [PACKAGE]... +Update package definitions to the latest style.\n")) + (display (G_ " + -S, --styling=RULE apply RULE, a styling rule")) + (newline) + (display (G_ " + -n, --dry-run display files that would be edited but do nothing")) + (display (G_ " + -L, --load-path=DIR prepend DIR to the package module search path")) + (display (G_ " + -e, --expression=EXPR consider the package EXPR evaluates to")) + (display (G_ " + --input-simplification=POLICY + follow POLICY for package input simplification, one + of 'silent', 'safe', or 'always'")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %default-options + ;; Alist of default option values. + `((input-simplification-policy . silent) + (styling-procedure . ,format-package-definition))) + + +;;; +;;; Entry point. +;;; + +(define-command (guix-style . args) + (category packaging) + (synopsis "update the style of package definitions") + + (define (parse-options) + ;; Return the alist of option values. + (parse-command-line args %options (list %default-options) + #:build-options? #f)) + + (let* ((opts (parse-options)) + (packages (filter-map (match-lambda + (('argument . spec) + (specification->package spec)) + (('expression . str) + (read/eval str)) + (_ #f)) + opts)) + (edit (if (assoc-ref opts 'dry-run?) + edit-expression/dry-run + edit-expression)) + (style (assoc-ref opts 'styling-procedure)) + (policy (assoc-ref opts 'input-simplification-policy))) + (with-error-handling + (for-each (lambda (package) + (style package #:policy policy + #:edit-expression edit)) + ;; Sort package by source code location so that we start editing + ;; files from the bottom and going upward. That way, the + ;; 'location' field of <package> records is not invalidated as + ;; we modify files. + (sort (if (null? packages) + (fold-packages cons '() #:select? (const #t)) + packages) + (negate package-location<?)))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index c044e1d47a..908a8334a8 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -237,7 +237,7 @@ was found." ;;; (define (show-help) - (display (G_ "Usage: guix substitute [OPTION]... + (display (G_ "Usage: guix substitute OPTION [ARGUMENT]... Internal tool to substitute a pre-built binary to a local build.\n")) (display (G_ " --query report on the availability of substitutes for the diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 65eb98e4b2..414e931c8a 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -57,6 +57,7 @@ #:use-module (guix build utils) #:use-module (guix progress) #:use-module ((guix build syscalls) #:select (terminal-columns)) + #:use-module (gnu build image) #:use-module (gnu build install) #:autoload (gnu build file-systems) (find-partition-by-label find-partition-by-uuid) @@ -64,6 +65,7 @@ (device-module-aliases matching-modules) #:use-module (gnu system linux-initrd) #:use-module (gnu image) + #:use-module (gnu platform) #:use-module (gnu system) #:use-module (gnu bootloader) #:use-module (gnu system file-systems) @@ -253,7 +255,7 @@ the ownership of '~a' may be incorrect!~%") (install-bootloader local-eval bootloader bootcfg #:target target) (return - (info (G_ "bootloader successfully installed on '~a'~%") + (info (G_ "bootloader successfully installed on~{ ~a~}~%") (bootloader-configuration-targets bootloader)))))))) @@ -688,6 +690,8 @@ checking this by themselves in their 'check' procedure." (define* (system-derivation-for-action image action #:key full-boot? + volatile? + (graphic? #t) container-shared-network? mappings) "Return as a monadic value the derivation for IMAGE according to ACTION." @@ -705,21 +709,18 @@ checking this by themselves in their 'check' procedure." ((vm) (system-qemu-image/shared-store-script os #:full-boot? full-boot? - #:disk-image-size - (if full-boot? - image-size - (* 70 (expt 2 20))) + #:volatile? volatile? + #:graphic? graphic? + #:disk-image-size image-size #:mappings mappings)) - ((image disk-image vm-image) + ((image disk-image vm-image docker-image) (when (eq? action 'disk-image) (warning (G_ "'disk-image' is deprecated: use 'image' instead~%"))) (when (eq? action 'vm-image) (warning (G_ "'vm-image' is deprecated: use 'image' instead~%"))) - (lower-object (system-image image))) - ((docker-image) - (system-docker-image os - #:memory-size 1024 - #:shared-network? container-shared-network?))))) + (when (eq? action 'docker-image) + (warning (G_ "'docker-image' is deprecated: use 'image' instead~%"))) + (lower-object (system-image image)))))) (define (maybe-suggest-running-guix-pull) "Suggest running 'guix pull' if this has never been done before." @@ -771,6 +772,8 @@ and TARGET arguments." dry-run? derivations-only? use-substitutes? target full-boot? + volatile-vm-root? + (graphic? #t) container-shared-network? (mappings '()) (gc-root #f)) @@ -824,6 +827,9 @@ static checks." (mlet* %store-monad ((sys (system-derivation-for-action image action #:full-boot? full-boot? + #:volatile? + volatile-vm-root? + #:graphic? graphic? #:container-shared-network? container-shared-network? #:mappings mappings)) @@ -994,6 +1000,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " --volatile for 'image', make the root file system volatile")) (display (G_ " + --persistent for 'vm', make the root file system persistent")) + (display (G_ " --label=LABEL for 'image', label disk image with LABEL")) (display (G_ " --save-provenance save provenance information")) @@ -1012,6 +1020,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " --full-boot for 'vm', make a full boot sequence")) (display (G_ " + --no-graphic for 'vm', use the tty that we are started in for IO")) + (display (G_ " --skip-checks skip file system and initrd module safety checks")) (display (G_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) @@ -1073,13 +1083,19 @@ Some ACTIONS support additional ARGS.\n")) (alist-cons 'install-bootloader? #f result))) (option '("volatile") #f #f (lambda (opt name arg result) - (alist-cons 'volatile-root? #t result))) + (alist-cons 'volatile-image-root? #t result))) + (option '("persistent") #f #f + (lambda (opt name arg result) + (alist-cons 'volatile-vm-root? #f result))) (option '("label") #t #f (lambda (opt name arg result) (alist-cons 'label arg result))) (option '("full-boot") #f #f (lambda (opt name arg result) (alist-cons 'full-boot? #t result))) + (option '("no-graphic") #f #f + (lambda (opt name arg result) + (alist-cons 'no-graphic? #t result))) (option '("save-provenance") #f #f (lambda (opt name arg result) (alist-cons 'save-provenance? #t result))) @@ -1139,7 +1155,8 @@ Some ACTIONS support additional ARGS.\n")) (image-size . guess) (install-bootloader? . #t) (label . #f) - (volatile-root? . #f) + (volatile-image-root? . #f) + (volatile-vm-root? . #t) (graph-backend . "graphviz"))) (define (verbosity-level opts) @@ -1204,23 +1221,26 @@ resulting from command-line parsing." (label (assoc-ref opts 'label)) (image-type (lookup-image-type-by-name (assoc-ref opts 'image-type))) - (image (let* ((image-type (if (eq? action 'vm-image) - qcow2-image-type - image-type)) + (image (let* ((image-type (case action + ((vm-image) qcow2-image-type) + ((docker-image) docker-image-type) + (else image-type))) (image-size (assoc-ref opts 'image-size)) - (volatile? (assoc-ref opts 'volatile-root?)) + (volatile? + (assoc-ref opts 'volatile-image-root?)) + (shared-network? + (assoc-ref opts 'container-shared-network?)) (base-image (if (operating-system? obj) (os->image obj #:type image-type) - obj)) - (base-target (image-target base-image))) + obj))) (image (inherit (if label (image-with-label base-image label) base-image)) - (target (or base-target target)) (size image-size) - (volatile-root? volatile?)))) + (volatile-root? volatile?) + (shared-network? shared-network?)))) (os (image-operating-system image)) (target-file (match args ((first second) second) @@ -1267,6 +1287,9 @@ resulting from command-line parsing." #:validate-reconfigure (assoc-ref opts 'validate-reconfigure) #:full-boot? (assoc-ref opts 'full-boot?) + #:volatile-vm-root? + (assoc-ref opts 'volatile-vm-root?) + #:graphic? (not (assoc-ref opts 'no-graphic?)) #:container-shared-network? (assoc-ref opts 'container-shared-network?) #:mappings (filter-map (match-lambda @@ -1307,7 +1330,7 @@ argument list and OPTS is the option alist." ((describe) (match (generation-number %system-profile) (0 - (error (G_ "no system generation, nothing to describe~%"))) + (leave (G_ "no system generation, nothing to describe~%"))) (generation (display-system-generation generation)))) ((search) |