code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 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 copy)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module (guix ssh)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix scripts build)
  #:use-module ((guix scripts archive) #:select (options->derivations+files))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:export (guix-copy))

;;;
;;; Exchanging store items over SSH.
;;;

(define (ssh-spec->user+host+port spec)
  "Parse SPEC, a string like \"user@host:port\" or just \"host\", and return
three values: the user name (or #f), the host name, and the TCP port
number (or #f) corresponding to SPEC."
  (define tokens
    (char-set #\@ #\:))

  (match (string-tokenize spec (char-set-complement tokens))
    ((host)
     (values #f host #f))
    ((left right)
     (if (string-index spec #\@)
         (values left right #f)
         (values #f left (string->number right))))
    ((user host port)
     (match (string->number port)
       ((? integer? port)
        (values user host port))
       (x
        (leave (G_ "~a: invalid TCP port number~%") port))))
    (x
     (leave (G_ "~a: invalid SSH specification~%") spec))))

(define (send-to-remote-host target opts)
  "Send ITEMS to TARGET.  ITEMS is a list of store items or package names; for ;
package names, build the underlying packages before sending them."
  (with-store local
    (set-build-options-from-command-line local opts)
    (let-values (((user host port)
                  (ssh-spec->user+host+port target))
                 ((drv items)
                  (options->derivations+files local opts)))
      (show-what-to-build local drv
                          #:use-substitutes? (assoc-ref opts 'substitutes?)
                          #:dry-run? (assoc-ref opts 'dry-run?))

      (and (or (assoc-ref opts 'dry-run?)
               (build-derivations local drv))
           (let* ((session (open-ssh-session host #:user user
                                             #:port (or port 22)))
                  (sent    (send-files local items
                                       (connect-to-remote-daemon session)
                                       #:recursive? #t)))
             (format #t "~{~a~%~}" sent)
             sent)))))

(define (retrieve-from-remote-host source opts)
  "Retrieve ITEMS from SOURCE."
  (with-store local
    (let*-values (((user host port)
                   (ssh-spec->user+host+port source))
                  ((session)
                   (open-ssh-session host #:user user #:port (or port 22)))
                  ((remote)
                   (connect-to-remote-daemon session)))
      (set-build-options-from-command-line local opts)
      ;; TODO: Here we could to compute and build the derivations on REMOTE
      ;; rather than on LOCAL (one-off offloading) but that is currently too
      ;; slow due to the many RPC round trips.  So we just assume that REMOTE
      ;; contains ITEMS.
      (let*-values (((drv items)
                     (options->derivations+files local opts))
                    ((retrieved)
                     (retrieve-files local items remote #:recursive? #t)))
        (format #t "~{~a~%~}" retrieved)
        retrieved))))

;;;
;;; Options.
;;;

(define (show-help)
  (display (G_ "Usage: guix copy [OPTION]... ITEMS...
Copy ITEMS to or from the specified host over SSH.\n"))
  (display (G_ "
      --to=HOST          send ITEMS to HOST"))
  (display (G_ "
      --from=HOST        receive ITEMS from HOST"))
  (newline)
  (show-build-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 %options
  ;; Specifications of the command-line options.
  (cons* (option '("to") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'destination arg result)))
         (option '("from") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'source arg result)))
         (option '(#\h "help") #f #f
                 (lambda args
                   (show-help)
                   (exit 0)))
         (option '(#\V "version") #f #f
                 (lambda args
                   (show-version-and-exit "guix copy")))
         (option '(#\s "system") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'system arg
                               (alist-delete 'system result eq?))))
         %standard-build-options))

(define %default-options
  `((system . ,(%current-system))
    (substitutes? . #t)
    (build-hook? . #t)
    (graft? . #t)
    (verbosity . 0)))

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

(define (guix-copy . args)
  (with-error-handling
    (let* ((opts     (parse-command-line args %options (list %default-options)))
           (source   (assoc-ref opts 'source))
           (target   (assoc-ref opts 'destination)))
      (cond (target (send-to-remote-host target opts))
            (source (retrieve-from-remote-host source opts))
            (else   (leave (G_ "use '--to' or '--from'~%")))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 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 describe)
  #:use-module ((guix ui) #:hide (display-profile-content))
  #:use-module (guix scripts)
  #:use-module (guix describe)
  #:use-module (guix profiles)
  #:use-module ((guix scripts pull) #:select (display-profile-content))
  #:use-module (git)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 match)
  #:autoload   (ice-9 pretty-print) (pretty-print)
  #:export (guix-describe))

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

(define %options
  ;; Specifications of the command-line options.
  (list (option '(#\f "format") #t #f
                (lambda (opt name arg result)
                  (unless (member arg '("human" "channels"))
                    (leave (G_ "~a: unsupported output format~%") arg))
                  (alist-cons 'format 'channels result)))
        (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix describe")))))

(define %default-options
  ;; Alist of default option values.
  '((format . human)))

(define (show-help)
  (display (G_ "Usage: guix describe [OPTION]...
Display information about the channels currently in use.\n"))
  (display (G_ "
  -f, --format=FORMAT    display information in the given FORMAT"))
  (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 (display-package-search-path fmt)
  "Display GUIX_PACKAGE_PATH, if it is set, according to FMT."
  (match (getenv "GUIX_PACKAGE_PATH")
    (#f #t)
    (string
     (match fmt
       ('human
        (format #t "~%GUIX_PACKAGE_PATH=\"~a\"~%" string))
       ('channels
        (format #t (G_ "~%;; warning: GUIX_PACKAGE_PATH=\"~a\"~%")
                string))))))

(define (display-checkout-info fmt)
  "Display information about the current checkout according to FMT, a symbol
denoting the requested format.  Exit if the current directory does not lie
within a Git checkout."
  (let* ((program    (car (command-line)))
         (directory  (catch 'git-error
                       (lambda ()
                         (repository-discover (dirname program)))
                       (lambda (key err)
                         (leave (G_ "failed to determine origin~%")))))
         (repository (repository-open directory))
         (head       (repository-head repository))
         (commit     (oid->string (reference-target head))))
    (match fmt
      ('human
       (format #t (G_ "Git checkout:~%"))
       (format #t (G_ "  repository: ~a~%") (dirname directory))
       (format #t (G_ "  branch: ~a~%") (reference-shorthand head))
       (format #t (G_ "  commit: ~a~%") commit))
      ('channels
       (pretty-print `(list (channel
                             (name 'guix)
                             (url ,(dirname directory))
                             (commit ,commit))))))
    (display-package-search-path fmt)))

(define (display-profile-info profile fmt)
  "Display information about PROFILE, a profile as created by (guix channels),
in the format specified by FMT."
  (define number
    (generation-number profile))

  (match fmt
    ('human
     (display-profile-content profile number))
    ('channels
     (pretty-print
      `(list ,@(map (lambda (entry)
                      (match (assq 'source (manifest-entry-properties entry))
                        (('source ('repository ('version 0)
                                               ('url url)
                                               ('branch branch)
                                               ('commit commit)
                                               _ ...))
                         `(channel (name ',(string->symbol
                                            (manifest-entry-name entry)))
                                   (url ,url)
                                   (commit ,commit)))

                        ;; Pre-0.15.0 Guix does not provide that information,
                        ;; so there's not much we can do in that case.
                        (_ '???)))

                    ;; Show most recently installed packages last.
                    (reverse
                     (manifest-entries
                      (profile-manifest
                       (if (zero? number)
                           profile
                           (generation-file-name profile number))))))))))
  (display-package-search-path fmt))

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

(define (guix-describe . args)
  (let* ((opts   (args-fold* args %options
                             (lambda (opt name arg result)
                               (leave (G_ "~A: unrecognized option~%")
                                      name))
                             cons
                             %default-options))
         (format (assq-ref opts 'format)))
    (with-error-handling
      (match (current-profile)
        (#f
         (display-checkout-info format))
        (profile
         (display-profile-info (canonicalize-profile profile) format))))))

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2015, 2016, 2017 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)
  #: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-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* (download-to-store* url #:key (verify-certificate? #t))
  (with-store store
    (download-to-store store url
                       #:verify-certificate? verify-certificate?)))

(define %default-options
  ;; Alist of default option values.
  `((format . ,bytevector->nix-base32-string)
    (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.

Supported formats: '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_ "
      --no-check-certificate
                         do not validate the certificate of HTTPS servers "))
  (format #f (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
                      ("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 '("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 (guix-download . args)
  (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))
                    port-sha256))
           (fmt   (assq-ref opts 'format)))
      (format #t "~a~%~a~%" path (fmt hash))
      #t)))


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

(define %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 edit")))))

(define (show-help)
  (display (G_ "Usage: guix edit PACKAGE...
Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\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 %editor
  ;; XXX: It would be better to default to something more likely to be
  ;; pre-installed on an average GNU system.  Since Nano is not suited for
  ;; editing Scheme, Emacs is used instead.
  (make-parameter (or (getenv "VISUAL") (getenv "EDITOR") "emacs")))

(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 (package->location-specification package)
  "Return the location specification for PACKAGE for a typical editor command
line."
  (let ((loc (package-location package)))
    (list (string-append "+"
                         (number->string
                          (location-line loc)))
          (search-path* %load-path (location-file loc)))))

(define (guix-edit . args)
  (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)))
           (packages (map specification->package specs)))
      (for-each (lambda (package)
                  (unless (package-location package)
                    (leave (G_ "source location of package '~a' is unknown~%")
                           (package-full-name package))))
                packages)

      (catch 'system-error
        (lambda ()
          (let ((file-names (append-map package->location-specification
                                        packages)))
            ;; 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))))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org>
;;; Copyright © 2015, 2016, 2017, 2018 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)
  #: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-inputs))
  #:use-module (guix scripts)
  #:use-module (guix scripts build)
  #:use-module (gnu build linux-container)
  #: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 commencement)
  #:use-module (gnu packages guile)
  #:use-module ((gnu packages bootstrap) #:select (%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 (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)
  "Unset almost all environment variables.  A small number of variables such
as 'HOME' and 'USER' are left untouched."
  (for-each unsetenv
            (remove (cut member <> %precious-variables)
                    (match (get-environment-variables)
                      (((names . _) ...)
                       names)))))

(define* (create-environment profile manifest #:key pure?)
  "Set the environment variables specified by MANIFEST for PROFILE.  When PURE?
is #t, unset the variables in the current environment.  Otherwise, augment
existing environment variables with additional search paths."
  (when pure? (purify-environment))
  (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_ "
      --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_ "
      --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_ "
      --bootstrap        use bootstrap binaries to build the environment"))
  (newline)
  (show-build-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)
    (build-hook? . #t)
    (graft? . #t)
    (print-build-trace? . #t)
    (print-extended-build-trace? . #t)
    (verbosity . 0)))

(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 "exec") #t #f ; deprecated
                 (lambda (opt name arg result)
                   (alist-cons 'exec (list %default-shell "-c" 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 (alist-cons 'graft? #f 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 '("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 '("bootstrap") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'bootstrap? #t result)))
         %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 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 (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
                    (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* (build-environment derivations opts)
  "Build the DERIVATIONS required by the environment using the build options
in OPTS."
  (let ((substitutes? (assoc-ref opts 'substitutes?))
        (dry-run?     (assoc-ref opts 'dry-run?)))
    (mbegin %store-monad
      (show-what-to-build* derivations
                           #:use-substitutes? substitutes?
                           #:dry-run? dry-run?)
      (if dry-run?
          (return #f)
          (built-derivations derivations)))))

(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 (sequence %store-monad
                                      (map 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?)
  "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."
  ;; Properly handle SIGINT, so pressing C-c in an interactive terminal
  ;; application works.
  (sigaction SIGINT SIG_DFL)
  (create-environment profile manifest #:pure? pure?)
  (match command
    ((program . args)
     (apply execlp program program args))))

(define* (launch-environment/fork command profile manifest #:key pure?)
  "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."
  (match (primitive-fork)
    (0 (launch-environment command profile manifest
                           #:pure? pure?))
    (pid (match (waitpid pid)
           ((_ . status) status)))))

(define* (launch-environment/container #:key command bash user user-mappings
                                       profile manifest link-profile? network?)
  "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."
  (mlet %store-monad ((reqs (inputs->requisites
                             (list (direct-store-path bash) profile))))
    (return
     (let* ((cwd      (getcwd))
            (home     (getenv "HOME"))
            (passwd   (mock-passwd (getpwuid (getuid))
                                   user
                                   bash))
            (home-dir (passwd:dir passwd))
            ;; Bind-mount all requisite store items, user-specified mappings,
            ;; /bin/sh, the current working directory, and possibly networking
            ;; configuration files within the container.
            (mappings
             (override-user-mappings
              user home
              (append user-mappings
                      ;; Current working directory.
                      (list (file-system-mapping
                             (source cwd)
                             (target cwd)
                             (writable? #t)))
                      ;; When in Rome, do as Nix build.cc does: Automagically
                      ;; map common network configuration files.
                      (if network?
                          %network-file-mappings
                          '())
                      ;; 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
                                  (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"))

            ;; 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")
            (call-with-output-file "/etc/passwd"
              (lambda (port)
                (display (string-join (list (passwd:name passwd)
                                            "x" ; but there is no shadow
                                            "0" "0" ; user is now root
                                            (passwd:gecos passwd)
                                            (passwd:dir passwd)
                                            bash)
                                      ":")
                         port)
                (newline port)))

            ;; For convenience, start in the user's current working
            ;; directory rather than the root directory.
            (chdir (override-user-dir user home cwd))

            (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)))
          #:namespaces (if network?
                           (delq 'net %namespaces) ; share host network
                           %namespaces)))))))

(define (mock-passwd passwd user-override shell)
  "Generate mock information for '/etc/passwd'.  If USER-OVERRIDE is not '#f',
it is expected to be a string representing the mock username; it will produce
a user of that name, with a home directory of '/home/USER-OVERRIDE', and no
GECOS field.  If USER-OVERRIDE is '#f', data will be inherited from PASSWD.
In either case, the shadow password and UID/GID are cleared, since the user
runs as root within the container.  SHELL will always be used in place of the
shell in PASSWD.

The resulting vector is suitable for use with Guile's POSIX user procedures.

See passwd(5) for more information each of the fields."
  (if user-override
      (vector
       user-override
        "x" "0" "0"  ;; no shadow, user is now root
        ""           ;; no personal information
        (user-override-home user-override)
        shell)
      (vector
       (passwd:name passwd)
        "x" "0" "0"  ;; no shadow, user is now root
        (passwd:gecos passwd)
        (passwd:dir passwd)
        shell)))

(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?)
      (interned-file
       (search-bootstrap-binary "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 (guix-environment . args)
  (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?))
           (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))))
           (manifest   (options/resolve-packages opts))
           (mappings   (pick-all opts 'file-system-mapping)))

      (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'~%")))

      (with-store store
        (with-status-report print-build-event
          (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
                               (canonical-package guile-2.2)))))
            (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
                  (build-environment (if (derivation? bash)
                                         (list prof-drv bash)
                                         (list prof-drv))
                                     opts)
                  (mwhen gc-root
                    (register-gc-root profile gc-root))

                  (cond
                   ((assoc-ref opts 'dry-run?)
                    (return #t))
                   ((assoc-ref opts 'search-paths)
                    (show-search-paths profile manifest #:pure? pure?)
                    (return #t))
                   (container?
                    (let ((bash-binary
                           (if bootstrap?
                               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
                                                    #:link-profile? link-prof?
                                                    #:network? network?)))
                   (else
                    (return
                     (exit/status
                      (launch-environment/fork command profile manifest
                                               #:pure? pure?))))))))))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018 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)
  #:autoload   (guix build syscalls) (free-disk-space)
  #: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           attempt to delete PATHS"))
  (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 %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
                (lambda (opt name arg result)
                  (alist-cons 'action 'delete
                              (alist-delete 'action 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-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 (guix-gc . args)
  (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)))))

  (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)))
           (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.)))))))
        ((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 © 2015, 2016, 2017, 2018 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 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 utils) #:select (location-file))
  #: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 match)
  #:export (%package-node-type
            %reverse-package-node-type
            %bag-node-type
            %bag-with-origins-node-type
            %bag-emerged-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
      (condition
       (&message
        (message (format #f (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 %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 (fold-packages cons '())))
         (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))))

;;;
;;; 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 (compose read-derivation-from-file derivation-input-path)
                   (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 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) ...)
                  file-names)))))
    ((? store-path? item)
     (with-monad %store-monad
       (return (list 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 ((nix-protocol-error? c)
               (match (substitutable-path-info store (list item))
                 ((info)
                  (values (substitutable-references info) store))
                 (()
                  (leave (G_ "references for '~a' are not known~%")
                         item)))))
      (values (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 identity %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 (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 identity %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
        %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))

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

(define %options
  (list (option '(#\t "type") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'node-type (lookup-node-type arg)
                              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?))))
        (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)
  ;; 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_ "
  -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_ "
  -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 (guix-graph . args)
  (with-error-handling
    (let* ((opts     (parse-command-line args %options
                                         (list %default-options)
                                         #:build-options? #f))
           (backend  (assoc-ref opts 'backend))
           (type     (assoc-ref opts 'node-type))
           (items    (filter-map (match-lambda
                                   (('argument . (? store-path? item))
                                    item)
                                   (('argument . spec)
                                    (specification->package spec))
                                   (('expression . exp)
                                    (read/eval-package-expression exp))
                                   (_ #f))
                                 opts)))
      (with-store store
        ;; Ask for absolute file names so that .drv file names passed from the
        ;; user to 'read-derivation' are absolute when it returns.
        (with-fluids ((%file-port-name-canonicalization 'absolute))
          (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)
                                             items)))
              (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 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@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 hash)
  #:use-module (guix base32)
  #:use-module (gcrypt hash)
  #:use-module (guix serialization)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module (guix base16)
  #: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)))

(define (show-help)
  (display (G_ "Usage: gcrypt hash [OPTION] FILE
Return the cryptographic hash of FILE.

Supported formats: '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_ "
  -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 '(#\f "format") #t #f
                (lambda (opt name arg result)
                  (define fmt-proc
                    (match arg
                      ("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 "gcrypt hash")))))

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

(define (guix-hash . args)
  (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-sha256 (current-input-port)))
              (_   (call-with-input-file file port-sha256))))))

    (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~%"))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.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 import)
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  #:export (%standard-import-options
            guix-import))

;;;
;;; Helper.
;;;

(define (newline-rewriting-port output)
  "Return an output port that rewrites strings containing the \\n escape
to an actual newline.  This works around the behavior of `pretty-print'
and `write', which output these as \\n instead of actual newlines,
whereas we want the `description' field to contain actual newlines
rather than \\n."
  (define (write-string str)
    (let loop ((chars (string->list str)))
      (match chars
        (()
         #t)
        ((#\\ #\n rest ...)
         (newline output)
         (loop rest))
        ((chr rest ...)
         (write-char chr output)
         (loop rest)))))

  (make-soft-port (vector (cut write-char <>)
                          write-string
                          (lambda _ #t)           ; flush
                          #f
                          (lambda _ #t)           ; close
                          #f)
                  "w"))

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

(define %standard-import-options '())

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

(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "stackage" "elpa" "gem"
                    "cran" "crate" "texlive" "json" "opam" "gopkg"))

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

(define (show-help)
  (display (G_ "Usage: guix import IMPORTER ARGS ...
Run IMPORTER with ARGS.\n"))
  (newline)
  (display (G_ "IMPORTER must be one of the importers listed below:\n"))
  (newline)
  (format #t "~{   ~a~%~}" importers)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define (guix-import . args)
  (match args
    (()
     (format (current-error-port)
             (G_ "guix import: missing importer name~%")))
    ((or ("-h") ("--help"))
     (show-help)
     (exit 0))
    ((or ("-V") ("--version"))
     (show-version-and-exit "guix import"))
    ((importer args ...)
     (if (member importer importers)
         (let ((print (lambda (expr)
                        (pretty-print expr (newline-rewriting-port
                                            (current-output-port))))))
           (match (apply (resolve-importer importer) args)
             ((and expr ('package _ ...))
              (print expr))
             ((? list? expressions)
              (for-each (lambda (expr)
                          (print expr)
                          (newline))
                        expressions))
             (x
              (leave (G_ "'~a' import failed~%") importer))))
         (leave (G_ "~a: invalid importer~%") importer)))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.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 import cpan)
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module (guix scripts)
  #:use-module (guix import cpan)
  #:use-module (guix scripts import)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:export (guix-import-cpan))

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

(define %default-options
  '())

(define (show-help)
  (display (G_ "Usage: guix import cpan PACKAGE-NAME
Import and convert the CPAN package for PACKAGE-NAME.\n"))
  (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.
  (cons* (option '(#\h "help") #f #f
                 (lambda args
                   (show-help)
                   (exit 0)))
         (option '(#\V "version") #f #f
                 (lambda args
                   (show-version-and-exit "guix import cpan")))
         %standard-import-options))

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

(define (guix-import-cpan . args)
  (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)
                  (alist-cons 'argument arg result))
                %default-options))

  (let* ((opts (parse-options))
         (args (filter-map (match-lambda
                            (('argument . value)
                             value)
                            (_ #f))
                           (reverse opts))))
    (match args
      ((package-name)
       (let ((sexp (cpan->guix-package package-name)))
         (unless sexp
           (leave (G_ "failed to download meta-data for package '~a'~%")
                  package-name))
         sexp))
      (()
       (leave (G_ "too few arguments~%")))
      ((many ...)
       (leave (G_ "too many arguments~%"))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 import cran)
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module (guix scripts)
  #:use-module (guix import cran)
  #:use-module (guix scripts import)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-37)
  #:use-module (srfi srfi-41)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:export (guix-import-cran))

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

(define %default-options
  '())

(define (show-help)
  (display (G_ "Usage: guix import cran PACKAGE-NAME
Import and convert the CRAN package for PACKAGE-NAME.\n"))
  (display (G_ "
  -a, --archive=ARCHIVE  specify the archive repository"))
  (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.
  (cons* (option '(#\h "help") #f #f
                 (lambda args
                   (show-help)
                   (exit 0)))
         (option '(#\V "version") #f #f
                 (lambda args
                   (show-version-and-exit "guix import cran")))
         (option '(#\a "archive") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'repo (string->symbol arg)
                               (alist-delete 'repo result))))
         (option '(#\r "recursive") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'recursive #t result)))
         %standard-import-options))

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

(define (guix-import-cran . args)
  (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)
                  (alist-cons 'argument arg result))
                %default-options))

  (let* ((opts (parse-options))
         (args (filter-map (match-lambda
                            (('argument . value)
                             value)
                            (_ #f))
                           (reverse opts))))
    (match args
      ((package-name)
       (if (assoc-ref opts 'recursive)
           ;; Recursive import
           (map (match-lambda
                  ((and ('package ('name name) . rest) pkg)
                   `(define-public ,(string->symbol name)
                      ,pkg))
                  (_ #f))
                (reverse
                 (stream->list
                  (cran-recursive-import package-name
                                         (or (assoc-ref opts 'repo) 'cran)))))
           ;; Single import
           (let ((sexp (cran->guix-package package-name
                                           (or (assoc-ref opts 'repo) 'cran))))
             (unless sexp
               (leave (G_ "failed to download description for package '~a'~%")
                      package-name))
             sexp)))
      (()
       (leave (G_ "too few arguments~%")))
      ((many ...)
       (leave (G_ "too many arguments~%"))))))