code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; 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 pack)
  #:use-module (guix scripts)
  #:use-module (guix ui)
  #:use-module (guix gexp)
  #:use-module (guix utils)
  #:use-module (guix store)
  #:use-module ((guix status) #:select (with-status-verbosity))
  #:use-module ((guix self) #:select (make-config.scm))
  #:use-module (guix grafts)
  #:autoload   (guix inferior) (inferior-package?
                                inferior-package-name
                                inferior-package-version)
  #:use-module (guix monads)
  #:use-module (guix modules)
  #:use-module (guix packages)
  #:use-module (guix profiles)
  #:use-module (guix describe)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module (guix build-system gnu)
  #:use-module (guix scripts build)
  #:use-module ((guix self) #:select (make-config.scm))
  #:use-module (gnu packages)
  #:use-module (gnu packages bootstrap)
  #:use-module ((gnu packages compression) #:hide (zip))
  #:use-module (gnu packages guile)
  #:use-module (gnu packages base)
  #:autoload   (gnu packages package-management) (guix)
  #:autoload   (gnu packages gnupg) (guile-gcrypt)
  #:autoload   (gnu packages guile) (guile2.0-json guile-json)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 match)
  #:export (compressor?
            lookup-compressor
            self-contained-tarball
            docker-image
            squashfs-image

            guix-pack))

