;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix gexp)
#:use-module (guix utils)
#:use-module (guix store)
- #:use-module (guix status)
+ #:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix grafts)
+ #:autoload (guix inferior) (inferior-package?)
#:use-module (guix monads)
#:use-module (guix modules)
#:use-module (guix packages)
#:use-module (guix profiles)
+ #:use-module (guix describe)
#:use-module (guix derivations)
#:use-module (guix search-paths)
#:use-module (guix build-system gnu)
#:export (compressor?
lookup-compressor
self-contained-tarball
+ docker-image
+ squashfs-image
+
guix-pack))
;; Type of a compression tool.
;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
(append-map (lambda (package)
(cons package
- (package-transitive-propagated-inputs package)))
+ (match (package-transitive-propagated-inputs package)
+ (((labels packages) ...)
+ packages))))
(list guile-gcrypt guile-sqlite3)))
(define (store-database items)
(define* (self-contained-tarball name profile
#:key target
+ (profile-name "guix-profile")
deduplicate?
(compressor (first %compressors))
localstatedir?
;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
(populate-single-profile-directory %root
#:profile #$profile
+ #:profile-name #$profile-name
#:closure "profile"
#:database #+database)
(define* (squashfs-image name profile
#:key target
+ (profile-name "guix-profile")
(compressor (first %compressors))
localstatedir?
(symlinks '())
SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
added to the pack."
+ (define database
+ (and localstatedir?
+ (file-append (store-database (list profile))
+ "/db/db.sqlite")))
+
(define build
(with-imported-modules (source-module-closure
'((guix build utils)
- (guix build store-copy))
+ (guix build store-copy)
+ (gnu build install))
#:select? not-config?)
#~(begin
(use-modules (guix build utils)
(guix build store-copy)
+ (gnu build install)
(srfi srfi-1)
(srfi srfi-26)
(ice-9 match))
+ (define database #+database)
+
(setenv "PATH" (string-append #$archiver "/bin"))
;; We need an empty file in order to have a valid file argument when
;; Create empty mount points.
"-p" "/proc d 555 0 0"
"-p" "/sys d 555 0 0"
- "-p" "/dev d 555 0 0")))))
+ "-p" "/dev d 555 0 0"))
+
+ (when database
+ ;; Initialize /var/guix.
+ (install-database-and-gc-roots "var-etc" database #$profile)
+ (invoke "mksquashfs" "var-etc" #$output)))))
(gexp->derivation (string-append name
(compressor-extension compressor)
(define* (docker-image name profile
#:key target
- deduplicate?
+ (profile-name "guix-profile")
(compressor (first %compressors))
localstatedir?
(symlinks '())
with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it
must a be a GNU triplet and it is used to derive the architecture metadata in
the image."
+ (define database
+ (and localstatedir?
+ (file-append (store-database (list profile))
+ "/db/db.sqlite")))
+
(define defmod 'define-module) ;trick Geiser
(define build
(call-with-input-file "profile"
read-reference-graph))
#$profile
+ #:database #+database
#:system (or #$target (utsname:machine (uname)))
#:symlinks '#$symlinks
#:compressor '#$(compressor-command compressor)
;;;
(define* (wrapped-package package
- #:optional (compiler (c-compiler)))
+ #:optional (compiler (c-compiler))
+ #:key proot?)
(define runner
(local-file (search-auxiliary-file "run-in-namespace.c")))
+ (define (proot)
+ (specification->package "proot-static"))
+
(define build
(with-imported-modules (source-module-closure
'((guix build utils)
(("@STORE_DIRECTORY@") (%store-directory)))
(let* ((base (strip-store-prefix program))
- (result (string-append #$output "/" base)))
+ (result (string-append #$output "/" base))
+ (proot #$(and proot?
+ #~(string-drop
+ #$(file-append (proot) "/bin/proot")
+ (+ (string-length (%store-directory))
+ 1)))))
(mkdir-p (dirname result))
- (invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
- "run.c" "-o" result)
+ (apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
+ "run.c" "-o" result
+ (if proot
+ (list (string-append "-DPROOT_PROGRAM=\""
+ proot "\""))
+ '()))
(delete-file "run.c")))
- (setvbuf (current-output-port)
- (cond-expand (guile-2.2 'line)
- (else _IOLBF)))
+ (setvbuf (current-output-port) 'line)
;; Link the top-level files of PACKAGE so that search paths are
;; properly defined in PROFILE/etc/profile.
(find-files #$(file-append package "/sbin"))
(find-files #$(file-append package "/libexec")))))))
- (computed-file (string-append (package-full-name package "-") "R")
+ (computed-file (string-append
+ (cond ((package? package)
+ (package-full-name package "-"))
+ ((inferior-package? package)
+ (string-append (inferior-package-name package)
+ "-"
+ (inferior-package-version package)))
+ (else "wrapper"))
+ "R")
build))
(define (map-manifest-entries proc manifest)
(define %default-options
;; Alist of default option values.
`((format . tarball)
+ (profile-name . "guix-profile")
(system . ,(%current-system))
(substitutes? . #t)
(build-hook? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
(multiplexed-build-output? . #t)
- (verbosity . 0)
+ (debug . 0)
+ (verbosity . 2)
(symlinks . ())
(compressor . ,(first %compressors))))
(squashfs . ,squashfs-image)
(docker . ,docker-image)))
+(define (show-formats)
+ ;; Print the supported pack formats.
+ (display (G_ "The supported formats for 'guix pack' are:"))
+ (newline)
+ (display (G_ "
+ tarball Self-contained tarball, ready to run on another machine"))
+ (display (G_ "
+ squashfs Squashfs image suitable for Singularity"))
+ (display (G_ "
+ docker Tarball ready for 'docker load'"))
+ (newline))
+
(define %options
;; Specifications of the command-line options.
(cons* (option '(#\h "help") #f #f
(option '(#\f "format") #t #f
(lambda (opt name arg result)
(alist-cons 'format (string->symbol arg) result)))
+ (option '("list-formats") #f #f
+ (lambda args
+ (show-formats)
+ (exit 0)))
(option '(#\R "relocatable") #f #f
(lambda (opt name arg result)
- (alist-cons 'relocatable? #t result)))
+ (match (assq-ref result 'relocatable?)
+ (#f
+ (alist-cons 'relocatable? #t result))
+ (_
+ (alist-cons 'relocatable? 'proot
+ (alist-delete 'relocatable? result))))))
(option '(#\e "expression") #t #f
(lambda (opt name arg result)
(alist-cons 'expression arg result)))
(x
(leave (G_ "~a: invalid symlink specification~%")
arg)))))
+ (option '("save-provenance") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'save-provenance? #t result)))
(option '("localstatedir") #f #f
(lambda (opt name arg result)
(alist-cons 'localstatedir? #t result)))
+ (option '("profile-name") #t #f
+ (lambda (opt name arg result)
+ (match arg
+ ((or "guix-profile" "current-guix")
+ (alist-cons 'profile-name arg result))
+ (_
+ (leave (G_ "~a: unsupported profile name~%") arg)))))
+ (option '(#\v "verbosity") #t #f
+ (lambda (opt name arg result)
+ (let ((level (string->number* arg)))
+ (alist-cons 'verbosity level
+ (alist-delete 'verbosity result)))))
(option '("bootstrap") #f #f
(lambda (opt name arg result)
(alist-cons 'bootstrap? #t result)))
(newline)
(display (G_ "
-f, --format=FORMAT build a pack in the given FORMAT"))
+ (display (G_ "
+ --list-formats list the formats available"))
(display (G_ "
-R, --relocatable produce relocatable executables"))
(display (G_ "
-S, --symlink=SPEC create symlinks to the profile according to SPEC"))
(display (G_ "
-m, --manifest=FILE create a pack with the manifest from FILE"))
+ (display (G_ "
+ --save-provenance save provenance information"))
(display (G_ "
--localstatedir include /var/guix in the resulting pack"))
+ (display (G_ "
+ --profile-name=NAME
+ populate /var/guix/profiles/.../NAME"))
+ (display (G_ "
+ -v, --verbosity=LEVEL use the given verbosity LEVEL"))
(display (G_ "
--bootstrap use the bootstrap binaries to build the pack"))
(newline)
(list (transform store package) "out")))
(filter-map maybe-package-argument opts)))
(manifest-file (assoc-ref opts 'manifest)))
+ (define properties
+ (if (assoc-ref opts 'save-provenance?)
+ (lambda (package)
+ (match (package-provenance package)
+ (#f
+ (warning (G_ "could not determine provenance of package ~a~%")
+ (package-full-name package))
+ '())
+ (sexp
+ `((provenance . ,sexp)))))
+ (const '())))
+
(cond
((and manifest-file (not (null? packages)))
(leave (G_ "both a manifest and a package list were given~%")))
(manifest-file
(let ((user-module (make-user-module '((guix profiles) (gnu)))))
(load* manifest-file user-module)))
- (else (packages->manifest packages)))))
+ (else
+ (manifest
+ (map (match-lambda
+ ((package output)
+ (package->manifest-entry package output
+ #:properties
+ (properties package))))
+ packages))))))
(with-error-handling
(with-store store
- (with-status-report print-build-event
+ (with-status-verbosity (assoc-ref opts 'verbosity)
;; Set the build options before we do anything else.
(set-build-options-from-command-line store opts)
#:graft? (assoc-ref opts 'graft?))))
(let* ((dry-run? (assoc-ref opts 'dry-run?))
(relocatable? (assoc-ref opts 'relocatable?))
+ (proot? (eq? relocatable? 'proot))
(manifest (let ((manifest (manifest-from-args store opts)))
;; Note: We cannot honor '--bootstrap' here because
;; 'glibc-bootstrap' lacks 'libc.a'.
(if relocatable?
- (map-manifest-entries wrapped-package manifest)
+ (map-manifest-entries
+ (cut wrapped-package <> #:proot? proot?)
+ manifest)
manifest)))
(pack-format (assoc-ref opts 'format))
(name (string-append (symbol->string pack-format)
(#f
(leave (G_ "~a: unknown pack format~%")
pack-format))))
- (localstatedir? (assoc-ref opts 'localstatedir?)))
+ (localstatedir? (assoc-ref opts 'localstatedir?))
+ (profile-name (assoc-ref opts 'profile-name)))
(run-with-store store
(mlet* %store-monad ((profile (profile-derivation
manifest
symlinks
#:localstatedir?
localstatedir?
+ #:profile-name
+ profile-name
#:archiver
archiver)))
(mbegin %store-monad
HCoop / jackhill / guix / guix.git / blobdiff