diff options
Diffstat (limited to 'guix/scripts/shell.scm')
-rw-r--r-- | guix/scripts/shell.scm | 394 |
1 files changed, 394 insertions, 0 deletions
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)) |