;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Ludovic Courtès ;;; ;;; 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 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 (guix base32) (bytevector->base32-string) #:autoload (rnrs bytevectors) (string->utf8) #:autoload (guix utils) (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, --install-from-file=FILE install the package that the code within FILE evaluates to")) (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 "install-from-file") #t #f (lambda (opt name arg result) (alist-cons 'load (tag-package-arg result arg) 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 (auto-detect-manifest (parse-command-line args %options (list %default-options) #:argument-handler handle-argument)))) (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." (let loop ((directory (getcwd))) (and (= (stat:uid (stat directory)) (getuid)) (or (any (lambda (candidate) (let ((candidate (string-append directory "/" candidate))) (and (file-exists? candidate) candidate))) candidates) (loop (string-append directory "/..")))))) ;Unix ".." resolution (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)))) (if (options-contain-payload? opts) opts (match (find-file-in-parent-directories '("guix.scm" "manifest.scm")) (#f (warning (G_ "no packages specified; creating an empty environment~%")) opts) (file ;; Load environment from FILE; if possible, use/maintain a GC root to ;; the corresponding profile in cache. (info (G_ "loading environment from '~a'...~%") file) (let* ((root (profile-cached-gc-root file)) (stat (and root (false-if-exception (lstat root))))) (if (and 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 opts)) ;load right away (let ((opts (match (basename file) ("guix.scm" (alist-cons 'load `(package ,file) opts)) ("manifest.scm" (alist-cons 'manifest file opts))))) (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)))))))) ;;; ;;; 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 (sha256 (string->utf8 (string-append (string-join commits) ":" (basename file) ":" (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)))) (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))))) (let ((result (guix-environment* (parse-args args)))) (maybe-remove-expired-cache-entries (%profile-cache-directory) cache-entries #:entry-expiration entry-expiration) result))