Toggle diff (273 lines)
diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm
index d23362a15d..85794745d4 100644
--- a/guix/scripts/shell.scm
+++ b/guix/scripts/shell.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -39,7 +40,7 @@ (define-module (guix scripts shell)
#: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 utils) (cache-directory data-directory)
#:autoload (guix describe) (current-channels)
#:autoload (guix channels) (channel-commit)
#:autoload (gcrypt hash) (sha256)
@@ -47,6 +48,9 @@ (define-module (guix scripts shell)
#:use-module (guix cache)
#:use-module ((ice-9 ftw) #:select (scandir))
#:autoload (ice-9 pretty-print) (pretty-print)
+ #:autoload (ice-9 textual-ports) (get-string-all)
+ #:autoload (gcrypt hash) (port-sha256)
+ #:autoload (guix rpm) (bytevector->hex-string)
#:autoload (gnu packages) (cache-is-authoritative?
package-unique-version-prefix
specification->package
@@ -75,6 +79,10 @@ (define (show-help)
(display (G_ "
-F, --emulate-fhs for containers, emulate the Filesystem Hierarchy
Standard (FHS)"))
+ (display (G_ "
+ --allow allow automatic loading of 'guix.scm' and 'manifest.scm'"))
+ (display (G_ "
+ --deny revoke automatic loading of 'guix.scm' and 'manifest.scm'"))
(show-environment-options-help)
(newline)
@@ -149,7 +157,13 @@ (define %options
(option '(#\F "emulate-fhs") #f #f
(lambda (opt name arg result)
- (alist-cons 'emulate-fhs? #t result))))
+ (alist-cons 'emulate-fhs? #t result)))
+ (option '("allow") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'allow "allow" result)))
+ (option '("deny") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'deny "deny" result))))
(filter-map (lambda (opt)
(and (not (any (lambda (name)
(member name to-remove))
@@ -189,6 +203,68 @@ (define (handle-argument arg result)
(("--") opts)
(("--" command ...) (alist-cons 'exec command opts))))))))
+(define (shell-file-hash file)
+ "Returns a unique hash for FILE."
+ (let* ((abs-path (canonicalize-path file))
+ (content (call-with-input-file abs-path get-string-all)))
+ (call-with-input-string (string-append abs-path "\n" content)
+ (compose bytevector->hex-string port-sha256))))
+
+(define (shell-permission path)
+ "Returns the current permission of file at PATH ('allow, 'deny or 'unknown)
+and its file-hash."
+ (define (is-valid? file-path)
+ (and (file-exists? file-path)
+ (string=? (string-trim-right
+ (call-with-input-file file-path get-string-all))
+ (canonicalize-path path))))
+ (catch 'system-error
+ (lambda ()
+ (let* ((file-hash (shell-file-hash path))
+ (database (string-append (data-directory) "/shell/")))
+ (cond
+ ((is-valid? (string-append database "deny/" file-hash))
+ (values 'deny file-hash))
+ ((is-valid? (string-append database "allow/" file-hash))
+ (values 'allow file-hash))
+ (else
+ (values 'unknown file-hash)))))
+ (const (values #f #f))))
+
+(define (database-do! target-type path)
+ "Allows or revokes (depending on TARGET-TYPE value) guix shell automatic
+loading for the file at PATH."
+ (let ((type file-hash (shell-permission path))
+ (origin-type (match target-type
+ ('allow 'deny)
+ ('deny 'allow)))
+ (database (string-append (data-directory) "/shell/")))
+ (unless (file-exists? (string-append database "/allow/"))
+ (mkdir-p (string-append database "/allow/"))
+ (mkdir-p (string-append database "/deny/")))
+ (match type
+ ((? (cut eq? origin-type <>))
+ (let ((old-file (string-append
+ database (symbol->string origin-type) "/" file-hash)))
+ (copy-file
+ old-file
+ (string-append database (symbol->string target-type) "/" file-hash))
+ (delete-file old-file)
+ (match target-type
+ ('allow (info (G_ "'~a' allowed!~%") path))
+ ('deny (info (G_ "'~a' denied!~%") path)))))
+ ((? (cut eq? target-type <>))
+ (match target-type
+ ('allow (info (G_ "'~a' is already allowed!~%") path))
+ ('deny (info (G_ "'~a' is already denied!~%") path))))
+ ('unknown
+ (call-with-output-file
+ (string-append database (symbol->string target-type) "/" file-hash)
+ (cut display (canonicalize-path path) <>))
+ (match target-type
+ ('allow (info (G_ "'~a' allowed!~%") path))
+ ('deny (info (G_ "'~a' denied!~%") path)))))))
+
(define (find-file-in-parent-directories candidates)
"Find one of CANDIDATES in the current directory or one of its ancestors."
(define start (getcwd))
@@ -205,39 +281,9 @@ (define device (stat:dev (stat start)))
(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)
- (loop))))))))))
- (const #f)))
+(define (authorized-shell-file? file)
+ "Return true if FILE is among the authorized files for automatic loading."
+ (and=> (shell-permission file) (cut eq? 'allow <>)))
(define (options-with-caching opts)
"If OPTS contains only options that allow us to compute a cache key,
@@ -292,6 +338,8 @@ (define disallow-implicit-load?
(if (or (not interactive?)
disallow-implicit-load?
+ (assoc-ref opts 'allow)
+ (assoc-ref opts 'deny)
(options-contain-payload? opts))
opts
(match (find-file-in-parent-directories '("manifest.scm" "guix.scm"))
@@ -299,7 +347,7 @@ (define disallow-implicit-load?
(warning (G_ "no packages specified; creating an empty environment~%"))
opts)
(file
- (if (authorized-shell-directory? (dirname file))
+ (if (authorized-shell-file? file)
(begin
(info (G_ "loading environment from '~a'...~%") file)
(match (basename file)
@@ -314,11 +362,9 @@ (define disallow-implicit-load?
directory, like so:
@example
-echo ~a >> ~a
+guix shell --allow
@end example\n")
- file
- (dirname file)
- (authorized-directory-file))
+ file)
(exit 1)))))))
@@ -596,4 +642,16 @@ (define interactive?
(if (assoc-ref opts 'export-manifest?)
(export-manifest opts (current-output-port))
- (guix-environment* opts))))
+ (match (or (assoc-ref opts 'allow) (assoc-ref opts 'deny))
+ (#f
+ (guix-environment* opts))
+ (command
+ (match (or (assoc-ref opts 'manifest)
+ (find-file-in-parent-directories
+ '("manifest.scm" "guix.scm")))
+ (#f
+ (report-error
+ (G_ "no 'manifest.scm' or 'guix.scm' file to ~a~%") command)
+ (exit 1))
+ (file
+ (database-do! (string->symbol command) file))))))))
diff --git a/guix/utils.scm b/guix/utils.scm
index f161cb4ef3..51af0435e5 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -141,6 +141,7 @@ (define-module (guix utils)
config-directory
cache-directory
+ data-directory
readlink*
go-to-location
@@ -1049,6 +1050,9 @@ (define config-directory
(define cache-directory
(cut xdg-directory "XDG_CACHE_HOME" "/.cache" <...>))
+(define data-directory
+ (cut xdg-directory "XDG_DATA_HOME" "/.local/share" <...>))
+
(define (readlink* file)
"Call 'readlink' until the result is not a symlink."
(define %max-symlink-depth 50)
diff --git a/tests/guix-shell.sh b/tests/guix-shell.sh
index b2f820bf26..0606febd91 100644
--- a/tests/guix-shell.sh
+++ b/tests/guix-shell.sh
@@ -60,7 +60,7 @@ grep "not authorized" "$tmpdir/stderr"
rm "$tmpdir/stderr"
# Authorize the directory.
-echo "$(realpath "$tmpdir")" > "$configdir/guix/shell-authorized-directories"
+(cd "$tmpdir"; guix shell --allow)
# Ignoring 'manifest.scm' and 'guix.scm' in non-interactive use.
(cd "$tmpdir"; guix shell --bootstrap -- true)
@@ -78,6 +78,7 @@ cat > "$tmpdir/fake-shell.sh" <<EOF
exec echo "\$GUIX_ENVIRONMENT"
EOF
chmod +x "$tmpdir/fake-shell.sh"
+(cd "$tmpdir"; SHELL="$(realpath fake-shell.sh)" guix shell --allow)
profile1="$(cd "$tmpdir"; SHELL="$(realpath fake-shell.sh)" guix shell --bootstrap)"
profile2="$(guix shell --bootstrap guile-bootstrap -- "$SHELL" -c 'echo $GUIX_ENVIRONMENT')"
test -n "$profile1"
@@ -157,7 +158,7 @@ then
# Honoring the local 'guix.scm' file.
echo '(@ (guix tests) gnu-make-for-tests)' > "$tmpdir/guix.scm"
- (cd "$tmpdir"; guix shell --bootstrap --search-paths --pure > "b")
+ (cd "$tmpdir"; guix shell --allow; guix shell --bootstrap --search-paths --pure > "b")
cmp "$tmpdir/a" "$tmpdir/b"
rm "$tmpdir/guix.scm"
fi
--
2.46.0