guix/scripts/pack.scm

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