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