aboutsummaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorEfraim Flashner <efraim@flashner.co.il>2021-10-31 12:47:14 +0200
committerEfraim Flashner <efraim@flashner.co.il>2021-10-31 14:49:47 +0200
commitbc5155b952ae8bdbc56aded4d8d39768b4e2a7d4 (patch)
tree6b55475d86c522543384dea7d1ab66bba32af63e /guix
parentdac8d013bd1fc7f57b8ba3582eef6e0e01b23dfd (diff)
parent4e5000114ec01b5e92a87c52f2a10f9ba7a601c8 (diff)
downloadguix-bc5155b952ae8bdbc56aded4d8d39768b4e2a7d4.tar
guix-bc5155b952ae8bdbc56aded4d8d39768b4e2a7d4.tar.gz
Merge remote-tracking branch 'origin/master' into core-updates-frozen
Diffstat (limited to 'guix')
-rw-r--r--guix/build/syscalls.scm49
-rw-r--r--guix/cache.scm10
-rw-r--r--guix/import/cran.scm23
-rw-r--r--guix/lint.scm19
-rw-r--r--guix/packages.scm101
-rw-r--r--guix/profiles.scm19
-rw-r--r--guix/scripts/environment.scm432
-rw-r--r--guix/scripts/home.scm24
-rw-r--r--guix/scripts/home/import.scm301
-rw-r--r--guix/scripts/package.scm47
-rw-r--r--guix/scripts/shell.scm394
-rw-r--r--guix/store.scm18
-rw-r--r--guix/ui.scm30
13 files changed, 1079 insertions, 388 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 99a3b45004..b305133c37 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -180,6 +180,8 @@
terminal-window-size
terminal-columns
terminal-rows
+ openpty
+ login-tty
utmpx?
utmpx-login-type
@@ -422,15 +424,21 @@ expansion-time error is raised if FIELD does not exist in TYPE."
"Evaluate EXPR and restart upon EINTR. Return the value of EXPR."
(call-with-restart-on-EINTR (lambda () expr)))
-(define (syscall->procedure return-type name argument-types)
+(define* (syscall->procedure return-type name argument-types
+ #:key library)
"Return a procedure that wraps the C function NAME using the dynamic FFI,
-and that returns two values: NAME's return value, and errno.
+and that returns two values: NAME's return value, and errno. When LIBRARY is
+specified, look up NAME in that library rather than in the global symbol name
+space.
If an error occurs while creating the binding, defer the error report until
the returned procedure is called."
(catch #t
(lambda ()
- (let ((ptr (dynamic-func name (dynamic-link))))
+ (let ((ptr (dynamic-func name
+ (if library
+ (dynamic-link library)
+ (dynamic-link)))))
;; The #:return-errno? facility was introduced in Guile 2.0.12.
(pointer->procedure return-type ptr argument-types
#:return-errno? #t)))
@@ -2286,6 +2294,41 @@ PORT, trying to guess a reasonable value if all else fails. The result is
always a positive integer."
(terminal-dimension window-size-rows port (const 25)))
+(define openpty
+ (let ((proc (syscall->procedure int "openpty" '(* * * * *)
+ #:library "libutil")))
+ (lambda ()
+ "Return two file descriptors: one for the pseudo-terminal control side,
+and one for the controlled side."
+ (let ((head (make-bytevector (sizeof int)))
+ (inferior (make-bytevector (sizeof int))))
+ (let-values (((ret err)
+ (proc (bytevector->pointer head)
+ (bytevector->pointer inferior)
+ %null-pointer %null-pointer %null-pointer)))
+ (unless (zero? ret)
+ (throw 'system-error "openpty" "~A"
+ (list (strerror err))
+ (list err))))
+
+ (let ((* (lambda (bv)
+ (bytevector-sint-ref bv 0 (native-endianness)
+ (sizeof int)))))
+ (values (* head) (* inferior)))))))
+
+(define login-tty
+ (let* ((proc (syscall->procedure int "login_tty" (list int)
+ #:library "libutil")))
+ (lambda (fd)
+ "Make FD the controlling terminal of the current process (with the
+TIOCSCTTY ioctl), redirect standard input, standard output and standard error
+output to this terminal, and close FD."
+ (let-values (((ret err) (proc fd)))
+ (unless (zero? ret)
+ (throw 'system-error "login-pty" "~A"
+ (list (strerror err))
+ (list err)))))))
+
;;;
;;; utmpx.
diff --git a/guix/cache.scm b/guix/cache.scm
index 0401a9d428..51009809bd 100644
--- a/guix/cache.scm
+++ b/guix/cache.scm
@@ -101,7 +101,13 @@ CLEANUP-PERIOD denotes the minimum time between two cache cleanups."
#:now now
#:entry-expiration entry-expiration
#:delete-entry delete-entry)
- (call-with-output-file expiry-file
- (cute write (time-second now) <>))))
+ (catch 'system-error
+ (lambda ()
+ (call-with-output-file expiry-file
+ (cute write (time-second now) <>)))
+ (lambda args
+ ;; ENOENT means CACHE does not exist.
+ (unless (= ENOENT (system-error-errno args))
+ (apply throw args))))))
;;; cache.scm ends here
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 510882bc00..9387a82065 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -34,6 +34,8 @@
#:use-module (web uri)
#:use-module (guix memoization)
#:use-module (guix http-client)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
#:use-module (gcrypt hash)
#:use-module (guix store)
#:use-module ((guix serialization) #:select (write-file))
@@ -171,11 +173,11 @@ package definition."
release."
(let ((url (string->uri (bioconductor-packages-list-url type))))
(guard (c ((http-get-error? c)
- (format (current-error-port)
- "error: failed to retrieve list of packages from ~s: ~a (~s)~%"
- (uri->string (http-get-error-uri c))
- (http-get-error-code c)
- (http-get-error-reason c))
+ (warning (G_ "failed to retrieve list of packages \
+from ~a: ~a (~a)~%")
+ (uri->string (http-get-error-uri c))
+ (http-get-error-code c)
+ (http-get-error-reason c))
#f))
;; Split the big list on empty lines, then turn each chunk into an
;; alist of attributes.
@@ -237,12 +239,11 @@ case-sensitive."
((cran)
(let ((url (string-append %cran-url name "/DESCRIPTION")))
(guard (c ((http-get-error? c)
- (format (current-error-port)
- "error: failed to retrieve package information \
-from ~s: ~a (~s)~%"
- (uri->string (http-get-error-uri c))
- (http-get-error-code c)
- (http-get-error-reason c))
+ (warning (G_ "failed to retrieve package information \
+from ~a: ~a (~a)~%")
+ (uri->string (http-get-error-uri c))
+ (http-get-error-code c)
+ (http-get-error-reason c))
#f))
(let* ((port (http-fetch url))
(result (description->alist (read-string port))))
diff --git a/guix/lint.scm b/guix/lint.scm
index 5edb9dea28..8bbbe210d6 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -322,6 +322,21 @@ markup is valid return a plain-text version of DESCRIPTION, otherwise #f."
(G_ "Texinfo markup in description is invalid")
#:field 'description))))
+ (define (check-description-typo description typo-corrections)
+ "Check that DESCRIPTION does not contain typo, with optional correction"
+ (append-map
+ (match-lambda
+ ((typo . correction)
+ (if (string-contains description typo)
+ (list
+ (make-warning package
+ (G_
+ (format #false
+ "description contains typo '~a'~@[, should be '~a'~]"
+ typo correction))))
+ '())))
+ typo-corrections))
+
(define (check-trademarks description)
"Check that DESCRIPTION does not contain '™' or '®' characters. See
http://www.gnu.org/prep/standards/html_node/Trademarks.html."
@@ -402,6 +417,10 @@ by two spaces; possible infraction~p at ~{~a~^, ~}")
(check-not-empty description)
(check-quotes description)
(check-trademarks description)
+ (check-description-typo description '(("This packages" . "This package")
+ ("This modules" . "This module")
+ ("allows to" . #f)
+ ("permits to" . #f)))
;; Use raw description for this because Texinfo rendering
;; automatically fixes end of sentence space.
(check-end-of-sentence-space description)
diff --git a/guix/packages.scm b/guix/packages.scm
index fa23cc39b3..fb7eabdc64 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -52,6 +52,7 @@
#:use-module (srfi srfi-35)
#:use-module (rnrs bytevectors)
#:use-module (web uri)
+ #:autoload (texinfo) (texi-fragment->stexi)
#:re-export (%current-system
%current-target-system
search-path-specification) ;for convenience
@@ -169,6 +170,7 @@
bag-transitive-host-inputs
bag-transitive-build-inputs
bag-transitive-target-inputs
+ package-development-inputs
package-closure
default-guile
@@ -465,6 +467,49 @@ lexical scope of its body."
(lambda (s) #,location)))
body ...))))))
+(define-syntax validate-texinfo
+ (let ((validate? (getenv "GUIX_UNINSTALLED")))
+ (define ensure-thread-safe-texinfo-parser!
+ ;; Work around <https://issues.guix.gnu.org/51264> for Guile <= 3.0.7.
+ (let ((patched? (or (> (string->number (major-version)) 3)
+ (> (string->number (minor-version)) 0)
+ (> (string->number (micro-version)) 7)))
+ (next-token-of/thread-safe
+ (lambda (pred port)
+ (let loop ((chars '()))
+ (match (read-char port)
+ ((? eof-object?)
+ (list->string (reverse! chars)))
+ (chr
+ (let ((chr* (pred chr)))
+ (if chr*
+ (loop (cons chr* chars))
+ (begin
+ (unread-char chr port)
+ (list->string (reverse! chars)))))))))))
+ (lambda ()
+ (unless patched?
+ (set! (@@ (texinfo) next-token-of) next-token-of/thread-safe)
+ (set! patched? #t)))))
+
+ (lambda (s)
+ "Raise a syntax error when passed a literal string that is not valid
+Texinfo. Otherwise, return the string."
+ (syntax-case s ()
+ ((_ str)
+ (string? (syntax->datum #'str))
+ (if validate?
+ (catch 'parser-error
+ (lambda ()
+ (ensure-thread-safe-texinfo-parser!)
+ (texi-fragment->stexi (syntax->datum #'str))
+ #'str)
+ (lambda _
+ (syntax-violation 'package "invalid Texinfo markup" #'str)))
+ #'str))
+ ((_ obj)
+ #'obj)))))
+
;; A package.
(define-record-type* <package>
package make-package
@@ -502,9 +547,11 @@ lexical scope of its body."
(replacement package-replacement ; package | #f
(default #f) (thunked) (innate))
- (synopsis package-synopsis) ; one-line description
- (description package-description) ; one or two paragraphs
- (license package-license)
+ (synopsis package-synopsis
+ (sanitize validate-texinfo)) ; one-line description
+ (description package-description
+ (sanitize validate-texinfo)) ; one or two paragraphs
+ (license package-license) ; <license> instance or list
(home-page package-home-page)
(supported-systems package-supported-systems ; list of strings
(default %supported-systems))
@@ -1176,23 +1223,36 @@ in INPUTS and their transitive propagated inputs."
(define package-transitive-supported-systems
(let ()
- (define supported-systems
- (mlambda (package system)
- (parameterize ((%current-system system))
- (fold (lambda (input systems)
- (match input
- ((label (? package? package) . _)
- (lset-intersection string=? systems
- (supported-systems package system)))
- (_
- systems)))
- (package-supported-systems package)
- (bag-direct-inputs (package->bag package))))))
+ (define (supported-systems-procedure system)
+ (define supported-systems
+ (mlambdaq (package)
+ (parameterize ((%current-system system))
+ (fold (lambda (input systems)
+ (match input
+ ((label (? package? package) . _)
+ (lset-intersection string=? systems
+ (supported-systems package)))
+ (_
+ systems)))
+ (package-supported-systems package)
+ (bag-direct-inputs (package->bag package))))))
+
+ supported-systems)
+
+ (define procs
+ ;; Map system strings to one-argument procedures. This allows these
+ ;; procedures to have fast 'eq?' memoization on their argument.
+ (make-hash-table))
(lambda* (package #:optional (system (%current-system)))
"Return the intersection of the systems supported by PACKAGE and those
supported by its dependencies."
- (supported-systems package system))))
+ (match (hash-ref procs system)
+ (#f
+ (hash-set! procs system (supported-systems-procedure system))
+ (package-transitive-supported-systems package system))
+ (proc
+ (proc package))))))
(define* (supported-package? package #:optional (system (%current-system)))
"Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
@@ -1229,6 +1289,15 @@ dependencies are known to build on SYSTEM."
(%current-system (bag-system bag)))
(transitive-inputs (bag-target-inputs bag))))
+(define* (package-development-inputs package
+ #:optional (system (%current-system))
+ #:key target)
+ "Return the list of inputs required by PACKAGE for development purposes on
+SYSTEM. When TARGET is true, return the inputs needed to cross-compile
+PACKAGE from SYSTEM to TRIPLET, where TRIPLET is a triplet such as
+\"aarch64-linux-gnu\"."
+ (bag-transitive-inputs (package->bag package system target)))
+
(define* (package-closure packages #:key (system (%current-system)))
"Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of
packages they depend on, recursively."
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 9494684228..aad23c0c0e 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -124,6 +124,7 @@
profile-manifest
package->manifest-entry
+ package->development-manifest
packages->manifest
ca-certificate-bundle
%default-profile-hooks
@@ -400,6 +401,24 @@ file name."
(properties properties))))
entry))
+(define* (package->development-manifest package
+ #:optional
+ (system (%current-system))
+ #:key target)
+ "Return a manifest for the \"development inputs\" of PACKAGE for SYSTEM,
+optionally when cross-compiling to TARGET. Development inputs include both
+explicit and implicit inputs of PACKAGE."
+ (manifest
+ (filter-map (match-lambda
+ ((label (? package? package))
+ (package->manifest-entry package))
+ ((label (? package? package) output)
+ (package->manifest-entry package output))
+ ;; TODO: Support <inferior-package>.
+ (_
+ #f))
+ (package-development-inputs package system #:target target))))
+
(define (packages->manifest packages)
"Return a list of manifest entries, one for each item listed in PACKAGES.
Elements of PACKAGES can be either package objects or package/string tuples
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 6958bd6238..cca0ad991b 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -34,23 +34,32 @@
#: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 (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 +75,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 +122,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 +182,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 +303,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 +319,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))
@@ -396,6 +403,155 @@ regexps in WHITE-LIST."
((program . args)
(apply execlp program program args))))
+(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* (launch-environment/fork command profile manifest
#:key pure? (white-list '()))
"Run COMMAND in a new process with an environment containing PROFILE, with
@@ -666,11 +822,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 +850,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 +880,89 @@ 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))
-
- (define manifest
- (if profile
- (profile-manifest profile)
- manifest-from-opts))
-
- (when (and profile
- (> (length (manifest-entries manifest-from-opts)) 0))
- (leave (G_ "'--profile' cannot be used with package options~%")))
-
- (when (null? (manifest-entries manifest))
- (warning (G_ "no packages specified; creating an empty environment~%")))
-
- (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
+ (with-store/maybe store
+ (with-status-verbosity (assoc-ref opts 'verbosity)
+ (define manifest-from-opts
+ (options/resolve-packages store opts))
+
+ (define manifest
+ (if profile
+ (profile-manifest profile)
+ manifest-from-opts))
+
+ (when (and profile
+ (> (length (manifest-entries manifest-from-opts)) 0))
+ (leave (G_ "'--profile' cannot be used with package options~%")))
+
+ (when (null? (manifest-entries manifest))
+ (warning (G_ "no packages specified; creating an empty environment~%")))
+
+ ;; Use the bootstrap Guile when requested.
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%guile-for-build
+ (and store-needed?
+ (package-derivation
+ store
+ (if bootstrap?
+ %bootstrap-guile
+ (default-guile))))))
+ (run-with-store store
+ ;; Containers need a Bourne shell at /bin/sh.
+ (mlet* %store-monad ((bash (environment-bash container?
+ bootstrap?
+ system))
+ (prof-drv (if profile
+ (return #f)
+ (manifest->derivation
+ manifest system bootstrap?)))
+ (profile -> (if profile
(readlink* profile)
(derivation->output-path prof-drv)))
- (gc-root -> (assoc-ref opts 'gc-root)))
-
- ;; First build the inputs. This is necessary even for
- ;; --search-paths. Additionally, we might need to build bash for
- ;; a container.
- (mbegin %store-monad
- (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?))))
-
- (else
- (return
- (exit/status
- (launch-environment/fork command profile manifest
- #:white-list white-list
- #:pure? pure?)))))))))))))))
+ (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
+ (validate-child-shell-environment profile manifest)))
+
+ (cond
+ ((assoc-ref opts 'search-paths)
+ (show-search-paths profile manifest #:pure? pure?)
+ (return #t))
+ (container?
+ (let ((bash-binary
+ (if bootstrap?
+ (derivation->output-path bash)
+ (string-append (derivation->output-path bash)
+ "/bin/sh"))))
+ (launch-environment/container #:command command
+ #:bash bash-binary
+ #:user user
+ #:user-mappings mappings
+ #:profile profile
+ #:manifest manifest
+ #:white-list white-list
+ #:link-profile? link-prof?
+ #:network? network?
+ #:map-cwd? (not no-cwd?))))
+
+ (else
+ (return
+ (exit/status
+ (launch-environment/fork command profile manifest
+ #:white-list white-list
+ #:pure? pure?))))))))))))))
+
+;;; Local Variables:
+;;; eval: (put 'with-store/maybe 'scheme-indent-function 1)
+;;; End:
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index 55e7b436c1..3f48b98ed4 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -40,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)
@@ -260,15 +261,20 @@ 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))
+ (import-manifest manifest destination (current-output-port))))
((describe)
(match (generation-number %guix-home)
(0
diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm
index 611f580e85..7a7712dd96 100644
--- a/guix/scripts/home/import.scm
+++ b/guix/scripts/home/import.scm
@@ -1,6 +1,7 @@
;;; 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>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,12 +23,16 @@
#: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 (srfi srfi-1)
#:use-module (srfi srfi-26)
- #:export (import-manifest))
+ #:export (import-manifest
+
+ ;; For tests.
+ manifest+configuration-files->code))
;;; Commentary:
;;;
@@ -36,200 +41,114 @@
;;;
;;; Code:
-
-(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 (local-file ,rc))))
- '())
- ,@(if (file-exists? profile)
- `((bash-profile
- (list (local-file ,profile))))
- '())
- ,@(if (file-exists? logout)
- `((bash-logout
- (list (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 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 (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))))
-
- (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))
-
- (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 name
- (qualified-name entry))
-
- (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))
-
- ,@transformations
-
- (packages->manifest
- (list ,@packages)))))))
-
-(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))))
+(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-configuration+modules destination-directory)
+ (define (destination-append path)
+ (string-append destination-directory "/" path))
+
+ (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)
+ `((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))))
+
+(define %files+configurations-alist
+ `((".bashrc" . ,generate-bash-configuration+modules)
+ (".bash_profile" . ,generate-bash-configuration+modules)
+ (".bash_logout" . ,generate-bash-configuration+modules)))
+
+(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?))
+
+ (map (lambda (proc) (proc configuration-directory)) configurations))
+
+(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))))
+
+ ,@definitions
+
+ (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)))
+
+ (home-environment
+ (packages (map specification->package ,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/package.scm b/guix/scripts/package.scm
index a34ecdcb54..4b9c5f210d 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -68,6 +68,7 @@
guix-package
search-path-environment-variables
+ manifest-entry-version-prefix
transaction-upgrade-entry ;mostly for testing
@@ -327,31 +328,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
diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm
new file mode 100644
index 0000000000..5749485a44
--- /dev/null
+++ b/guix/scripts/shell.scm
@@ -0,0 +1,394 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 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) (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))
+ #: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 create environment for the package that the code within
+ 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)
+ 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 exactly one 'load' or one 'manifest' 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)."
+ (define (single-file-for-caching opts)
+ (let loop ((opts opts)
+ (file #f))
+ (match opts
+ (() file)
+ ((('package . _) . _) #f)
+ ((('load . ('package candidate)) . rest)
+ (and (not file) (loop rest candidate)))
+ ((('manifest . candidate) . rest)
+ (and (not file) (loop rest candidate)))
+ ((('expression . _) . _) #f)
+ ((_ . rest) (loop rest file)))))
+
+ ;; Check whether there's a single 'load' or 'manifest' option. When that is
+ ;; the case, arrange to automatically cache the resulting profile.
+ (match (single-file-for-caching opts)
+ (#f opts)
+ (file
+ (let* ((root (profile-cached-gc-root file))
+ (stat (and root (false-if-exception (lstat root)))))
+ (if (and (not (assoc-ref opts 'rebuild-cache?))
+ stat
+ (<= (stat:mtime ((@ (guile) stat) file))
+ (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)
+ (_ #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-key file)
+ "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 (current-channels)
+ (() #f)
+ (((= channel-commit commits) ...)
+ (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 (string-join commits) ":"
+ (number->string (stat:dev stat)) ":"
+ (number->string (stat:ino stat))))))))))
+
+(define (profile-cached-gc-root file)
+ "Return the cached GC root for FILE, a 'guix.scm' or 'manifest.scm' file, or
+#f if we lack information to cache it."
+ (match (profile-cache-key file)
+ (#f #f)
+ (key (string-append (%profile-cache-directory) "/" key))))
+
+
+;;;
+;;; 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."))) )
+
+ (let ((result (guix-environment* opts)))
+ (maybe-remove-expired-cache-entries (%profile-cache-directory)
+ cache-entries
+ #:entry-expiration entry-expiration)
+ result))
diff --git a/guix/store.scm b/guix/store.scm
index 89a719bcfc..7388953d15 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1349,11 +1349,14 @@ on the build output of a previous derivation."
(things unresolved-things)
(continuation unresolved-continuation))
-(define (build-accumulator continue store things mode)
- "This build handler accumulates THINGS and returns an <unresolved> object."
- (if (= mode (build-mode normal))
- (unresolved things continue)
- (continue #t)))
+(define (build-accumulator expected-store)
+ "Return a build handler that accumulates THINGS and returns an <unresolved>
+object, only for build requests on EXPECTED-STORE."
+ (lambda (continue store things mode)
+ (if (and (eq? store expected-store)
+ (= mode (build-mode normal)))
+ (unresolved things continue)
+ (continue #t))))
(define* (map/accumulate-builds store proc lst
#:key (cutoff 30))
@@ -1366,13 +1369,16 @@ CUTOFF is the threshold above which we stop accumulating unresolved nodes."
;; stumbling upon the same .drv build requests with many incoming edges.
;; See <https://bugs.gnu.org/49439>.
+ (define accumulator
+ (build-accumulator store))
+
(define-values (result rest)
(let loop ((lst lst)
(result '())
(unresolved 0))
(match lst
((head . tail)
- (match (with-build-handler build-accumulator
+ (match (with-build-handler accumulator
(proc head))
((? unresolved? obj)
(if (>= unresolved cutoff)
diff --git a/guix/ui.scm b/guix/ui.scm
index 1428c254b3..b01bb3d587 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1431,10 +1431,22 @@ converted to a space; sequences of more than one line break are preserved."
(with-fluids ((%default-port-encoding "UTF-8"))
(stexi->plain-text (texi-fragment->stexi str))))
+(define (texi->plain-text* package str)
+ "Same as 'texi->plain-text', but gracefully handle Texinfo errors."
+ (catch 'parser-error
+ (lambda ()
+ (texi->plain-text str))
+ (lambda args
+ (warning (package-location package)
+ (G_ "~a: invalid Texinfo markup~%")
+ (package-full-name package))
+ str)))
+
(define (package-field-string package field-accessor)
"Return a plain-text representation of PACKAGE field."
(and=> (field-accessor package)
- (compose texi->plain-text P_)))
+ (lambda (str)
+ (texi->plain-text* package (P_ str)))))
(define (package-description-string package)
"Return a plain-text representation of PACKAGE description field."
@@ -1555,7 +1567,8 @@ HYPERLINKS? is true, emit hyperlink escape sequences when appropriate."
(parameterize ((%text-width width*))
;; Call 'texi->plain-text' on the concatenated string to account
;; for the width of "description:" in paragraph filling.
- (texi->plain-text
+ (texi->plain-text*
+ p
(string-append "description: "
(or (and=> (package-description p) P_)
""))))
@@ -2085,10 +2098,17 @@ contain a 'define-command' form."
(lambda (command)
(eq? category (command-category command))))
- (format #t (G_ "Usage: guix COMMAND ARGS...
-Run COMMAND with ARGS.\n"))
+ (display (G_ "Usage: guix OPTION | COMMAND ARGS...
+Run COMMAND with ARGS, if given.\n"))
+
+ (display (G_ "
+ -h, --help display this helpful text again and exit"))
+ (display (G_ "
+ -V, --version display version and copyright information and exit"))
+ (newline)
+
(newline)
- (format #t (G_ "COMMAND must be one of the sub-commands listed below:\n"))
+ (display (G_ "COMMAND must be one of the sub-commands listed below:\n"))
(let ((commands (commands))
(categories (module-ref (resolve-interface '(guix scripts))
generated by cgit v1.2.3 (git 2.25.4) at 2024-06-06 22:48:20 +0000