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                     #:references-graphs `(("profile" ,profile))))
 290
 291 (define (singularity-environment-file profile)
 292   "Return a shell script that defines the environment variables corresponding
 293 to the search paths of PROFILE."
 294   (define build
 295     (with-extensions (list guile-gcrypt)
 296       (with-imported-modules `(((guix config) => ,(make-config.scm))
 297                                ,@(source-module-closure
 298                                   `((guix profiles)
 299                                     (guix search-paths))
 300                                   #:select? not-config?))
 301         #~(begin
 302             (use-modules (guix profiles) (guix search-paths)
 303                          (ice-9 match))
 304
 305             (call-with-output-file #$output
 306               (lambda (port)
 307                 (for-each (match-lambda
 308                             ((spec . value)
 309                              (format port "~a=~a~%export ~a~%"
 310                                      (search-path-specification-variable spec)
 311                                      value
 312                                      (search-path-specification-variable spec))))
 313                           (profile-search-paths #$profile))))))))
 314
 315   (computed-file "singularity-environment.sh" build))
 316
 317 (define* (squashfs-image name profile
 318                          #:key target
 319                          (profile-name "guix-profile")
 320                          (compressor (first %compressors))
 321                          entry-point
 322                          localstatedir?
 323                          (symlinks '())
 324                          (archiver squashfs-tools))
 325   "Return a squashfs image containing a store initialized with the closure of
 326 PROFILE, a derivation.  The image contains a subset of /gnu/store, empty mount
 327 points for virtual file systems (like procfs), and optional symlinks.
 328
 329 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 330 added to the pack."
 331   (define database
 332     (and localstatedir?
 333          (file-append (store-database (list profile))
 334                       "/db/db.sqlite")))
 335
 336   (define environment
 337     (singularity-environment-file profile))
 338
 339   (define symlinks*
 340     ;; Singularity requires /bin (specifically /bin/sh), so ensure that
 341     ;; symlink is created.
 342     (if (find (match-lambda
 343                 (("/bin" . _) #t)
 344                 (_            #f))
 345               symlinks)
 346         symlinks
 347         `(("/bin" -> "bin") ,@symlinks)))
 348
 349   (define build
 350     (with-imported-modules (source-module-closure
 351                             '((guix build utils)
 352                               (guix build store-copy)
 353                               (guix build union)
 354                               (gnu build install))
 355                             #:select? not-config?)
 356       #~(begin
 357           (use-modules (guix build utils)
 358                        (guix build store-copy)
 359                        ((guix build union) #:select (relative-file-name))
 360                        (gnu build install)
 361                        (srfi srfi-1)
 362                        (srfi srfi-26)
 363                        (ice-9 match))
 364
 365           (define database #+database)
 366           (define entry-point #$entry-point)
 367
 368           (setenv "PATH" (string-append #$archiver "/bin"))
 369
 370           ;; We need an empty file in order to have a valid file argument when
 371           ;; we reparent the root file system.  Read on for why that's
 372           ;; necessary.
 373           (with-output-to-file ".empty" (lambda () (display "")))
 374
 375           ;; Create the squashfs image in several steps.
 376           ;; Add all store items.  Unfortunately mksquashfs throws away all
 377           ;; ancestor directories and only keeps the basename.  We fix this
 378           ;; in the following invocations of mksquashfs.
 379           (apply invoke "mksquashfs"
 380                  `(,@(map store-info-item
 381                           (call-with-input-file "profile"
 382                             read-reference-graph))
 383                    #$environment
 384                    ,#$output
 385
 386                    ;; Do not perform duplicate checking because we
 387                    ;; don't have any dupes.
 388                    "-no-duplicates"
 389                    "-comp"
 390                    ,#+(compressor-name compressor)))
 391
 392           ;; Here we reparent the store items.  For each sub-directory of
 393           ;; the store prefix we need one invocation of "mksquashfs".
 394           (for-each (lambda (dir)
 395                       (apply invoke "mksquashfs"
 396                              `(".empty"
 397                                ,#$output
 398                                "-root-becomes" ,dir)))
 399                     (reverse (string-tokenize (%store-directory)
 400                                               (char-set-complement (char-set #\/)))))
 401
 402           ;; Add symlinks and mount points.
 403           (apply invoke "mksquashfs"
 404                  `(".empty"
 405                    ,#$output
 406                    ;; Create SYMLINKS via pseudo file definitions.
 407                    ,@(append-map
 408                       (match-lambda
 409                         ((source '-> target)
 410                          ;; Create relative symlinks to work around a bug in
 411                          ;; Singularity 2.x:
 412                          ;;   https://bugs.gnu.org/34913
 413                          ;;   https://github.com/sylabs/singularity/issues/1487
 414                          (let ((target (string-append #$profile "/" target)))
 415                            (list "-p"
 416                                  (string-join
 417                                   ;; name s mode uid gid symlink
 418                                   (list source
 419                                         "s" "777" "0" "0"
 420                                         (relative-file-name (dirname source)
 421                                                             target)))))))
 422                       '#$symlinks*)
 423
 424                    "-p" "/.singularity.d d 555 0 0"
 425
 426                    ;; Create the environment file.
 427                    "-p" "/.singularity.d/env d 555 0 0"
 428                    "-p" ,(string-append
 429                           "/.singularity.d/env/90-environment.sh s 777 0 0 "
 430                           (relative-file-name "/.singularity.d/env"
 431                                               #$environment))
 432
 433                    ;; Create /.singularity.d/actions, and optionally the 'run'
 434                    ;; script, used by 'singularity run'.
 435                    "-p" "/.singularity.d/actions d 555 0 0"
 436
 437                    ,@(if entry-point
 438                          `(;; This one if for Singularity 2.x.
 439                            "-p"
 440                            ,(string-append
 441                              "/.singularity.d/actions/run s 777 0 0 "
 442                              (relative-file-name "/.singularity.d/actions"
 443                                                  (string-append #$profile "/"
 444                                                                 entry-point)))
 445
 446                            ;; This one is for Singularity 3.x.
 447                            "-p"
 448                            ,(string-append
 449                              "/.singularity.d/runscript s 777 0 0 "
 450                              (relative-file-name "/.singularity.d"
 451                                                  (string-append #$profile "/"
 452                                                                 entry-point))))
 453                          '())
 454
 455                    ;; Create empty mount points.
 456                    "-p" "/proc d 555 0 0"
 457                    "-p" "/sys d 555 0 0"
 458                    "-p" "/dev d 555 0 0"
 459                    "-p" "/home d 555 0 0"))
 460
 461           (when database
 462             ;; Initialize /var/guix.
 463             (install-database-and-gc-roots "var-etc" database #$profile)
 464             (invoke "mksquashfs" "var-etc" #$output)))))
 465
 466   (gexp->derivation (string-append name
 467                                    (compressor-extension compressor)
 468                                    ".squashfs")
 469                     build
 470                     #:references-graphs `(("profile" ,profile))))
 471
 472 (define* (docker-image name profile
 473                        #:key target
 474                        (profile-name "guix-profile")
 475                        (compressor (first %compressors))
 476                        entry-point
 477                        localstatedir?
 478                        (symlinks '())
 479                        (archiver tar))
 480   "Return a derivation to construct a Docker image of PROFILE.  The
 481 image is a tarball conforming to the Docker Image Specification, compressed
 482 with COMPRESSOR.  It can be passed to 'docker load'.  If TARGET is true, it
 483 must a be a GNU triplet and it is used to derive the architecture metadata in
 484 the image."
 485   (define database
 486     (and localstatedir?
 487          (file-append (store-database (list profile))
 488                       "/db/db.sqlite")))
 489
 490   (define defmod 'define-module)                  ;trick Geiser
 491
 492   (define build
 493     ;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
 494     (with-extensions (list guile-json-3 guile-gcrypt)
 495       (with-imported-modules `(((guix config) => ,(make-config.scm))
 496                                ,@(source-module-closure
 497                                   `((guix docker)
 498                                     (guix build store-copy)
 499                                     (guix profiles)
 500                                     (guix search-paths))
 501                                   #:select? not-config?))
 502         #~(begin
 503             (use-modules (guix docker) (guix build store-copy)
 504                          (guix profiles) (guix search-paths)
 505                          (srfi srfi-1) (srfi srfi-19)
 506                          (ice-9 match))
 507
 508             (define environment
 509               (map (match-lambda
 510                      ((spec . value)
 511                       (cons (search-path-specification-variable spec)
 512                             value)))
 513                    (profile-search-paths #$profile)))
 514
 515             (define symlink->directives
 516               ;; Return "populate directives" to make the given symlink and its
 517               ;; parent directories.
 518               (match-lambda
 519                 ((source '-> target)
 520                  (let ((target (string-append #$profile "/" target))
 521                        (parent (dirname source)))
 522                    `((directory ,parent)
 523                      (,source -> ,target))))))
 524
 525             (define directives
 526               ;; Create a /tmp directory, as some programs expect it, and
 527               ;; create SYMLINKS.
 528               `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
 529                 ,@(append-map symlink->directives '#$symlinks)))
 530
 531             (define tag
 532               ;; Compute a meaningful "repository" name, which will show up in
 533               ;; the output of "docker images".
 534               (let ((manifest (profile-manifest #$profile)))
 535                 (let loop ((names (map manifest-entry-name
 536                                        (manifest-entries manifest))))
 537                   (define str (string-join names "-"))
 538                   (if (< (string-length str) 40)
 539                       str
 540                       (match names
 541                         ((_) str)
 542                         ((names ... _) (loop names))))))) ;drop one entry
 543
 544             (setenv "PATH" (string-append #$archiver "/bin"))
 545
 546             (build-docker-image #$output
 547                                 (map store-info-item
 548                                      (call-with-input-file "profile"
 549                                        read-reference-graph))
 550                                 #$profile
 551                                 #:repository tag
 552                                 #:database #+database
 553                                 #:system (or #$target (utsname:machine (uname)))
 554                                 #:environment environment
 555                                 #:entry-point
 556                                 #$(and entry-point
 557                                        #~(list (string-append #$profile "/"
 558                                                               #$entry-point)))
 559                                 #:extra-files directives
 560                                 #:compressor '#$(compressor-command compressor)
 561                                 #:creation-time (make-time time-utc 0 1))))))
 562
 563   (gexp->derivation (string-append name ".tar"
 564                                    (compressor-extension compressor))
 565                     build
 566                     #:references-graphs `(("profile" ,profile))))
 567
 568 \f
 569 ;;;
 570 ;;; Compiling C programs.
 571 ;;;
 572
 573 ;; A C compiler.  That lowers to a single program that can be passed typical C
 574 ;; compiler flags, and it makes sure the whole toolchain is available.
 575 (define-record-type <c-compiler>
 576   (%c-compiler toolchain guile)
 577   c-compiler?
 578   (toolchain c-compiler-toolchain)
 579   (guile     c-compiler-guile))
 580
 581 (define* (c-compiler #:optional inputs
 582                      #:key (guile (default-guile)))
 583   (%c-compiler inputs guile))
 584
 585 (define (bootstrap-c-compiler)
 586   "Return the C compiler that uses the bootstrap toolchain.  This is used only
 587 by '--bootstrap', for testing purposes."
 588   (define bootstrap-toolchain
 589     (list (first (assoc-ref (%bootstrap-inputs) "gcc"))
 590           (first (assoc-ref (%bootstrap-inputs) "binutils"))
 591           (first (assoc-ref (%bootstrap-inputs) "libc"))))
 592
 593   (c-compiler bootstrap-toolchain
 594               #:guile %bootstrap-guile))
 595
 596 (define-gexp-compiler (c-compiler-compiler (compiler <c-compiler>) system target)
 597   "Lower COMPILER to a single script that does the right thing."
 598   (define toolchain
 599     (or (c-compiler-toolchain compiler)
 600         (list (first (assoc-ref (standard-packages) "gcc"))
 601               (first (assoc-ref (standard-packages) "ld-wrapper"))
 602               (first (assoc-ref (standard-packages) "binutils"))
 603               (first (assoc-ref (standard-packages) "libc"))
 604               (gexp-input (first (assoc-ref (standard-packages) "libc"))
 605                           "static"))))
 606
 607   (define inputs
 608     (match (append-map package-propagated-inputs
 609                        (filter package? toolchain))
 610       (((labels things . _) ...)
 611        (append toolchain things))))
 612
 613   (define search-paths
 614     (cons $PATH
 615           (append-map package-native-search-paths
 616                       (filter package? inputs))))
 617
 618   (define run
 619     (with-imported-modules (source-module-closure
 620                             '((guix build utils)
 621                               (guix search-paths)))
 622       #~(begin
 623           (use-modules (guix build utils) (guix search-paths)
 624                        (ice-9 match))
 625
 626           (define (output-file args)
 627             (let loop ((args args))
 628               (match args
 629                 (() "a.out")
 630                 (("-o" file _ ...) file)
 631                 ((head rest ...) (loop rest)))))
 632
 633           (set-search-paths (map sexp->search-path-specification
 634                                  '#$(map search-path-specification->sexp
 635                                          search-paths))
 636                             '#$inputs)
 637
 638           (let ((output (output-file (command-line))))
 639             (apply invoke "gcc" (cdr (command-line)))
 640             (invoke "strip" output)))))
 641
 642   (when target
 643     ;; TODO: Yep, we'll have to do it someday!
 644     (leave (G_ "cross-compilation not implemented here;
 645 please email '~a'~%")
 646            (@ (guix config) %guix-bug-report-address)))
 647
 648   (gexp->script "c-compiler" run
 649                 #:guile (c-compiler-guile compiler)))
 650
 651 \f
 652 ;;;
 653 ;;; Wrapped package.
 654 ;;;
 655
 656 (define* (wrapped-package package
 657                           #:optional
 658                           (output* "out")
 659                           (compiler (c-compiler))
 660                           #:key proot?)
 661   "Return the OUTPUT of PACKAGE with its binaries wrapped such that they are
 662 relocatable.  When PROOT? is true, include PRoot in the result and use it as a
 663 last resort for relocation."
 664   (define runner
 665     (local-file (search-auxiliary-file "run-in-namespace.c")))
 666
 667   (define (proot)
 668     (specification->package "proot-static"))
 669
 670   (define build
 671     (with-imported-modules (source-module-closure
 672                             '((guix build utils)
 673                               (guix build union)))
 674       #~(begin
 675           (use-modules (guix build utils)
 676                        ((guix build union) #:select (relative-file-name))
 677                        (ice-9 ftw)
 678                        (ice-9 match))
 679
 680           (define input
 681             ;; The OUTPUT* output of PACKAGE.
 682             (ungexp package output*))
 683
 684           (define target
 685             ;; The output we are producing.
 686             (ungexp output output*))
 687
 688           (define (strip-store-prefix file)
 689             ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
 690             ;; "/bin/foo".
 691             (let* ((len  (string-length (%store-directory)))
 692                    (base (string-drop file (+ 1 len))))
 693               (match (string-index base #\/)
 694                 (#f    base)
 695                 (index (string-drop base index)))))
 696
 697           (define (build-wrapper program)
 698             ;; Build a user-namespace wrapper for PROGRAM.
 699             (format #t "building wrapper for '~a'...~%" program)
 700             (copy-file #$runner "run.c")
 701
 702             (substitute* "run.c"
 703               (("@WRAPPED_PROGRAM@") program)
 704               (("@STORE_DIRECTORY@") (%store-directory)))
 705
 706             (let* ((base   (strip-store-prefix program))
 707                    (result (string-append target "/" base))
 708                    (proot  #$(and proot?
 709                                   #~(string-drop
 710                                      #$(file-append (proot) "/bin/proot")
 711                                      (+ (string-length (%store-directory))
 712                                         1)))))
 713               (mkdir-p (dirname result))
 714               (apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
 715                      "run.c" "-o" result
 716                      (if proot
 717                          (list (string-append "-DPROOT_PROGRAM=\""
 718                                               proot "\""))
 719                          '()))
 720               (delete-file "run.c")))
 721
 722           (setvbuf (current-output-port) 'line)
 723
 724           ;; Link the top-level files of PACKAGE so that search paths are
 725           ;; properly defined in PROFILE/etc/profile.
 726           (mkdir target)
 727           (for-each (lambda (file)
 728                       (unless (member file '("." ".." "bin" "sbin" "libexec"))
 729                         (let ((file* (string-append input "/" file)))
 730                           (symlink (relative-file-name target file*)
 731                                    (string-append target "/" file)))))
 732                     (scandir input))
 733
 734           (for-each build-wrapper
 735                     (append (find-files (string-append input "/bin"))
 736                             (find-files (string-append input "/sbin"))
 737                             (find-files (string-append input "/libexec")))))))
 738
 739   (computed-file (string-append
 740                   (cond ((package? package)
 741                          (package-full-name package "-"))
 742                         ((inferior-package? package)
 743                          (string-append (inferior-package-name package)
 744                                         "-"
 745                                         (inferior-package-version package)))
 746                         (else "wrapper"))
 747                   "R")
 748                  build))
 749
 750 (define (wrapped-manifest-entry entry . args)
 751   (manifest-entry
 752     (inherit entry)
 753     (item (apply wrapped-package
 754                  (manifest-entry-item entry)
 755                  (manifest-entry-output entry)
 756                  args))))
 757
 758 \f
 759 ;;;
 760 ;;; Command-line options.
 761 ;;;
 762
 763 (define %default-options
 764   ;; Alist of default option values.
 765   `((format . tarball)
 766     (profile-name . "guix-profile")
 767     (system . ,(%current-system))
 768     (substitutes? . #t)
 769     (offload? . #t)
 770     (graft? . #t)
 771     (print-build-trace? . #t)
 772     (print-extended-build-trace? . #t)
 773     (multiplexed-build-output? . #t)
 774     (debug . 0)
 775     (verbosity . 1)
 776     (symlinks . ())
 777     (compressor . ,(first %compressors))))
 778
 779 (define %formats
 780   ;; Supported pack formats.
 781   `((tarball . ,self-contained-tarball)
 782     (squashfs . ,squashfs-image)
 783     (docker  . ,docker-image)))
 784
 785 (define (show-formats)
 786   ;; Print the supported pack formats.
 787   (display (G_ "The supported formats for 'guix pack' are:"))
 788   (newline)
 789   (display (G_ "
 790   tarball       Self-contained tarball, ready to run on another machine"))
 791   (display (G_ "
 792   squashfs      Squashfs image suitable for Singularity"))
 793   (display (G_ "
 794   docker        Tarball ready for 'docker load'"))
 795   (newline))
 796
 797 (define %options
 798   ;; Specifications of the command-line options.
 799   (cons* (option '(#\h "help") #f #f
 800                  (lambda args
 801                    (show-help)
 802                    (exit 0)))
 803          (option '(#\V "version") #f #f
 804                  (lambda args
 805                    (show-version-and-exit "guix pack")))
 806
 807          (option '(#\n "dry-run") #f #f
 808                  (lambda (opt name arg result)
 809                    (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
 810          (option '(#\d "derivation") #f #f
 811                  (lambda (opt name arg result)
 812                    (alist-cons 'derivation-only? #t result)))
 813
 814          (option '(#\f "format") #t #f
 815                  (lambda (opt name arg result)
 816                    (alist-cons 'format (string->symbol arg) result)))
 817          (option '("list-formats") #f #f
 818                  (lambda args
 819                    (show-formats)
 820                    (exit 0)))
 821          (option '(#\R "relocatable") #f #f
 822                  (lambda (opt name arg result)
 823                    (match (assq-ref result 'relocatable?)
 824                      (#f
 825                       (alist-cons 'relocatable? #t result))
 826                      (_
 827                       (alist-cons 'relocatable? 'proot
 828                                   (alist-delete 'relocatable? result))))))
 829          (option '(#\e "expression") #t #f
 830                  (lambda (opt name arg result)
 831                    (alist-cons 'expression arg result)))
 832          (option '(#\m "manifest") #t #f
 833                  (lambda (opt name arg result)
 834                    (alist-cons 'manifest arg result)))
 835          (option '(#\s "system") #t #f
 836                  (lambda (opt name arg result)
 837                    (alist-cons 'system arg
 838                                (alist-delete 'system result eq?))))
 839          (option '("entry-point") #t #f
 840                  (lambda (opt name arg result)
 841                    (alist-cons 'entry-point arg result)))
 842          (option '("target") #t #f
 843                  (lambda (opt name arg result)
 844                    (alist-cons 'target arg
 845                                (alist-delete 'target result eq?))))
 846          (option '(#\C "compression") #t #f
 847                  (lambda (opt name arg result)
 848                    (alist-cons 'compressor (lookup-compressor arg)
 849                                result)))
 850          (option '(#\S "symlink") #t #f
 851                  (lambda (opt name arg result)
 852                    ;; Note: Using 'string-split' allows us to handle empty
 853                    ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is
 854                    ;; a symlink to the profile) correctly.
 855                    (match (string-split arg (char-set #\=))
 856                      ((source target)
 857                       (let ((symlinks (assoc-ref result 'symlinks)))
 858                         (alist-cons 'symlinks
 859                                     `((,source -> ,target) ,@symlinks)
 860                                     (alist-delete 'symlinks result eq?))))
 861                      (x
 862                       (leave (G_ "~a: invalid symlink specification~%")
 863                              arg)))))
 864          (option '("save-provenance") #f #f
 865                  (lambda (opt name arg result)
 866                    (alist-cons 'save-provenance? #t result)))
 867          (option '("localstatedir") #f #f
 868                  (lambda (opt name arg result)
 869                    (alist-cons 'localstatedir? #t result)))
 870          (option '("profile-name") #t #f
 871                  (lambda (opt name arg result)
 872                    (match arg
 873                      ((or "guix-profile" "current-guix")
 874                       (alist-cons 'profile-name arg result))
 875                      (_
 876                       (leave (G_ "~a: unsupported profile name~%") arg)))))
 877          (option '(#\r "root") #t #f
 878                  (lambda (opt name arg result)
 879                    (alist-cons 'gc-root arg result)))
 880
 881          (option '(#\v "verbosity") #t #f
 882                  (lambda (opt name arg result)
 883                    (let ((level (string->number* arg)))
 884                      (alist-cons 'verbosity level
 885                                  (alist-delete 'verbosity result)))))
 886          (option '("bootstrap") #f #f
 887                  (lambda (opt name arg result)
 888                    (alist-cons 'bootstrap? #t result)))
 889
 890          (append %transformation-options
 891                  %standard-build-options)))
 892
 893 (define (show-help)
 894   (display (G_ "Usage: guix pack [OPTION]... PACKAGE...
 895 Create a bundle of PACKAGE.\n"))
 896   (show-build-options-help)
 897   (newline)
 898   (show-transformation-options-help)
 899   (newline)
 900   (display (G_ "
 901   -f, --format=FORMAT    build a pack in the given FORMAT"))
 902   (display (G_ "
 903       --list-formats     list the formats available"))
 904   (display (G_ "
 905   -R, --relocatable      produce relocatable executables"))
 906   (display (G_ "
 907   -e, --expression=EXPR  consider the package EXPR evaluates to"))
 908   (display (G_ "
 909   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
 910   (display (G_ "
 911       --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
 912   (display (G_ "
 913   -C, --compression=TOOL compress using TOOL--e.g., \"lzip\""))
 914   (display (G_ "
 915   -S, --symlink=SPEC     create symlinks to the profile according to SPEC"))
 916   (display (G_ "
 917   -m, --manifest=FILE    create a pack with the manifest from FILE"))
 918   (display (G_ "
 919       --entry-point=PROGRAM
 920                          use PROGRAM as the entry point of the pack"))
 921   (display (G_ "
 922       --save-provenance  save provenance information"))
 923   (display (G_ "
 924       --localstatedir    include /var/guix in the resulting pack"))
 925   (display (G_ "
 926       --profile-name=NAME
 927                          populate /var/guix/profiles/.../NAME"))
 928   (display (G_ "
 929   -r, --root=FILE        make FILE a symlink to the result, and register it
 930                          as a garbage collector root"))
 931   (display (G_ "
 932   -d, --derivation       return the derivation of the pack"))
 933   (display (G_ "
 934   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
 935   (display (G_ "
 936       --bootstrap        use the bootstrap binaries to build the pack"))
 937   (newline)
 938   (display (G_ "
 939   -h, --help             display this help and exit"))
 940   (display (G_ "
 941   -V, --version          display version information and exit"))
 942   (newline)
 943   (show-bug-report-information))
 944
 945 \f
 946 ;;;
 947 ;;; Entry point.
 948 ;;;
 949
 950 (define (guix-pack . args)
 951   (define opts
 952     (parse-command-line args %options (list %default-options)))
 953
 954   (define maybe-package-argument
 955     ;; Given an option pair, return a package, a package/output tuple, or #f.
 956     (match-lambda
 957       (('argument . spec)
 958        (call-with-values
 959            (lambda ()
 960              (specification->package+output spec))
 961          list))
 962       (('expression . exp)
 963        (read/eval-package-expression exp))
 964       (x #f)))
 965
 966   (define (manifest-from-args store opts)
 967     (let* ((transform     (options->transformation opts))
 968            (packages      (map (match-lambda
 969                                  (((? package? package) output)
 970                                   (list (transform store package) output))
 971                                  ((? package? package)
 972                                   (list (transform store package) "out")))
 973                                (reverse
 974                                 (filter-map maybe-package-argument opts))))
 975            (manifests     (filter-map (match-lambda
 976                                         (('manifest . file) file)
 977                                         (_ #f))
 978                                       opts)))
 979       (define with-provenance
 980         (if (assoc-ref opts 'save-provenance?)
 981             (lambda (manifest)
 982               (map-manifest-entries
 983                (lambda (entry)
 984                  (let ((entry (manifest-entry-with-provenance entry)))
 985                    (unless (assq 'provenance (manifest-entry-properties entry))
 986                      (warning (G_ "could not determine provenance of package ~a~%")
 987                               (manifest-entry-name entry)))
 988                    entry))
 989                manifest))
 990             identity))
 991
 992       (with-provenance
 993        (cond
 994         ((and (not (null? manifests)) (not (null? packages)))
 995          (leave (G_ "both a manifest and a package list were given~%")))
 996         ((not (null? manifests))
 997          (concatenate-manifests
 998           (map (lambda (file)
 999                  (let ((user-module (make-user-module
1000                                      '((guix profiles) (gnu)))))
1001                    (load* file user-module)))
1002                manifests)))
1003         (else
1004          (packages->manifest packages))))))
1005
1006   (with-error-handling
1007     (with-store store
1008       (with-status-verbosity (assoc-ref opts 'verbosity)
1009         ;; Set the build options before we do anything else.
1010         (set-build-options-from-command-line store opts)
1011
1012         (parameterize ((%graft? (assoc-ref opts 'graft?))
1013                        (%guile-for-build (package-derivation
1014                                           store
1015                                           (if (assoc-ref opts 'bootstrap?)
1016                                               %bootstrap-guile
1017                                               (canonical-package guile-2.2))
1018                                           (assoc-ref opts 'system)
1019                                           #:graft? (assoc-ref opts 'graft?))))
1020           (let* ((dry-run?    (assoc-ref opts 'dry-run?))
1021                  (derivation? (assoc-ref opts 'derivation-only?))
1022                  (relocatable? (assoc-ref opts 'relocatable?))
1023                  (proot?      (eq? relocatable? 'proot))
1024                  (manifest    (let ((manifest (manifest-from-args store opts)))
1025                                 ;; Note: We cannot honor '--bootstrap' here because
1026                                 ;; 'glibc-bootstrap' lacks 'libc.a'.
1027                                 (if relocatable?
1028                                     (map-manifest-entries
1029                                      (cut wrapped-manifest-entry <> #:proot? proot?)
1030                                      manifest)
1031                                     manifest)))
1032                  (pack-format (assoc-ref opts 'format))
1033                  (name        (string-append (symbol->string pack-format)
1034                                              "-pack"))
1035                  (target      (assoc-ref opts 'target))
1036                  (bootstrap?  (assoc-ref opts 'bootstrap?))
1037                  (compressor  (if bootstrap?
1038                                   bootstrap-xz
1039                                   (assoc-ref opts 'compressor)))
1040                  (archiver    (if (equal? pack-format 'squashfs)
1041                                   squashfs-tools
1042                                   (if bootstrap?
1043                                       %bootstrap-coreutils&co
1044                                       tar)))
1045                  (symlinks    (assoc-ref opts 'symlinks))
1046                  (build-image (match (assq-ref %formats pack-format)
1047                                 ((? procedure? proc) proc)
1048                                 (#f
1049                                  (leave (G_ "~a: unknown pack format~%")
1050                                         pack-format))))
1051                  (localstatedir? (assoc-ref opts 'localstatedir?))
1052                  (entry-point    (assoc-ref opts 'entry-point))
1053                  (profile-name   (assoc-ref opts 'profile-name))
1054                  (gc-root        (assoc-ref opts 'gc-root)))
1055             (define (lookup-package package)
1056               (manifest-lookup manifest (manifest-pattern (name package))))
1057
1058             (when (null? (manifest-entries manifest))
1059               (warning (G_ "no packages specified; building an empty pack~%")))
1060
1061             (when (and (eq? pack-format 'squashfs)
1062                        (not (any lookup-package '("bash" "bash-minimal"))))
1063               (warning (G_ "Singularity requires you to provide a shell~%"))
1064               (display-hint (G_ "Add @code{bash} or @code{bash-minimal} \
1065 to your package list.")))
1066
1067             (run-with-store store
1068               (mlet* %store-monad ((profile (profile-derivation
1069                                              manifest
1070
1071                                              ;; Always produce relative
1072                                              ;; symlinks for Singularity (see
1073                                              ;; <https://bugs.gnu.org/34913>).
1074                                              #:relative-symlinks?
1075                                              (or relocatable?
1076                                                  (eq? 'squashfs pack-format))
1077
1078                                              #:hooks (if bootstrap?
1079                                                          '()
1080                                                          %default-profile-hooks)
1081                                              #:locales? (not bootstrap?)
1082                                              #:target target))
1083                                    (drv (build-image name profile
1084                                                      #:target
1085                                                      target
1086                                                      #:compressor
1087                                                      compressor
1088                                                      #:symlinks
1089                                                      symlinks
1090                                                      #:localstatedir?
1091                                                      localstatedir?
1092                                                      #:entry-point
1093                                                      entry-point
1094                                                      #:profile-name
1095                                                      profile-name
1096                                                      #:archiver
1097                                                      archiver)))
1098                 (mbegin %store-monad
1099                   (munless derivation?
1100                     (show-what-to-build* (list drv)
1101                                          #:use-substitutes?
1102                                          (assoc-ref opts 'substitutes?)
1103                                          #:dry-run? dry-run?))
1104                   (mwhen derivation?
1105                     (return (format #t "~a~%"
1106                                     (derivation-file-name drv))))
1107                   (munless (or derivation? dry-run?)
1108                     (built-derivations (list drv))
1109                     (mwhen gc-root
1110                       (register-root* (match (derivation->output-paths drv)
1111                                         (((names . items) ...)
1112                                          items))
1113                                       gc-root))
1114                     (return (format #t "~a~%"
1115                                     (derivation->output-path drv))))))
1116               #:system (assoc-ref opts 'system))))))))