Package: guix;
Reported by: Nicolas Graves <ngraves <at> ngraves.fr>
Date: Tue, 10 Sep 2024 11:32:02 UTC
Severity: normal
Tags: patch
View this message in rfc822 format
From: Nicolas Graves <ngraves <at> ngraves.fr> To: 73166 <at> debbugs.gnu.org Cc: ludo <at> gnu.org, Nicolas Graves <ngraves <at> ngraves.fr>, andrew <at> trop.in Subject: bug#73166: [PATCH] shell: Rewrite authorized directories management. Date: Sat, 9 Nov 2024 22:33:42 +0100
Let's say you pull code with a malicious change in guix.scm or
manifest.scm from a repo authorized by guix shell. guix shell would
continue to trust it. This commit rewrites the way guix shell allow
model works, by taking inspiration (literaly doing the exact same
thing) on direnv security model.
It adds the options
guix shell --allow
guix shell --deny
Previous allowed directories will be lost, but will continue to work
with guix time-machine.
* guix/utils.scm (data-directory): Add variable.
* guix/scripts/shell.scm
(show-help, %options, auto-detect-manifest): Add options --allow and
--deny.
(shell-file-hash, shell-permission, database-do!): Add variables.
(authorized-directory-file): Remove variable.
(authorized-shell-directory): Rewrite and rename procedure...
(authorized-shell-file): ...to this variable.
(guix-shell): Properly dispatch allow and deny options.
* tests/guix-shell.scm : Adapt tests.
---
guix/scripts/shell.scm | 140 +++++++++++++++++++++++++++++------------
guix/utils.scm | 4 ++
tests/guix-shell.sh | 5 +-
3 files changed, 106 insertions(+), 43 deletions(-)
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 <at> gnu.org>
;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke <at> gnu.org>
+;;; Copyright © 2024 Nicolas Graves <ngraves <at> 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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.