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