guix/scripts/pack.scm

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