guix/scripts/pack.scm

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