;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021-2024 Ludovic Courtès ;;; Copyright © 2023 Janneke Nieuwenhuizen ;;; Copyright © 2024 Nicolas Graves ;;; ;;; 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 . (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 show-native-build-options-help) #:autoload (guix transformations) (options->transformation transformation-option-key? cacheable-transformation-option-key? show-transformation-options-help) #:autoload (guix grafts) (%graft?) #: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) (cache-directory data-directory) #:autoload (guix describe) (current-channels) #:autoload (guix channels) (channel-commit) #:autoload (gcrypt hash) (sha256) #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (guix cache) #:use-module ((ice-9 ftw) #:select (scandir)) #:autoload (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 specification->package+output specifications->manifest) #:export (guix-shell)) (define (show-help) (display (G_ "Usage: guix shell [OPTION] PACKAGES... [-- COMMAND...] Build an environment that includes PACKAGES and execute COMMAND or an interactive shell in that environment.\n")) (newline) ;; These two options differ from 'guix environment'. (display (G_ " -D, --development include the development inputs of the next package")) (display (G_ " -f, --file=FILE add to the environment the package FILE evaluates to")) (display (G_ " -q inhibit loading of 'guix.scm' and 'manifest.scm'")) (display (G_ " --rebuild-cache rebuild cached environment, if any")) (display (G_ " --export-manifest print a manifest for the given options")) (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) (show-build-options-help) (newline) (show-native-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 (leave-on-EPIPE (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))) (option '("export-manifest") #f #f (lambda (opt name arg result) (alist-cons 'export-manifest? #t result))) ;; For consistency with 'guix package', support '-f' rather than ;; '-l' like 'guix environment' does. (option '(#\f "file") #t #f (lambda (opt name arg result) (alist-cons 'load (tag-package-arg result arg) (ensure-ad-hoc result)))) (option '(#\q) #f #f (lambda (opt name arg result) (alist-cons 'explicit-loading? #t result))) (option '("rebuild-cache") #f #f (lambda (opt name arg result) (alist-cons 'rebuild-cache? #t result))) (option '(#\F "emulate-fhs") #f #f (lambda (opt name arg 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)) (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* ((args-parsed (parse-command-line args %options (list %default-options) #:argument-handler handle-argument)) ;; For an FHS-container, add the (hidden) package glibc-for-fhs ;; which uses the global cache at /etc/ld.so.cache. We handle ;; adding this package here to ensure it will always appear in the ;; container as it is the first package in OPTS. (opts (if (assoc-ref args-parsed 'emulate-fhs?) (alist-cons 'expression '(ad-hoc-package "(@@ (gnu packages base) glibc-for-fhs)") args-parsed) args-parsed))) (options-with-caching (auto-detect-manifest (match command (() opts) (("--") 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)) (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-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, automatically add a 'profile' key (when a profile for that file is already in cache) or a 'gc-root' key (to add the profile to cache)." ;; Attempt to compute a file name for use as the cached profile GC root. (let* ((root timestamp (profile-cached-gc-root opts)) (stat (and root (false-if-exception (lstat root))))) (if (and (not (assoc-ref opts 'rebuild-cache?)) stat (<= timestamp (stat:mtime stat))) (let ((now (current-time))) ;; Update the atime on ROOT to reflect usage. (utime root now (stat:mtime stat) 0 (stat:mtimensec stat) AT_SYMLINK_NOFOLLOW) (alist-cons 'profile root (remove (match-lambda (('load . _) #t) (('manifest . _) #t) (('package . _) #t) (('ad-hoc-package . _) #t) (_ #f)) opts))) ;load right away (if (and root (not (assq-ref opts 'gc-root))) (begin (if stat (delete-file root) (mkdir-p (dirname root))) (alist-cons 'gc-root root opts)) opts)))) (define (auto-detect-manifest opts) "If OPTS do not specify packages or a manifest, load a \"guix.scm\" or \"manifest.scm\" file from the current directory or one of its ancestors. Return the modified OPTS." (define (options-contain-payload? opts) (match opts (() #f) ((('package . _) . _) #t) ((('load . _) . _) #t) ((('manifest . _) . _) #t) ((('profile . _) . _) #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? (assoc-ref opts 'allow) (assoc-ref opts 'deny) (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-file? 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 (G_ "To allow automatic loading of @file{~a} when running @command{guix shell}, you must explicitly authorize its directory, like so: @example guix shell --allow @end example\n") file) (exit 1))))))) ;;; ;;; Profile cache. ;;; (define %profile-cache-directory ;; Directory where profiles created by 'guix shell' alone (without extra ;; options) are cached. (make-parameter (string-append (cache-directory #:ensure? #f) "/profiles"))) (define (profile-cache-primary-key) "Return the \"primary key\" used when computing keys for the profile cache. Return #f if no such key can be obtained and caching cannot be performed--e.g., because the package cache is not authoritative." (and (cache-is-authoritative?) (match (current-channels) (() #f) (((= channel-commit commits) ...) (string-join commits))))) (define (profile-file-cache-key file system) "Return the cache key for the profile corresponding to FILE, a 'guix.scm' or 'manifest.scm' file, or #f if we lack channel information." (match (profile-cache-primary-key) (#f #f) (primary-key (let ((stat (stat file))) (bytevector->base32-string ;; Since FILE is not canonicalized, only include the device/inode ;; numbers. XXX: In some rare cases involving Btrfs and NFS, this can ;; be insufficient: . (sha256 (string->utf8 (string-append primary-key ":" system ":" (if (%graft?) "" "ungrafted:") (number->string (stat:dev stat)) ":" (number->string (stat:ino stat)))))))))) (define (profile-spec-cache-key specs system) "Return the cache key corresponding to SPECS built for SYSTEM, where SPECS is a list of package specs. Return #f if caching is not possible." (match (profile-cache-primary-key) (#f #f) (primary-key (bytevector->base32-string (sha256 (string->utf8 (string-append primary-key ":" system ":" (if (%graft?) "" "ungrafted:") (object->string specs)))))))) (define (profile-cached-gc-root opts) "Return two values: the file name of a GC root for use as a profile cache for the options in OPTS, and a timestamp which, if greater than the GC root's mtime, indicates that the GC root is stale. If OPTS do not permit caching, return #f and #f." (define (key->file key) (string-append (%profile-cache-directory) "/" key)) ;; A given key such as 'system might appear more than once in OPTS, so ;; process it backwards so the last occurrence "wins". (let loop ((opts (reverse opts)) (system (%current-system)) (file #f) (specs '())) (match opts (() (if file (values (and=> (profile-file-cache-key file system) key->file) (stat:mtime (stat file))) (values (and=> (profile-spec-cache-key specs system) key->file) 0))) (((and spec ('package . _)) . rest) (if (not file) (loop rest system file (cons spec specs)) (values #f #f))) ((('nesting? . #t) . rest) (loop rest system file (append specs '("nested guix")))) ((('load . ('package candidate)) . rest) ;; This is 'guix shell -D -f guix.scm'. (if (and (not file) (null? specs)) (loop rest system candidate specs) (values #f #f))) ((('load . ('ad-hoc-package candidate)) . rest) ;; When running 'guix shell -f guix.scm', one typically expects ;; 'guix.scm' to be evaluated every time because it may contain ;; references like (local-file "." #:recursive? #t). Thus, disable ;; caching. (values #f #f)) ((('manifest . candidate) . rest) (if (and (not file) (null? specs)) (loop rest system candidate specs) (values #f #f))) ((('expression . _) . _) ;; Arbitrary expressions might be non-deterministic or otherwise depend ;; on external state so do not cache when they're used. (values #f #f)) ((((? transformation-option-key? key) . _) . rest) ;; Transformation options are potentially "non-deterministic", or at ;; least depending on external state (with-source, with-commit, etc.). ;; Cache only those that are known to be "cacheable". (if (cacheable-transformation-option-key? key) (loop rest system file (cons (first opts) specs)) (values #f #f))) ((('profile . _) . _) ;; If the user already specified a profile, there's nothing more to ;; cache. (values #f #f)) ((('export-manifest? . #t) . _) ;; When exporting a manifest, compute it anew so that '-D' packages ;; lead to 'package-development-manifest' expressions rather than an ;; expanded list of inputs. (values #f #f)) ((('system . system) . rest) (loop rest system file specs)) ((_ . rest) (loop rest system file specs))))) ;;; ;;; Exporting 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." (package-unique-version-prefix (manifest-entry-name entry) (manifest-entry-version entry))) (define (manifest->code* manifest extra-manifests) "Like 'manifest->code', but insert a 'concatenate-manifests' call that concatenates MANIFESTS, a list of expressions." (if (null? (manifest-entries manifest)) (match extra-manifests ((one) one) (lst `(concatenate-manifests (list ,@extra-manifests)))) (match (manifest->code manifest #:entry-package-version manifest-entry-version-prefix) (('begin exp ... last) `(begin ,@exp ,(match extra-manifests (() last) (_ `(concatenate-manifests (list ,last ,@extra-manifests))))))))) (define (export-manifest opts port) "Write to PORT a manifest corresponding to OPTS." (define (manifest-lift proc) (lambda (entry) (match (manifest-entry-item entry) ((? package? p) (manifest-entry (inherit (package->manifest-entry (proc p))) (output (manifest-entry-output entry)))) (_ entry)))) (define (validated-spec spec) ;; Return SPEC if it's a valid package spec. (specification->package+output spec) spec) (let* ((transform (options->transformation opts)) (specs (reverse (filter-map (match-lambda (('package 'ad-hoc-package spec) (validated-spec spec)) (_ #f)) opts))) (extras (reverse (filter-map (match-lambda (('package 'package spec) ;; Make sure SPEC is valid. (specification->package spec) ;; XXX: This is an approximation: ;; transformation options are not applied. `(package->development-manifest (specification->package ,spec))) (_ #f)) opts))) (manifest (concatenate-manifests (cons (map-manifest-entries (manifest-lift transform) (specifications->manifest specs)) (filter-map (match-lambda (('manifest . file) (load-manifest file)) (('profile . file) (profile-manifest file)) (_ #f)) opts))))) (display (G_ "\ ;; What follows is a \"manifest\" equivalent to the command line you gave. ;; You can store it in a file that you may then pass to any 'guix' command ;; that accepts a '--manifest' (or '-m') option.\n") port) (match (manifest->code* manifest extras) (('begin exp ...) (for-each (lambda (exp) (newline port) (pretty-print exp port)) exp)) (exp (pretty-print exp port))))) ;;; ;;; 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") (with-error-handling (define (cache-entries directory) (filter-map (match-lambda ((or "." "..") #f) (file (string-append directory "/" file))) (or (scandir directory) '()))) (define* (entry-expiration file) ;; Return the time at which FILE, a cached profile, is considered expired. (match (false-if-exception (lstat file)) (#f 0) ;FILE may have been deleted in the meantime (st (+ (stat:atime st) (* 60 60 24 7))))) (define opts (parse-args args)) (define interactive? (not (assoc-ref opts 'exec))) (if (assoc-ref opts 'check?) (record-hint 'shell-check) (when (and interactive? (not (hint-given? 'shell-check)) (not (assoc-ref opts 'container?)) (not (assoc-ref opts 'search-paths))) (display-hint (G_ "Consider passing the @option{--check} option once to make sure your shell does not clobber environment variables."))) ) ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use ;; of cached profiles, and (2) cleanup actually happens, even when ;; 'guix-environment*' calls 'exit'. (add-hook! exit-hook (lambda _ (maybe-remove-expired-cache-entries (%profile-cache-directory) cache-entries #:entry-expiration entry-expiration))) (if (assoc-ref opts 'export-manifest?) (export-manifest opts (current-output-port)) (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))))))))