code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2020 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 download)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module (guix store)
  #:use-module (gcrypt hash)
  #:use-module (guix base16)
  #:use-module (guix base32)
  #:autoload   (guix base64) (base64-encode)
  #:use-module ((guix download) #:hide (url-fetch))
  #:use-module ((guix build download)
                #:select (url-fetch))
  #:use-module ((guix progress)
                #:select (current-terminal-columns))
  #:use-module ((guix build syscalls)
                #:select (terminal-columns))
  #:use-module (web uri)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-14)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 binary-ports)
  #:export (guix-download))

;;;
;;; Command-line options.
;;;

(define (download-to-file url file)
  "Download the file at URI to FILE.  Return FILE."
  (let ((uri (string->uri url)))
    (match (uri-scheme uri)
      ((or 'file #f)
       (copy-file (uri-path uri) file))
      (_
       (url-fetch url file #:mirrors %mirrors)))
    file))

(define (ensure-valid-store-file-name name)
  "Replace any character not allowed in a stror name by an underscore."

  (define valid
    ;; according to nix/libstore/store-api.cc
    (string->char-set (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
                                     "abcdefghijklmnopqrstuvwxyz"
                                     "0123456789" "+-._?=")))
  (string-map (lambda (c)
                (if (char-set-contains? valid c) c #\_))
              name))

(define* (download-to-store* url #:key (verify-certificate? #t))
  (with-store store
    (download-to-store store url
                       (ensure-valid-store-file-name (basename url))
                       #:verify-certificate? verify-certificate?)))

(define %default-options
  ;; Alist of default option values.
  `((format . ,bytevector->nix-base32-string)
    (hash-algorithm . ,(hash-algorithm sha256))
    (verify-certificate? . #t)
    (download-proc . ,download-to-store*)))

(define (show-help)
  (display (G_ "Usage: guix download [OPTION] URL
Download the file at URL to the store or to the given file, and print its
file name and the hash of its contents.\n"))
  (newline)
  (display (G_ "\
Supported formats: 'base64', 'nix-base32' (default), 'base32',
and 'base16' ('hex' and 'hexadecimal' can be used as well).\n"))
  (format #t (G_ "
  -f, --format=FMT       write the hash in the given format"))
  (format #t (G_ "
  -H, --hash=ALGORITHM   use the given hash ALGORITHM"))
  (format #t (G_ "
      --no-check-certificate
                         do not validate the certificate of HTTPS servers "))
  (format #t (G_ "
  -o, --output=FILE      download to FILE"))
  (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 %options
  ;; Specifications of the command-line options.
  (list (option '(#\f "format") #t #f
                (lambda (opt name arg result)
                  (define fmt-proc
                    (match arg
                      ("base64"
                       base64-encode)
                      ("nix-base32"
                       bytevector->nix-base32-string)
                      ("base32"
                       bytevector->base32-string)
                      ((or "base16" "hex" "hexadecimal")
                       bytevector->base16-string)
                      (x
                       (leave (G_ "unsupported hash format: ~a~%") arg))))

                  (alist-cons 'format fmt-proc
                              (alist-delete 'format result))))
        (option '(#\H "hash") #t #f
                (lambda (opt name arg result)
                  (match (lookup-hash-algorithm (string->symbol arg))
                    (#f
                     (leave (G_ "~a: unknown hash algorithm~%") arg))
                    (algo
                     (alist-cons 'hash-algorithm algo result)))))
        (option '("no-check-certificate") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'verify-certificate? #f result)))
        (option '(#\o "output") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'download-proc
                              (lambda* (url #:key verify-certificate?)
                                (download-to-file url arg))
                              (alist-delete 'download result))))

        (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix download")))))

;;;
;;; Entry point.
;;;

(define-command (guix-download . args)
  (category packaging)
  (synopsis "download a file to the store and print its hash")

  (define (parse-options)
    ;; Return the alist of option values.
    (args-fold* args %options
                (lambda (opt name arg result)
                  (leave (G_ "~A: unrecognized option~%") name))
                (lambda (arg result)
                  (when (assq 'argument result)
                    (leave (G_ "~A: extraneous argument~%") arg))

                  (alist-cons 'argument arg result))
                %default-options))

  (with-error-handling
    (let* ((opts  (parse-options))
           (arg   (or (assq-ref opts 'argument)
                      (leave (G_ "no download URI was specified~%"))))
           (uri   (or (string->uri arg)
                      (false-if-exception
                       (string->uri
                        (string-append "file://" (canonicalize-path arg))))
                      (leave (G_ "~a: failed to parse URI~%")
                             arg)))
           (fetch (assq-ref opts 'download-proc))
           (path  (parameterize ((current-terminal-columns
                                  (terminal-columns)))
                    (fetch (uri->string uri)
                           #:verify-certificate?
                           (assq-ref opts 'verify-certificate?))))
           (hash  (call-with-input-file
                      (or path
                          (leave (G_ "~a: download failed~%")
                                 arg))
                    (cute port-hash (assoc-ref opts 'hash-algorithm) <>)))
           (fmt   (assq-ref opts 'format)))
      (format #t "~a~%~a~%" path (fmt hash))
      #t)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; 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 edit)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module ((guix scripts build) #:select (%standard-build-options))
  #:use-module (guix utils)
  #:use-module (gnu packages)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-37)
  #:export (%editor
            guix-edit))

(define %options
  (list (find (lambda (option)
                (member "load-path" (option-names option)))
              %standard-build-options)
        (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix edit")))))

(define (show-help)
  (display (G_ "Usage: guix edit PACKAGE...
Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n"))
  (newline)
  (display (G_ "
  -L, --load-path=DIR    prepend DIR to the package module search path"))
  (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 %editor
  ;; Nano is sensible default, as it is installed by base system.
  ;; For development, user can set custom value for $EDITOR.
  (make-parameter (or (getenv "VISUAL") (getenv "EDITOR") "nano")))

(define (search-path* path file)
  "Like 'search-path' but exit if FILE is not found."
  (let ((absolute-file-name (search-path path file)))
    (unless absolute-file-name
      ;; Shouldn't happen unless somebody fiddled with the 'location' field.
      (leave (G_ "file '~a' not found in search path ~s~%")
             file path))
    absolute-file-name))

(define (location->location-specification location)
  "Return the location specification for LOCATION for a typical editor command
line."
  (list (string-append "+"
                       (number->string
                        (location-line location)))
        (search-path* %load-path (location-file location))))

(define-command (guix-edit . args)
  (category packaging)
  (synopsis "view and edit package definitions")

  (define (parse-arguments)
    ;; Return the list of package names.
    (args-fold* args %options
                (lambda (opt name arg result)
                  (leave (G_ "~A: unrecognized option~%") name))
                cons
                '()))

  (with-error-handling
    (let* ((specs     (reverse (parse-arguments)))
           (locations (map specification->location specs)))

      (catch 'system-error
        (lambda ()
          (let ((file-names (append-map location->location-specification
                                        locations)))
            ;; Use `system' instead of `exec' in order to sanely handle
            ;; possible command line arguments in %EDITOR.
            (exit (system (string-join (cons (%editor) file-names))))))
        (lambda args
          (let ((errno (system-error-errno args)))
            (leave (G_ "failed to launch '~a': ~a~%")
                   (%editor) (strerror errno))))))))

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org>
;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mike Gerwitz <mtg@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 environment)
  #:use-module (guix ui)
  #:use-module (guix store)
  #:use-module ((guix status) #:select (with-status-verbosity))
  #:use-module (guix grafts)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix profiles)
  #:use-module (guix search-paths)
  #:use-module (guix build utils)
  #:use-module (guix monads)
  #:use-module ((guix gexp) #:select (lower-object))
  #:use-module (guix scripts)
  #:use-module (guix scripts build)
  #:use-module (gnu build linux-container)
  #:use-module (gnu build accounts)
  #:use-module (gnu system linux-container)
  #:use-module (gnu system file-systems)
  #:use-module (gnu packages)
  #:use-module (gnu packages bash)
  #:use-module ((gnu packages bootstrap)
                #:select (bootstrap-executable %bootstrap-guile))
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (srfi srfi-98)
  #:export (assert-container-features
            guix-environment))

;; Protect some env vars from purification.  Borrowed from nix-shell.
(define %precious-variables
  '("HOME" "USER" "LOGNAME" "DISPLAY" "TERM" "TZ" "PAGER"))

(define %default-shell
  (or (getenv "SHELL") "/bin/sh"))

(define (purify-environment white-list)
  "Unset all environment variables except those that match the regexps in
WHITE-LIST and those listed in %PRECIOUS-VARIABLES.  A small number of
variables such as 'HOME' and 'USER' are left untouched."
  (for-each unsetenv
            (remove (lambda (variable)
                      (or (member variable %precious-variables)
                          (find (cut regexp-exec <> variable)
                                white-list)))
                    (match (get-environment-variables)
                      (((names . _) ...)
                       names)))))

(define* (create-environment profile manifest
                             #:key pure? (white-list '()))
  "Set the environment variables specified by MANIFEST for PROFILE.  When
PURE?  is #t, unset the variables in the current environment except those that
match the regexps in WHITE-LIST.  Otherwise, augment existing environment
variables with additional search paths."
  (when pure?
    (purify-environment white-list))
  (for-each (match-lambda
              ((($ <search-path-specification> variable _ separator) . value)
               (let ((current (getenv variable)))
                 (setenv variable
                         (if (and current (not pure?))
                             (if separator
                                 (string-append value separator current)
                                 value)
                             value)))))
            (profile-search-paths profile manifest))

  ;; Give users a way to know that they're in 'guix environment', so they can
  ;; adjust 'PS1' accordingly, for instance.  Set it to PROFILE so users can
  ;; conveniently access its contents.
  (setenv "GUIX_ENVIRONMENT" profile))

(define* (show-search-paths profile manifest #:key pure?)
  "Display the search paths of MANIFEST applied to PROFILE.  When PURE? is #t,
do not augment existing environment variables with additional search paths."
  (for-each (match-lambda
              ((search-path . value)
               (display
                (search-path-definition search-path value
                                        #:kind (if pure? 'exact 'prefix)))
               (newline)))
            (profile-search-paths profile manifest)))

(define (input->manifest-entry input)
  "Return a manifest entry for INPUT, or #f if INPUT does not correspond to a
package."
  (match input
    ((_ (? package? package))
     (package->manifest-entry package))
    ((_ (? package? package) output)
     (package->manifest-entry package output))
    (_
     #f)))

(define (package-environment-inputs package)
  "Return a list of manifest entries corresponding to the transitive input
packages for PACKAGE."
  ;; Remove non-package inputs such as origin records.
  (filter-map input->manifest-entry
              (bag-transitive-inputs (package->bag package))))

(define (show-help)
  (display (G_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...]
Build an environment that includes the dependencies of PACKAGE and execute
COMMAND or an interactive shell in that environment.\n"))
  (display (G_ "
  -e, --expression=EXPR  create environment for the package that EXPR
                         evaluates to"))
  (display (G_ "
  -l, --load=FILE        create environment for the package that the code within
                         FILE evaluates to"))
  (display (G_ "
  -m, --manifest=FILE    create environment with the manifest from FILE"))
  (display (G_ "
      --ad-hoc           include all specified packages in the environment instead
                         of only their inputs"))
  (display (G_ "
      --pure             unset existing environment variables"))
  (display (G_ "
  -E, --preserve=REGEXP  preserve environment variables that match REGEXP"))
  (display (G_ "
      --search-paths     display needed environment variable definitions"))
  (display (G_ "
  -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
  (display (G_ "
  -r, --root=FILE        make FILE a symlink to the result, and register it
                         as a garbage collector root"))
  (display (G_ "
  -C, --container        run command within an isolated container"))
  (display (G_ "
  -N, --network          allow containers to access the network"))
  (display (G_ "
  -P, --link-profile     link environment profile to ~/.guix-profile within
                         an isolated container"))
  (display (G_ "
  -u, --user=USER        instead of copying the name and home of the current
                         user into an isolated container, use the name USER
                         with home directory /home/USER"))
  (display (G_ "
      --no-cwd           do not share current working directory with an
                         isolated container"))

  (display (G_ "
      --share=SPEC       for containers, share writable host file system
                         according to SPEC"))
  (display (G_ "
      --expose=SPEC      for containers, expose read-only host file system
                         according to SPEC"))
  (display (G_ "
  -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
  (display (G_ "
      --bootstrap        use bootstrap binaries to build the environment"))
  (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 %default-options
  `((system . ,(%current-system))
    (substitutes? . #t)
    (offload? . #t)
    (graft? . #t)
    (print-build-trace? . #t)
    (print-extended-build-trace? . #t)
    (multiplexed-build-output? . #t)
    (debug . 0)
    (verbosity . 1)))

(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."
  ;; Normally, the transitive inputs to a package are added to an environment,
  ;; but the ad-hoc? flag changes the meaning of a package argument such that
  ;; the package itself is added to the environment instead.
  (if (assoc-ref opts 'ad-hoc?)
      `(ad-hoc-package ,arg)
      `(package ,arg)))

(define %options
  ;; Specification of the command-line options.
  (cons* (option '(#\h "help") #f #f
                 (lambda args
                   (show-help)
                   (exit 0)))
         (option '(#\V "version") #f #f
                 (lambda args
                   (show-version-and-exit "guix environment")))
         (option '("pure") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'pure #t result)))
         (option '(#\E "preserve") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'inherit-regexp
                               (make-regexp* arg)
                               result)))
         (option '("inherit") #t #f               ;deprecated
                 (lambda (opt name arg result)
                   (warning (G_ "'--inherit' is deprecated, \
use '--preserve' instead~%"))
                   (alist-cons 'inherit-regexp
                               (make-regexp* arg)
                               result)))
         (option '("search-paths") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'search-paths #t result)))
         (option '(#\l "load") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'load
                               (tag-package-arg result arg)
                               result)))
         (option '(#\e "expression") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'expression
                               (tag-package-arg result arg)
                               result)))
         (option '(#\m "manifest") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'manifest
                               arg
                               result)))
         (option '("ad-hoc") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'ad-hoc? #t result)))
         (option '(#\n "dry-run") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'dry-run? #t result)))
         (option '(#\s "system") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'system arg
                               (alist-delete 'system result eq?))))
         (option '(#\C "container") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'container? #t result)))
         (option '(#\N "network") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'network? #t result)))
         (option '(#\P "link-profile") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'link-profile? #t result)))
         (option '(#\u "user") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'user arg
                               (alist-delete 'user result eq?))))
         (option '("no-cwd") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'no-cwd? #t result)))
         (option '("share") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'file-system-mapping
                               (specification->file-system-mapping arg #t)
                               result)))
         (option '("expose") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'file-system-mapping
                               (specification->file-system-mapping arg #f)
                               result)))
         (option '(#\r "root") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'gc-root arg result)))
         (option '(#\v "verbosity") #t #f
                 (lambda (opt name arg result)
                   (let ((level (string->number* arg)))
                     (alist-cons 'verbosity level
                                 (alist-delete 'verbosity result)))))
         (option '("bootstrap") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'bootstrap? #t result)))

         (append %transformation-options
                 %standard-build-options)))

(define (pick-all alist key)
  "Return a list of values in ALIST associated with KEY."
  (define same-key? (cut eq? key <>))

  (fold (lambda (pair memo)
          (match pair
            (((? same-key? k) . v)
             (cons v memo))
            (_ memo)))
        '() alist))

(define (options/resolve-packages store opts)
  "Return OPTS with package specification strings replaced by manifest entries
for the corresponding packages."
  (define (manifest-entry=? e1 e2)
    (and (eq? (manifest-entry-item e1) (manifest-entry-item e2))
         (string=? (manifest-entry-output e1)
                   (manifest-entry-output e2))))

  (define transform
    (cut (options->transformation opts) store <>))

  (define* (package->manifest-entry* package #:optional (output "out"))
    (package->manifest-entry (transform package) output))

  (define (packages->outputs packages mode)
    (match packages
      ((? package? package)
       (if (eq? mode 'ad-hoc-package)
           (list (package->manifest-entry* package))
           (package-environment-inputs package)))
      (((? package? package) (? string? output))
       (if (eq? mode 'ad-hoc-package)
           (list (package->manifest-entry* package output))
           (package-environment-inputs package)))
      ((lst ...)
       (append-map (cut packages->outputs <> mode) lst))))

  (manifest
   (delete-duplicates
    (append-map (match-lambda
                  (('package 'ad-hoc-package (? string? spec))
                   (let-values (((package output)
                                 (specification->package+output spec)))
                     (list (package->manifest-entry* package output))))
                  (('package 'package (? string? spec))
                   (package-environment-inputs
                    (transform (specification->package+output spec))))
                  (('expression mode str)
                   ;; Add all the outputs of the package STR evaluates to.
                   (packages->outputs (read/eval str) mode))
                  (('load mode file)
                   ;; Add all the outputs of the package defined in FILE.
                   (let ((module (make-user-module '())))
                     (packages->outputs (load* file module) mode)))
                  (('manifest . file)
                   (let ((module (make-user-module '((guix profiles) (gnu)))))
                     (manifest-entries (load* file module))))
                  (_ '()))
                opts)
    manifest-entry=?)))

(define (manifest->derivation manifest system bootstrap?)
  "Return the derivation for a profile of MANIFEST.
BOOTSTRAP? specifies whether to use the bootstrap Guile to build the profile."
  (profile-derivation manifest
                      #:system system

                      ;; Packages can have conflicting inputs, or explicit
                      ;; inputs that conflict with implicit inputs (e.g., gcc,
                      ;; gzip, etc.).  Thus, do not error out when we
                      ;; encounter collision.
                      #:allow-collisions? #t

                      #:hooks (if bootstrap?
                                  '()
                                  %default-profile-hooks)
                      #:locales? (not bootstrap?)))

(define requisites* (store-lift requisites))

(define (inputs->requisites inputs)
  "Convert INPUTS, a list of input tuples or store path strings, into a set of
requisite store items i.e. the union closure of all the inputs."
  (define (input->requisites input)
    (requisites*
     (match input
       ((drv output)
        (list (derivation->output-path drv output)))
       ((drv)
        (list (derivation->output-path drv)))
       ((? direct-store-path? path)
        (list path)))))

  (mlet %store-monad ((reqs (mapm %store-monad
                                  input->requisites inputs)))
    (return (delete-duplicates (concatenate reqs)))))

(define (status->exit-code status)
  "Compute the exit code made from STATUS, a value as returned by 'waitpid',
and suitable for 'exit'."
  ;; See <bits/waitstatus.h>.
  (or (status:exit-val status)
      (logior #x80 (status:term-sig status))))

(define exit/status (compose exit status->exit-code))
(define primitive-exit/status (compose primitive-exit status->exit-code))

(define* (launch-environment command profile manifest
                             #:key pure? (white-list '()))
  "Run COMMAND in a new environment containing INPUTS, using the native search
paths defined by the list PATHS.  When PURE?, pre-existing environment
variables are cleared before setting the new ones, except those matching the
regexps in WHITE-LIST."
  ;; Properly handle SIGINT, so pressing C-c in an interactive terminal
  ;; application works.
  (sigaction SIGINT SIG_DFL)
  (create-environment profile manifest
                      #:pure? pure? #:white-list white-list)
  (match command
    ((program . args)
     (apply execlp program program args))))

(define* (launch-environment/fork command profile manifest
                                  #:key pure? (white-list '()))
  "Run COMMAND in a new process with an environment containing PROFILE, with
the search paths specified by MANIFEST.  When PURE?, pre-existing environment
variables are cleared before setting the new ones, except those matching the
regexps in WHITE-LIST."
  (match (primitive-fork)
    (0 (launch-environment command profile manifest
                           #:pure? pure?
                           #:white-list white-list))
    (pid (match (waitpid pid)
           ((_ . status) status)))))

(define* (launch-environment/container #:key command bash user user-mappings
                                       profile manifest link-profile? network?
                                       map-cwd? (white-list '()))
  "Run COMMAND within a container that features the software in PROFILE.
Environment variables are set according to the search paths of MANIFEST.
The global shell is BASH, a file name for a GNU Bash binary in the
store.  When NETWORK?, access to the host system network is permitted.
USER-MAPPINGS, a list of file system mappings, contains the user-specified
host file systems to mount inside the container.  If USER is not #f, each
target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER
will be used for the passwd entry.  LINK-PROFILE? creates a symbolic link from
~/.guix-profile to the environment profile.

Preserve environment variables whose name matches the one of the regexps in
WHILE-LIST."
  (define (optional-mapping->fs mapping)
    (and (file-exists? (file-system-mapping-source mapping))
         (file-system-mapping->bind-mount mapping)))

  (mlet %store-monad ((reqs (inputs->requisites
                             (list (direct-store-path bash) profile))))
    (return
     (let* ((cwd      (getcwd))
            (home     (getenv "HOME"))
            (uid      (if user 1000 (getuid)))
            (gid      (if user 1000 (getgid)))
            (passwd   (let ((pwd (getpwuid (getuid))))
                        (password-entry
                         (name (or user (passwd:name pwd)))
                         (real-name (if user
                                        ""
                                        (passwd:gecos pwd)))
                         (uid uid) (gid gid) (shell bash)
                         (directory (if user
                                        (string-append "/home/" user)
                                        (passwd:dir pwd))))))
            (groups   (list (group-entry (name "users") (gid gid))
                            (group-entry (gid 65534) ;the overflow GID
                                         (name "overflow"))))
            (home-dir (password-entry-directory passwd))
            (logname  (password-entry-name passwd))
            (environ  (filter (match-lambda
                                ((variable . value)
                                 (find (cut regexp-exec <> variable)
                                       white-list)))
                              (get-environment-variables)))
            ;; Bind-mount all requisite store items, user-specified mappings,
            ;; /bin/sh, the current working directory, and possibly networking
            ;; configuration files within the container.
            (mappings
             (append
              (override-user-mappings
               user home
               (append user-mappings
                       ;; Share current working directory, unless asked not to.
                       (if map-cwd?
                           (list (file-system-mapping
                                  (source cwd)
                                  (target cwd)
                                  (writable? #t)))
                           '())))
              ;; Mappings for the union closure of all inputs.
              (map (lambda (dir)
                     (file-system-mapping
                      (source dir)
                      (target dir)
                      (writable? #f)))
                   reqs)))
            (file-systems (append %container-file-systems
                                  (if network?
                                      (filter-map optional-mapping->fs
                                                  %network-file-mappings)
                                      '())
                                  (map file-system-mapping->bind-mount
                                       mappings))))
       (exit/status
        (call-with-container file-systems
          (lambda ()
            ;; Setup global shell.
            (mkdir-p "/bin")
            (symlink bash "/bin/sh")

            ;; Set a reasonable default PS1.
            (setenv "PS1" "\\u@\\h \\w [env]\\$ ")

            ;; Setup directory for temporary files.
            (mkdir-p "/tmp")
            (for-each (lambda (var)
                        (setenv var "/tmp"))
                      ;; The same variables as in Nix's 'build.cc'.
                      '("TMPDIR" "TEMPDIR" "TMP" "TEMP"))

            ;; Some programs expect USER and/or LOGNAME to be set.
            (setenv "LOGNAME" logname)
            (setenv "USER" logname)

            ;; Create a dummy home directory.
            (mkdir-p home-dir)
            (setenv "HOME" home-dir)

            ;; If requested, link $GUIX_ENVIRONMENT to $HOME/.guix-profile;
            ;; this allows programs expecting that path to continue working as
            ;; expected within a container.
            (when link-profile? (link-environment profile home-dir))

            ;; Create a dummy /etc/passwd to satisfy applications that demand
            ;; to read it, such as 'git clone' over SSH, a valid use-case when
            ;; sharing the host's network namespace.
            (mkdir-p "/etc")
            (write-passwd (list passwd))
            (write-group groups)

            ;; For convenience, start in the user's current working
            ;; directory or, if unmapped, the home directory.
            (chdir (if map-cwd?
                       (override-user-dir user home cwd)
                       home-dir))

            ;; Set environment variables that match WHITE-LIST.
            (for-each (match-lambda
                        ((variable . value)
                         (setenv variable value)))
                      environ)

            (primitive-exit/status
             ;; A container's environment is already purified, so no need to
             ;; request it be purified again.
             (launch-environment command profile manifest #:pure? #f)))
          #:guest-uid uid
          #:guest-gid gid
          #:namespaces (if network?
                           (delq 'net %namespaces) ; share host network
                           %namespaces)))))))

(define (user-override-home user)
  "Return home directory for override user USER."
  (string-append "/home/" user))

(define (override-user-mappings user home mappings)
  "If a username USER is provided, rewrite each HOME prefix in file system
mappings MAPPINGS to a home directory determined by 'override-user-dir';
otherwise, return MAPPINGS."
  (if (not user)
      mappings
      (map (lambda (mapping)
             (let ((target (file-system-mapping-target mapping)))
               (if (string-prefix? home target)
                   (file-system-mapping
                    (source    (file-system-mapping-source mapping))
                    (target    (override-user-dir user home target))
                    (writable? (file-system-mapping-writable? mapping)))
                   mapping)))
           mappings)))

(define (override-user-dir user home dir)
  "If username USER is provided, overwrite string prefix HOME in DIR with a
directory determined by 'user-override-home'; otherwise, return DIR."
  (if (and user (string-prefix? home dir))
      (string-append (user-override-home user)
                     (substring dir (string-length home)))
      dir))

(define (link-environment profile home-dir)
  "Create a symbolic link from HOME-DIR/.guix-profile to PROFILE."
  (let ((profile-dir (string-append home-dir "/.guix-profile")))
    (catch 'system-error
      (lambda ()
        (symlink profile profile-dir))
      (lambda args
        (if (= EEXIST (system-error-errno args))
            (leave (G_ "cannot link profile: '~a' already exists within container~%")
                   profile-dir)
            (apply throw args))))))

(define (environment-bash container? bootstrap? system)
  "Return a monadic value in the store monad for the version of GNU Bash
needed in the environment for SYSTEM, if any.  If CONTAINER? is #f, return #f.
If CONTAINER? and BOOTSTRAP?, return the store path for the bootstrap Bash.
Otherwise, return the derivation for the Bash package."
  (with-monad %store-monad
    (cond
     ((and container? (not bootstrap?))
      (package->derivation bash))
     ;; Use the bootstrap Bash instead.
     ((and container? bootstrap?)
      (lower-object (bootstrap-executable "bash" system)))
     (else
      (return #f)))))

(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) result))

  ;; The '--' token is used to separate the command to run from the rest of
  ;; the operands.
  (let-values (((args command) (break (cut string=? "--" <>) args)))
    (let ((opts (parse-command-line args %options (list %default-options)
                                    #:argument-handler handle-argument)))
      (match command
        (() opts)
        (("--") opts)
        (("--" command ...) (alist-cons 'exec command opts))))))

(define (assert-container-features)
  "Check if containers can be created and exit with an informative error
message if any test fails."
  (unless (user-namespace-supported?)
    (report-error (G_ "cannot create container: user namespaces unavailable\n"))
    (leave (G_ "is your kernel version < 3.10?\n")))

  (unless (unprivileged-user-namespace-supported?)
    (report-error (G_ "cannot create container: unprivileged user cannot create user namespaces\n"))
    (leave (G_ "please set /proc/sys/kernel/unprivileged_userns_clone to \"1\"\n")))

  (unless (setgroups-supported?)
    (report-error (G_ "cannot create container: /proc/self/setgroups does not exist\n"))
    (leave (G_ "is your kernel version < 3.19?\n"))))

(define (register-gc-root target root)
  "Make ROOT an indirect root to TARGET.  This is procedure is idempotent."
  (let* ((root (if (string-prefix? "/" root)
                   root
                   (string-append (canonicalize-path (dirname root))
                                  "/" root))))
    (catch 'system-error
      (lambda ()
        (symlink target root)
        ((store-lift add-indirect-root) root))
      (lambda args
        (if (and (= EEXIST (system-error-errno args))
                 (equal? (false-if-exception (readlink root)) target))
            (with-monad %store-monad
              (return #t))
            (apply throw args))))))

;;;
;;; Entry point.
;;;

(define-command (guix-environment . args)
  (category development)
  (synopsis "spawn one-off software environments")

  (with-error-handling
    (let* ((opts       (parse-args args))
           (pure?      (assoc-ref opts 'pure))
           (container? (assoc-ref opts 'container?))
           (link-prof? (assoc-ref opts 'link-profile?))
           (network?   (assoc-ref opts 'network?))
           (no-cwd?    (assoc-ref opts 'no-cwd?))
           (user       (assoc-ref opts 'user))
           (bootstrap? (assoc-ref opts 'bootstrap?))
           (system     (assoc-ref opts 'system))
           (command    (or (assoc-ref opts 'exec)
                           ;; Spawn a shell if the user didn't specify
                           ;; anything in particular.
                           (if container?
                               ;; The user's shell is likely not available
                               ;; within the container.
                               '("/bin/sh")
                               (list %default-shell))))
           (mappings   (pick-all opts 'file-system-mapping))
           (white-list (pick-all opts 'inherit-regexp)))

      (when container? (assert-container-features))

      (when (and (not container?) link-prof?)
        (leave (G_ "'--link-profile' cannot be used without '--container'~%")))
      (when (and (not container?) user)
        (leave (G_ "'--user' cannot be used without '--container'~%")))
      (when (and (not container?) no-cwd?)
        (leave (G_ "--no-cwd cannot be used without --container~%")))

      (with-store store
        (with-build-handler (build-notifier #:use-substitutes?
                                            (assoc-ref opts 'substitutes?)
                                            #:verbosity
                                            (assoc-ref opts 'verbosity)
                                            #:dry-run?
                                            (assoc-ref opts 'dry-run?))
          (with-status-verbosity (assoc-ref opts 'verbosity)
            (define manifest
              (options/resolve-packages store opts))

            (set-build-options-from-command-line store opts)

            ;; Use the bootstrap Guile when requested.
            (parameterize ((%graft? (assoc-ref opts 'graft?))
                           (%guile-for-build
                            (package-derivation
                             store
                             (if bootstrap?
                                 %bootstrap-guile
                                 (default-guile)))))
              (run-with-store store
                ;; Containers need a Bourne shell at /bin/sh.
                (mlet* %store-monad ((bash       (environment-bash container?
                                                                   bootstrap?
                                                                   system))
                                     (prof-drv   (manifest->derivation
                                                  manifest system bootstrap?))
                                     (profile -> (derivation->output-path prof-drv))
                                     (gc-root -> (assoc-ref opts 'gc-root)))

                  ;; First build the inputs.  This is necessary even for
                  ;; --search-paths.  Additionally, we might need to build bash for
                  ;; a container.
                  (mbegin %store-monad
                    (built-derivations (if (derivation? bash)
                                           (list prof-drv bash)
                                           (list prof-drv)))
                    (mwhen gc-root
                      (register-gc-root profile gc-root))

                    (cond
                     ((assoc-ref opts 'search-paths)
                      (show-search-paths profile manifest #:pure? pure?)
                      (return #t))
                     (container?
                      (let ((bash-binary
                             (if bootstrap?
                                 (derivation->output-path bash)
                                 (string-append (derivation->output-path bash)
                                                "/bin/sh"))))
                        (launch-environment/container #:command command
                                                      #:bash bash-binary
                                                      #:user user
                                                      #:user-mappings mappings
                                                      #:profile profile
                                                      #:manifest manifest
                                                      #:white-list white-list
                                                      #:link-profile? link-prof?
                                                      #:network? network?
                                                      #:map-cwd? (not no-cwd?))))

                     (else
                      (return
                       (exit/status
                        (launch-environment/fork command profile manifest
                                                 #:white-list white-list
                                                 #:pure? pure?)))))))))))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018, 2019, 2020 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 gc)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module (guix store)
  #:use-module (guix store roots)
  #:autoload   (guix build syscalls) (free-disk-space)
  #:autoload   (guix profiles) (generation-profile
                                profile-generations
                                generation-number)
  #:autoload   (guix scripts package) (delete-generations)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:export (guix-gc))

;;;
;;; Command-line options.
;;;

(define %default-options
  ;; Alist of default option values.
  `((action . collect-garbage)))

(define (show-help)
  (display (G_ "Usage: guix gc [OPTION]... PATHS...
Invoke the garbage collector.\n"))
  (display (G_ "
  -C, --collect-garbage[=MIN]
                         collect at least MIN bytes of garbage"))
  (display (G_ "
  -F, --free-space=FREE  attempt to reach FREE available space in the store"))
  (display (G_ "
  -d, --delete-generations[=PATTERN]
                         delete profile generations matching PATTERN"))
  (display (G_ "
  -D, --delete           attempt to delete PATHS"))
  (display (G_ "
      --list-roots       list the user's garbage collector roots"))
  (display (G_ "
      --list-busy        list store items used by running processes"))
  (display (G_ "
      --optimize         optimize the store by deduplicating identical files"))
  (display (G_ "
      --list-dead        list dead paths"))
  (display (G_ "
      --list-live        list live paths"))
  (newline)
  (display (G_ "
      --references       list the references of PATHS"))
  (display (G_ "
  -R, --requisites       list the requisites of PATHS"))
  (display (G_ "
      --referrers        list the referrers of PATHS"))
  (display (G_ "
      --derivers         list the derivers of PATHS"))
  (newline)
  (display (G_ "
      --verify[=OPTS]    verify the integrity of the store; OPTS is a
                         comma-separated combination of 'repair' and
                         'contents'"))
  (display (G_ "
      --list-failures    list cached build failures"))
  (display (G_ "
      --clear-failures   remove PATHS from the set of cached failures"))
  (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 argument->verify-options
  (let ((not-comma (char-set-complement (char-set #\,)))
        (validate  (lambda (option)
                     (unless (memq option '(repair contents))
                       (leave (G_ "~a: invalid '--verify' option~%")
                              option)))))
    (lambda (arg)
      "Turn ARG into a list of symbols denoting '--verify' options."
      (if arg
          (let ((lst (map string->symbol
                          (string-tokenize arg not-comma))))
            (for-each validate lst)
            lst)
          '()))))

(define (delete-old-generations store profile pattern)
  "Remove the generations of PROFILE that match PATTERN, a duration pattern;
do nothing if none matches.  If PATTERN is #f, delete all generations but the
current one."
  (let* ((current (generation-number profile))
         (numbers (if (not pattern)
                      (profile-generations profile)
                      (matching-generations pattern profile
                                            #:duration-relation >))))

    ;; Make sure we don't inadvertently remove the current generation.
    (delete-generations store profile (delv current numbers))))

(define %options
  ;; Specification of the command-line options.
  (list (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix gc")))

        (option '(#\C "collect-garbage") #f #t
                (lambda (opt name arg result)
                  (let ((result (alist-cons 'action 'collect-garbage
                                            (alist-delete 'action result))))
                   (match arg
                     ((? string?)
                      (let ((amount (size->number arg)))
                        (if arg
                            (alist-cons 'min-freed amount result)
                            (leave (G_ "invalid amount of storage: ~a~%")
                                   arg))))
                     (#f result)))))
        (option '(#\F "free-space") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'free-space (size->number arg) result)))
        (option '(#\D "delete") #f #f            ;used to be '-d' (lower case)
                (lambda (opt name arg result)
                  (alist-cons 'action 'delete
                              (alist-delete 'action result))))
        (option '(#\d "delete-generations") #f #t
                (lambda (opt name arg result)
                  (if (and arg (store-path? arg))
                      (begin
                        (warning (G_ "'-d' as an alias for '--delete' \
is deprecated; use '-D'~%"))
                        `((action . delete)
                          (argument . ,arg)
                          (alist-delete 'action result)))
                      (begin
                        (when (and arg (not (string->duration arg)))
                          (leave (G_ "~s does not denote a duration~%")
                                 arg))
                        (alist-cons 'delete-generations arg result)))))
        (option '("optimize") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'action 'optimize
                              (alist-delete 'action result))))
        (option '("verify") #f #t
                (lambda (opt name arg result)
                  (let ((options (argument->verify-options arg)))
                    (alist-cons 'action 'verify
                                (alist-cons 'verify-options options
                                            (alist-delete 'action
                                                          result))))))
        (option '("list-roots") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'action 'list-roots
                              (alist-delete 'action result))))
        (option '("list-busy") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'action 'list-busy
                              (alist-delete 'action result))))
        (option '("list-dead") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'action 'list-dead
                              (alist-delete 'action result))))
        (option '("list-live") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'action 'list-live
                              (alist-delete 'action result))))
        (option '("references") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'action 'list-references
                              (alist-delete 'action result))))
        (option '(#\R "requisites") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'action 'list-requisites
                              (alist-delete 'action result))))
        (option '("referrers") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'action 'list-referrers
                              (alist-delete 'action result))))
        (option '("derivers") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'action 'list-derivers
                              (alist-delete 'action result))))
        (option '("list-failures") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'action 'list-failures
                              (alist-delete 'action result))))
        (option '("clear-failures") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'action 'clear-failures
                              (alist-delete 'action result))))))

;;;
;;; Entry point.
;;;

(define-command (guix-gc . args)
  (synopsis "invoke the garbage collector")

  (define (parse-options)
    ;; Return the alist of option values.
    (parse-command-line args %options (list %default-options)
                        #:build-options? #f))

  (define (symlink-target file)
    (let ((s (false-if-exception (lstat file))))
      (if (and s (eq? 'symlink (stat:type s)))
          (symlink-target (readlink file))
          file)))

  (define (store-directory file)
    ;; Return the store directory that holds FILE if it's in the store,
    ;; otherwise return FILE.
    (or (and=> (string-match (string-append "^" (regexp-quote (%store-prefix))
                                            "/([^/]+)")
                             file)
               (compose (cut string-append (%store-prefix) "/" <>)
                        (cut match:substring <> 1)))
        file))

  (define (ensure-free-space store space)
    ;; Attempt to have at least SPACE bytes available in STORE.
    (let ((free (free-disk-space (%store-prefix))))
      (if (> free space)
          (info (G_ "already ~h MiBs available on ~a, nothing to do~%")
                (/ free 1024. 1024.) (%store-prefix))
          (let ((to-free (- space free)))
            (info (G_ "freeing ~h MiBs~%") (/ to-free 1024. 1024.))
            (collect-garbage store to-free)))))

  (define (delete-generations store pattern)
    ;; Delete the generations matching PATTERN of all the user's profiles.
    (let ((profiles (delete-duplicates
                     (filter-map (lambda (root)
                                   (and (or (zero? (getuid))
                                            (user-owned? root))
                                        (generation-profile root)))
                                 (gc-roots)))))
      (for-each (lambda (profile)
                  (delete-old-generations store profile pattern))
                profiles)))

  (define (list-roots)
    ;; List all the user-owned GC roots.
    (let ((roots (filter (if (zero? (getuid)) (const #t) user-owned?)
                         (gc-roots))))
      (for-each (lambda (root)
                  (display root)
                  (newline))
                roots)))

  (define (list-busy)
    ;; List store items used by running processes.
    (for-each (lambda (item)
                (display item) (newline))
              (busy-store-items)))

  (with-error-handling
    (let* ((opts  (parse-options))
           (store (open-connection))
           (paths (filter-map (match-lambda
                               (('argument . arg) arg)
                               (_ #f))
                              opts)))
      (define (assert-no-extra-arguments)
        (unless (null? paths)
          (leave (G_ "extraneous arguments: ~{~a ~}~%") paths)))

      (define (list-relatives relatives)
        (for-each (compose (lambda (path)
                             (for-each (cut simple-format #t "~a~%" <>)
                                       (relatives store path)))
                           store-directory
                           symlink-target)
                  paths))

      (case (assoc-ref opts 'action)
        ((collect-garbage)
         (assert-no-extra-arguments)
         (let ((min-freed  (assoc-ref opts 'min-freed))
               (free-space (assoc-ref opts 'free-space)))
           (match (assq 'delete-generations opts)
             (#f #t)
             ((_ . pattern)
              (delete-generations store pattern)))
           (cond
            (free-space
             (ensure-free-space store free-space))
            (min-freed
             (let-values (((paths freed) (collect-garbage store min-freed)))
              (info (G_ "freed ~h MiBs~%") (/ freed 1024. 1024.))))
            (else
             (let-values (((paths freed) (collect-garbage store)))
              (info (G_ "freed ~h MiBs~%") (/ freed 1024. 1024.)))))))
        ((list-roots)
         (assert-no-extra-arguments)
         (list-roots))
        ((list-busy)
         (assert-no-extra-arguments)
         (list-busy))
        ((delete)
         (delete-paths store (map direct-store-path paths)))
        ((list-references)
         (list-relatives references))
        ((list-requisites)
         (list-relatives (lambda (store item)
                           (requisites store (list item)))))
        ((list-referrers)
         (list-relatives referrers))
        ((list-derivers)
         (list-relatives valid-derivers))
        ((optimize)
         (assert-no-extra-arguments)
         (optimize-store store))
        ((verify)
         (assert-no-extra-arguments)
         (let ((options (assoc-ref opts 'verify-options)))
           (exit
            (verify-store store
                          #:check-contents? (memq 'contents options)
                          #:repair? (memq 'repair options)))))
        ((list-failures)
         (for-each (cut simple-format #t "~a~%" <>)
                   (query-failed-paths store)))
        ((clear-failures)
         (clear-failed-paths store (map direct-store-path paths)))
        ((list-dead)
         (for-each (cut simple-format #t "~a~%" <>)
                   (dead-paths store)))
        ((list-live)
         (for-each (cut simple-format #t "~a~%" <>)
                   (live-paths store)))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 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 git)
  #:use-module (ice-9 match)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:export (guix-git))

(define (show-help)
  (display (G_ "Usage: guix git COMMAND ARGS...
Operate on Git repositories.\n"))
  (newline)
  (display (G_ "The valid values for ACTION are:\n"))
  (newline)
  (display (G_ "\
   authenticate    verify commit signatures and authorizations\n"))
  (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 %sub-commands '("authenticate"))

(define (resolve-sub-command name)
  (let ((module (resolve-interface
                 `(guix scripts git ,(string->symbol name))))
        (proc (string->symbol (string-append "guix-git-" name))))
    (module-ref module proc)))

(define-command (guix-git . args)
  (category plumbing)
  (synopsis "operate on Git repositories")

  (with-error-handling
    (match args
      (()
       (format (current-error-port)
               (G_ "guix git: missing sub-command~%")))
      ((or ("-h") ("--help"))
       (show-help)
       (exit 0))
      ((or ("-V") ("--version"))
       (show-version-and-exit "guix git"))
      ((sub-command args ...)
       (if (member sub-command %sub-commands)
           (apply (resolve-sub-command sub-command) args)
           (format (current-error-port)
                   (G_ "guix git: invalid sub-command~%")))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 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 git authenticate)
  #:use-module (git)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module (guix git-authenticate)
  #:autoload   (guix openpgp) (openpgp-format-fingerprint
                               openpgp-public-key-fingerprint)
  #:use-module ((guix channels) #:select (openpgp-fingerprint))
  #:use-module ((guix git) #:select (with-git-error-handling))
  #:use-module (guix progress)
  #:use-module (guix base64)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:export (guix-git-authenticate))

;;; Commentary:
;;;
;;; Authenticate a Git checkout by reading '.guix-authorizations' files and
;;; following the "authorizations invariant" also used by (guix channels).
;;;
;;; Code:

(define %options
  ;; Specifications of the command-line options.
  (list (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix git authenticate")))

        (option '(#\r "repository") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'directory arg result)))
        (option '(#\e "end") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'end-commit (string->oid arg) result)))
        (option '(#\k "keyring") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'keyring-reference arg result)))
        (option '("cache-key") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'cache-key arg result)))
        (option '("historical-authorizations") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'historical-authorizations arg
                              result)))
        (option '("stats") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'show-stats? #t result)))))

(define %default-options
  '((directory . ".")
    (keyring-reference . "keyring")))

(define (show-stats stats)
  "Display STATS, an alist containing commit signing stats as returned by
'authenticate-repository'."
  (format #t (G_ "Signing statistics:~%"))
  (for-each (match-lambda
              ((signer . count)
               (format #t "  ~a ~10d~%"
                       (openpgp-format-fingerprint
                        (openpgp-public-key-fingerprint signer))
                       count)))
            (sort stats
                  (match-lambda*
                    (((_ . count1) (_ . count2))
                     (> count1 count2))))))

(define (show-help)
  (display (G_ "Usage: guix git authenticate COMMIT SIGNER [OPTIONS...]
Authenticate the given Git checkout using COMMIT/SIGNER as its introduction.\n"))
  (display (G_ "
  -r, --repository=DIRECTORY
                         open the Git repository at DIRECTORY"))
  (display (G_ "
  -k, --keyring=REFERENCE
                         load keyring from REFERENCE, a Git branch"))
  (display (G_ "
      --stats            display commit signing statistics upon completion"))
  (display (G_ "
      --cache-key=KEY    cache authenticated commits under KEY"))
  (display (G_ "
      --historical-authorizations=FILE
                         read historical authorizations from FILE"))
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

;;;
;;; Entry point.
;;;

(define (guix-git-authenticate . args)
  (define options
    (parse-command-line args %options (list %default-options)
                        #:build-options? #f))

  (define (command-line-arguments lst)
    (reverse (filter-map (match-lambda
                           (('argument . arg) arg)
                           (_ #f))
                         lst)))

  (define commit-short-id
    (compose (cut string-take <> 7) oid->string commit-id))

  (define (make-reporter start-commit end-commit commits)
    (format (current-error-port)
            (G_ "Authenticating commits ~a to ~a (~h new \
commits)...~%")
            (commit-short-id start-commit)
            (commit-short-id end-commit)
            (length commits))

    (if (isatty? (current-error-port))
        (progress-reporter/bar (length commits))
        progress-reporter/silent))

  (with-error-handling
    (with-git-error-handling
     (match (command-line-arguments options)
       ((commit signer)
        (let* ((directory   (assoc-ref options 'directory))
               (show-stats? (assoc-ref options 'show-stats?))
               (keyring     (assoc-ref options 'keyring-reference))
               (repository  (repository-open directory))
               (end         (match (assoc-ref options 'end-commit)
                              (#f  (reference-target
                                    (repository-head repository)))
                              (oid oid)))
               (history     (match (assoc-ref options 'historical-authorizations)
                              (#f '())
                              (file (call-with-input-file file
                                      read-authorizations))))
               (cache-key   (or (assoc-ref options 'cache-key)
                                (repository-cache-key repository))))
          (define stats
            (authenticate-repository repository (string->oid commit)
                                     (openpgp-fingerprint signer)
                                     #:end end
                                     #:keyring-reference keyring
                                     #:historical-authorizations history
                                     #:cache-key cache-key
                                     #:make-reporter make-reporter))

          (when (and show-stats? (not (null? stats)))
            (show-stats stats))))
       (_
        (leave (G_ "wrong number of arguments; \
expected COMMIT and SIGNER~%")))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; 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 graph)
  #:use-module (guix ui)
  #:use-module (guix graph)
  #:use-module (guix grafts)
  #:use-module (guix scripts)
  #:use-module (guix packages)
  #:use-module (guix monads)
  #:use-module (guix store)
  #:use-module (guix gexp)
  #:use-module (guix derivations)
  #:use-module (guix memoization)
  #:use-module (guix modules)
  #:use-module ((guix build-system gnu) #:select (standard-packages))
  #:use-module (gnu packages)
  #:use-module (guix sets)
  #:use-module ((guix diagnostics)
                #:select (location-file formatted-message))
  #:use-module ((guix scripts build)
                #:select (show-transformation-options-help
                          options->transformation
                          %standard-build-options
                          %transformation-options))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:export (%package-node-type
            %reverse-package-node-type
            %bag-node-type
            %bag-with-origins-node-type
            %bag-emerged-node-type
            %reverse-bag-node-type
            %derivation-node-type
            %reference-node-type
            %referrer-node-type
            %module-node-type
            %node-types

            guix-graph))

;;;
;;; Package DAG.
;;;

(define (node-full-name thing)
  "Return a human-readable name to denote THING, a package, origin, or file
name."
  (cond ((package? thing)
         (package-full-name thing))
        ((origin? thing)
         (origin-actual-file-name thing))
        ((string? thing)                          ;file name
         (or (basename thing)
             (error "basename" thing)))
        (else
         (number->string (object-address thing) 16))))

(define (package-node-edges package)
  "Return the list of dependencies of PACKAGE."
  (match (package-direct-inputs package)
    (((labels packages . outputs) ...)
     ;; Filter out origins and other non-package dependencies.
     (filter package? packages))))

(define assert-package
  (match-lambda
    ((? package? package)
     package)
    (x
     (raise
      (formatted-message (G_ "~a: invalid argument (package name expected)")
                         x)))))

(define nodes-from-package
  ;; The default conversion method.
  (lift1 (compose list assert-package) %store-monad))

(define %package-node-type
  ;; Type for the traversal of package nodes.
  (node-type
   (name "package")
   (description "the DAG of packages, excluding implicit inputs")
   (convert nodes-from-package)

   ;; We use package addresses as unique identifiers.  This generally works
   ;; well, but for generated package objects, we could end up with two
   ;; packages that are not 'eq?', yet map to the same derivation (XXX).
   (identifier (lift1 object-address %store-monad))
   (label node-full-name)
   (edges (lift1 package-node-edges %store-monad))))

;;;
;;; Reverse package DAG.
;;;

(define (all-packages)            ;XXX: duplicated from (guix scripts refresh)
  "Return the list of all the distro's packages."
  (fold-packages (lambda (package result)
                   ;; Ignore deprecated packages.
                   (if (package-superseded package)
                       result
                       (cons package result)))
                 '()
                 #:select? (const #t)))           ;include hidden packages

(define %reverse-package-node-type
  ;; For this node type we first need to compute the list of packages and the
  ;; list of back-edges.  Since we want to do it only once, we use the
  ;; promises below.
  (let* ((packages   (delay (all-packages)))
         (back-edges (delay (run-with-store #f    ;store not actually needed
                              (node-back-edges %package-node-type
                                               (force packages))))))
    (node-type
     (inherit %package-node-type)
     (name "reverse-package")
     (description "the reverse DAG of packages")
     (edges (lift1 (force back-edges) %store-monad)))))

;;;
;;; Package DAG using bags.
;;;

(define (bag-node-identifier thing)
  "Return a unique identifier for THING, which may be a package, origin, or a
file name."
  ;; If THING is a file name (a string), we just return it; if it's a package
  ;; or origin, we return its address.  That gives us the object graph, but
  ;; that may differ from the derivation graph (for instance,
  ;; 'package-with-bootstrap-guile' generates fresh package objects, and
  ;; several packages that are not 'eq?' may actually map to the same
  ;; derivation.)  Thus, we lower THING and use its derivation file name as a
  ;; unique identifier.
  (with-monad %store-monad
    (if (string? thing)
        (return thing)
        (mlet %store-monad ((low (lower-object thing)))
          (return (if (derivation? low)
                      (derivation-file-name low)
                      low))))))

(define (bag-node-edges thing)
  "Return the list of dependencies of THING, a package or origin.
Dependencies may include packages, origin, and file names."
  (cond ((package? thing)
         (match (bag-direct-inputs (package->bag thing))
           (((labels things . outputs) ...)
            things)))
        ((origin? thing)
         (cons (or (origin-patch-guile thing) (default-guile))
               (if (or (pair? (origin-patches thing))
                       (origin-snippet thing))
                   (match (origin-patch-inputs thing)
                     (#f '())
                     (((labels dependencies _ ...) ...)
                      (delete-duplicates dependencies eq?)))
                   '())))
        (else
         '())))

(define %bag-node-type
  ;; Type for the traversal of package nodes via the "bag" representation,
  ;; which includes implicit inputs.
  (node-type
   (name "bag")
   (description "the DAG of packages, including implicit inputs")
   (convert nodes-from-package)
   (identifier bag-node-identifier)
   (label node-full-name)
   (edges (lift1 (compose (cut filter package? <>) bag-node-edges)
                 %store-monad))))

(define %bag-with-origins-node-type
  (node-type
   (name "bag-with-origins")
   (description "the DAG of packages and origins, including implicit inputs")
   (convert nodes-from-package)
   (identifier bag-node-identifier)
   (label node-full-name)
   (edges (lift1 (lambda (thing)
                   (filter (match-lambda
                             ((? package?) #t)
                             ((? origin?)  #t)
                             (_            #f))
                           (bag-node-edges thing)))
                 %store-monad))))

(define standard-package-set
  (mlambda ()
    "Return the set of standard packages provided by GNU-BUILD-SYSTEM."
    (match (standard-packages)
      (((labels packages . output) ...)
       (list->setq packages)))))

(define (bag-node-edges-sans-bootstrap thing)
  "Like 'bag-node-edges', but pretend that the standard packages of
GNU-BUILD-SYSTEM have zero dependencies."
  (if (set-contains? (standard-package-set) thing)
      '()
      (bag-node-edges thing)))

(define %bag-emerged-node-type
  ;; Like %BAG-NODE-TYPE, but without the bootstrap subset of the DAG.
  (node-type
   (name "bag-emerged")
   (description "same as 'bag', but without the bootstrap nodes")
   (convert nodes-from-package)
   (identifier bag-node-identifier)
   (label node-full-name)
   (edges (lift1 (compose (cut filter package? <>)
                          bag-node-edges-sans-bootstrap)
                 %store-monad))))

(define %reverse-bag-node-type
  ;; Type for the reverse traversal of package nodes via the "bag"
  ;; representation, which includes implicit inputs.
  (let* ((packages   (delay (package-closure (all-packages))))
         (back-edges (delay (run-with-store #f    ;store not actually needed
                              (node-back-edges %bag-node-type
                                               (force packages))))))
    (node-type
     (name "reverse-bag")
     (description "the reverse DAG of packages, including implicit inputs")
     (convert nodes-from-package)
     (identifier bag-node-identifier)
     (label node-full-name)
     (edges (lift1 (force back-edges) %store-monad)))))

;;;
;;; Derivation DAG.
;;;

(define (derivation-dependencies obj)
  "Return the <derivation> objects and store items corresponding to the
dependencies of OBJ, a <derivation> or store item."
  (if (derivation? obj)
      (append (map derivation-input-derivation (derivation-inputs obj))
              (derivation-sources obj))
      '()))

(define (derivation-node-identifier node)
  "Return a unique identifier for NODE, which may be either a <derivation> or
a plain store file."
  (if (derivation? node)
      (derivation-file-name node)
      node))

(define (derivation-node-label node)
  "Return a label for NODE, a <derivation> object or plain store item."
  (store-path-package-name (match node
                             ((? derivation? drv)
                              (derivation-file-name drv))
                             ((? string? file)
                              file))))

(define %derivation-node-type
  ;; DAG of derivations.  Very accurate, very detailed, but usually too much
  ;; detailed.
  (node-type
   (name "derivation")
   (description "the DAG of derivations")
   (convert (match-lambda
              ((? package? package)
               (with-monad %store-monad
                 (>>= (package->derivation package)
                      (lift1 list %store-monad))))
              ((? derivation-path? item)
               (mbegin %store-monad
                 ((store-lift add-temp-root) item)
                 (return (list (read-derivation-from-file item)))))
              (x
               (raise
                (condition (&message (message "unsupported argument for \
derivation graph")))))))
   (identifier (lift1 derivation-node-identifier %store-monad))
   (label derivation-node-label)
   (edges (lift1 derivation-dependencies %store-monad))))

;;;
;;; DAG of residual references (aka. run-time dependencies).
;;;

(define intern
  (mlambda (str)
    "Intern STR, a string denoting a store item."
    ;; This is necessary for %REFERENCE-NODE-TYPE and %REFERRER-NODE-TYPE
    ;; because their nodes are strings but the (guix graph) traversal
    ;; procedures expect to be able to compare nodes with 'eq?'.
    str))

(define ensure-store-items
  ;; Return a list of store items as a monadic value based on the given
  ;; argument, which may be a store item or a package.
  (match-lambda
    ((? package? package)
     ;; Return the output file names of PACKAGE.
     (mlet %store-monad ((drv (package->derivation package)))
       (return (match (derivation->output-paths drv)
                 (((_ . file-names) ...)
                  (map intern file-names))))))
    ((? store-path? item)
     (with-monad %store-monad
       (return (list (intern item)))))
    (x
     (raise
      (condition (&message (message "unsupported argument for \
this type of graph")))))))

(define (references* item)
  "Return as a monadic value the references of ITEM, based either on the
information available in the local store or using information about
substitutes."
  (lambda (store)
    (guard (c ((store-protocol-error? c)
               (match (substitutable-path-info store (list item))
                 ((info)
                  (values (map intern (substitutable-references info))
                          store))
                 (()
                  (leave (G_ "references for '~a' are not known~%")
                         item)))))
      (values (map intern (references store item)) store))))

(define %reference-node-type
  (node-type
   (name "references")
   (description "the DAG of run-time dependencies (store references)")
   (convert ensure-store-items)
   (identifier (lift1 intern %store-monad))
   (label store-path-package-name)
   (edges references*)))

(define non-derivation-referrers
  (let ((referrers (store-lift referrers)))
    (lambda (item)
      "Return the referrers of ITEM, except '.drv' files."
      (mlet %store-monad ((items (referrers item)))
        (return (map intern (remove derivation-path? items)))))))

(define %referrer-node-type
  (node-type
   (name "referrers")
   (description "the DAG of referrers in the store")
   (convert ensure-store-items)
   (identifier (lift1 intern %store-monad))
   (label store-path-package-name)
   (edges non-derivation-referrers)))

;;;
;;; Scheme modules.
;;;

(define (module-from-package package)
  (file-name->module-name (location-file (package-location package))))

(define (source-module-dependencies* module)
  "Like 'source-module-dependencies' but filter out modules that are not
package modules, while attempting to retain user package modules."
  (remove (match-lambda
            (('guix _ ...) #t)
            (('system _ ...) #t)
            (('language _ ...) #t)
            (('ice-9 _ ...) #t)
            (('srfi _ ...) #t)
            (_ #f))
          (source-module-dependencies module)))

(define %module-node-type
  ;; Show the graph of package modules.
  (node-type
   (name "module")
   (description "the graph of package modules")
   (convert (lift1 (compose list module-from-package) %store-monad))
   (identifier (lift1 identity %store-monad))
   (label object->string)
   (edges (lift1 source-module-dependencies* %store-monad))))

;;;
;;; List of node types.
;;;

(define %node-types
  ;; List of all the node types.
  (list %package-node-type
        %reverse-package-node-type
        %bag-node-type
        %bag-with-origins-node-type
        %bag-emerged-node-type
        %reverse-bag-node-type
        %derivation-node-type
        %reference-node-type
        %referrer-node-type
        %module-node-type))

(define (lookup-node-type name)
  "Return the node type called NAME.  Raise an error if it is not found."
  (or (find (lambda (type)
              (string=? (node-type-name type) name))
            %node-types)
      (leave (G_ "~a: unknown node type~%") name)))

(define (lookup-backend name)
  "Return the graph backend called NAME.  Raise an error if it is not found."
  (or (find (lambda (backend)
              (string=? (graph-backend-name backend) name))
            %graph-backends)
      (leave (G_ "~a: unknown backend~%") name)))

(define (list-node-types)
  "Print the available node types along with their synopsis."
  (display (G_ "The available node types are:\n"))
  (newline)
  (for-each (lambda (type)
              (format #t "  - ~a: ~a~%"
                      (node-type-name type)
                      (node-type-description type)))
            %node-types))

(define (list-backends)
  "Print the available backends along with their synopsis."
  (display (G_ "The available backend types are:\n"))
  (newline)
  (for-each (lambda (backend)
              (format #t "  - ~a: ~a~%"
                      (graph-backend-name backend)
                      (graph-backend-description backend)))
            %graph-backends))

;;;
;;; Displaying a path.
;;;

(define (display-path node1 node2 type)
  "Display the shortest path from NODE1 to NODE2, of TYPE."
  (mlet %store-monad ((path (shortest-path node1 node2 type)))
    (define node-label
      (let ((label (node-type-label type)))
        ;; Special-case derivations and store items to print them in full,
        ;; contrary to what their 'node-type-label' normally does.
        (match-lambda
          ((? derivation? drv) (derivation-file-name drv))
          ((? string? str) str)
          (node (label node)))))

    (if path
        (format #t "~{~a~%~}" (map node-label path))
        (leave (G_ "no path from '~a' to '~a'~%")
               (node-label node1) (node-label node2)))
    (return #t)))

;;;
;;; Command-line options.
;;;

(define %options
  (cons* (option '(#\t "type") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'node-type (lookup-node-type arg)
                               result)))
         (option '("path") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'path? #t result)))
         (option '("list-types") #f #f
                 (lambda (opt name arg result)
                   (list-node-types)
                   (exit 0)))
         (option '(#\b "backend") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'backend (lookup-backend arg)
                               result)))
         (option '("list-backends") #f #f
                 (lambda (opt name arg result)
                   (list-backends)
                   (exit 0)))
         (option '(#\e "expression") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'expression arg result)))
         (option '(#\s "system") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'system arg
                               (alist-delete 'system result eq?))))
         (find (lambda (option)
                (member "load-path" (option-names option)))
              %standard-build-options)
         (option '(#\h "help") #f #f
                 (lambda args
                   (show-help)
                   (exit 0)))
         (option '(#\V "version") #f #f
                 (lambda args
                   (show-version-and-exit "guix graph")))

         %transformation-options))

(define (show-help)
  ;; TRANSLATORS: Here 'dot' is the name of a program; it must not be
  ;; translated.
  (display (G_ "Usage: guix graph PACKAGE...
Emit a representation of the dependency graph of PACKAGE...\n"))
  (display (G_ "
  -b, --backend=TYPE     produce a graph with the given backend TYPE"))
  (display (G_ "
      --list-backends    list the available graph backends"))
  (display (G_ "
  -t, --type=TYPE        represent nodes of the given TYPE"))
  (display (G_ "
      --list-types       list the available graph types"))
  (display (G_ "
      --path             display the shortest path between the given nodes"))
  (display (G_ "
  -e, --expression=EXPR  consider the package EXPR evaluates to"))
  (display (G_ "
  -s, --system=SYSTEM    consider the graph for SYSTEM--e.g., \"i686-linux\""))
  (newline)
  (display (G_ "
  -L, --load-path=DIR    prepend DIR to the package module search path"))
  (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 %default-options
  `((node-type . ,%package-node-type)
    (backend   . ,%graphviz-backend)
    (system    . ,(%current-system))))

;;;
;;; Entry point.
;;;

(define-command (guix-graph . args)
  (category packaging)
  (synopsis "view and query package dependency graphs")

  (with-error-handling
    (define opts
      (parse-command-line args %options
                          (list %default-options)
                          #:build-options? #f))
    (define backend
      (assoc-ref opts 'backend))
    (define type
      (assoc-ref opts 'node-type))

    (with-store store
      (let* ((transform (options->transformation opts))
             (items     (filter-map (match-lambda
                                      (('argument . (? store-path? item))
                                       item)
                                      (('argument . spec)
                                       (transform store
                                                  (specification->package spec)))
                                      (('expression . exp)
                                       (transform store
                                                  (read/eval-package-expression exp)))
                                      (_ #f))
                                    opts)))
        (run-with-store store
          ;; XXX: Since grafting can trigger unsolicited builds, disable it.
          (mlet %store-monad ((_     (set-grafting #f))
                              (nodes (mapm %store-monad
                                           (node-type-convert type)
                                           (reverse items))))
            (if (assoc-ref opts 'path?)
                (match nodes
                  (((node1 _ ...) (node2 _ ...))
                   (display-path node1 node2 type))
                  (_
                   (leave (G_ "'--path' option requires exactly two \
nodes (given ~a)~%")
                          (length nodes))))
                (export-graph (concatenate nodes)
                              (current-output-port)
                              #:node-type type
                              #:backend backend)))
          #:system (assq-ref opts 'system)))))
  #t)

;;; graph.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018 Tim Gesthuizen <tim.gesthuizen@yahoo.de>
;;;
;;; 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 hash)
  #:use-module (gcrypt hash)
  #:use-module (guix serialization)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module (guix base16)
  #:use-module (guix base32)
  #:autoload   (guix base64) (base64-encode)
  #:use-module (ice-9 binary-ports)
  #:use-module (rnrs files)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:export (guix-hash))

;;;
;;; Command-line options.
;;;

(define %default-options
  ;; Alist of default option values.
  `((format . ,bytevector->nix-base32-string)
    (hash-algorithm . ,(hash-algorithm sha256))))

(define (show-help)
  (display (G_ "Usage: guix hash [OPTION] FILE
Return the cryptographic hash of FILE.\n"))
  (newline)
  (display (G_ "\
Supported formats: 'base64', 'nix-base32' (default), 'base32',
and 'base16' ('hex' and 'hexadecimal' can be used as well).\n"))
  (format #t (G_ "
  -x, --exclude-vcs      exclude version control directories"))
  (format #t (G_ "
  -H, --hash=ALGORITHM   use the given hash ALGORITHM"))
  (format #t (G_ "
  -f, --format=FMT       write the hash in the given format"))
  (format #t (G_ "
  -r, --recursive        compute the hash on FILE recursively"))
  (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 %options
  ;; Specification of the command-line options.
  (list (option '(#\x "exclude-vcs") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'exclude-vcs? #t result)))
        (option '(#\H "hash") #t #f
                (lambda (opt name arg result)
                  (match (lookup-hash-algorithm (string->symbol arg))
                    (#f
                     (leave (G_ "~a: unknown hash algorithm~%") arg))
                    (algo
                     (alist-cons 'hash-algorithm algo result)))))
        (option '(#\f "format") #t #f
                (lambda (opt name arg result)
                  (define fmt-proc
                    (match arg
                      ("base64"
                       base64-encode)
                      ("nix-base32"
                       bytevector->nix-base32-string)
                      ("base32"
                       bytevector->base32-string)
                      ((or "base16" "hex" "hexadecimal")
                       bytevector->base16-string)
                      (x
                       (leave (G_ "unsupported hash format: ~a~%")
                              arg))))

                  (alist-cons 'format fmt-proc
                              (alist-delete 'format result))))
        (option '(#\r "recursive") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'recursive? #t result)))
        (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix hash")))))

;;;
;;; Entry point.
;;;

(define-command (guix-hash . args)
  (category packaging)
  (synopsis "compute the cryptographic hash of a file")

  (define (parse-options)
    ;; Return the alist of option values.
    (parse-command-line args %options (list %default-options)
                        #:build-options? #f))

  (define (vcs-file? file stat)
    (case (stat:type stat)
      ((directory)
       (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
      ((regular)
       ;; Git sub-modules have a '.git' file that is a regular text file.
       (string=? (basename file) ".git"))
      (else
       #f)))

  (let* ((opts (parse-options))
         (args (filter-map (match-lambda
                            (('argument . value)
                             value)
                            (_ #f))
                           (reverse opts)))
         (fmt  (assq-ref opts 'format))
         (select? (if (assq-ref opts 'exclude-vcs?)
                      (negate vcs-file?)
                      (const #t))))

    (define (file-hash file)
      ;; Compute the hash of FILE.
      ;; Catch and gracefully report possible '&nar-error' conditions.
      (with-error-handling
        (if (assoc-ref opts 'recursive?)
            (let-values (((port get-hash) (open-sha256-port)))
              (write-file file port #:select? select?)
              (force-output port)
              (get-hash))
            (match file
              ("-" (port-hash (assoc-ref opts 'hash-algorithm)
                              (current-input-port)))
              (_   (call-with-input-file file
                     (cute port-hash (assoc-ref opts 'hash-algorithm)
                           <>)))))))

    (match args
      ((file)
       (catch 'system-error
         (lambda ()
           (format #t "~a~%" (fmt (file-hash file))))
         (lambda args
           (leave (G_ "~a~%")
                  (strerror (system-error-errno args))))))
      (x
       (leave (G_ "wrong number of arguments~%"))))))