;; Type of a compression tool.
(define-record-type <compressor>
  (compressor name extension command)
  compressor?
  (name       compressor-name)      ;string (e.g., "gzip")
  (extension  compressor-extension) ;string (e.g., ".lz")
  (command    compressor-command))  ;gexp (e.g., #~("/gnu/store/…/gzip" "-9n"))

(define %compressors
  ;; Available compression tools.
  (list (compressor "gzip"  ".gz"
                    #~(#+(file-append gzip "/bin/gzip") "-9n"))
        (compressor "lzip"  ".lz"
                    #~(#+(file-append lzip "/bin/lzip") "-9"))
        (compressor "xz"    ".xz"
                    #~(#+(file-append xz "/bin/xz") "-e"))
        (compressor "bzip2" ".bz2"
                    #~(#+(file-append bzip2 "/bin/bzip2") "-9"))
        (compressor "zstd" ".zst"
                    ;; The default level 3 compresses better than gzip in a
                    ;; fraction of the time, while the highest level 19
                    ;; (de)compresses more slowly and worse than xz.
                    #~(#+(file-append zstd "/bin/zstd") "-3"))
        (compressor "none" "" #f)))

;; This one is only for use in this module, so don't put it in %compressors.
(define bootstrap-xz
  (compressor "bootstrap-xz" ".xz"
              #~(#+(file-append %bootstrap-coreutils&co "/bin/xz") "-e")))

(define (lookup-compressor name)
  "Return the compressor object called NAME.  Error out if it could not be
found."
  (or (find (match-lambda
              (($ <compressor> name*)
               (string=? name* name)))
            %compressors)
      (leave (G_ "~a: compressor not found~%") name)))

(define not-config?
  ;; Select (guix …) and (gnu …) modules, except (guix config).
  (match-lambda
    (('guix 'config) #f)
    (('guix _ ...) #t)
    (('gnu _ ...) #t)
    (_ #f)))

(define gcrypt-sqlite3&co
  ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
  (append-map (lambda (package)
                (cons package
                      (match (package-transitive-propagated-inputs package)
                        (((labels packages) ...)
                         packages))))
              (list guile-gcrypt guile-sqlite3)))

(define (store-database items)
  "Return a directory containing a store database where all of ITEMS and their
dependencies are registered."
  (define schema
    (local-file (search-path %load-path
                             "guix/store/schema.sql")))

  (define labels
    (map (lambda (n)
           (string-append "closure" (number->string n)))
         (iota (length items))))

  (define build
    (with-extensions gcrypt-sqlite3&co
      (with-imported-modules (source-module-closure
                              '((guix build store-copy)
                                (guix store database)))
        #~(begin
            (use-modules (guix store database)
                         (guix build store-copy)
                         (srfi srfi-1))

            (define (read-closure closure)
              (call-with-input-file closure read-reference-graph))

            (define db-file
              (store-database-file #:state-directory #$output))

            ;; Make sure non-ASCII file names are properly handled.
            (setenv "GUIX_LOCPATH"
                    #+(file-append glibc-utf8-locales "/lib/locale"))
            (setlocale LC_ALL "en_US.utf8")

            (sql-schema #$schema)
            (let ((items (append-map read-closure '#$labels)))
              (with-database db-file db
                (register-items db items
                                #:deduplicate? #f
                                #:reset-timestamps? #f
                                #:registration-time %epoch)))))))

  (computed-file "store-database" build
                 #:options `(#:references-graphs ,(zip labels items))))

(define* (self-contained-tarball name profile
                                 #:key target
                                 (profile-name "guix-profile")
                                 deduplicate?
                                 entry-point
                                 (compressor (first %compressors))
                                 localstatedir?
                                 (symlinks '())
                                 (archiver tar))
  "Return a self-contained tarball containing a store initialized with the
closure of PROFILE, a derivation.  The tarball contains /gnu/store; if
LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db
with a properly initialized store database.

SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
added to the pack."
  (define database
    (and localstatedir?
         (file-append (store-database (list profile))
                      "/db/db.sqlite")))

  (define set-utf8-locale
    ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'.
    (and (or (not (profile? profile))
             (profile-locales? profile))
         #~(begin
             (setenv "GUIX_LOCPATH"
                     #+(file-append glibc-utf8-locales "/lib/locale"))
             (setlocale LC_ALL "en_US.utf8"))))

  (define build
    (with-imported-modules (source-module-closure
                            `((guix build utils)
                              (guix build union)
                              (gnu build install))
                            #:select? not-config?)
      #~(begin
          (use-modules (guix build utils)
                       ((guix build union) #:select (relative-file-name))
                       (gnu build install)
                       (srfi srfi-1)
                       (srfi srfi-26)
                       (ice-9 match))

          (define %root "root")

          (define symlink->directives
            ;; Return "populate directives" to make the given symlink and its
            ;; parent directories.
            (match-lambda
              ((source '-> target)
               (let ((target (string-append #$profile "/" target))
                     (parent (dirname source)))
                 ;; Never add a 'directory' directive for "/" so as to
                 ;; preserve its ownnership when extracting the archive (see
                 ;; below), and also because this would lead to adding the
                 ;; same entries twice in the tarball.
                 `(,@(if (string=? parent "/")
                         '()
                         `((directory ,parent)))
                   (,source
                    -> ,(relative-file-name parent target)))))))

          (define directives
            ;; Fully-qualified symlinks.
            (append-map symlink->directives '#$symlinks))

          ;; The --sort option was added to GNU tar in version 1.28, released
          ;; 2014-07-28.  For testing, we use the bootstrap tar, which is
          ;; older and doesn't support it.
          (define tar-supports-sort?
            (zero? (system* (string-append #+archiver "/bin/tar")
                            "cf" "/dev/null" "--files-from=/dev/null"
                            "--sort=name")))

          ;; Make sure non-ASCII file names are properly handled.
          #+set-utf8-locale

          ;; Add 'tar' to the search path.
          (setenv "PATH" #+(file-append archiver "/bin"))

          ;; Note: there is not much to gain here with deduplication and there
          ;; is the overhead of the '.links' directory, so turn it off.
          ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
          ;; with hard links:
          ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
          (populate-single-profile-directory %root
                                             #:profile #$profile
                                             #:profile-name #$profile-name
                                             #:closure "profile"
                                             #:database #+database)

          ;; Create SYMLINKS.
          (for-each (cut evaluate-populate-directive <> %root)
                    directives)

          ;; Create the tarball.  Use GNU format so there's no file name
          ;; length limitation.
          (with-directory-excursion %root
            (exit
             (zero? (apply system* "tar"
                           #+@(if (compressor-command compressor)
                                  #~("-I"
                                     (string-join
                                      '#+(compressor-command compressor)))
                                  #~())
                           "--format=gnu"

                           ;; Avoid non-determinism in the archive.  Use
                           ;; mtime = 1, not zero, because that is what the
                           ;; daemon does for files in the store (see the
                           ;; 'mtimeStore' constant in local-store.cc.)
                           (if tar-supports-sort? "--sort=name" "--mtime=@1")
                           "--mtime=@1"           ;for files in /var/guix
                           "--owner=root:0"
                           "--group=root:0"

                           "--check-links"
                           "-cvf" #$output
                           ;; Avoid adding / and /var to the tarball, so
                           ;; that the ownership and permissions of those
                           ;; directories will not be overwritten when
                           ;; extracting the archive.  Do not include /root
                           ;; because the root account might have a
                           ;; different home directory.
                           #$@(if localstatedir?
                                  '("./var/guix")
                                  '())

                           (string-append "." (%store-directory))

                           (delete-duplicates
                            (filter-map (match-lambda
                                          (('directory directory)
                                           (string-append "." directory))
                                          ((source '-> _)
                                           (string-append "." source))
                                          (_ #f))
                                        directives)))))))))

  (when entry-point
    (warning (G_ "entry point not supported in the '~a' format~%")
             'tarball))

  (gexp->derivation (string-append name ".tar"
                                   (compressor-extension compressor))
                    build
                    #:target target
                    #:references-graphs `(("profile" ,profile))))

(define (singularity-environment-file profile)
  "Return a shell script that defines the environment variables corresponding
to the search paths of PROFILE."
  (define build
    (with-extensions (list guile-gcrypt)
      (with-imported-modules `(((guix config) => ,(make-config.scm))
                               ,@(source-module-closure
                                  `((guix profiles)
                                    (guix search-paths))
                                  #:select? not-config?))
        #~(begin
            (use-modules (guix profiles) (guix search-paths)
                         (ice-9 match))

            (call-with-output-file #$output
              (lambda (port)
                (for-each (match-lambda
                            ((spec . value)
                             (format port "~a=~a~%export ~a~%"
                                     (search-path-specification-variable spec)
                                     value
                                     (search-path-specification-variable spec))))
                          (profile-search-paths #$profile))))))))

  (computed-file "singularity-environment.sh" build))

(define* (squashfs-image name profile
                         #:key target
                         (profile-name "guix-profile")
                         (compressor (first %compressors))
                         entry-point
                         localstatedir?
                         (symlinks '())
                         (archiver squashfs-tools))
  "Return a squashfs image containing a store initialized with the closure of
PROFILE, a derivation.  The image contains a subset of /gnu/store, empty mount
points for virtual file systems (like procfs), and optional symlinks.

SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
added to the pack."
  (define database
    (and localstatedir?
         (file-append (store-database (list profile))
                      "/db/db.sqlite")))

  (define environment
    (singularity-environment-file profile))

  (define symlinks*
    ;; Singularity requires /bin (specifically /bin/sh), so ensure that
    ;; symlink is created.
    (if (find (match-lambda
                (("/bin" . _) #t)
                (_            #f))
              symlinks)
        symlinks
        `(("/bin" -> "bin") ,@symlinks)))

  (define build
    (with-imported-modules (source-module-closure
                            '((guix build utils)
                              (guix build store-copy)
                              (guix build union)
                              (gnu build install))
                            #:select? not-config?)
      #~(begin
          (use-modules (guix build utils)
                       (guix build store-copy)
                       ((guix build union) #:select (relative-file-name))
                       (gnu build install)
                       (srfi srfi-1)
                       (srfi srfi-26)
                       (ice-9 match))

          (define database #+database)
          (define entry-point #$entry-point)

          (define (mksquashfs args)
            (apply invoke "mksquashfs"
                   `(,@args

                     ;; Do not create a "recovery file" when appending to the
                     ;; file system since it's useless in this case.
                     "-no-recovery"

                     ;; Do not attempt to store extended attributes.
                     ;; See <https://bugs.gnu.org/40043>.
                     "-no-xattrs"

                     ;; Set file times and the file system creation time to
                     ;; one second after the Epoch.
                     "-all-time" "1" "-mkfs-time" "1"

                     ;; Reset all UIDs and GIDs.
                     "-force-uid" "0" "-force-gid" "0")))

          (setenv "PATH" #+(file-append archiver "/bin"))

          ;; We need an empty file in order to have a valid file argument when
          ;; we reparent the root file system.  Read on for why that's
          ;; necessary.
          (with-output-to-file ".empty" (lambda () (display "")))

          ;; Create the squashfs image in several steps.
          ;; Add all store items.  Unfortunately mksquashfs throws away all
          ;; ancestor directories and only keeps the basename.  We fix this
          ;; in the following invocations of mksquashfs.
          (mksquashfs `(,@(map store-info-item
                               (call-with-input-file "profile"
                                 read-reference-graph))
                        #$environment
                        ,#$output

                        ;; Do not perform duplicate checking because we
                        ;; don't have any dupes.
                        "-no-duplicates"
                        "-comp"
                        ,#+(compressor-name compressor)))

          ;; Here we reparent the store items.  For each sub-directory of
          ;; the store prefix we need one invocation of "mksquashfs".
          (for-each (lambda (dir)
                      (mksquashfs `(".empty"
                                    ,#$output
                                    "-root-becomes" ,dir)))
                    (reverse (string-tokenize (%store-directory)
                                              (char-set-complement (char-set #\/)))))

          ;; Add symlinks and mount points.
          (mksquashfs
           `(".empty"
             ,#$output
             ;; Create SYMLINKS via pseudo file definitions.
             ,@(append-map
                (match-lambda
                  ((source '-> target)
                   ;; Create relative symlinks to work around a bug in
                   ;; Singularity 2.x:
                   ;;   https://bugs.gnu.org/34913
                   ;;   https://github.com/sylabs/singularity/issues/1487
                   (let ((target (string-append #$profile "/" target)))
                     (list "-p"
                           (string-join
                            ;; name s mode uid gid symlink
                            (list source
                                  "s" "777" "0" "0"
                                  (relative-file-name (dirname source)
                                                      target)))))))
                '#$symlinks*)

             "-p" "/.singularity.d d 555 0 0"

             ;; Create the environment file.
             "-p" "/.singularity.d/env d 555 0 0"
             "-p" ,(string-append
                    "/.singularity.d/env/90-environment.sh s 777 0 0 "
                    (relative-file-name "/.singularity.d/env"
                                        #$environment))

             ;; Create /.singularity.d/actions, and optionally the 'run'
             ;; script, used by 'singularity run'.
             "-p" "/.singularity.d/actions d 555 0 0"

             ,@(if entry-point
                   `(;; This one if for Singularity 2.x.
                     "-p"
                     ,(string-append
                       "/.singularity.d/actions/run s 777 0 0 "
                       (relative-file-name "/.singularity.d/actions"
                                           (string-append #$profile "/"
                                                          entry-point)))

                     ;; This one is for Singularity 3.x.
                     "-p"
                     ,(string-append
                       "/.singularity.d/runscript s 777 0 0 "
                       (relative-file-name "/.singularity.d"
                                           (string-append #$profile "/"
                                                          entry-point))))
                   '())

             ;; Create empty mount points.
             "-p" "/proc d 555 0 0"
             "-p" "/sys d 555 0 0"
             "-p" "/dev d 555 0 0"
             "-p" "/home d 555 0 0"))

          (when database
            ;; Initialize /var/guix.
            (install-database-and-gc-roots "var-etc" database #$profile)
            (mksquashfs `("var-etc" ,#$output))))))

  (gexp->derivation (string-append name
                                   (compressor-extension compressor)
                                   ".squashfs")
                    build
                    #:target target
                    #:references-graphs `(("profile" ,profile))))

(define* (docker-image name profile
                       #:key target
                       (profile-name "guix-profile")
                       (compressor (first %compressors))
                       entry-point
                       localstatedir?
                       (symlinks '())
                       (archiver tar))
  "Return a derivation to construct a Docker image of PROFILE.  The
image is a tarball conforming to the Docker Image Specification, compressed
with COMPRESSOR.  It can be passed to 'docker load'.  If TARGET is true, it
must a be a GNU triplet and it is used to derive the architecture metadata in
the image."
  (define database
    (and localstatedir?
         (file-append (store-database (list profile))
                      "/db/db.sqlite")))

  (define defmod 'define-module)                  ;trick Geiser

  (define build
    ;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
    (with-extensions (list guile-json-3 guile-gcrypt)
      (with-imported-modules `(((guix config) => ,(make-config.scm))
                               ,@(source-module-closure
                                  `((guix docker)
                                    (guix build store-copy)
                                    (guix profiles)
                                    (guix search-paths))
                                  #:select? not-config?))
        #~(begin
            (use-modules (guix docker) (guix build store-copy)
                         (guix profiles) (guix search-paths)
                         (srfi srfi-1) (srfi srfi-19)
                         (ice-9 match))

            (define environment
              (map (match-lambda
                     ((spec . value)
                      (cons (search-path-specification-variable spec)
                            value)))
                   (profile-search-paths #$profile)))

            (define symlink->directives
              ;; Return "populate directives" to make the given symlink and its
              ;; parent directories.
              (match-lambda
                ((source '-> target)
                 (let ((target (string-append #$profile "/" target))
                       (parent (dirname source)))
                   `((directory ,parent)
                     (,source -> ,target))))))

            (define directives
              ;; Create a /tmp directory, as some programs expect it, and
              ;; create SYMLINKS.
              `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
                ,@(append-map symlink->directives '#$symlinks)))

            (define tag
              ;; Compute a meaningful "repository" name, which will show up in
              ;; the output of "docker images".
              (let ((manifest (profile-manifest #$profile)))
                (let loop ((names (map manifest-entry-name
                                       (manifest-entries manifest))))
                  (define str (string-join names "-"))
                  (if (< (string-length str) 40)
                      str
                      (match names
                        ((_) str)
                        ((names ... _) (loop names))))))) ;drop one entry

            (setenv "PATH" #+(file-append archiver "/bin"))

            (build-docker-image #$output
                                (map store-info-item
                                     (call-with-input-file "profile"
                                       read-reference-graph))
                                #$profile
                                #:repository tag
                                #:database #+database
                                #:system (or #$target (utsname:machine (uname)))
                                #:environment environment
                                #:entry-point
                                #$(and entry-point
                                       #~(list (string-append #$profile "/"
                                                              #$entry-point)))
                                #:extra-files directives
                                #:compressor '#+(compressor-command compressor)
                                #:creation-time (make-time time-utc 0 1))))))

  (gexp->derivation (string-append name ".tar"
                                   (compressor-extension compressor))
                    build
                    #:target target
                    #:references-graphs `(("profile" ,profile))))

;;;
;;; Compiling C programs.
;;;

;; A C compiler.  That lowers to a single program that can be passed typical C
;; compiler flags, and it makes sure the whole toolchain is available.
(define-record-type <c-compiler>
  (%c-compiler toolchain guile)
  c-compiler?
  (toolchain c-compiler-toolchain)
  (guile     c-compiler-guile))

(define* (c-compiler #:optional inputs
                     #:key (guile (default-guile)))
  (%c-compiler inputs guile))

(define (bootstrap-c-compiler)
  "Return the C compiler that uses the bootstrap toolchain.  This is used only
by '--bootstrap', for testing purposes."
  (define bootstrap-toolchain
    (list (first (assoc-ref (%bootstrap-inputs) "gcc"))
          (first (assoc-ref (%bootstrap-inputs) "binutils"))
          (first (assoc-ref (%bootstrap-inputs) "libc"))))

  (c-compiler bootstrap-toolchain
              #:guile %bootstrap-guile))

(define-gexp-compiler (c-compiler-compiler (compiler <c-compiler>) system target)
  "Lower COMPILER to a single script that does the right thing."
  (define toolchain
    (or (c-compiler-toolchain compiler)
        (list (first (assoc-ref (standard-packages) "gcc"))
              (first (assoc-ref (standard-packages) "ld-wrapper"))
              (first (assoc-ref (standard-packages) "binutils"))
              (first (assoc-ref (standard-packages) "libc"))
              (gexp-input (first (assoc-ref (standard-packages) "libc"))
                          "static"))))

  (define inputs
    (match (append-map package-propagated-inputs
                       (filter package? toolchain))
      (((labels things . _) ...)
       (append toolchain things))))

  (define search-paths
    (cons $PATH
          (append-map package-native-search-paths
                      (filter package? inputs))))

  (define run
    (with-imported-modules (source-module-closure
                            '((guix build utils)
                              (guix search-paths)))
      #~(begin
          (use-modules (guix build utils) (guix search-paths)
                       (ice-9 match))

          (define (output-file args)
            (let loop ((args args))
              (match args
                (() "a.out")
                (("-o" file _ ...) file)
                ((head rest ...) (loop rest)))))

          (set-search-paths (map sexp->search-path-specification
                                 '#$(map search-path-specification->sexp
                                         search-paths))
                            '#$inputs)

          (let ((output (output-file (command-line))))
            (apply invoke "gcc" (cdr (command-line)))
            (invoke "strip" output)))))

  (when target
    ;; TODO: Yep, we'll have to do it someday!
    (leave (G_ "cross-compilation not implemented here;
please email '~a'~%")
           (@ (guix config) %guix-bug-report-address)))

  (gexp->script "c-compiler" run
                #:guile (c-compiler-guile compiler)))

;;;
;;; Wrapped package.
;;;

(define* (wrapped-package package
                          #:optional
                          (output* "out")
                          (compiler (c-compiler))
                          #:key proot?)
  "Return the OUTPUT of PACKAGE with its binaries wrapped such that they are
relocatable.  When PROOT? is true, include PRoot in the result and use it as a
last resort for relocation."
  (define runner
    (local-file (search-auxiliary-file "run-in-namespace.c")))

  (define audit-source
    (local-file (search-auxiliary-file "pack-audit.c")))

  (define (proot)
    (specification->package "proot-static"))

  (define (fakechroot-library)
    (computed-file "libfakechroot.so"
                   #~(copy-file #$(file-append
                                   (specification->package "fakechroot")
                                   "/lib/fakechroot/libfakechroot.so")
                                #$output)))

  (define (audit-module)
    ;; Return an ld.so audit module for use by the 'fakechroot' execution
    ;; engine that translates file names of all the files ld.so loads.
    (computed-file "pack-audit.so"
                   (with-imported-modules '((guix build utils))
                     #~(begin
                         (use-modules (guix build utils))

                         (copy-file #$audit-source "audit.c")
                         (substitute* "audit.c"
                           (("@STORE_DIRECTORY@")
                            (%store-directory)))

                         (invoke #$compiler "-std=gnu99"
                                 "-shared" "-fPIC" "-Os" "-g0"
                                 "-Wall" "audit.c" "-o" #$output)))))

  (define build
    (with-imported-modules (source-module-closure
                            '((guix build utils)
                              (guix build union)
                              (guix build gremlin)
                              (guix elf)))
      #~(begin
          (use-modules (guix build utils)
                       ((guix build union) #:select (relative-file-name))
                       (guix elf)
                       (guix build gremlin)
                       (ice-9 binary-ports)
                       (ice-9 ftw)
                       (ice-9 match)
                       (srfi srfi-1)
                       (rnrs bytevectors))

          (define input
            ;; The OUTPUT* output of PACKAGE.
            (ungexp package output*))

          (define target
            ;; The output we are producing.
            (ungexp output output*))

          (define (strip-store-prefix file)
            ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
            ;; "/bin/foo".
            (let* ((len  (string-length (%store-directory)))
                   (base (string-drop file (+ 1 len))))
              (match (string-index base #\/)
                (#f    base)
                (index (string-drop base index)))))

          (define (elf-interpreter elf)
            ;; Return the interpreter of ELF as a string, or #f if ELF has no
            ;; interpreter segment.
            (match (find (lambda (segment)
                           (= (elf-segment-type segment) PT_INTERP))
                         (elf-segments elf))
              (#f #f)                             ;maybe a .so
              (segment
               (let ((bv (make-bytevector (- (elf-segment-memsz segment) 1))))
                 (bytevector-copy! (elf-bytes elf)
                                   (elf-segment-offset segment)
                                   bv 0 (bytevector-length bv))
                 (utf8->string bv)))))

          (define (runpath file)
            ;; Return the RUNPATH of FILE as a list of directories.
            (let* ((bv      (call-with-input-file file get-bytevector-all))
                   (elf     (parse-elf bv))
                   (dyninfo (elf-dynamic-info elf)))
              (or (and=> dyninfo elf-dynamic-info-runpath)
                  '())))

          (define (elf-loader-compile-flags program)
            ;; Return the cpp flags defining macros for the ld.so/fakechroot
            ;; wrapper of PROGRAM.

            ;; TODO: Handle scripts by wrapping their interpreter.
            (if (elf-file? program)
                (let* ((bv      (call-with-input-file program
                                  get-bytevector-all))
                       (elf     (parse-elf bv))
                       (interp  (elf-interpreter elf))
                       (gconv   (and interp
                                     (string-append (dirname interp)
                                                    "/gconv"))))
                  (if interp
                      (list (string-append "-DPROGRAM_INTERPRETER=\""
                                           interp "\"")
                            (string-append "-DFAKECHROOT_LIBRARY=\""
                                           #$(fakechroot-library) "\"")

                            (string-append "-DLOADER_AUDIT_MODULE=\""
                                           #$(audit-module) "\"")
                            (string-append "-DLOADER_AUDIT_RUNPATH={ "
                                           (string-join
                                            (map object->string
                                                 (runpath
                                                  #$(audit-module)))
                                            ", " 'suffix)
                                           "NULL }")
                            (if gconv
                                (string-append "-DGCONV_DIRECTORY=\""
                                               gconv "\"")
                                "-UGCONV_DIRECTORY"))
                      '()))
                '()))

          (define (build-wrapper program)
            ;; Build a user-namespace wrapper for PROGRAM.
            (format #t "building wrapper for '~a'...~%" program)
            (copy-file #$runner "run.c")

            (substitute* "run.c"
              (("@WRAPPED_PROGRAM@") program)
              (("@STORE_DIRECTORY@") (%store-directory)))

            (let* ((base   (strip-store-prefix program))
                   (result (string-append target "/" base))
                   (proot  #$(and proot?
                                  #~(string-drop
                                     #$(file-append (proot) "/bin/proot")
                                     (+ (string-length (%store-directory))
                                        1)))))
              (mkdir-p (dirname result))
              (apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
                     "run.c" "-o" result
                     (append (if proot
                                 (list (string-append "-DPROOT_PROGRAM=\""
                                                      proot "\""))
                                 '())
                             (elf-loader-compile-flags program)))
              (delete-file "run.c")))

          (setvbuf (current-output-port) 'line)

          ;; Link the top-level files of PACKAGE so that search paths are
          ;; properly defined in PROFILE/etc/profile.
          (mkdir target)
          (for-each (lambda (file)
                      (unless (member file '("." ".." "bin" "sbin" "libexec"))
                        (let ((file* (string-append input "/" file)))
                          (symlink (relative-file-name target file*)
                                   (string-append target "/" file)))))
                    (scandir input))

          (for-each build-wrapper
                    ;; Note: Trailing slash in case these are symlinks.
                    (append (find-files (string-append input "/bin/"))
                            (find-files (string-append input "/sbin/"))
                            (find-files (string-append input "/libexec/")))))))

  (computed-file (string-append
                  (cond ((package? package)
                         (package-full-name package "-"))
                        ((inferior-package? package)
                         (string-append (inferior-package-name package)
                                        "-"
                                        (inferior-package-version package)))
                        (else "wrapper"))
                  "R")
                 build))

(define (wrapped-manifest-entry entry . args)
  (manifest-entry
    (inherit entry)
    (item (apply wrapped-package
                 (manifest-entry-item entry)
                 (manifest-entry-output entry)
                 args))
    (dependencies (map (lambda (entry)
                         (apply wrapped-manifest-entry entry args))
                       (manifest-entry-dependencies entry)))))

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

(define %default-options
  ;; Alist of default option values.
  `((format . tarball)
    (profile-name . "guix-profile")
    (system . ,(%current-system))
    (substitutes? . #t)
    (offload? . #t)
    (graft? . #t)
    (print-build-trace? . #t)
    (print-extended-build-trace? . #t)
    (multiplexed-build-output? . #t)
    (debug . 0)
    (verbosity . 1)
    (symlinks . ())
    (compressor . ,(first %compressors))))

(define %formats
  ;; Supported pack formats.
  `((tarball . ,self-contained-tarball)
    (squashfs . ,squashfs-image)
    (docker  . ,docker-image)))

(define (show-formats)
  ;; Print the supported pack formats.
  (display (G_ "The supported formats for 'guix pack' are:"))
  (newline)
  (display (G_ "
  tarball       Self-contained tarball, ready to run on another machine"))
  (display (G_ "
  squashfs      Squashfs image suitable for Singularity"))
  (display (G_ "
  docker        Tarball ready for 'docker load'"))
  (newline))

(define %options
  ;; Specifications 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 pack")))

         (option '(#\n "dry-run") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'dry-run? #t result)))
         (option '(#\d "derivation") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'derivation-only? #t result)))

         (option '(#\f "format") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'format (string->symbol arg) result)))
         (option '("list-formats") #f #f
                 (lambda args
                   (show-formats)
                   (exit 0)))
         (option '(#\R "relocatable") #f #f
                 (lambda (opt name arg result)
                   (match (assq-ref result 'relocatable?)
                     (#f
                      (alist-cons 'relocatable? #t result))
                     (_
                      (alist-cons 'relocatable? 'proot
                                  (alist-delete 'relocatable? result))))))
         (option '(#\e "expression") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'expression arg result)))
         (option '(#\m "manifest") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'manifest arg result)))
         (option '(#\s "system") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'system arg
                               (alist-delete 'system result eq?))))
         (option '("entry-point") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'entry-point arg result)))
         (option '("target") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'target arg
                               (alist-delete 'target result eq?))))
         (option '(#\C "compression") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'compressor (lookup-compressor arg)
                               result)))
         (option '(#\S "symlink") #t #f
                 (lambda (opt name arg result)
                   ;; Note: Using 'string-split' allows us to handle empty
                   ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is
                   ;; a symlink to the profile) correctly.
                   (match (string-split arg (char-set #\=))
                     ((source target)
                      (let ((symlinks (assoc-ref result 'symlinks)))
                        (alist-cons 'symlinks
                                    `((,source -> ,target) ,@symlinks)
                                    (alist-delete 'symlinks result eq?))))
                     (x
                      (leave (G_ "~a: invalid symlink specification~%")
                             arg)))))
         (option '("save-provenance") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'save-provenance? #t result)))
         (option '("localstatedir") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'localstatedir? #t result)))
         (option '("profile-name") #t #f
                 (lambda (opt name arg result)
                   (match arg
                     ((or "guix-profile" "current-guix")
                      (alist-cons 'profile-name arg result))
                     (_
                      (leave (G_ "~a: unsupported profile name~%") arg)))))
         (option '(#\r "root") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'gc-root arg result)))

         (option '(#\v "verbosity") #t #f
                 (lambda (opt name arg result)
                   (let ((level (string->number* arg)))
                     (alist-cons 'verbosity level
                                 (alist-delete 'verbosity result)))))
         (option '("bootstrap") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'bootstrap? #t result)))

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

(define (show-help)
  (display (G_ "Usage: guix pack [OPTION]... PACKAGE...
Create a bundle of PACKAGE.\n"))
  (show-build-options-help)
  (newline)
  (show-transformation-options-help)
  (newline)
  (display (G_ "
  -f, --format=FORMAT    build a pack in the given FORMAT"))
  (display (G_ "
      --list-formats     list the formats available"))
  (display (G_ "
  -R, --relocatable      produce relocatable executables"))
  (display (G_ "
  -e, --expression=EXPR  consider the package EXPR evaluates to"))
  (display (G_ "
  -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
  (display (G_ "
      --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
  (display (G_ "
  -C, --compression=TOOL compress using TOOL--e.g., \"lzip\""))
  (display (G_ "
  -S, --symlink=SPEC     create symlinks to the profile according to SPEC"))
  (display (G_ "
  -m, --manifest=FILE    create a pack with the manifest from FILE"))
  (display (G_ "
      --entry-point=PROGRAM
                         use PROGRAM as the entry point of the pack"))
  (display (G_ "
      --save-provenance  save provenance information"))
  (display (G_ "
      --localstatedir    include /var/guix in the resulting pack"))
  (display (G_ "
      --profile-name=NAME
                         populate /var/guix/profiles/.../NAME"))
  (display (G_ "
  -r, --root=FILE        make FILE a symlink to the result, and register it
                         as a garbage collector root"))
  (display (G_ "
  -d, --derivation       return the derivation of the pack"))
  (display (G_ "
  -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
  (display (G_ "
      --bootstrap        use the bootstrap binaries to build the pack"))
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

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

(define-command (guix-pack . args)
  (category development)
  (synopsis "create application bundles")

  (define opts
    (parse-command-line args %options (list %default-options)))

  (define maybe-package-argument
    ;; Given an option pair, return a package, a package/output tuple, or #f.
    (match-lambda
      (('argument . spec)
       (call-with-values
           (lambda ()
             (specification->package+output spec))
         list))
      (('expression . exp)
       (read/eval-package-expression exp))
      (x #f)))

  (define (manifest-from-args store opts)
    (let* ((transform     (options->transformation opts))
           (packages      (map (match-lambda
                                 (((? package? package) output)
                                  (list (transform store package) output))
                                 ((? package? package)
                                  (list (transform store package) "out")))
                               (reverse
                                (filter-map maybe-package-argument opts))))
           (manifests     (filter-map (match-lambda
                                        (('manifest . file) file)
                                        (_ #f))
                                      opts)))
      (define with-provenance
        (if (assoc-ref opts 'save-provenance?)
            (lambda (manifest)
              (map-manifest-entries
               (lambda (entry)
                 (let ((entry (manifest-entry-with-provenance entry)))
                   (unless (assq 'provenance (manifest-entry-properties entry))
                     (warning (G_ "could not determine provenance of package ~a~%")
                              (manifest-entry-name entry)))
                   entry))
               manifest))
            identity))

      (with-provenance
       (cond
        ((and (not (null? manifests)) (not (null? packages)))
         (leave (G_ "both a manifest and a package list were given~%")))
        ((not (null? manifests))
         (concatenate-manifests
          (map (lambda (file)
                 (let ((user-module (make-user-module
                                     '((guix profiles) (gnu)))))
                   (load* file user-module)))
               manifests)))
        (else
         (packages->manifest packages))))))

  (with-error-handling
    (with-store store
      (with-status-verbosity (assoc-ref opts 'verbosity)
        ;; Set the build options before we do anything else.
        (set-build-options-from-command-line store opts)

        (with-build-handler (build-notifier #:dry-run?
                                            (assoc-ref opts 'dry-run?)
                                            #:verbosity
                                            (assoc-ref opts 'verbosity)
                                            #:use-substitutes?
                                            (assoc-ref opts 'substitutes?))
          (parameterize ((%graft? (assoc-ref opts 'graft?))
                         (%guile-for-build (package-derivation
                                            store
                                            (if (assoc-ref opts 'bootstrap?)
                                                %bootstrap-guile
                                                (default-guile))
                                            (assoc-ref opts 'system)
                                            #:graft? (assoc-ref opts 'graft?))))
            (let* ((derivation? (assoc-ref opts 'derivation-only?))
                   (relocatable? (assoc-ref opts 'relocatable?))
                   (proot?      (eq? relocatable? 'proot))
                   (manifest    (let ((manifest (manifest-from-args store opts)))
                                  ;; Note: We cannot honor '--bootstrap' here because
                                  ;; 'glibc-bootstrap' lacks 'libc.a'.
                                  (if relocatable?
                                      (map-manifest-entries
                                       (cut wrapped-manifest-entry <> #:proot? proot?)
                                       manifest)
                                      manifest)))
                   (pack-format (assoc-ref opts 'format))
                   (name        (string-append (symbol->string pack-format)
                                               "-pack"))
                   (target      (assoc-ref opts 'target))
                   (bootstrap?  (assoc-ref opts 'bootstrap?))
                   (compressor  (if bootstrap?
                                    bootstrap-xz
                                    (assoc-ref opts 'compressor)))
                   (archiver    (if (equal? pack-format 'squashfs)
                                    squashfs-tools
                                    (if bootstrap?
                                        %bootstrap-coreutils&co
                                        tar)))
                   (symlinks    (assoc-ref opts 'symlinks))
                   (build-image (match (assq-ref %formats pack-format)
                                  ((? procedure? proc) proc)
                                  (#f
                                   (leave (G_ "~a: unknown pack format~%")
                                          pack-format))))
                   (localstatedir? (assoc-ref opts 'localstatedir?))
                   (entry-point    (assoc-ref opts 'entry-point))
                   (profile-name   (assoc-ref opts 'profile-name))
                   (gc-root        (assoc-ref opts 'gc-root))
                   (profile        (profile
                                    (content manifest)

                                    ;; Always produce relative symlinks for
                                    ;; Singularity (see
                                    ;; <https://bugs.gnu.org/34913>).
                                    (relative-symlinks?
                                     (or relocatable?
                                         (eq? 'squashfs pack-format)))

                                    (hooks (if bootstrap?
                                               '()
                                               %default-profile-hooks))
                                    (locales? (not bootstrap?)))))
              (define (lookup-package package)
                (manifest-lookup manifest (manifest-pattern (name package))))

              (when (null? (manifest-entries manifest))
                (warning (G_ "no packages specified; building an empty pack~%")))

              (when (and (eq? pack-format 'squashfs)
                         (not (any lookup-package '("bash" "bash-minimal"))))
                (warning (G_ "Singularity requires you to provide a shell~%"))
                (display-hint (G_ "Add @code{bash} or @code{bash-minimal} \
to your package list.")))

              (run-with-store store
                (mlet* %store-monad ((drv (build-image name profile
                                                       #:target
                                                       target
                                                       #:compressor
                                                       compressor
                                                       #:symlinks
                                                       symlinks
                                                       #:localstatedir?
                                                       localstatedir?
                                                       #:entry-point
                                                       entry-point
                                                       #:profile-name
                                                       profile-name
                                                       #:archiver
                                                       archiver)))
                  (mbegin %store-monad
                    (mwhen derivation?
                      (return (format #t "~a~%"
                                      (derivation-file-name drv))))
                    (munless derivation?
                      (built-derivations (list drv))
                      (mwhen gc-root
                        (register-root* (match (derivation->output-paths drv)
                                          (((names . items) ...)
                                           items))
                                        gc-root))
                      (return (format #t "~a~%"
                                      (derivation->output-path drv))))))
                #:target target
                #:system (assoc-ref opts 'system)))))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix scripts package)
  #:use-module (guix ui)
  #:use-module ((guix status) #:select (with-status-verbosity))
  #:use-module ((guix build syscalls) #:select (terminal-rows))
  #:use-module (guix store)
  #:use-module (guix grafts)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix profiles)
  #:use-module (guix search-paths)
  #:use-module (guix import json)
  #:use-module (guix monads)
  #:use-module (guix utils)
  #:use-module (guix config)
  #:use-module (guix scripts)
  #:use-module (guix scripts build)
  #:use-module (guix describe)
  #:autoload   (guix store roots) (gc-roots user-owned?)
  #:use-module ((guix build utils)
                #:select (directory-exists? mkdir-p))
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-37)
  #:use-module (gnu packages)
  #:autoload   (gnu packages bootstrap) (%bootstrap-guile)
  #:export (build-and-use-profile
            delete-generations
            delete-matching-generations
            guix-package

            search-path-environment-variables

            transaction-upgrade-entry             ;mostly for testing

            (%options . %package-options)
            (%default-options . %package-default-options)
            guix-package*))

(define %store
  (make-parameter #f))

;;;
;;; Profiles.
;;;

(define (ensure-default-profile)
  "Ensure the default profile symlink and directory exist and are writable."
  (ensure-profile-directory)

  ;; Try to create ~/.guix-profile if it doesn't exist yet.
  (when (and %user-profile-directory
             %current-profile
             (not (false-if-exception
                   (lstat %user-profile-directory))))
    (catch 'system-error
      (lambda ()
        (symlink %current-profile %user-profile-directory))
      (const #t))))

(define (delete-generations store profile generations)
  "Delete GENERATIONS from PROFILE.
GENERATIONS is a list of generation numbers."
  (for-each (cut delete-generation* store profile <>)
            generations))

(define (delete-matching-generations store profile pattern)
  "Delete from PROFILE all the generations matching PATTERN.  PATTERN must be
a string denoting a set of generations: the empty list means \"all generations
but the current one\", a number designates a generation, and other patterns
denote ranges as interpreted by 'matching-generations'."
  (let ((current (generation-number profile)))
    (cond ((not (file-exists? profile))            ; XXX: race condition
           (raise (condition (&profile-not-found-error
                              (profile profile)))))
          ((not pattern)
           (delete-generations store profile
                               (delv current (profile-generations profile))))
          ;; Do not delete the zeroth generation.
          ((equal? 0 (string->number pattern))
           #t)

          ;; If PATTERN is a duration, match generations that are
          ;; older than the specified duration.
          ((matching-generations pattern profile
                                 #:duration-relation >)
           =>
           (lambda (numbers)
             (when (memv current numbers)
               (warning (G_ "not removing generation ~a, which is current~%")
                        current))

             ;; Make sure we don't inadvertently remove the current
             ;; generation.
             (let ((numbers (delv current numbers)))
               (when (null-list? numbers)
                 (leave (G_ "no matching generation~%")))
               (delete-generations store profile numbers)))))))

(define* (build-and-use-profile store profile manifest
                                #:key
                                (hooks %default-profile-hooks)
                                allow-collisions?
                                bootstrap?)
  "Build a new generation of PROFILE, a file name, using the packages
specified in MANIFEST, a manifest object.  When ALLOW-COLLISIONS? is true,
do not treat collisions in MANIFEST as an error.  HOOKS is a list of \"profile
hooks\" run when building the profile."
  (let* ((prof-drv (run-with-store store
                     (profile-derivation manifest
                                         #:allow-collisions? allow-collisions?
                                         #:hooks (if bootstrap? '() hooks)
                                         #:locales? (not bootstrap?))))
         (prof     (derivation->output-path prof-drv)))

    (cond
     ((and (file-exists? profile)
           (and=> (readlink* profile) (cut string=? prof <>)))
      (format (current-error-port) (G_ "nothing to be done~%")))
     (else
      (let* ((number (generation-number profile))

             ;; Always use NUMBER + 1 for the new profile, possibly
             ;; overwriting a "previous future generation".
             (name   (generation-file-name profile (+ 1 number))))
        (and (build-derivations store (list prof-drv))
             (let* ((entries (manifest-entries manifest))
                    (count   (length entries)))
               (switch-symlinks name prof)
               (switch-symlinks profile (basename name))
               (unless (string=? profile %current-profile)
                 (register-gc-root store name))
               (display-search-path-hint entries profile)))

        (warn-about-disk-space profile))))))

;;;
;;; Package specifications.
;;;

(define (find-packages-by-description regexps)
  "Return a list of pairs: packages whose name, synopsis, description,
or output matches at least one of REGEXPS sorted by relevance, and its
non-zero relevance score."
  (let ((matches (fold-packages (lambda (package result)
                                  (if (package-superseded package)
                                      result
                                      (match (package-relevance package
                                                                regexps)
                                        ((? zero?)
                                         result)
                                        (score
                                         (cons (cons package score)
                                               result)))))
                                '())))
    (sort matches
          (lambda (m1 m2)
            (match m1
              ((package1 . score1)
               (match m2
                 ((package2 . score2)
                  (if (= score1 score2)
                      (string>? (package-full-name package1)
                                (package-full-name package2))
                      (> score1 score2))))))))))

(define (transaction-upgrade-entry store entry transaction)
  "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a
<manifest-entry>."
  (define (lower-manifest-entry* entry)
    (run-with-store store
      (lower-manifest-entry entry (%current-system))))

  (define (supersede old new)
    (info (G_ "package '~a' has been superseded by '~a'~%")
          (manifest-entry-name old) (package-name new))
    (manifest-transaction-install-entry
     (package->manifest-entry* new (manifest-entry-output old))
     (manifest-transaction-remove-pattern
      (manifest-pattern
        (name (manifest-entry-name old))
        (version (manifest-entry-version old))
        (output (manifest-entry-output old)))
      transaction)))

  (define (upgrade entry)
    (match entry
      (($ <manifest-entry> name version output (? string? path))
       (match (find-best-packages-by-name name #f)
         ((pkg . rest)
          (let ((candidate-version (package-version pkg)))
            (match (package-superseded pkg)
              ((? package? new)
               (supersede entry new))
              (#f
               (case (version-compare candidate-version version)
                 ((>)
                  (manifest-transaction-install-entry
                   (package->manifest-entry* pkg output)
                   transaction))
                 ((<)
                  transaction)
                 ((=)
                  (let* ((new (package->manifest-entry* pkg output)))
                    ;; Here we want to determine whether the NEW actually
                    ;; differs from ENTRY, but we need to intercept
                    ;; 'build-things' calls because they would prevent us from
                    ;; displaying the list of packages to install/upgrade
                    ;; upfront.  Thus, if lowering NEW triggers a build (due
                    ;; to grafts), assume NEW differs from ENTRY.
                    (if (with-build-handler (const #f)
                          (manifest-entry=? (lower-manifest-entry* new)
                                            entry))
                        transaction
                        (manifest-transaction-install-entry
                         new transaction)))))))))
         (()
          (warning (G_ "package '~a' no longer exists~%") name)
          transaction)))))

  (if (manifest-transaction-removal-candidate? entry transaction)
      transaction
      (upgrade entry)))

;;;
;;; Search paths.
;;;

(define* (search-path-environment-variables entries profiles
                                            #:optional (getenv getenv)
                                            #:key (kind 'exact))
  "Return environment variable definitions that may be needed for the use of
ENTRIES, a list of manifest entries, in PROFILES.  Use GETENV to determine the
current settings and report only settings not already effective.  KIND
must be one of 'exact, 'prefix, or 'suffix, depending on the kind of search
path definition to be returned."
  (let ((search-paths (delete-duplicates
                       (cons $PATH
                             (append-map manifest-entry-search-paths
                                         entries)))))
    (filter-map (match-lambda
                  ((spec . value)
                   (let ((variable (search-path-specification-variable spec))
                         (sep      (search-path-specification-separator spec)))
                     (environment-variable-definition variable value
                                                      #:separator sep
                                                      #:kind kind))))
                (evaluate-search-paths search-paths profiles
                                       getenv))))

(define (absolutize file)
  "Return an absolute file name equivalent to FILE, but without resolving
symlinks like 'canonicalize-path' would do."
  (if (string-prefix? "/" file)
      file
      (string-append (getcwd) "/" file)))

(define (display-search-path-hint entries profile)
  "Display a hint on how to set environment variables to use ENTRIES, a list
of manifest entries, in the context of PROFILE."
  (let* ((profile  (user-friendly-profile (absolutize profile)))
         (settings (search-path-environment-variables entries (list profile)
                                                      #:kind 'prefix)))
    (unless (null? settings)
      (display-hint (format #f (G_ "Consider setting the necessary environment
variables by running:

@example
GUIX_PROFILE=\"~a\"
. \"$GUIX_PROFILE/etc/profile\"
@end example

Alternately, see @command{guix package --search-paths -p ~s}.")
                            profile profile)))))

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

(define %default-options
  ;; Alist of default option values.
  `((verbosity . 1)
    (debug . 0)
    (graft? . #t)
    (substitutes? . #t)
    (offload? . #t)
    (print-build-trace? . #t)
    (print-extended-build-trace? . #t)
    (multiplexed-build-output? . #t)))

(define (show-help)
  (display (G_ "Usage: guix package [OPTION]...
Install, remove, or upgrade packages in a single transaction.\n"))
  (display (G_ "
  -i, --install PACKAGE ...
                         install PACKAGEs"))
  (display (G_ "
  -e, --install-from-expression=EXP
                         install the package EXP evaluates to"))
  (display (G_ "
  -f, --install-from-file=FILE
                         install the package that the code within FILE
                         evaluates to"))
  (display (G_ "
  -r, --remove PACKAGE ...
                         remove PACKAGEs"))
  (display (G_ "
  -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP"))
  (display (G_ "
  -m, --manifest=FILE    create a new profile generation with the manifest
                         from FILE"))
  (display (G_ "
      --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP"))
  (display (G_ "
      --roll-back        roll back to the previous generation"))
  (display (G_ "
      --search-paths[=KIND]
                         display needed environment variable definitions"))
  (display (G_ "
  -l, --list-generations[=PATTERN]
                         list generations matching PATTERN"))
  (display (G_ "
  -d, --delete-generations[=PATTERN]
                         delete generations matching PATTERN"))
  (display (G_ "
  -S, --switch-generation=PATTERN
                         switch to a generation matching PATTERN"))
  (display (G_ "
  -p, --profile=PROFILE  use PROFILE instead of the user's default profile"))
  (display (G_ "
      --list-profiles    list the user's profiles"))
  (newline)
  (display (G_ "
      --allow-collisions do not treat collisions in the profile as an error"))
  (display (G_ "
      --bootstrap        use the bootstrap Guile to build the profile"))
  (display (G_ "
  -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
  (newline)
  (display (G_ "
  -s, --search=REGEXP    search in synopsis and description using REGEXP"))
  (display (G_ "
  -I, --list-installed[=REGEXP]
                         list installed packages matching REGEXP"))
  (display (G_ "
  -A, --list-available[=REGEXP]
                         list available packages matching REGEXP"))
  (display (G_ "
      --show=PACKAGE     show details about PACKAGE"))
  (newline)
  (show-build-options-help)
  (newline)
  (show-transformation-options-help)
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

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

         (option '(#\i "install") #f #t
                 (lambda (opt name arg result arg-handler)
                   (let arg-handler ((arg arg) (result result))
                     (values (if arg
                                 (alist-cons 'install arg result)
                                 result)
                             arg-handler))))
         (option '(#\e "install-from-expression") #t #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'install (read/eval-package-expression arg)
                                       result)
                           #f)))
         (option '(#\f "install-from-file") #t #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'install
                                       (let ((file (or (and (string-suffix? ".json" arg)
                                                            (json->scheme-file arg))
                                                       arg)))
                                         (load* file (make-user-module '())))
                                       result)
                           #f)))
         (option '(#\r "remove") #f #t
                 (lambda (opt name arg result arg-handler)
                   (let arg-handler ((arg arg) (result result))
                     (values (if arg
                                 (alist-cons 'remove arg result)
                                 result)
                             arg-handler))))
         (option '(#\u "upgrade") #f #t
                 (lambda (opt name arg result arg-handler)
                   (when (and arg (string-prefix? "-" arg))
                     (warning (G_ "upgrade regexp '~a' looks like a \
command-line option~%")
                              arg)
                     (warning (G_ "is this intended?~%")))
                   (let arg-handler ((arg arg) (result result))
                     (values (alist-cons 'upgrade arg
                                         ;; Delete any prior "upgrade all"
                                         ;; command, or else "--upgrade gcc"
                                         ;; would upgrade everything.
                                         (delete '(upgrade . #f) result))
                             arg-handler))))
         (option '("do-not-upgrade") #f #t
                 (lambda (opt name arg result arg-handler)
                   (let arg-handler ((arg arg) (result result))
                     (values (if arg
                                 (alist-cons 'do-not-upgrade arg result)
                                 result)
                             arg-handler))))
         (option '("roll-back" "rollback") #f #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'roll-back? #t result)
                           #f)))
         (option '(#\m "manifest") #t #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'manifest arg result)
                           arg-handler)))
         (option '(#\l "list-generations") #f #t
                 (lambda (opt name arg result arg-handler)
                   (values (cons `(query list-generations ,arg)
                                 result)
                           #f)))
         (option '("list-profiles") #f #f
                 (lambda (opt name arg result arg-handler)
                   (values (cons `(query list-profiles #t)
                                 result)
                           #f)))
         (option '(#\d "delete-generations") #f #t
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'delete-generations arg
                                       result)
                           #f)))
         (option '(#\S "switch-generation") #t #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'switch-generation arg result)
                           #f)))
         (option '("search-paths") #f #t
                 (lambda (opt name arg result arg-handler)
                   (let ((kind (match arg
                                 ((or "exact" "prefix" "suffix")
                                  (string->symbol arg))
                                 (#f
                                  'exact)
                                 (x
                                  (leave (G_ "~a: unsupported \
kind of search path~%")
                                         x)))))
                     (values (cons `(query search-paths ,kind)
                                   result)
                             #f))))
         (option '(#\p "profile") #t #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'profile (canonicalize-profile arg)
                                       result)
                           #f)))
         (option '(#\n "dry-run") #f #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'dry-run? #t result)
                           #f)))
         (option '(#\v "verbosity") #t #f
                 (lambda (opt name arg result arg-handler)
                   (let ((level (string->number* arg)))
                     (values (alist-cons 'verbosity level
                                         (alist-delete 'verbosity result))
                             #f))))
         (option '("bootstrap") #f #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'bootstrap? #t result)
                           #f)))
         (option '("verbose") #f #f               ;deprecated
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'verbosity 2
                                       (alist-delete 'verbosity
                                                     result))
                           #f)))
         (option '("allow-collisions") #f #f
                 (lambda (opt name arg result arg-handler)
                   (values (alist-cons 'allow-collisions? #t result)
                           #f)))
         (option '(#\s "search") #t #f
                 (lambda (opt name arg result arg-handler)
                   (values (cons `(query search ,(or arg ""))
                                 result)
                           #f)))
         (option '(#\I "list-installed") #f #t
                 (lambda (opt name arg result arg-handler)
                   (values (cons `(query list-installed ,(or arg ""))
                                 result)
                           #f)))
         (option '(#\A "list-available") #f #t
                 (lambda (opt name arg result arg-handler)
                   (values (cons `(query list-available ,(or arg ""))
                                 result)
                           #f)))
         (option '("show") #t #t
                 (lambda (opt name arg result arg-handler)
                   (values (cons `(query show ,arg)
                                 result)
                           #f)))

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

(define (options->upgrade-predicate opts)
  "Return a predicate based on the upgrade/do-not-upgrade regexps in OPTS
that, given a package name, returns true if the package is a candidate for
upgrading, #f otherwise."
  (define upgrade-regexps
    (filter-map (match-lambda
                  (('upgrade . regexp)
                   (make-regexp* (or regexp "") regexp/icase))
                  (_ #f))
                opts))

  (define do-not-upgrade-regexps
    (filter-map (match-lambda
                  (('do-not-upgrade . regexp)
                   (make-regexp* regexp regexp/icase))
                  (_ #f))
                opts))

  (lambda (name)
    (and (any (cut regexp-exec <> name) upgrade-regexps)
         (not (any (cut regexp-exec <> name) do-not-upgrade-regexps)))))

(define (store-item->manifest-entry item)
  "Return a manifest entry for ITEM, a \"/gnu/store/...\" file name."
  (let-values (((name version)
                (package-name->name+version (store-path-package-name item)
                                            #\-)))
    (manifest-entry
      (name name)
      (version version)
      (output "out")                              ;XXX: wild guess
      (item item))))

(define (package->manifest-entry* package output)
  "Like 'package->manifest-entry', but attach PACKAGE provenance meta-data to
the resulting manifest entry."
  (define (provenance-properties package)
    (match (package-provenance package)
      (#f   '())
      (sexp `((provenance ,@sexp)))))

  (package->manifest-entry package output
                           #:properties (provenance-properties package)))

(define (options->installable opts manifest transaction)
  "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
return an variant of TRANSACTION that accounts for the specified installations
and upgrades."
  (define upgrade?
    (options->upgrade-predicate opts))

  (define upgraded
    (fold (lambda (entry transaction)
            (if (upgrade? (manifest-entry-name entry))
                (transaction-upgrade-entry (%store) entry transaction)
                transaction))
          transaction
          (manifest-entries manifest)))

  (define to-install
    (filter-map (match-lambda
                  (('install . (? package? p))
                   ;; When given a package via `-e', install the first of its
                   ;; outputs (XXX).
                   (package->manifest-entry* p "out"))
                  (('install . (? string? spec))
                   (if (store-path? spec)
                       (store-item->manifest-entry spec)
                       (let-values (((package output)
                                     (specification->package+output spec)))
                         (package->manifest-entry* package output))))
                  (('install . obj)
                   (leave (G_ "cannot install non-package object: ~s~%")
                          obj))
                  (_
                   #f))
                opts))

  (fold manifest-transaction-install-entry
        upgraded
        to-install))

(define (options->removable options manifest transaction)
  "Given options, return a variant of TRANSACTION augmented with the list of
patterns of packages to remove."
  (fold (lambda (opt transaction)
          (match opt
            (('remove . spec)
             (call-with-values
                 (lambda ()
                   (package-specification->name+version+output spec))
               (lambda (name version output)
                 (manifest-transaction-remove-pattern
                  (manifest-pattern
                    (name name)
                    (version version)
                    (output output))
                  transaction))))
            (_ transaction)))
        transaction
        options))

(define (register-gc-root store profile)
  "Register PROFILE, a profile generation symlink, as a GC root, unless it
doesn't need it."
  (define absolute
    ;; We must pass the daemon an absolute file name for PROFILE.  However, we
    ;; cannot use (canonicalize-path profile) because that would return us the
    ;; target of PROFILE in the store; using a store item as an indirect root
    ;; would mean that said store item will always remain live, which is not
    ;; what we want here.
    (if (string-prefix? "/" profile)
        profile
        (string-append (getcwd) "/" profile)))

  (add-indirect-root store absolute))

;;;
;;; Queries and actions.
;;;

(define (process-query opts)
  "Process any query specified by OPTS.  Return #t when a query was actually
processed, #f otherwise."
  (let* ((profiles (delete-duplicates
                    (match (filter-map (match-lambda
                                         (('profile . p) p)
                                         (_              #f))
                                       opts)
                      (() (list %current-profile))
                      (lst (reverse lst)))))
         (profile  (match profiles
                     ((head tail ...) head))))
    (match (assoc-ref opts 'query)
      (('list-generations pattern)
       (define (list-generation display-function number)
         (unless (zero? number)
           (display-generation profile number)
           (display-function profile number)
           (newline)))
       (define (diff-profiles profile numbers)
         (unless (null-list? (cdr numbers))
           (display-profile-content-diff profile (car numbers) (cadr numbers))
           (diff-profiles profile (cdr numbers))))

       (leave-on-EPIPE
        (cond ((not (file-exists? profile))       ; XXX: race condition
               (raise (condition (&profile-not-found-error
                                  (profile profile)))))
              ((not pattern)
               (match (profile-generations profile)
                 (()
                  #t)
                 ((first rest ...)
                  (list-generation display-profile-content first)
                  (diff-profiles profile (cons first rest)))))
              ((matching-generations pattern profile)
               =>
               (lambda (numbers)
                 (if (null-list? numbers)
                     (exit 1)
                     (begin
                       (list-generation display-profile-content (car numbers))
                       (diff-profiles profile numbers)))))))
       #t)

      (('list-installed regexp)
       (let* ((regexp    (and regexp (make-regexp* regexp regexp/icase)))
              (manifest  (concatenate-manifests
                          (map profile-manifest profiles)))
              (installed (manifest-entries manifest)))
         (leave-on-EPIPE
          (for-each (match-lambda
                      (($ <manifest-entry> name version output path _)
                       (when (or (not regexp)
                                 (regexp-exec regexp name))
                         (format #t "~a\t~a\t~a\t~a~%"
                                 name (or version "?") output path))))

                    ;; Show most recently installed packages last.
                    (reverse installed))))
       #t)

      (('list-available regexp)
       (let* ((regexp    (and regexp (make-regexp* regexp regexp/icase)))
              (available (fold-available-packages
                          (lambda* (name version result
                                         #:key outputs location
                                         supported? deprecated?
                                         #:allow-other-keys)
                            (if (and supported? (not deprecated?))
                                (if regexp
                                    (if (regexp-exec regexp name)
                                        (cons `(,name ,version
                                                      ,outputs ,location)
                                              result)
                                        result)
                                    (cons `(,name ,version
                                                  ,outputs ,location)
                                          result))
                                result))
                          '())))
         (leave-on-EPIPE
          (for-each (match-lambda
                      ((name version outputs location)
                       (format #t "~a\t~a\t~a\t~a~%"
                               name version
                               (string-join outputs ",")
                               (location->string location))))
                    (sort available
                          (match-lambda*
                            (((name1 . _) (name2 . _))
                             (string<? name1 name2))))))
         #t))

      (('list-profiles _)
       (let ((profiles (delete-duplicates
                        (filter-map (lambda (root)
                                      (and (or (zero? (getuid))
                                               (user-owned? root))
                                           (generation-profile root)))
                                    (gc-roots)))))
         (leave-on-EPIPE
          (for-each (lambda (profile)
                      (display (user-friendly-profile profile))
                      (newline))
                    (sort profiles string<?)))))

      (('search _)
       (let* ((patterns (filter-map (match-lambda
                                      (('query 'search rx) rx)
                                      (_                   #f))
                                    opts))
              (regexps  (map (cut make-regexp* <> regexp/icase) patterns))
              (matches  (find-packages-by-description regexps)))
         (leave-on-EPIPE
          (display-search-results matches (current-output-port)))
         #t))

      (('show _)
       (let ((requested-names
              (filter-map (match-lambda
                            (('query 'show requested-name) requested-name)
                            (_                            #f))
                          opts)))
         (for-each
          (lambda (requested-name)
            (let-values (((name version)
                          (package-name->name+version requested-name)))
              (match (remove package-superseded
                             (find-packages-by-name name version))
                (()
                 (leave (G_ "~a~@[@~a~]: package not found~%") name version))
                (packages
                 (leave-on-EPIPE
                  (for-each (cute package->recutils <> (current-output-port))
                            packages))))))
          requested-names))
       #t)

      (('search-paths kind)
       (let* ((manifests (map profile-manifest profiles))
              (entries   (append-map manifest-transitive-entries
                                     manifests))
              (profiles  (map user-friendly-profile profiles))
              (settings  (search-path-environment-variables entries profiles
                                                            (const #f)
                                                            #:kind kind)))
         (format #t "~{~a~%~}" settings)
         #t))

      (_ #f))))

(define* (roll-back-action store profile arg opts
                           #:key dry-run?)
  "Roll back PROFILE to its previous generation."
  (unless dry-run?
    (roll-back* store profile)))

(define* (switch-generation-action store profile spec opts
                                   #:key dry-run?)
  "Switch PROFILE to the generation specified by SPEC."
  (unless dry-run?
    (let ((number (relative-generation-spec->number profile spec)))
      (if number
          (switch-to-generation* profile number)
          (leave (G_ "cannot switch to generation '~a'~%") spec)))))

(define* (delete-generations-action store profile pattern opts
                                    #:key dry-run?)
  "Delete PROFILE's generations that match PATTERN."
  (unless dry-run?
    (delete-matching-generations store profile pattern)))

(define (load-manifest file)
  "Load the user-profile manifest (Scheme code) from FILE and return it."
  (let ((user-module (make-user-module '((guix profiles) (gnu)))))
    (load* file user-module)))

(define %actions
  ;; List of actions that may be processed.  The car of each pair is the
  ;; action's symbol in the option list; the cdr is the action's procedure.
  `((roll-back? . ,roll-back-action)
    (switch-generation . ,switch-generation-action)
    (delete-generations . ,delete-generations-action)))

(define (process-actions store opts)
  "Process any install/remove/upgrade action from OPTS."

  (define dry-run? (assoc-ref opts 'dry-run?))
  (define bootstrap? (assoc-ref opts 'bootstrap?))
  (define substitutes? (assoc-ref opts 'substitutes?))
  (define allow-collisions? (assoc-ref opts 'allow-collisions?))
  (define profile  (or (assoc-ref opts 'profile) %current-profile))
  (define transform (options->transformation opts))

  (define (transform-entry entry)
    (let ((item (transform store (manifest-entry-item entry))))
      (manifest-entry
        (inherit entry)
        (item item)
        (version (if (package? item)
                     (package-version item)
                     (manifest-entry-version entry))))))

  (when (equal? profile %current-profile)
    ;; Normally the daemon created %CURRENT-PROFILE when we connected, unless
    ;; it's a version that lacks the fix for <https://bugs.gnu.org/37744>
    ;; (aka. CVE-2019-18192).  Ensure %CURRENT-PROFILE exists so that
    ;; 'with-profile-lock' can create its lock file below.
    (ensure-default-profile))

  ;; First, acquire a lock on the profile, to ensure only one guix process
  ;; is modifying it at a time.
  (with-profile-lock profile
    ;; Then, process roll-backs, generation removals, etc.
    (for-each (match-lambda
                ((key . arg)
                 (and=> (assoc-ref %actions key)
                        (lambda (proc)
                          (proc store profile arg opts
                                #:dry-run? dry-run?)))))
              opts)

    ;; Then, process normal package removal/installation/upgrade.
    (let* ((files    (filter-map (match-lambda
                                   (('manifest . file) file)
                                   (_ #f))
                                 opts))
           (manifest (match files
                       (() (profile-manifest profile))
                       (_  (map-manifest-entries
                            manifest-entry-with-provenance
                            (concatenate-manifests
                             (map load-manifest files))))))
           (step1    (options->removable opts manifest
                                         (manifest-transaction)))
           (step2    (options->installable opts manifest step1))
           (step3    (manifest-transaction
                      (inherit step2)
                      (install (map transform-entry
                                    (manifest-transaction-install step2)))))
           (new      (manifest-perform-transaction manifest step3))
           (trans    (if (null? files)
                         step3
                         (fold manifest-transaction-install-entry
                               step3
                               (manifest-entries manifest)))))

      (warn-about-old-distro)

      (unless (manifest-transaction-null? trans)
        ;; When '--manifest' is used, display information about TRANS as if we
        ;; were starting from an empty profile.
        (show-manifest-transaction store
                                   (if (null? files)
                                       manifest
                                       (make-manifest '()))
                                   trans
                                   #:dry-run? dry-run?)
        (build-and-use-profile store profile new
                               #:allow-collisions? allow-collisions?
                               #:bootstrap? bootstrap?)))))

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

(define-command (guix-package . args)
  (synopsis "manage packages and profiles")

  (define (handle-argument arg result arg-handler)
    ;; Process non-option argument ARG by calling back ARG-HANDLER.
    (if arg-handler
        (arg-handler arg result)
        (leave (G_ "~A: extraneous argument~%") arg)))

  (define opts
    (parse-command-line args %options (list %default-options #f)
                        #:argument-handler handle-argument))

  (guix-package* opts))

(define (guix-package* opts)
  "Run the 'guix package' command on OPTS, an alist resulting for command-line
option processing with 'parse-command-line'."
  (with-error-handling
    (or (process-query opts)
        (parameterize ((%store  (open-connection))
                       (%graft? (assoc-ref opts 'graft?)))
          (with-status-verbosity (assoc-ref opts 'verbosity)
            (set-build-options-from-command-line (%store) opts)
            (with-build-handler (build-notifier #:use-substitutes?
                                                (assoc-ref opts 'substitutes?)
                                                #:verbosity
                                                (assoc-ref opts 'verbosity)
                                                #:dry-run?
                                                (assoc-ref opts 'dry-run?))
              (parameterize ((%guile-for-build
                              (package-derivation
                               (%store)
                               (if (assoc-ref opts 'bootstrap?)
                                   %bootstrap-guile
                                   (default-guile)))))
                (process-actions (%store) opts))))))))

license: mit