guix/scripts/pack.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
   4 ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
   5 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
   6 ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (guix scripts pack)
  24   #:use-module (guix scripts)
  25   #:use-module (guix ui)
  26   #:use-module (guix gexp)
  27   #:use-module (guix utils)
  28   #:use-module (guix store)
  29   #:use-module ((guix status) #:select (with-status-verbosity))
  30   #:use-module (guix grafts)
  31   #:autoload   (guix inferior) (inferior-package?)
  32   #:use-module (guix monads)
  33   #:use-module (guix modules)
  34   #:use-module (guix packages)
  35   #:use-module (guix profiles)
  36   #:use-module (guix describe)
  37   #:use-module (guix derivations)
  38   #:use-module (guix search-paths)
  39   #:use-module (guix build-system gnu)
  40   #:use-module (guix scripts build)
  41   #:use-module ((guix self) #:select (make-config.scm))
  42   #:use-module (gnu packages)
  43   #:use-module (gnu packages bootstrap)
  44   #:use-module ((gnu packages compression) #:hide (zip))
  45   #:use-module (gnu packages guile)
  46   #:use-module (gnu packages base)
  47   #:autoload   (gnu packages package-management) (guix)
  48   #:autoload   (gnu packages gnupg) (guile-gcrypt)
  49   #:autoload   (gnu packages guile) (guile2.0-json guile-json)
  50   #:use-module (srfi srfi-1)
  51   #:use-module (srfi srfi-9)
  52   #:use-module (srfi srfi-26)
  53   #:use-module (srfi srfi-37)
  54   #:use-module (ice-9 match)
  55   #:export (compressor?
  56             lookup-compressor
  57             self-contained-tarball
  58             docker-image
  59             squashfs-image
  60
  61             guix-pack))
  62
  63 ;; Type of a compression tool.
  64 (define-record-type <compressor>
  65   (compressor name extension command)
  66   compressor?
  67   (name       compressor-name)      ;string (e.g., "gzip")
  68   (extension  compressor-extension) ;string (e.g., ".lz")
  69   (command    compressor-command))  ;gexp (e.g., #~("/gnu/store/…/gzip" "-9n"))
  70
  71 (define %compressors
  72   ;; Available compression tools.
  73   (list (compressor "gzip"  ".gz"
  74                     #~(#+(file-append gzip "/bin/gzip") "-9n"))
  75         (compressor "lzip"  ".lz"
  76                     #~(#+(file-append lzip "/bin/lzip") "-9"))
  77         (compressor "xz"    ".xz"
  78                     #~(#+(file-append xz "/bin/xz") "-e"))
  79         (compressor "bzip2" ".bz2"
  80                     #~(#+(file-append bzip2 "/bin/bzip2") "-9"))
  81         (compressor "none" "" #f)))
  82
  83 ;; This one is only for use in this module, so don't put it in %compressors.
  84 (define bootstrap-xz
  85   (compressor "bootstrap-xz" ".xz"
  86               #~(#+(file-append %bootstrap-coreutils&co "/bin/xz") "-e")))
  87
  88 (define (lookup-compressor name)
  89   "Return the compressor object called NAME.  Error out if it could not be
  90 found."
  91   (or (find (match-lambda
  92               (($ <compressor> name*)
  93                (string=? name* name)))
  94             %compressors)
  95       (leave (G_ "~a: compressor not found~%") name)))
  96
  97 (define not-config?
  98   ;; Select (guix …) and (gnu …) modules, except (guix config).
  99   (match-lambda
 100     (('guix 'config) #f)
 101     (('guix _ ...) #t)
 102     (('gnu _ ...) #t)
 103     (_ #f)))
 104
 105 (define gcrypt-sqlite3&co
 106   ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
 107   (append-map (lambda (package)
 108                 (cons package
 109                       (match (package-transitive-propagated-inputs package)
 110                         (((labels packages) ...)
 111                          packages))))
 112               (list guile-gcrypt guile-sqlite3)))
 113
 114 (define (store-database items)
 115   "Return a directory containing a store database where all of ITEMS and their
 116 dependencies are registered."
 117   (define schema
 118     (local-file (search-path %load-path
 119                              "guix/store/schema.sql")))
 120
 121
 122   (define labels
 123     (map (lambda (n)
 124            (string-append "closure" (number->string n)))
 125          (iota (length items))))
 126
 127   (define build
 128     (with-extensions gcrypt-sqlite3&co
 129       (with-imported-modules (source-module-closure
 130                               '((guix build store-copy)
 131                                 (guix store database)))
 132         #~(begin
 133             (use-modules (guix store database)
 134                          (guix build store-copy)
 135                          (srfi srfi-1))
 136
 137             (define (read-closure closure)
 138               (call-with-input-file closure read-reference-graph))
 139
 140             (let ((items (append-map read-closure '#$labels)))
 141               (register-items items
 142                               #:state-directory #$output
 143                               #:deduplicate? #f
 144                               #:reset-timestamps? #f
 145                               #:registration-time %epoch
 146                               #:schema #$schema))))))
 147
 148   (computed-file "store-database" build
 149                  #:options `(#:references-graphs ,(zip labels items))))
 150
 151 (define* (self-contained-tarball name profile
 152                                  #:key target
 153                                  (profile-name "guix-profile")
 154                                  deduplicate?
 155                                  (compressor (first %compressors))
 156                                  localstatedir?
 157                                  (symlinks '())
 158                                  (archiver tar))
 159   "Return a self-contained tarball containing a store initialized with the
 160 closure of PROFILE, a derivation.  The tarball contains /gnu/store; if
 161 LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db
 162 with a properly initialized store database.
 163
 164 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 165 added to the pack."
 166   (define database
 167     (and localstatedir?
 168          (file-append (store-database (list profile))
 169                       "/db/db.sqlite")))
 170
 171   (define build
 172     (with-imported-modules (source-module-closure
 173                             `((guix build utils)
 174                               (guix build union)
 175                               (gnu build install))
 176                             #:select? not-config?)
 177       #~(begin
 178           (use-modules (guix build utils)
 179                        ((guix build union) #:select (relative-file-name))
 180                        (gnu build install)
 181                        (srfi srfi-1)
 182                        (srfi srfi-26)
 183                        (ice-9 match))
 184
 185           (define %root "root")
 186
 187           (define symlink->directives
 188             ;; Return "populate directives" to make the given symlink and its
 189             ;; parent directories.
 190             (match-lambda
 191               ((source '-> target)
 192                (let ((target (string-append #$profile "/" target))
 193                      (parent (dirname source)))
 194                  ;; Never add a 'directory' directive for "/" so as to
 195                  ;; preserve its ownnership when extracting the archive (see
 196                  ;; below), and also because this would lead to adding the
 197                  ;; same entries twice in the tarball.
 198                  `(,@(if (string=? parent "/")
 199                          '()
 200                          `((directory ,parent)))
 201                    (,source
 202                     -> ,(relative-file-name parent target)))))))
 203
 204           (define directives
 205             ;; Fully-qualified symlinks.
 206             (append-map symlink->directives '#$symlinks))
 207
 208           ;; The --sort option was added to GNU tar in version 1.28, released
 209           ;; 2014-07-28.  For testing, we use the bootstrap tar, which is
 210           ;; older and doesn't support it.
 211           (define tar-supports-sort?
 212             (zero? (system* (string-append #+archiver "/bin/tar")
 213                             "cf" "/dev/null" "--files-from=/dev/null"
 214                             "--sort=name")))
 215
 216           ;; Add 'tar' to the search path.
 217           (setenv "PATH" #+(file-append archiver "/bin"))
 218
 219           ;; Note: there is not much to gain here with deduplication and there
 220           ;; is the overhead of the '.links' directory, so turn it off.
 221           ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
 222           ;; with hard links:
 223           ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
 224           (populate-single-profile-directory %root
 225                                              #:profile #$profile
 226                                              #:profile-name #$profile-name
 227                                              #:closure "profile"
 228                                              #:database #+database)
 229
 230           ;; Create SYMLINKS.
 231           (for-each (cut evaluate-populate-directive <> %root)
 232                     directives)
 233
 234           ;; Create the tarball.  Use GNU format so there's no file name
 235           ;; length limitation.
 236           (with-directory-excursion %root
 237             (exit
 238              (zero? (apply system* "tar"
 239                            #+@(if (compressor-command compressor)
 240                                   #~("-I"
 241                                      (string-join
 242                                       '#+(compressor-command compressor)))
 243                                   #~())
 244                            "--format=gnu"
 245
 246                            ;; Avoid non-determinism in the archive.  Use
 247                            ;; mtime = 1, not zero, because that is what the
 248                            ;; daemon does for files in the store (see the
 249                            ;; 'mtimeStore' constant in local-store.cc.)
 250                            (if tar-supports-sort? "--sort=name" "--mtime=@1")
 251                            "--mtime=@1"           ;for files in /var/guix
 252                            "--owner=root:0"
 253                            "--group=root:0"
 254
 255                            "--check-links"
 256                            "-cvf" #$output
 257                            ;; Avoid adding / and /var to the tarball, so
 258                            ;; that the ownership and permissions of those
 259                            ;; directories will not be overwritten when
 260                            ;; extracting the archive.  Do not include /root
 261                            ;; because the root account might have a
 262                            ;; different home directory.
 263                            #$@(if localstatedir?
 264                                   '("./var/guix")
 265                                   '())
 266
 267                            (string-append "." (%store-directory))
 268
 269                            (delete-duplicates
 270                             (filter-map (match-lambda
 271                                           (('directory directory)
 272                                            (string-append "." directory))
 273                                           ((source '-> _)
 274                                            (string-append "." source))
 275                                           (_ #f))
 276                                         directives)))))))))
 277
 278   (gexp->derivation (string-append name ".tar"
 279                                    (compressor-extension compressor))
 280                     build
 281                     #:references-graphs `(("profile" ,profile))))
 282
 283 (define* (squashfs-image name profile
 284                          #:key target
 285                          (profile-name "guix-profile")
 286                          (compressor (first %compressors))
 287                          localstatedir?
 288                          (symlinks '())
 289                          (archiver squashfs-tools-next))
 290   "Return a squashfs image containing a store initialized with the closure of
 291 PROFILE, a derivation.  The image contains a subset of /gnu/store, empty mount
 292 points for virtual file systems (like procfs), and optional symlinks.
 293
 294 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 295 added to the pack."
 296   (define database
 297     (and localstatedir?
 298          (file-append (store-database (list profile))
 299                       "/db/db.sqlite")))
 300
 301   (define build
 302     (with-imported-modules (source-module-closure
 303                             '((guix build utils)
 304                               (guix build store-copy)
 305                               (guix build union)
 306                               (gnu build install))
 307                             #:select? not-config?)
 308       #~(begin
 309           (use-modules (guix build utils)
 310                        (guix build store-copy)
 311                        ((guix build union) #:select (relative-file-name))
 312                        (gnu build install)
 313                        (srfi srfi-1)
 314                        (srfi srfi-26)
 315                        (ice-9 match))
 316
 317           (define database #+database)
 318
 319           (setenv "PATH" (string-append #$archiver "/bin"))
 320
 321           ;; We need an empty file in order to have a valid file argument when
 322           ;; we reparent the root file system.  Read on for why that's
 323           ;; necessary.
 324           (with-output-to-file ".empty" (lambda () (display "")))
 325
 326           ;; Create the squashfs image in several steps.
 327           ;; Add all store items.  Unfortunately mksquashfs throws away all
 328           ;; ancestor directories and only keeps the basename.  We fix this
 329           ;; in the following invocations of mksquashfs.
 330           (apply invoke "mksquashfs"
 331                  `(,@(map store-info-item
 332                           (call-with-input-file "profile"
 333                             read-reference-graph))
 334                    ,#$output
 335
 336                    ;; Do not perform duplicate checking because we
 337                    ;; don't have any dupes.
 338                    "-no-duplicates"
 339                    "-comp"
 340                    ,#+(compressor-name compressor)))
 341
 342           ;; Here we reparent the store items.  For each sub-directory of
 343           ;; the store prefix we need one invocation of "mksquashfs".
 344           (for-each (lambda (dir)
 345                       (apply invoke "mksquashfs"
 346                              `(".empty"
 347                                ,#$output
 348                                "-root-becomes" ,dir)))
 349                     (reverse (string-tokenize (%store-directory)
 350                                               (char-set-complement (char-set #\/)))))
 351
 352           ;; Add symlinks and mount points.
 353           (apply invoke "mksquashfs"
 354                  `(".empty"
 355                    ,#$output
 356                    ;; Create SYMLINKS via pseudo file definitions.
 357                    ,@(append-map
 358                       (match-lambda
 359                         ((source '-> target)
 360                          ;; Create relative symlinks to work around a bug in
 361                          ;; Singularity 2.x:
 362                          ;;   https://bugs.gnu.org/34913
 363                          ;;   https://github.com/sylabs/singularity/issues/1487
 364                          (let ((target (string-append #$profile "/" target)))
 365                            (list "-p"
 366                                  (string-join
 367                                   ;; name s mode uid gid symlink
 368                                   (list source
 369                                         "s" "777" "0" "0"
 370                                         (relative-file-name (dirname source)
 371                                                             target)))))))
 372                       '#$symlinks)
 373
 374                    ;; Create empty mount points.
 375                    "-p" "/proc d 555 0 0"
 376                    "-p" "/sys d 555 0 0"
 377                    "-p" "/dev d 555 0 0"
 378                    "-p" "/home d 555 0 0"))
 379
 380           (when database
 381             ;; Initialize /var/guix.
 382             (install-database-and-gc-roots "var-etc" database #$profile)
 383             (invoke "mksquashfs" "var-etc" #$output)))))
 384
 385   (gexp->derivation (string-append name
 386                                    (compressor-extension compressor)
 387                                    ".squashfs")
 388                     build
 389                     #:references-graphs `(("profile" ,profile))))
 390
 391 (define* (docker-image name profile
 392                        #:key target
 393                        (profile-name "guix-profile")
 394                        (compressor (first %compressors))
 395                        localstatedir?
 396                        (symlinks '())
 397                        (archiver tar))
 398   "Return a derivation to construct a Docker image of PROFILE.  The
 399 image is a tarball conforming to the Docker Image Specification, compressed
 400 with COMPRESSOR.  It can be passed to 'docker load'.  If TARGET is true, it
 401 must a be a GNU triplet and it is used to derive the architecture metadata in
 402 the image."
 403   (define database
 404     (and localstatedir?
 405          (file-append (store-database (list profile))
 406                       "/db/db.sqlite")))
 407
 408   (define defmod 'define-module)                  ;trick Geiser
 409
 410   (define build
 411     ;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
 412     (with-extensions (list guile-json guile-gcrypt)
 413       (with-imported-modules (source-module-closure '((guix docker)
 414                                                       (guix build store-copy))
 415                                                     #:select? not-config?)
 416         #~(begin
 417             (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
 418
 419             (setenv "PATH" (string-append #$archiver "/bin"))
 420
 421             (build-docker-image #$output
 422                                 (map store-info-item
 423                                      (call-with-input-file "profile"
 424                                        read-reference-graph))
 425                                 #$profile
 426                                 #:database #+database
 427                                 #:system (or #$target (utsname:machine (uname)))
 428                                 #:symlinks '#$symlinks
 429                                 #:compressor '#$(compressor-command compressor)
 430                                 #:creation-time (make-time time-utc 0 1))))))
 431
 432   (gexp->derivation (string-append name ".tar"
 433                                    (compressor-extension compressor))
 434                     build
 435                     #:references-graphs `(("profile" ,profile))))
 436
 437 \f
 438 ;;;
 439 ;;; Compiling C programs.
 440 ;;;
 441
 442 ;; A C compiler.  That lowers to a single program that can be passed typical C
 443 ;; compiler flags, and it makes sure the whole toolchain is available.
 444 (define-record-type <c-compiler>
 445   (%c-compiler toolchain guile)
 446   c-compiler?
 447   (toolchain c-compiler-toolchain)
 448   (guile     c-compiler-guile))
 449
 450 (define* (c-compiler #:optional inputs
 451                      #:key (guile (default-guile)))
 452   (%c-compiler inputs guile))
 453
 454 (define (bootstrap-c-compiler)
 455   "Return the C compiler that uses the bootstrap toolchain.  This is used only
 456 by '--bootstrap', for testing purposes."
 457   (define bootstrap-toolchain
 458     (list (first (assoc-ref %bootstrap-inputs "gcc"))
 459           (first (assoc-ref %bootstrap-inputs "binutils"))
 460           (first (assoc-ref %bootstrap-inputs "libc"))))
 461
 462   (c-compiler bootstrap-toolchain
 463               #:guile %bootstrap-guile))
 464
 465 (define-gexp-compiler (c-compiler-compiler (compiler <c-compiler>) system target)
 466   "Lower COMPILER to a single script that does the right thing."
 467   (define toolchain
 468     (or (c-compiler-toolchain compiler)
 469         (list (first (assoc-ref (standard-packages) "gcc"))
 470               (first (assoc-ref (standard-packages) "ld-wrapper"))
 471               (first (assoc-ref (standard-packages) "binutils"))
 472               (first (assoc-ref (standard-packages) "libc"))
 473               (gexp-input (first (assoc-ref (standard-packages) "libc"))
 474                           "static"))))
 475
 476   (define inputs
 477     (match (append-map package-propagated-inputs
 478                        (filter package? toolchain))
 479       (((labels things . _) ...)
 480        (append toolchain things))))
 481
 482   (define search-paths
 483     (cons $PATH
 484           (append-map package-native-search-paths
 485                       (filter package? inputs))))
 486
 487   (define run
 488     (with-imported-modules (source-module-closure
 489                             '((guix build utils)
 490                               (guix search-paths)))
 491       #~(begin
 492           (use-modules (guix build utils) (guix search-paths)
 493                        (ice-9 match))
 494
 495           (define (output-file args)
 496             (let loop ((args args))
 497               (match args
 498                 (() "a.out")
 499                 (("-o" file _ ...) file)
 500                 ((head rest ...) (loop rest)))))
 501
 502           (set-search-paths (map sexp->search-path-specification
 503                                  '#$(map search-path-specification->sexp
 504                                          search-paths))
 505                             '#$inputs)
 506
 507           (let ((output (output-file (command-line))))
 508             (apply invoke "gcc" (cdr (command-line)))
 509             (invoke "strip" output)))))
 510
 511   (when target
 512     ;; TODO: Yep, we'll have to do it someday!
 513     (leave (G_ "cross-compilation not implemented here;
 514 please email '~a'~%")
 515            (@ (guix config) %guix-bug-report-address)))
 516
 517   (gexp->script "c-compiler" run
 518                 #:guile (c-compiler-guile compiler)))
 519
 520 \f
 521 ;;;
 522 ;;; Wrapped package.
 523 ;;;
 524
 525 (define* (wrapped-package package
 526                           #:optional (compiler (c-compiler))
 527                           #:key proot?)
 528   (define runner
 529     (local-file (search-auxiliary-file "run-in-namespace.c")))
 530
 531   (define (proot)
 532     (specification->package "proot-static"))
 533
 534   (define build
 535     (with-imported-modules (source-module-closure
 536                             '((guix build utils)
 537                               (guix build union)))
 538       #~(begin
 539           (use-modules (guix build utils)
 540                        ((guix build union) #:select (relative-file-name))
 541                        (ice-9 ftw)
 542                        (ice-9 match))
 543
 544           (define (strip-store-prefix file)
 545             ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
 546             ;; "/bin/foo".
 547             (let* ((len  (string-length (%store-directory)))
 548                    (base (string-drop file (+ 1 len))))
 549               (match (string-index base #\/)
 550                 (#f    base)
 551                 (index (string-drop base index)))))
 552
 553           (define (build-wrapper program)
 554             ;; Build a user-namespace wrapper for PROGRAM.
 555             (format #t "building wrapper for '~a'...~%" program)
 556             (copy-file #$runner "run.c")
 557
 558             (substitute* "run.c"
 559               (("@WRAPPED_PROGRAM@") program)
 560               (("@STORE_DIRECTORY@") (%store-directory)))
 561
 562             (let* ((base   (strip-store-prefix program))
 563                    (result (string-append #$output "/" base))
 564                    (proot  #$(and proot?
 565                                   #~(string-drop
 566                                      #$(file-append (proot) "/bin/proot")
 567                                      (+ (string-length (%store-directory))
 568                                         1)))))
 569               (mkdir-p (dirname result))
 570               (apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
 571                      "run.c" "-o" result
 572                      (if proot
 573                          (list (string-append "-DPROOT_PROGRAM=\""
 574                                               proot "\""))
 575                          '()))
 576               (delete-file "run.c")))
 577
 578           (setvbuf (current-output-port) 'line)
 579
 580           ;; Link the top-level files of PACKAGE so that search paths are
 581           ;; properly defined in PROFILE/etc/profile.
 582           (mkdir #$output)
 583           (for-each (lambda (file)
 584                       (unless (member file '("." ".." "bin" "sbin" "libexec"))
 585                         (let ((file* (string-append #$package "/" file)))
 586                           (symlink (relative-file-name #$output file*)
 587                                    (string-append #$output "/" file)))))
 588                     (scandir #$package))
 589
 590           (for-each build-wrapper
 591                     (append (find-files #$(file-append package "/bin"))
 592                             (find-files #$(file-append package "/sbin"))
 593                             (find-files #$(file-append package "/libexec")))))))
 594
 595   (computed-file (string-append
 596                   (cond ((package? package)
 597                          (package-full-name package "-"))
 598                         ((inferior-package? package)
 599                          (string-append (inferior-package-name package)
 600                                         "-"
 601                                         (inferior-package-version package)))
 602                         (else "wrapper"))
 603                   "R")
 604                  build))
 605
 606 (define (map-manifest-entries proc manifest)
 607   "Apply PROC to all the entries of MANIFEST and return a new manifest."
 608   (make-manifest
 609    (map (lambda (entry)
 610           (manifest-entry
 611             (inherit entry)
 612             (item (proc (manifest-entry-item entry)))))
 613         (manifest-entries manifest))))
 614
 615 \f
 616 ;;;
 617 ;;; Command-line options.
 618 ;;;
 619
 620 (define %default-options
 621   ;; Alist of default option values.
 622   `((format . tarball)
 623     (profile-name . "guix-profile")
 624     (system . ,(%current-system))
 625     (substitutes? . #t)
 626     (build-hook? . #t)
 627     (graft? . #t)
 628     (print-build-trace? . #t)
 629     (print-extended-build-trace? . #t)
 630     (multiplexed-build-output? . #t)
 631     (debug . 0)
 632     (verbosity . 1)
 633     (symlinks . ())
 634     (compressor . ,(first %compressors))))
 635
 636 (define %formats
 637   ;; Supported pack formats.
 638   `((tarball . ,self-contained-tarball)
 639     (squashfs . ,squashfs-image)
 640     (docker  . ,docker-image)))
 641
 642 (define (show-formats)
 643   ;; Print the supported pack formats.
 644   (display (G_ "The supported formats for 'guix pack' are:"))
 645   (newline)
 646   (display (G_ "
 647   tarball       Self-contained tarball, ready to run on another machine"))
 648   (display (G_ "
 649   squashfs      Squashfs image suitable for Singularity"))
 650   (display (G_ "
 651   docker        Tarball ready for 'docker load'"))
 652   (newline))
 653
 654 (define %options
 655   ;; Specifications of the command-line options.
 656   (cons* (option '(#\h "help") #f #f
 657                  (lambda args
 658                    (show-help)
 659                    (exit 0)))
 660          (option '(#\V "version") #f #f
 661                  (lambda args
 662                    (show-version-and-exit "guix pack")))
 663
 664          (option '(#\n "dry-run") #f #f
 665                  (lambda (opt name arg result)
 666                    (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
 667          (option '(#\f "format") #t #f
 668                  (lambda (opt name arg result)
 669                    (alist-cons 'format (string->symbol arg) result)))
 670          (option '("list-formats") #f #f
 671                  (lambda args
 672                    (show-formats)
 673                    (exit 0)))
 674          (option '(#\R "relocatable") #f #f
 675                  (lambda (opt name arg result)
 676                    (match (assq-ref result 'relocatable?)
 677                      (#f
 678                       (alist-cons 'relocatable? #t result))
 679                      (_
 680                       (alist-cons 'relocatable? 'proot
 681                                   (alist-delete 'relocatable? result))))))
 682          (option '(#\e "expression") #t #f
 683                  (lambda (opt name arg result)
 684                    (alist-cons 'expression arg result)))
 685          (option '(#\m "manifest") #t #f
 686                  (lambda (opt name arg result)
 687                    (alist-cons 'manifest arg result)))
 688          (option '(#\s "system") #t #f
 689                  (lambda (opt name arg result)
 690                    (alist-cons 'system arg
 691                                (alist-delete 'system result eq?))))
 692          (option '("target") #t #f
 693                  (lambda (opt name arg result)
 694                    (alist-cons 'target arg
 695                                (alist-delete 'target result eq?))))
 696          (option '(#\C "compression") #t #f
 697                  (lambda (opt name arg result)
 698                    (alist-cons 'compressor (lookup-compressor arg)
 699                                result)))
 700          (option '(#\S "symlink") #t #f
 701                  (lambda (opt name arg result)
 702                    ;; Note: Using 'string-split' allows us to handle empty
 703                    ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is
 704                    ;; a symlink to the profile) correctly.
 705                    (match (string-split arg (char-set #\=))
 706                      ((source target)
 707                       (let ((symlinks (assoc-ref result 'symlinks)))
 708                         (alist-cons 'symlinks
 709                                     `((,source -> ,target) ,@symlinks)
 710                                     (alist-delete 'symlinks result eq?))))
 711                      (x
 712                       (leave (G_ "~a: invalid symlink specification~%")
 713                              arg)))))
 714          (option '("save-provenance") #f #f
 715                  (lambda (opt name arg result)
 716                    (alist-cons 'save-provenance? #t result)))
 717          (option '("localstatedir") #f #f
 718                  (lambda (opt name arg result)
 719                    (alist-cons 'localstatedir? #t result)))
 720          (option '("profile-name") #t #f
 721                  (lambda (opt name arg result)
 722                    (match arg
 723                      ((or "guix-profile" "current-guix")
 724                       (alist-cons 'profile-name arg result))
 725                      (_
 726                       (leave (G_ "~a: unsupported profile name~%") arg)))))
 727          (option '(#\r "root") #t #f
 728                  (lambda (opt name arg result)
 729                    (alist-cons 'gc-root arg result)))
 730
 731          (option '(#\v "verbosity") #t #f
 732                  (lambda (opt name arg result)
 733                    (let ((level (string->number* arg)))
 734                      (alist-cons 'verbosity level
 735                                  (alist-delete 'verbosity result)))))
 736          (option '("bootstrap") #f #f
 737                  (lambda (opt name arg result)
 738                    (alist-cons 'bootstrap? #t result)))
 739
 740          (append %transformation-options
 741                  %standard-build-options)))
 742
 743 (define (show-help)
 744   (display (G_ "Usage: guix pack [OPTION]... PACKAGE...
 745 Create a bundle of PACKAGE.\n"))
 746   (show-build-options-help)
 747   (newline)
 748   (show-transformation-options-help)
 749   (newline)
 750   (display (G_ "
 751   -f, --format=FORMAT    build a pack in the given FORMAT"))
 752   (display (G_ "
 753       --list-formats     list the formats available"))
 754   (display (G_ "
 755   -R, --relocatable      produce relocatable executables"))
 756   (display (G_ "
 757   -e, --expression=EXPR  consider the package EXPR evaluates to"))
 758   (display (G_ "
 759   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
 760   (display (G_ "
 761       --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
 762   (display (G_ "
 763   -C, --compression=TOOL compress using TOOL--e.g., \"lzip\""))
 764   (display (G_ "
 765   -S, --symlink=SPEC     create symlinks to the profile according to SPEC"))
 766   (display (G_ "
 767   -m, --manifest=FILE    create a pack with the manifest from FILE"))
 768   (display (G_ "
 769       --save-provenance  save provenance information"))
 770   (display (G_ "
 771       --localstatedir    include /var/guix in the resulting pack"))
 772   (display (G_ "
 773       --profile-name=NAME
 774                          populate /var/guix/profiles/.../NAME"))
 775   (display (G_ "
 776   -r, --root=FILE        make FILE a symlink to the result, and register it
 777                          as a garbage collector root"))
 778   (display (G_ "
 779   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
 780   (display (G_ "
 781       --bootstrap        use the bootstrap binaries to build the pack"))
 782   (newline)
 783   (display (G_ "
 784   -h, --help             display this help and exit"))
 785   (display (G_ "
 786   -V, --version          display version information and exit"))
 787   (newline)
 788   (show-bug-report-information))
 789
 790 \f
 791 ;;;
 792 ;;; Entry point.
 793 ;;;
 794
 795 (define (guix-pack . args)
 796   (define opts
 797     (parse-command-line args %options (list %default-options)))
 798
 799   (define maybe-package-argument
 800     ;; Given an option pair, return a package, a package/output tuple, or #f.
 801     (match-lambda
 802       (('argument . spec)
 803        (call-with-values
 804            (lambda ()
 805              (specification->package+output spec))
 806          list))
 807       (('expression . exp)
 808        (read/eval-package-expression exp))
 809       (x #f)))
 810
 811   (define (manifest-from-args store opts)
 812     (let* ((transform     (options->transformation opts))
 813            (packages      (map (match-lambda
 814                                  (((? package? package) output)
 815                                   (list (transform store package) output))
 816                                  ((? package? package)
 817                                   (list (transform store package) "out")))
 818                                (filter-map maybe-package-argument opts)))
 819            (manifest-file (assoc-ref opts 'manifest)))
 820       (define properties
 821         (if (assoc-ref opts 'save-provenance?)
 822             (lambda (package)
 823               (match (package-provenance package)
 824                 (#f
 825                  (warning (G_ "could not determine provenance of package ~a~%")
 826                           (package-full-name package))
 827                  '())
 828                 (sexp
 829                  `((provenance . ,sexp)))))
 830             (const '())))
 831
 832       (cond
 833        ((and manifest-file (not (null? packages)))
 834         (leave (G_ "both a manifest and a package list were given~%")))
 835        (manifest-file
 836         (let ((user-module (make-user-module '((guix profiles) (gnu)))))
 837           (load* manifest-file user-module)))
 838        (else
 839         (manifest
 840          (map (match-lambda
 841                 ((package output)
 842                  (package->manifest-entry package output
 843                                           #:properties
 844                                           (properties package))))
 845               packages))))))
 846
 847   (with-error-handling
 848     (with-store store
 849       (with-status-verbosity (assoc-ref opts 'verbosity)
 850         ;; Set the build options before we do anything else.
 851         (set-build-options-from-command-line store opts)
 852
 853         (parameterize ((%graft? (assoc-ref opts 'graft?))
 854                        (%guile-for-build (package-derivation
 855                                           store
 856                                           (if (assoc-ref opts 'bootstrap?)
 857                                               %bootstrap-guile
 858                                               (canonical-package guile-2.2))
 859                                           (assoc-ref opts 'system)
 860                                           #:graft? (assoc-ref opts 'graft?))))
 861           (let* ((dry-run?    (assoc-ref opts 'dry-run?))
 862                  (relocatable? (assoc-ref opts 'relocatable?))
 863                  (proot?      (eq? relocatable? 'proot))
 864                  (manifest    (let ((manifest (manifest-from-args store opts)))
 865                                 ;; Note: We cannot honor '--bootstrap' here because
 866                                 ;; 'glibc-bootstrap' lacks 'libc.a'.
 867                                 (if relocatable?
 868                                     (map-manifest-entries
 869                                      (cut wrapped-package <> #:proot? proot?)
 870                                      manifest)
 871                                     manifest)))
 872                  (pack-format (assoc-ref opts 'format))
 873                  (name        (string-append (symbol->string pack-format)
 874                                              "-pack"))
 875                  (target      (assoc-ref opts 'target))
 876                  (bootstrap?  (assoc-ref opts 'bootstrap?))
 877                  (compressor  (if bootstrap?
 878                                   bootstrap-xz
 879                                   (assoc-ref opts 'compressor)))
 880                  (archiver    (if (equal? pack-format 'squashfs)
 881                                   squashfs-tools-next
 882                                   (if bootstrap?
 883                                       %bootstrap-coreutils&co
 884                                       tar)))
 885                  (symlinks    (assoc-ref opts 'symlinks))
 886                  (build-image (match (assq-ref %formats pack-format)
 887                                 ((? procedure? proc) proc)
 888                                 (#f
 889                                  (leave (G_ "~a: unknown pack format~%")
 890                                         pack-format))))
 891                  (localstatedir? (assoc-ref opts 'localstatedir?))
 892                  (profile-name   (assoc-ref opts 'profile-name))
 893                  (gc-root        (assoc-ref opts 'gc-root)))
 894             (run-with-store store
 895               (mlet* %store-monad ((profile (profile-derivation
 896                                              manifest
 897
 898                                              ;; Always produce relative
 899                                              ;; symlinks for Singularity (see
 900                                              ;; <https://bugs.gnu.org/34913>).
 901                                              #:relative-symlinks?
 902                                              (or relocatable?
 903                                                  (eq? 'squashfs pack-format))
 904
 905                                              #:hooks (if bootstrap?
 906                                                          '()
 907                                                          %default-profile-hooks)
 908                                              #:locales? (not bootstrap?)
 909                                              #:target target))
 910                                    (drv (build-image name profile
 911                                                      #:target
 912                                                      target
 913                                                      #:compressor
 914                                                      compressor
 915                                                      #:symlinks
 916                                                      symlinks
 917                                                      #:localstatedir?
 918                                                      localstatedir?
 919                                                      #:profile-name
 920                                                      profile-name
 921                                                      #:archiver
 922                                                      archiver)))
 923                 (mbegin %store-monad
 924                   (show-what-to-build* (list drv)
 925                                        #:use-substitutes?
 926                                        (assoc-ref opts 'substitutes?)
 927                                        #:dry-run? dry-run?)
 928                   (munless dry-run?
 929                     (built-derivations (list drv))
 930                     (mwhen gc-root
 931                       (register-root* (match (derivation->output-paths drv)
 932                                         (((names . items) ...)
 933                                          items))
 934                                       gc-root))
 935                     (return (format #t "~a~%"
 936                                     (derivation->output-path drv))))))
 937               #:system (assoc-ref opts 'system))))))))