;;; 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.
;;;
;;; 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
                                     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)))))))

\f
;;;
;;; 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: <https://lwn.net/Articles/866582/>.
        (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)))))

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

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

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