guix/scripts/pack.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2017, 2018, 2019, 2020, 2021 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 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
   8 ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
   9 ;;;
  10 ;;; This file is part of GNU Guix.
  11 ;;;
  12 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  13 ;;; under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 3 of the License, or (at
  15 ;;; your option) any later version.
  16 ;;;
  17 ;;; GNU Guix is distributed in the hope that it will be useful, but
  18 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 (define-module (guix scripts pack)
  26   #:use-module (guix scripts)
  27   #:use-module (guix ui)
  28   #:use-module (guix gexp)
  29   #:use-module (guix utils)
  30   #:use-module (guix store)
  31   #:use-module ((guix status) #:select (with-status-verbosity))
  32   #:use-module ((guix self) #:select (make-config.scm))
  33   #:use-module (guix grafts)
  34   #:autoload   (guix inferior) (inferior-package?
  35                                 inferior-package-name
  36                                 inferior-package-version)
  37   #:use-module (guix monads)
  38   #:use-module (guix modules)
  39   #:use-module (guix packages)
  40   #:use-module (guix profiles)
  41   #:use-module (guix describe)
  42   #:use-module (guix derivations)
  43   #:use-module (guix search-paths)
  44   #:use-module (guix build-system gnu)
  45   #:use-module (guix scripts build)
  46   #:use-module (guix transformations)
  47   #:use-module ((guix self) #:select (make-config.scm))
  48   #:use-module (gnu packages)
  49   #:use-module (gnu packages bootstrap)
  50   #:use-module ((gnu packages compression) #:hide (zip))
  51   #:use-module (gnu packages guile)
  52   #:use-module (gnu packages base)
  53   #:autoload   (gnu packages package-management) (guix)
  54   #:autoload   (gnu packages gnupg) (guile-gcrypt)
  55   #:autoload   (gnu packages guile) (guile2.0-json guile-json)
  56   #:use-module (srfi srfi-1)
  57   #:use-module (srfi srfi-9)
  58   #:use-module (srfi srfi-26)
  59   #:use-module (srfi srfi-37)
  60   #:use-module (ice-9 match)
  61   #:export (compressor?
  62             compressor-name
  63             compressor-extenstion
  64             compressor-command
  65             %compressors
  66             lookup-compressor
  67             self-contained-tarball
  68             docker-image
  69             squashfs-image
  70
  71             %formats
  72             guix-pack))
  73
  74 ;; Type of a compression tool.
  75 (define-record-type <compressor>
  76   (compressor name extension command)
  77   compressor?
  78   (name       compressor-name)      ;string (e.g., "gzip")
  79   (extension  compressor-extension) ;string (e.g., ".lz")
  80   (command    compressor-command))  ;gexp (e.g., #~("/gnu/store/…/gzip" "-9n"))
  81
  82 (define %compressors
  83   ;; Available compression tools.
  84   (list (compressor "gzip"  ".gz"
  85                     #~(#+(file-append gzip "/bin/gzip") "-9n"))
  86         (compressor "lzip"  ".lz"
  87                     #~(#+(file-append lzip "/bin/lzip") "-9"))
  88         (compressor "xz"    ".xz"
  89                     #~(#+(file-append xz "/bin/xz") "-e"))
  90         (compressor "bzip2" ".bz2"
  91                     #~(#+(file-append bzip2 "/bin/bzip2") "-9"))
  92         (compressor "zstd" ".zst"
  93                     ;; The default level 3 compresses better than gzip in a
  94                     ;; fraction of the time, while the highest level 19
  95                     ;; (de)compresses more slowly and worse than xz.
  96                     #~(#+(file-append zstd "/bin/zstd") "-3"))
  97         (compressor "none" "" #f)))
  98
  99 ;; This one is only for use in this module, so don't put it in %compressors.
 100 (define bootstrap-xz
 101   (compressor "bootstrap-xz" ".xz"
 102               #~(#+(file-append %bootstrap-coreutils&co "/bin/xz") "-e")))
 103
 104 (define (lookup-compressor name)
 105   "Return the compressor object called NAME.  Error out if it could not be
 106 found."
 107   (or (find (match-lambda
 108               (($ <compressor> name*)
 109                (string=? name* name)))
 110             %compressors)
 111       (leave (G_ "~a: compressor not found~%") name)))
 112
 113 (define not-config?
 114   ;; Select (guix …) and (gnu …) modules, except (guix config).
 115   (match-lambda
 116     (('guix 'config) #f)
 117     (('guix _ ...) #t)
 118     (('gnu _ ...) #t)
 119     (_ #f)))
 120
 121 (define gcrypt-sqlite3&co
 122   ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
 123   (append-map (lambda (package)
 124                 (cons package
 125                       (match (package-transitive-propagated-inputs package)
 126                         (((labels packages) ...)
 127                          packages))))
 128               (list guile-gcrypt guile-sqlite3)))
 129
 130 (define (store-database items)
 131   "Return a directory containing a store database where all of ITEMS and their
 132 dependencies are registered."
 133   (define schema
 134     (local-file (search-path %load-path
 135                              "guix/store/schema.sql")))
 136
 137
 138   (define labels
 139     (map (lambda (n)
 140            (string-append "closure" (number->string n)))
 141          (iota (length items))))
 142
 143   (define build
 144     (with-extensions gcrypt-sqlite3&co
 145       (with-imported-modules `(((guix config) => ,(make-config.scm))
 146                                ,@(source-module-closure
 147                                   '((guix build store-copy)
 148                                     (guix store database))
 149                                   #:select? not-config?))
 150         #~(begin
 151             (use-modules (guix store database)
 152                          (guix build store-copy)
 153                          (srfi srfi-1))
 154
 155             (define (read-closure closure)
 156               (call-with-input-file closure read-reference-graph))
 157
 158             (define db-file
 159               (store-database-file #:state-directory #$output))
 160
 161             ;; Make sure non-ASCII file names are properly handled.
 162             (setenv "GUIX_LOCPATH"
 163                     #+(file-append glibc-utf8-locales "/lib/locale"))
 164             (setlocale LC_ALL "en_US.utf8")
 165
 166             (sql-schema #$schema)
 167             (let ((items (append-map read-closure '#$labels)))
 168               (with-database db-file db
 169                 (register-items db items
 170                                 #:registration-time %epoch)))))))
 171
 172   (computed-file "store-database" build
 173                  #:options `(#:references-graphs ,(zip labels items))))
 174
 175 \f
 176 ;;;
 177 ;;; Tarball format.
 178 ;;;
 179 (define* (self-contained-tarball/builder profile
 180                                          #:key (profile-name "guix-profile")
 181                                          (compressor (first %compressors))
 182                                          localstatedir?
 183                                          (symlinks '())
 184                                          (archiver tar))
 185   "Return the G-Expression of the builder used for self-contained-tarball."
 186   (define database
 187     (and localstatedir?
 188          (file-append (store-database (list profile))
 189                       "/db/db.sqlite")))
 190
 191   (define set-utf8-locale
 192     ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'.
 193     (and (or (not (profile? profile))
 194              (profile-locales? profile))
 195          #~(begin
 196              (setenv "GUIX_LOCPATH"
 197                      #+(file-append glibc-utf8-locales "/lib/locale"))
 198              (setlocale LC_ALL "en_US.utf8"))))
 199
 200   (define (import-module? module)
 201     ;; Since we don't use deduplication support in 'populate-store', don't
 202     ;; import (guix store deduplication) and its dependencies, which includes
 203     ;; Guile-Gcrypt.  That way we can run tests with '--bootstrap'.
 204     (and (not-config? module)
 205          (not (equal? '(guix store deduplication) module))))
 206
 207   (with-imported-modules (source-module-closure
 208                           `((guix build utils)
 209                             (guix build union)
 210                             (gnu build install))
 211                           #:select? import-module?)
 212     #~(begin
 213         (use-modules (guix build utils)
 214                      ((guix build union) #:select (relative-file-name))
 215                      (gnu build install)
 216                      (srfi srfi-1)
 217                      (srfi srfi-26)
 218                      (ice-9 match))
 219
 220         (define %root "root")
 221
 222         (define symlink->directives
 223           ;; Return "populate directives" to make the given symlink and its
 224           ;; parent directories.
 225           (match-lambda
 226             ((source '-> target)
 227              (let ((target (string-append #$profile "/" target))
 228                    (parent (dirname source)))
 229                ;; Never add a 'directory' directive for "/" so as to
 230                ;; preserve its ownnership when extracting the archive (see
 231                ;; below), and also because this would lead to adding the
 232                ;; same entries twice in the tarball.
 233                `(,@(if (string=? parent "/")
 234                        '()
 235                        `((directory ,parent)))
 236                  (,source
 237                   -> ,(relative-file-name parent target)))))))
 238
 239         (define directives
 240           ;; Fully-qualified symlinks.
 241           (append-map symlink->directives '#$symlinks))
 242
 243         ;; The --sort option was added to GNU tar in version 1.28, released
 244         ;; 2014-07-28.  For testing, we use the bootstrap tar, which is
 245         ;; older and doesn't support it.
 246         (define tar-supports-sort?
 247           (zero? (system* (string-append #+archiver "/bin/tar")
 248                           "cf" "/dev/null" "--files-from=/dev/null"
 249                           "--sort=name")))
 250
 251         ;; Make sure non-ASCII file names are properly handled.
 252         #+set-utf8-locale
 253
 254         ;; Add 'tar' to the search path.
 255         (setenv "PATH" #+(file-append archiver "/bin"))
 256
 257         ;; Note: there is not much to gain here with deduplication and there
 258         ;; is the overhead of the '.links' directory, so turn it off.
 259         ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
 260         ;; with hard links:
 261         ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
 262         (populate-single-profile-directory %root
 263                                            #:profile #$profile
 264                                            #:profile-name #$profile-name
 265                                            #:closure "profile"
 266                                            #:database #+database)
 267
 268         ;; Create SYMLINKS.
 269         (for-each (cut evaluate-populate-directive <> %root)
 270                   directives)
 271
 272         ;; Create the tarball.  Use GNU format so there's no file name
 273         ;; length limitation.
 274         (with-directory-excursion %root
 275           (apply invoke "tar"
 276                  #+@(if (compressor-command compressor)
 277                         #~("-I"
 278                            (string-join
 279                             '#+(compressor-command compressor)))
 280                         #~())
 281                  "--format=gnu"
 282                  ;; Avoid non-determinism in the archive.
 283                  ;; Use mtime = 1, not zero, because that is what the daemon
 284                  ;; does for files in the store (see the 'mtimeStore' constant
 285                  ;; in local-store.cc.)
 286                  (if tar-supports-sort? "--sort=name" "--mtime=@1")
 287                  "--owner=root:0"
 288                  "--group=root:0"
 289                  "--check-links"
 290                  "-cvf" #$output
 291                  ;; Avoid adding / and /var to the tarball, so
 292                  ;; that the ownership and permissions of those
 293                  ;; directories will not be overwritten when
 294                  ;; extracting the archive.  Do not include /root
 295                  ;; because the root account might have a
 296                  ;; different home directory.
 297                  #$@(if localstatedir?
 298                         '("./var/guix")
 299                         '())
 300
 301                  (string-append "." (%store-directory))
 302
 303                  (delete-duplicates
 304                   (filter-map (match-lambda
 305                                 (('directory directory)
 306                                  (string-append "." directory))
 307                                 ((source '-> _)
 308                                  (string-append "." source))
 309                                 (_ #f))
 310                               directives)))))))
 311
 312 (define* (self-contained-tarball name profile
 313                                  #:key target
 314                                  (profile-name "guix-profile")
 315                                  deduplicate?
 316                                  entry-point
 317                                  (compressor (first %compressors))
 318                                  localstatedir?
 319                                  (symlinks '())
 320                                  (archiver tar))
 321   "Return a self-contained tarball containing a store initialized with the
 322 closure of PROFILE, a derivation.  The tarball contains /gnu/store; if
 323 LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db
 324 with a properly initialized store database.
 325
 326 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 327 added to the pack."
 328   (when entry-point
 329     (warning (G_ "entry point not supported in the '~a' format~%")
 330              'tarball))
 331
 332   (gexp->derivation
 333    (string-append name ".tar"
 334                   (compressor-extension compressor))
 335    (self-contained-tarball/builder profile
 336                                    #:profile-name profile-name
 337                                    #:compressor compressor
 338                                    #:localstatedir? localstatedir?
 339                                    #:symlinks symlinks
 340                                    #:archiver archiver)
 341    #:target target
 342    #:references-graphs `(("profile" ,profile))))
 343
 344 (define (singularity-environment-file profile)
 345   "Return a shell script that defines the environment variables corresponding
 346 to the search paths of PROFILE."
 347   (define build
 348     (with-extensions (list guile-gcrypt)
 349       (with-imported-modules `(((guix config) => ,(make-config.scm))
 350                                ,@(source-module-closure
 351                                   `((guix profiles)
 352                                     (guix search-paths))
 353                                   #:select? not-config?))
 354         #~(begin
 355             (use-modules (guix profiles) (guix search-paths)
 356                          (ice-9 match))
 357
 358             (call-with-output-file #$output
 359               (lambda (port)
 360                 (for-each (match-lambda
 361                             ((spec . value)
 362                              (format port "~a=~a~%export ~a~%"
 363                                      (search-path-specification-variable spec)
 364                                      value
 365                                      (search-path-specification-variable spec))))
 366                           (profile-search-paths #$profile))))))))
 367
 368   (computed-file "singularity-environment.sh" build))
 369
 370 (define* (squashfs-image name profile
 371                          #:key target
 372                          (profile-name "guix-profile")
 373                          (compressor (first %compressors))
 374                          entry-point
 375                          localstatedir?
 376                          (symlinks '())
 377                          (archiver squashfs-tools))
 378   "Return a squashfs image containing a store initialized with the closure of
 379 PROFILE, a derivation.  The image contains a subset of /gnu/store, empty mount
 380 points for virtual file systems (like procfs), and optional symlinks.
 381
 382 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 383 added to the pack."
 384   (define database
 385     (and localstatedir?
 386          (file-append (store-database (list profile))
 387                       "/db/db.sqlite")))
 388
 389   (define environment
 390     (singularity-environment-file profile))
 391
 392   (define symlinks*
 393     ;; Singularity requires /bin (specifically /bin/sh), so ensure that
 394     ;; symlink is created.
 395     (if (find (match-lambda
 396                 (("/bin" . _) #t)
 397                 (_            #f))
 398               symlinks)
 399         symlinks
 400         `(("/bin" -> "bin") ,@symlinks)))
 401
 402   (define build
 403     (with-extensions (list guile-gcrypt)
 404       (with-imported-modules (source-module-closure
 405                               '((guix build utils)
 406                                 (guix build store-copy)
 407                                 (guix build union)
 408                                 (gnu build install))
 409                               #:select? not-config?)
 410         #~(begin
 411             (use-modules (guix build utils)
 412                          (guix build store-copy)
 413                          ((guix build union) #:select (relative-file-name))
 414                          (gnu build install)
 415                          (srfi srfi-1)
 416                          (srfi srfi-26)
 417                          (ice-9 match))
 418
 419             (define database #+database)
 420             (define entry-point #$entry-point)
 421
 422             (define (mksquashfs args)
 423               (apply invoke "mksquashfs"
 424                      `(,@args
 425
 426                        ;; Do not create a "recovery file" when appending to the
 427                        ;; file system since it's useless in this case.
 428                        "-no-recovery"
 429
 430                        ;; Do not attempt to store extended attributes.
 431                        ;; See <https://bugs.gnu.org/40043>.
 432                        "-no-xattrs"
 433
 434                        ;; Set file times and the file system creation time to
 435                        ;; one second after the Epoch.
 436                        "-all-time" "1" "-mkfs-time" "1"
 437
 438                        ;; Reset all UIDs and GIDs.
 439                        "-force-uid" "0" "-force-gid" "0")))
 440
 441             (setenv "PATH" #+(file-append archiver "/bin"))
 442
 443             ;; We need an empty file in order to have a valid file argument when
 444             ;; we reparent the root file system.  Read on for why that's
 445             ;; necessary.
 446             (with-output-to-file ".empty" (lambda () (display "")))
 447
 448             ;; Create the squashfs image in several steps.
 449             ;; Add all store items.  Unfortunately mksquashfs throws away all
 450             ;; ancestor directories and only keeps the basename.  We fix this
 451             ;; in the following invocations of mksquashfs.
 452             (mksquashfs `(,@(map store-info-item
 453                                  (call-with-input-file "profile"
 454                                    read-reference-graph))
 455                           #$environment
 456                           ,#$output
 457
 458                           ;; Do not perform duplicate checking because we
 459                           ;; don't have any dupes.
 460                           "-no-duplicates"
 461                           "-comp"
 462                           ,#+(compressor-name compressor)))
 463
 464             ;; Here we reparent the store items.  For each sub-directory of
 465             ;; the store prefix we need one invocation of "mksquashfs".
 466             (for-each (lambda (dir)
 467                         (mksquashfs `(".empty"
 468                                       ,#$output
 469                                       "-root-becomes" ,dir)))
 470                       (reverse (string-tokenize (%store-directory)
 471                                                 (char-set-complement (char-set #\/)))))
 472
 473             ;; Add symlinks and mount points.
 474             (mksquashfs
 475              `(".empty"
 476                ,#$output
 477                ;; Create SYMLINKS via pseudo file definitions.
 478                ,@(append-map
 479                   (match-lambda
 480                     ((source '-> target)
 481                      ;; Create relative symlinks to work around a bug in
 482                      ;; Singularity 2.x:
 483                      ;;   https://bugs.gnu.org/34913
 484                      ;;   https://github.com/sylabs/singularity/issues/1487
 485                      (let ((target (string-append #$profile "/" target)))
 486                        (list "-p"
 487                              (string-join
 488                               ;; name s mode uid gid symlink
 489                               (list source
 490                                     "s" "777" "0" "0"
 491                                     (relative-file-name (dirname source)
 492                                                         target)))))))
 493                   '#$symlinks*)
 494
 495                "-p" "/.singularity.d d 555 0 0"
 496
 497                ;; Create the environment file.
 498                "-p" "/.singularity.d/env d 555 0 0"
 499                "-p" ,(string-append
 500                       "/.singularity.d/env/90-environment.sh s 777 0 0 "
 501                       (relative-file-name "/.singularity.d/env"
 502                                           #$environment))
 503
 504                ;; Create /.singularity.d/actions, and optionally the 'run'
 505                ;; script, used by 'singularity run'.
 506                "-p" "/.singularity.d/actions d 555 0 0"
 507
 508                ,@(if entry-point
 509                      `( ;; This one if for Singularity 2.x.
 510                        "-p"
 511                        ,(string-append
 512                          "/.singularity.d/actions/run s 777 0 0 "
 513                          (relative-file-name "/.singularity.d/actions"
 514                                              (string-append #$profile "/"
 515                                                             entry-point)))
 516
 517                        ;; This one is for Singularity 3.x.
 518                        "-p"
 519                        ,(string-append
 520                          "/.singularity.d/runscript s 777 0 0 "
 521                          (relative-file-name "/.singularity.d"
 522                                              (string-append #$profile "/"
 523                                                             entry-point))))
 524                      '())
 525
 526                ;; Create empty mount points.
 527                "-p" "/proc d 555 0 0"
 528                "-p" "/sys d 555 0 0"
 529                "-p" "/dev d 555 0 0"
 530                "-p" "/home d 555 0 0"))
 531
 532             (when database
 533               ;; Initialize /var/guix.
 534               (install-database-and-gc-roots "var-etc" database #$profile)
 535               (mksquashfs `("var-etc" ,#$output)))))))
 536
 537   (gexp->derivation (string-append name
 538                                    (compressor-extension compressor)
 539                                    ".squashfs")
 540                     build
 541                     #:target target
 542                     #:references-graphs `(("profile" ,profile))))
 543
 544 (define* (docker-image name profile
 545                        #:key target
 546                        (profile-name "guix-profile")
 547                        (compressor (first %compressors))
 548                        entry-point
 549                        localstatedir?
 550                        (symlinks '())
 551                        (archiver tar))
 552   "Return a derivation to construct a Docker image of PROFILE.  The
 553 image is a tarball conforming to the Docker Image Specification, compressed
 554 with COMPRESSOR.  It can be passed to 'docker load'.  If TARGET is true, it
 555 must a be a GNU triplet and it is used to derive the architecture metadata in
 556 the image."
 557   (define database
 558     (and localstatedir?
 559          (file-append (store-database (list profile))
 560                       "/db/db.sqlite")))
 561
 562   (define defmod 'define-module)                  ;trick Geiser
 563
 564   (define build
 565     ;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
 566     (with-extensions (list guile-json-3 guile-gcrypt)
 567       (with-imported-modules `(((guix config) => ,(make-config.scm))
 568                                ,@(source-module-closure
 569                                   `((guix docker)
 570                                     (guix build store-copy)
 571                                     (guix profiles)
 572                                     (guix search-paths))
 573                                   #:select? not-config?))
 574         #~(begin
 575             (use-modules (guix docker) (guix build store-copy)
 576                          (guix profiles) (guix search-paths)
 577                          (srfi srfi-1) (srfi srfi-19)
 578                          (ice-9 match))
 579
 580             (define environment
 581               (map (match-lambda
 582                      ((spec . value)
 583                       (cons (search-path-specification-variable spec)
 584                             value)))
 585                    (profile-search-paths #$profile)))
 586
 587             (define symlink->directives
 588               ;; Return "populate directives" to make the given symlink and its
 589               ;; parent directories.
 590               (match-lambda
 591                 ((source '-> target)
 592                  (let ((target (string-append #$profile "/" target))
 593                        (parent (dirname source)))
 594                    `((directory ,parent)
 595                      (,source -> ,target))))))
 596
 597             (define directives
 598               ;; Create a /tmp directory, as some programs expect it, and
 599               ;; create SYMLINKS.
 600               `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
 601                 ,@(append-map symlink->directives '#$symlinks)))
 602
 603             (define tag
 604               ;; Compute a meaningful "repository" name, which will show up in
 605               ;; the output of "docker images".
 606               (let ((manifest (profile-manifest #$profile)))
 607                 (let loop ((names (map manifest-entry-name
 608                                        (manifest-entries manifest))))
 609                   (define str (string-join names "-"))
 610                   (if (< (string-length str) 40)
 611                       str
 612                       (match names
 613                         ((_) str)
 614                         ((names ... _) (loop names))))))) ;drop one entry
 615
 616             (setenv "PATH" #+(file-append archiver "/bin"))
 617
 618             (build-docker-image #$output
 619                                 (map store-info-item
 620                                      (call-with-input-file "profile"
 621                                        read-reference-graph))
 622                                 #$profile
 623                                 #:repository tag
 624                                 #:database #+database
 625                                 #:system (or #$target %host-type)
 626                                 #:environment environment
 627                                 #:entry-point
 628                                 #$(and entry-point
 629                                        #~(list (string-append #$profile "/"
 630                                                               #$entry-point)))
 631                                 #:extra-files directives
 632                                 #:compressor '#+(compressor-command compressor)
 633                                 #:creation-time (make-time time-utc 0 1))))))
 634
 635   (gexp->derivation (string-append name ".tar"
 636                                    (compressor-extension compressor))
 637                     build
 638                     #:target target
 639                     #:references-graphs `(("profile" ,profile))))
 640
 641 \f
 642 ;;;
 643 ;;; Compiling C programs.
 644 ;;;
 645
 646 ;; A C compiler.  That lowers to a single program that can be passed typical C
 647 ;; compiler flags, and it makes sure the whole toolchain is available.
 648 (define-record-type <c-compiler>
 649   (%c-compiler toolchain guile)
 650   c-compiler?
 651   (toolchain c-compiler-toolchain)
 652   (guile     c-compiler-guile))
 653
 654 (define* (c-compiler #:optional inputs
 655                      #:key (guile (default-guile)))
 656   (%c-compiler inputs guile))
 657
 658 (define (bootstrap-c-compiler)
 659   "Return the C compiler that uses the bootstrap toolchain.  This is used only
 660 by '--bootstrap', for testing purposes."
 661   (define bootstrap-toolchain
 662     (list (first (assoc-ref (%bootstrap-inputs) "gcc"))
 663           (first (assoc-ref (%bootstrap-inputs) "binutils"))
 664           (first (assoc-ref (%bootstrap-inputs) "libc"))))
 665
 666   (c-compiler bootstrap-toolchain
 667               #:guile %bootstrap-guile))
 668
 669 (define-gexp-compiler (c-compiler-compiler (compiler <c-compiler>) system target)
 670   "Lower COMPILER to a single script that does the right thing."
 671   (define toolchain
 672     (or (c-compiler-toolchain compiler)
 673         (list (first (assoc-ref (standard-packages) "gcc"))
 674               (first (assoc-ref (standard-packages) "ld-wrapper"))
 675               (first (assoc-ref (standard-packages) "binutils"))
 676               (first (assoc-ref (standard-packages) "libc"))
 677               (gexp-input (first (assoc-ref (standard-packages) "libc"))
 678                           "static"))))
 679
 680   (define inputs
 681     (match (append-map package-propagated-inputs
 682                        (filter package? toolchain))
 683       (((labels things . _) ...)
 684        (append toolchain things))))
 685
 686   (define search-paths
 687     (cons $PATH
 688           (append-map package-native-search-paths
 689                       (filter package? inputs))))
 690
 691   (define run
 692     (with-imported-modules (source-module-closure
 693                             '((guix build utils)
 694                               (guix search-paths)))
 695       #~(begin
 696           (use-modules (guix build utils) (guix search-paths)
 697                        (ice-9 match))
 698
 699           (define (output-file args)
 700             (let loop ((args args))
 701               (match args
 702                 (() "a.out")
 703                 (("-o" file _ ...) file)
 704                 ((head rest ...) (loop rest)))))
 705
 706           (set-search-paths (map sexp->search-path-specification
 707                                  '#$(map search-path-specification->sexp
 708                                          search-paths))
 709                             '#$inputs)
 710
 711           (let ((output (output-file (command-line))))
 712             (apply invoke "gcc" (cdr (command-line)))
 713             (invoke "strip" output)))))
 714
 715   (when target
 716     ;; TODO: Yep, we'll have to do it someday!
 717     (leave (G_ "cross-compilation not implemented here;
 718 please email '~a'~%")
 719            (@ (guix config) %guix-bug-report-address)))
 720
 721   (gexp->script "c-compiler" run
 722                 #:guile (c-compiler-guile compiler)))
 723
 724 \f
 725 ;;;
 726 ;;; Wrapped package.
 727 ;;;
 728
 729 (define* (wrapped-package package
 730                           #:optional
 731                           (output* "out")
 732                           (compiler (c-compiler))
 733                           #:key proot?)
 734   "Return the OUTPUT of PACKAGE with its binaries wrapped such that they are
 735 relocatable.  When PROOT? is true, include PRoot in the result and use it as a
 736 last resort for relocation."
 737   (define runner
 738     (local-file (search-auxiliary-file "run-in-namespace.c")))
 739
 740   (define audit-source
 741     (local-file (search-auxiliary-file "pack-audit.c")))
 742
 743   (define (proot)
 744     (specification->package "proot-static"))
 745
 746   (define (fakechroot-library)
 747     (computed-file "libfakechroot.so"
 748                    #~(copy-file #$(file-append
 749                                    (specification->package "fakechroot")
 750                                    "/lib/fakechroot/libfakechroot.so")
 751                                 #$output)))
 752
 753   (define (audit-module)
 754     ;; Return an ld.so audit module for use by the 'fakechroot' execution
 755     ;; engine that translates file names of all the files ld.so loads.
 756     (computed-file "pack-audit.so"
 757                    (with-imported-modules '((guix build utils))
 758                      #~(begin
 759                          (use-modules (guix build utils))
 760
 761                          (copy-file #$audit-source "audit.c")
 762                          (substitute* "audit.c"
 763                            (("@STORE_DIRECTORY@")
 764                             (%store-directory)))
 765
 766                          (invoke #$compiler "-std=gnu99"
 767                                  "-shared" "-fPIC" "-Os" "-g0"
 768                                  "-Wall" "audit.c" "-o" #$output)))))
 769
 770   (define build
 771     (with-imported-modules (source-module-closure
 772                             '((guix build utils)
 773                               (guix build union)
 774                               (guix build gremlin)
 775                               (guix elf)))
 776       #~(begin
 777           (use-modules (guix build utils)
 778                        ((guix build union) #:select (symlink-relative))
 779                        (guix elf)
 780                        (guix build gremlin)
 781                        (ice-9 binary-ports)
 782                        (ice-9 ftw)
 783                        (ice-9 match)
 784                        (ice-9 receive)
 785                        (srfi srfi-1)
 786                        (rnrs bytevectors))
 787
 788           (define input
 789             ;; The OUTPUT* output of PACKAGE.
 790             (ungexp package output*))
 791
 792           (define target
 793             ;; The output we are producing.
 794             (ungexp output output*))
 795
 796           (define (strip-store-prefix file)
 797             ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
 798             ;; "/bin/foo".
 799             (let* ((len  (string-length (%store-directory)))
 800                    (base (string-drop file (+ 1 len))))
 801               (match (string-index base #\/)
 802                 (#f    base)
 803                 (index (string-drop base index)))))
 804
 805           (define (elf-interpreter elf)
 806             ;; Return the interpreter of ELF as a string, or #f if ELF has no
 807             ;; interpreter segment.
 808             (match (find (lambda (segment)
 809                            (= (elf-segment-type segment) PT_INTERP))
 810                          (elf-segments elf))
 811               (#f #f)                             ;maybe a .so
 812               (segment
 813                (let ((bv (make-bytevector (- (elf-segment-memsz segment) 1))))
 814                  (bytevector-copy! (elf-bytes elf)
 815                                    (elf-segment-offset segment)
 816                                    bv 0 (bytevector-length bv))
 817                  (utf8->string bv)))))
 818
 819           (define (runpath file)
 820             ;; Return the RUNPATH of FILE as a list of directories.
 821             (let* ((bv      (call-with-input-file file get-bytevector-all))
 822                    (elf     (parse-elf bv))
 823                    (dyninfo (elf-dynamic-info elf)))
 824               (or (and=> dyninfo elf-dynamic-info-runpath)
 825                   '())))
 826
 827           (define (elf-loader-compile-flags program)
 828             ;; Return the cpp flags defining macros for the ld.so/fakechroot
 829             ;; wrapper of PROGRAM.
 830
 831             ;; TODO: Handle scripts by wrapping their interpreter.
 832             (if (elf-file? program)
 833                 (let* ((bv      (call-with-input-file program
 834                                   get-bytevector-all))
 835                        (elf     (parse-elf bv))
 836                        (interp  (elf-interpreter elf))
 837                        (gconv   (and interp
 838                                      (string-append (dirname interp)
 839                                                     "/gconv"))))
 840                   (if interp
 841                       (list (string-append "-DPROGRAM_INTERPRETER=\""
 842                                            interp "\"")
 843                             (string-append "-DFAKECHROOT_LIBRARY=\""
 844                                            #$(fakechroot-library) "\"")
 845
 846                             (string-append "-DLOADER_AUDIT_MODULE=\""
 847                                            #$(audit-module) "\"")
 848
 849                             ;; XXX: Normally (runpath #$(audit-module)) is
 850                             ;; enough.  However, to work around
 851                             ;; <https://sourceware.org/bugzilla/show_bug.cgi?id=26634>
 852                             ;; (glibc <= 2.32), pass the whole search path of
 853                             ;; PROGRAM, which presumably is a superset of that
 854                             ;; of the audit module.
 855                             (string-append "-DLOADER_AUDIT_RUNPATH={ "
 856                                            (string-join
 857                                             (map object->string
 858                                                  (runpath program))
 859                                             ", " 'suffix)
 860                                            "NULL }")
 861                             (if gconv
 862                                 (string-append "-DGCONV_DIRECTORY=\""
 863                                                gconv "\"")
 864                                 "-UGCONV_DIRECTORY"))
 865                       '()))
 866                 '()))
 867
 868           (define (build-wrapper program)
 869             ;; Build a user-namespace wrapper for PROGRAM.
 870             (format #t "building wrapper for '~a'...~%" program)
 871             (copy-file #$runner "run.c")
 872
 873             (substitute* "run.c"
 874               (("@WRAPPED_PROGRAM@") program)
 875               (("@STORE_DIRECTORY@") (%store-directory)))
 876
 877             (let* ((base   (strip-store-prefix program))
 878                    (result (string-append target base))
 879                    (proot  #$(and proot?
 880                                   #~(string-drop
 881                                      #$(file-append (proot) "/bin/proot")
 882                                      (+ (string-length (%store-directory))
 883                                         1)))))
 884               (mkdir-p (dirname result))
 885               (apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
 886                      "run.c" "-o" result
 887                      (string-append "-DWRAPPER_PROGRAM=\""
 888                                     (canonicalize-path (dirname result)) "/"
 889                                     (basename result) "\"")
 890                      (append (if proot
 891                                  (list (string-append "-DPROOT_PROGRAM=\""
 892                                                       proot "\""))
 893                                  '())
 894                              (elf-loader-compile-flags program)))
 895               (delete-file "run.c")))
 896
 897           (setvbuf (current-output-port) 'line)
 898
 899           ;; Link the top-level files of PACKAGE so that search paths are
 900           ;; properly defined in PROFILE/etc/profile.
 901           (mkdir target)
 902           (for-each (lambda (file)
 903                       (unless (member file '("." ".." "bin" "sbin" "libexec"))
 904                         (symlink-relative (string-append input  "/" file)
 905                                           (string-append target "/" file))))
 906                     (scandir input))
 907
 908           (receive (executables others)
 909               (partition executable-file?
 910                          ;; Note: Trailing slash in case these are symlinks.
 911                          (append (find-files (string-append input "/bin/"))
 912                                  (find-files (string-append input "/sbin/"))
 913                                  (find-files (string-append input "/libexec/"))))
 914             ;; Wrap only executables, since the wrapper will eventually need
 915             ;; to execve them.  E.g. git's "libexec" directory contains many
 916             ;; shell scripts that are source'd from elsewhere, which fails if
 917             ;; they are wrapped.
 918             (for-each build-wrapper executables)
 919             ;; Link any other non-executable files
 920             (for-each (lambda (old)
 921                         (let ((new (string-append target (strip-store-prefix old))))
 922                           (mkdir-p (dirname new))
 923                           (symlink-relative old new)))
 924                       others)))))
 925
 926   (computed-file (string-append
 927                   (cond ((package? package)
 928                          (package-full-name package "-"))
 929                         ((inferior-package? package)
 930                          (string-append (inferior-package-name package)
 931                                         "-"
 932                                         (inferior-package-version package)))
 933                         (else "wrapper"))
 934                   "R")
 935                  build))
 936
 937 (define (wrapped-manifest-entry entry . args)
 938   (manifest-entry
 939     (inherit entry)
 940     (item (apply wrapped-package
 941                  (manifest-entry-item entry)
 942                  (manifest-entry-output entry)
 943                  args))
 944     (dependencies (map (lambda (entry)
 945                          (apply wrapped-manifest-entry entry args))
 946                        (manifest-entry-dependencies entry)))))
 947
 948 \f
 949 ;;;
 950 ;;; Command-line options.
 951 ;;;
 952
 953 (define %default-options
 954   ;; Alist of default option values.
 955   `((format . tarball)
 956     (profile-name . "guix-profile")
 957     (system . ,(%current-system))
 958     (substitutes? . #t)
 959     (offload? . #t)
 960     (graft? . #t)
 961     (print-build-trace? . #t)
 962     (print-extended-build-trace? . #t)
 963     (multiplexed-build-output? . #t)
 964     (debug . 0)
 965     (verbosity . 1)
 966     (symlinks . ())
 967     (compressor . ,(first %compressors))))
 968
 969 (define %formats
 970   ;; Supported pack formats.
 971   `((tarball . ,self-contained-tarball)
 972     (squashfs . ,squashfs-image)
 973     (docker  . ,docker-image)))
 974
 975 (define (show-formats)
 976   ;; Print the supported pack formats.
 977   (display (G_ "The supported formats for 'guix pack' are:"))
 978   (newline)
 979   (display (G_ "
 980   tarball       Self-contained tarball, ready to run on another machine"))
 981   (display (G_ "
 982   squashfs      Squashfs image suitable for Singularity"))
 983   (display (G_ "
 984   docker        Tarball ready for 'docker load'"))
 985   (newline))
 986
 987 (define %options
 988   ;; Specifications of the command-line options.
 989   (cons* (option '(#\h "help") #f #f
 990                  (lambda args
 991                    (show-help)
 992                    (exit 0)))
 993          (option '(#\V "version") #f #f
 994                  (lambda args
 995                    (show-version-and-exit "guix pack")))
 996
 997          (option '(#\n "dry-run") #f #f
 998                  (lambda (opt name arg result)
 999                    (alist-cons 'dry-run? #t result)))
1000          (option '(#\d "derivation") #f #f
1001                  (lambda (opt name arg result)
1002                    (alist-cons 'derivation-only? #t result)))
1003
1004          (option '(#\f "format") #t #f
1005                  (lambda (opt name arg result)
1006                    (alist-cons 'format (string->symbol arg) result)))
1007          (option '("list-formats") #f #f
1008                  (lambda args
1009                    (show-formats)
1010                    (exit 0)))
1011          (option '(#\R "relocatable") #f #f
1012                  (lambda (opt name arg result)
1013                    (match (assq-ref result 'relocatable?)
1014                      (#f
1015                       (alist-cons 'relocatable? #t result))
1016                      (_
1017                       (alist-cons 'relocatable? 'proot
1018                                   (alist-delete 'relocatable? result))))))
1019          (option '(#\e "expression") #t #f
1020                  (lambda (opt name arg result)
1021                    (alist-cons 'expression arg result)))
1022          (option '(#\m "manifest") #t #f
1023                  (lambda (opt name arg result)
1024                    (alist-cons 'manifest arg result)))
1025          (option '(#\s "system") #t #f
1026                  (lambda (opt name arg result)
1027                    (alist-cons 'system arg
1028                                (alist-delete 'system result eq?))))
1029          (option '("entry-point") #t #f
1030                  (lambda (opt name arg result)
1031                    (alist-cons 'entry-point arg result)))
1032          (option '("target") #t #f
1033                  (lambda (opt name arg result)
1034                    (alist-cons 'target arg
1035                                (alist-delete 'target result eq?))))
1036          (option '(#\C "compression") #t #f
1037                  (lambda (opt name arg result)
1038                    (alist-cons 'compressor (lookup-compressor arg)
1039                                result)))
1040          (option '(#\S "symlink") #t #f
1041                  (lambda (opt name arg result)
1042                    ;; Note: Using 'string-split' allows us to handle empty
1043                    ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is
1044                    ;; a symlink to the profile) correctly.
1045                    (match (string-split arg (char-set #\=))
1046                      ((source target)
1047                       (let ((symlinks (assoc-ref result 'symlinks)))
1048                         (alist-cons 'symlinks
1049                                     `((,source -> ,target) ,@symlinks)
1050                                     (alist-delete 'symlinks result eq?))))
1051                      (x
1052                       (leave (G_ "~a: invalid symlink specification~%")
1053                              arg)))))
1054          (option '("save-provenance") #f #f
1055                  (lambda (opt name arg result)
1056                    (alist-cons 'save-provenance? #t result)))
1057          (option '("localstatedir") #f #f
1058                  (lambda (opt name arg result)
1059                    (alist-cons 'localstatedir? #t result)))
1060          (option '("profile-name") #t #f
1061                  (lambda (opt name arg result)
1062                    (match arg
1063                      ((or "guix-profile" "current-guix")
1064                       (alist-cons 'profile-name arg result))
1065                      (_
1066                       (leave (G_ "~a: unsupported profile name~%") arg)))))
1067          (option '(#\r "root") #t #f
1068                  (lambda (opt name arg result)
1069                    (alist-cons 'gc-root arg result)))
1070
1071          (option '(#\v "verbosity") #t #f
1072                  (lambda (opt name arg result)
1073                    (let ((level (string->number* arg)))
1074                      (alist-cons 'verbosity level
1075                                  (alist-delete 'verbosity result)))))
1076          (option '("bootstrap") #f #f
1077                  (lambda (opt name arg result)
1078                    (alist-cons 'bootstrap? #t result)))
1079
1080          (append %transformation-options
1081                  %standard-build-options)))
1082
1083 (define (show-help)
1084   (display (G_ "Usage: guix pack [OPTION]... PACKAGE...
1085 Create a bundle of PACKAGE.\n"))
1086   (show-build-options-help)
1087   (newline)
1088   (show-transformation-options-help)
1089   (newline)
1090   (display (G_ "
1091   -f, --format=FORMAT    build a pack in the given FORMAT"))
1092   (display (G_ "
1093       --list-formats     list the formats available"))
1094   (display (G_ "
1095   -R, --relocatable      produce relocatable executables"))
1096   (display (G_ "
1097   -e, --expression=EXPR  consider the package EXPR evaluates to"))
1098   (display (G_ "
1099   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
1100   (display (G_ "
1101       --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
1102   (display (G_ "
1103   -C, --compression=TOOL compress using TOOL--e.g., \"lzip\""))
1104   (display (G_ "
1105   -S, --symlink=SPEC     create symlinks to the profile according to SPEC"))
1106   (display (G_ "
1107   -m, --manifest=FILE    create a pack with the manifest from FILE"))
1108   (display (G_ "
1109       --entry-point=PROGRAM
1110                          use PROGRAM as the entry point of the pack"))
1111   (display (G_ "
1112       --save-provenance  save provenance information"))
1113   (display (G_ "
1114       --localstatedir    include /var/guix in the resulting pack"))
1115   (display (G_ "
1116       --profile-name=NAME
1117                          populate /var/guix/profiles/.../NAME"))
1118   (display (G_ "
1119   -r, --root=FILE        make FILE a symlink to the result, and register it
1120                          as a garbage collector root"))
1121   (display (G_ "
1122   -d, --derivation       return the derivation of the pack"))
1123   (display (G_ "
1124   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
1125   (display (G_ "
1126       --bootstrap        use the bootstrap binaries to build the pack"))
1127   (newline)
1128   (display (G_ "
1129   -h, --help             display this help and exit"))
1130   (display (G_ "
1131   -V, --version          display version information and exit"))
1132   (newline)
1133   (show-bug-report-information))
1134
1135 \f
1136 ;;;
1137 ;;; Entry point.
1138 ;;;
1139
1140 (define-command (guix-pack . args)
1141   (category development)
1142   (synopsis "create application bundles")
1143
1144   (define opts
1145     (parse-command-line args %options (list %default-options)))
1146
1147   (define maybe-package-argument
1148     ;; Given an option pair, return a package, a package/output tuple, or #f.
1149     (match-lambda
1150       (('argument . spec)
1151        (call-with-values
1152            (lambda ()
1153              (specification->package+output spec))
1154          list))
1155       (('expression . exp)
1156        (read/eval-package-expression exp))
1157       (x #f)))
1158
1159   (define (manifest-from-args store opts)
1160     (let* ((transform     (options->transformation opts))
1161            (packages      (map (match-lambda
1162                                  (((? package? package) output)
1163                                   (list (transform package) output))
1164                                  ((? package? package)
1165                                   (list (transform package) "out")))
1166                                (reverse
1167                                 (filter-map maybe-package-argument opts))))
1168            (manifests     (filter-map (match-lambda
1169                                         (('manifest . file) file)
1170                                         (_ #f))
1171                                       opts)))
1172       (define with-provenance
1173         (if (assoc-ref opts 'save-provenance?)
1174             (lambda (manifest)
1175               (map-manifest-entries
1176                (lambda (entry)
1177                  (let ((entry (manifest-entry-with-provenance entry)))
1178                    (unless (assq 'provenance (manifest-entry-properties entry))
1179                      (warning (G_ "could not determine provenance of package ~a~%")
1180                               (manifest-entry-name entry)))
1181                    entry))
1182                manifest))
1183             identity))
1184
1185       (with-provenance
1186        (cond
1187         ((and (not (null? manifests)) (not (null? packages)))
1188          (leave (G_ "both a manifest and a package list were given~%")))
1189         ((not (null? manifests))
1190          (concatenate-manifests
1191           (map (lambda (file)
1192                  (let ((user-module (make-user-module
1193                                      '((guix profiles) (gnu)))))
1194                    (load* file user-module)))
1195                manifests)))
1196         (else
1197          (packages->manifest packages))))))
1198
1199   (with-error-handling
1200     (with-store store
1201       (with-status-verbosity (assoc-ref opts 'verbosity)
1202         ;; Set the build options before we do anything else.
1203         (set-build-options-from-command-line store opts)
1204
1205         (with-build-handler (build-notifier #:dry-run?
1206                                             (assoc-ref opts 'dry-run?)
1207                                             #:verbosity
1208                                             (assoc-ref opts 'verbosity)
1209                                             #:use-substitutes?
1210                                             (assoc-ref opts 'substitutes?))
1211           (parameterize ((%graft? (assoc-ref opts 'graft?))
1212                          (%guile-for-build (package-derivation
1213                                             store
1214                                             (if (assoc-ref opts 'bootstrap?)
1215                                                 %bootstrap-guile
1216                                                 (default-guile))
1217                                             (assoc-ref opts 'system)
1218                                             #:graft? (assoc-ref opts 'graft?))))
1219             (let* ((derivation? (assoc-ref opts 'derivation-only?))
1220                    (relocatable? (assoc-ref opts 'relocatable?))
1221                    (proot?      (eq? relocatable? 'proot))
1222                    (manifest    (let ((manifest (manifest-from-args store opts)))
1223                                   ;; Note: We cannot honor '--bootstrap' here because
1224                                   ;; 'glibc-bootstrap' lacks 'libc.a'.
1225                                   (if relocatable?
1226                                       (map-manifest-entries
1227                                        (cut wrapped-manifest-entry <> #:proot? proot?)
1228                                        manifest)
1229                                       manifest)))
1230                    (pack-format (assoc-ref opts 'format))
1231                    (name        (string-append (symbol->string pack-format)
1232                                                "-pack"))
1233                    (target      (assoc-ref opts 'target))
1234                    (bootstrap?  (assoc-ref opts 'bootstrap?))
1235                    (compressor  (if bootstrap?
1236                                     bootstrap-xz
1237                                     (assoc-ref opts 'compressor)))
1238                    (archiver    (if (equal? pack-format 'squashfs)
1239                                     squashfs-tools
1240                                     (if bootstrap?
1241                                         %bootstrap-coreutils&co
1242                                         tar)))
1243                    (symlinks    (assoc-ref opts 'symlinks))
1244                    (build-image (match (assq-ref %formats pack-format)
1245                                   ((? procedure? proc) proc)
1246                                   (#f
1247                                    (leave (G_ "~a: unknown pack format~%")
1248                                           pack-format))))
1249                    (localstatedir? (assoc-ref opts 'localstatedir?))
1250                    (entry-point    (assoc-ref opts 'entry-point))
1251                    (profile-name   (assoc-ref opts 'profile-name))
1252                    (gc-root        (assoc-ref opts 'gc-root))
1253                    (profile        (profile
1254                                     (content manifest)
1255
1256                                     ;; Always produce relative symlinks for
1257                                     ;; Singularity (see
1258                                     ;; <https://bugs.gnu.org/34913>).
1259                                     (relative-symlinks?
1260                                      (or relocatable?
1261                                          (eq? 'squashfs pack-format)))
1262
1263                                     (hooks (if bootstrap?
1264                                                '()
1265                                                %default-profile-hooks))
1266                                     (locales? (not bootstrap?)))))
1267               (define (lookup-package package)
1268                 (manifest-lookup manifest (manifest-pattern (name package))))
1269
1270               (when (null? (manifest-entries manifest))
1271                 (warning (G_ "no packages specified; building an empty pack~%")))
1272
1273               (when (and (eq? pack-format 'squashfs)
1274                          (not (any lookup-package '("bash" "bash-minimal"))))
1275                 (warning (G_ "Singularity requires you to provide a shell~%"))
1276                 (display-hint (G_ "Add @code{bash} or @code{bash-minimal} \
1277 to your package list.")))
1278
1279               (run-with-store store
1280                 (mlet* %store-monad ((drv (build-image name profile
1281                                                        #:target
1282                                                        target
1283                                                        #:compressor
1284                                                        compressor
1285                                                        #:symlinks
1286                                                        symlinks
1287                                                        #:localstatedir?
1288                                                        localstatedir?
1289                                                        #:entry-point
1290                                                        entry-point
1291                                                        #:profile-name
1292                                                        profile-name
1293                                                        #:archiver
1294                                                        archiver)))
1295                   (mbegin %store-monad
1296                     (mwhen derivation?
1297                       (return (format #t "~a~%"
1298                                       (derivation-file-name drv))))
1299                     (munless derivation?
1300                       (built-derivations (list drv))
1301                       (mwhen gc-root
1302                         (register-root* (match (derivation->output-paths drv)
1303                                           (((names . items) ...)
1304                                            items))
1305                                         gc-root))
1306                       (return (format #t "~a~%"
1307                                       (derivation->output-path drv))))))
1308                 #:target target
1309                 #:system (assoc-ref opts 'system)))))))))