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