bug#73166: shell-autorized-directories

bug#73166: shell-autorized-directories

[Nicolas Graves]

According to current uses of the XDG base dirs specification, I think
guix shell-autorized-directories is in the wrong place, and should
instead be in $XDG_STATE_HOME/guix/

direnv uses $XDG_STATE_HOME too to store authorized directories, and it
also makes more sense in the context of immutable configs

WDYT? Should we implement this change? The tricky thing might be the
migration for those files. Maybe we should also add a --allow argument
to guix shell to make it easier to add files.

-- 
Best regards,
Nicolas Graves

bug#73166: shell-autorized-directories

[Ludovic Courtès]

Hi,

Nicolas Graves <ngraves@ngraves.fr> skribis:

> According to current uses of the XDG base dirs specification, I think
> guix shell-autorized-directories is in the wrong place, and should
> instead be in $XDG_STATE_HOME/guix/
>
> direnv uses $XDG_STATE_HOME too to store authorized directories, and it
> also makes more sense in the context of immutable configs

Is it that clear-cut?  It can be viewed as config rather than state too,
no?

> WDYT? Should we implement this change? The tricky thing might be the
> migration for those files.

Right, migration in itself is difficult.  Not to mention that we’d have
to account for people who use ‘time-machine’ to run a pre-migration
shell.

> Maybe we should also add a --allow argument to guix shell to make it
> easier to add files.

That option would add a line to ‘shell-autorized-directories’?

Thanks,
Ludo’.

bug#73166: shell-autorized-directories

[Nicolas Graves]

On 2024-09-11 11:52, Ludovic Courtès wrote:

> Hi,
>
> Nicolas Graves <ngraves@ngraves.fr> skribis:
>
> Is it that clear-cut?  It can be viewed as config rather than state too,
> no?

Possibly, though I'm not sure which use-case will make more sense using
this file as config rather than state.

In my use-case I tried to have an as-much-as-possible immutable home
config, and since I don't think it makes sense to run a guix home
reconfiguration after `echo X > ~/wherever/guix-shell-authorized-directories`,
I had to make a uggly trick/exception for this file.

>
>> WDYT? Should we implement this change? The tricky thing might be the
>> migration for those files.
>
> Right, migration in itself is difficult.  Not to mention that we’d have
> to account for people who use ‘time-machine’ to run a pre-migration
> shell.

Question is, is that worth it ? Probably not for only file relocation,
but I now think we need more, see next answer.

>
>> Maybe we should also add a --allow argument to guix shell to make it
>> easier to add files.
>
> That option would add a line to ‘shell-autorized-directories’?

Yes. Actually I would like to develop a little more after thinking about
that.

Let's say you git pull code from a guix-shell-authorized repo and the 
pull includes some potentially harmful / dangerous code.

The assumption of direnv is that the user has to allow the code to run
again in this case, putting more emphasis on security. This is not the
case in Guix, IIRC. I think it should be done in Guix too. 

Implementing that kind of additional security will indeed need such an
option, for this will need to actually include the hash of the file of
something like that.

It's actually quite simple in direnv, they take a sha256 hash of the
absolute filename + the content of the file.
(See
https://github.com/nicolas-graves/python-direnv/blob/f8f0967a9772f0775ffe75a68d868c75076f5af4/direnv.py#L36)
That hash makes a simple file-based database where a file is allowed based
not only on its location but on its location+content.

We could have two options to interact with such a database :
--allow
--revoke

>
> Thanks,
> Ludo’.

-- 
Best regards,
Nicolas Graves

bug#73166: shell-autorized-directories

[Nicolas Graves]

On 2024-09-11 16:11, Nicolas Graves wrote:

>> That option would add a line to ‘shell-autorized-directories’?
>
> Yes. Actually I would like to develop a little more after thinking about
> that.
>
> Let's say you git pull code from a guix-shell-authorized repo and the 
> pull includes some potentially harmful / dangerous code.
>
> The assumption of direnv is that the user has to allow the code to run
> again in this case, putting more emphasis on security. This is not the
> case in Guix, IIRC. I think it should be done in Guix too. 
>
> Implementing that kind of additional security will indeed need such an
> option, for this will need to actually include the hash of the file of
> something like that.
>
> It's actually quite simple in direnv, they take a sha256 hash of the
> absolute filename + the content of the file.
> (See
> https://github.com/nicolas-graves/python-direnv/blob/f8f0967a9772f0775ffe75a68d868c75076f5af4/direnv.py#L36)
> That hash makes a simple file-based database where a file is allowed based
> not only on its location but on its location+content.
>
> We could have two options to interact with such a database :
> --allow
> --revoke

Here's a working draft for some code for that.  This is currently able
to properly allow or deny my direnv-validated directories.  With a
proper direnv rename, we can almost already replace
authorized-shell-directory? function.

I feel like this is a far more secure and convenient way to manage
autorized-directories for guix shell.  WDYT ?

@Andrew you might also be interested in that given your focus on
per-directory complete dev environments.  Originally I thought of this
while thinking about how unsecure patch 3 of 
https://lists.sr.ht/~abcdw/rde-devel/patches/54944 was.

I'll probably continue to work on that to bring it to a full reviewable
patch, some input would be greatly appreciated in the meantime!


(use-modules
 (gcrypt hash)
 (guix rpm) ; for bytevector->hex-string
 (guix serialization)
 (srfi srfi-1)
 (srfi srfi-11)
 (srfi srfi-26)
 (srfi srfi-71)
 (ice-9 match)
 (ice-9 textual-ports))

(define (direnv-file-hash path)
  (let* ((abs-path (canonicalize-path path))
         (content (call-with-input-file abs-path get-string-all)))
    (call-with-input-string (string-append abs-path "\n" content)
      (cut (compose bytevector->hex-string port-sha256) <>))))

(define (xdg-data-home)
  (or (getenv "XDG_DATA_HOME")
      (string-append (getenv "HOME") "/.local/share")))

(define (permissions path)
  (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))))

  (let* ((file-hash (direnv-file-hash path))
         (database-path (string-append (xdg-data-home) "/direnv/")))
    (cond
     ((is-valid? (string-append database-path "deny/" file-hash))
      (values 'deny file-hash))
     ((is-valid? (string-append database-path "allow/" file-hash))
      (values 'allow file-hash))
     (else
      (values 'unknown file-hash)))))

(define (is-allowed? path)
  (eq? 'allow (permissions path)))

(define (is-denied? path)
  (eq? 'deny (permissions path)))

(define (allow-or-deny! path target-type origin-type)
  (let ((type file-hash (permissions path))
        (data-home (string-append (xdg-data-home) "/direnv/")))
    (match type
      (origin-type
       (rename-file
        (string-append data-home (symbol->string origin-type) "/" file-hash)
        (string-append data-home (symbol->string target-type) "/" file-hash)))
      (target-type
       (warn "not necessary"))  ;TODO do that properly
      ('unknown
       (call-with-output-file
           (string-append data-home (symbol->string target-type) "/" file-hash)
         (cut display (canonicalize-path path) <>))))))

(define (allow! path)
  (allow-or-deny! path 'allow 'deny))

(define (deny! path)
  (allow-or-deny! path 'deny 'allow))

-- 
Best regards,
Nicolas Graves

bug#73166: [PATCH] shell: Rewrite authorized directories management.

[Nicolas Graves]

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@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)))))))
 
 \f
@@ -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