summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build/download.scm3
-rw-r--r--guix/build/syscalls.scm45
-rw-r--r--guix/scripts/pack.scm151
-rw-r--r--guix/upstream.scm4
-rw-r--r--guix/zlib.scm29
5 files changed, 169 insertions, 63 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 203338b527..e7a7afecd1 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
;;;
@@ -37,6 +37,7 @@
#:use-module (ice-9 format)
#:export (open-socket-for-uri
open-connection-for-uri
+ %x509-certificate-directory
close-connection
resolve-uri-reference
maybe-expand-mirrors
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 58c23f2844..5aae1530f4 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -656,6 +656,36 @@ mounted at FILE."
(define CLONE_NEWPID #x20000000)
(define CLONE_NEWNET #x40000000)
+(cond-expand
+ (guile-2.2
+ (define %set-automatic-finalization-enabled?!
+ (let ((proc (pointer->procedure int
+ (dynamic-func
+ "scm_set_automatic_finalization_enabled"
+ (dynamic-link))
+ (list int))))
+ (lambda (enabled?)
+ "Switch on or off automatic finalization in a separate thread.
+Turning finalization off shuts down the finalization thread as a side effect."
+ (->bool (proc (if enabled? 1 0))))))
+
+ (define-syntax-rule (without-automatic-finalization exp)
+ "Turn off automatic finalization within the dynamic extent of EXP."
+ (let ((enabled? #t))
+ (dynamic-wind
+ (lambda ()
+ (set! enabled? (%set-automatic-finalization-enabled?! #f)))
+ (lambda ()
+ exp)
+ (lambda ()
+ (%set-automatic-finalization-enabled?! enabled?))))))
+
+ (else
+ (define-syntax-rule (without-automatic-finalization exp)
+ ;; Nothing to do here: Guile 2.0 does not have a separate finalization
+ ;; thread.
+ exp)))
+
;; The libc interface to sys_clone is not useful for Scheme programs, so the
;; low-level system call is wrapped instead. The 'syscall' function is
;; declared in <unistd.h> as a variadic function; in practice, it expects 6
@@ -678,10 +708,17 @@ mounted at FILE."
Unlike the fork system call, clone accepts FLAGS that specify which resources
are shared between the parent and child processes."
(let-values (((ret err)
- (proc syscall-id flags
- %null-pointer ;child stack
- %null-pointer %null-pointer ;ptid & ctid
- %null-pointer))) ;unused
+ ;; Guile 2.2 runs a finalization thread. 'primitive-fork'
+ ;; takes care of shutting it down before forking, and we
+ ;; must do the same here. Failing to do that, if the
+ ;; child process calls 'primitive-fork', it will hang
+ ;; while trying to pthread_join the finalization thread
+ ;; since that thread does not exist.
+ (without-automatic-finalization
+ (proc syscall-id flags
+ %null-pointer ;child stack
+ %null-pointer %null-pointer ;ptid & ctid
+ %null-pointer)))) ;unused
(if (= ret -1)
(throw 'system-error "clone" "~d: ~A"
(list flags (strerror err))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index e8f3d800a8..067b1227e0 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -43,20 +43,19 @@
;; Type of a compression tool.
(define-record-type <compressor>
- (compressor name package extension tar-option)
+ (compressor name package extension command)
compressor?
(name compressor-name) ;string (e.g., "gzip")
(package compressor-package) ;package
(extension compressor-extension) ;string (e.g., "lz")
- (tar-option compressor-tar-option)) ;string (e.g., "--lzip")
+ (command compressor-command)) ;list (e.g., '("gzip" "-9n"))
(define %compressors
;; Available compression tools.
- ;; FIXME: Use '--no-name' for gzip.
- (list (compressor "gzip" gzip "gz" "--gzip")
- (compressor "lzip" lzip "lz" "--lzip")
- (compressor "xz" xz "xz" "--xz")
- (compressor "bzip2" bzip2 "bz2" "--bzip2")))
+ (list (compressor "gzip" gzip "gz" '("gzip" "-9n"))
+ (compressor "lzip" lzip "lz" '("lzip" "-9"))
+ (compressor "xz" xz "xz" '("xz" "-e"))
+ (compressor "bzip2" bzip2 "bz2" '("bzip2" "-9"))))
(define (lookup-compressor name)
"Return the compressor object called NAME. Error out if it could not be
@@ -69,23 +68,57 @@ found."
(define* (self-contained-tarball name profile
#:key deduplicate?
- (compressor (first %compressors)))
+ (compressor (first %compressors))
+ localstatedir?
+ (symlinks '())
+ (tar tar))
"Return a self-contained tarball containing a store initialized with the
-closure of PROFILE, a derivation. The tarball contains /gnu/store, /var/guix,
-and PROFILE is available as /root/.guix-profile."
+closure of PROFILE, a derivation. The tarball contains /gnu/store; if
+LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db
+with a properly initialized store database.
+
+SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
+added to the pack."
(define build
(with-imported-modules '((guix build utils)
(guix build store-copy)
(gnu build install))
#~(begin
(use-modules (guix build utils)
- (gnu build install))
+ (gnu build install)
+ (srfi srfi-1)
+ (srfi srfi-26)
+ (ice-9 match))
(define %root "root")
+ (define symlink->directives
+ ;; Return "populate directives" to make the given symlink and its
+ ;; parent directories.
+ (match-lambda
+ ((source '-> target)
+ (let ((target (string-append #$profile "/" target)))
+ `((directory ,(dirname source))
+ (,source -> ,target))))))
+
+ (define directives
+ ;; Fully-qualified symlinks.
+ (append-map symlink->directives '#$symlinks))
+
+ ;; The --sort option was added to GNU tar in version 1.28, released
+ ;; 2014-07-28. For testing, we use the bootstrap tar, which is
+ ;; older and doesn't support it.
+ (define tar-supports-sort?
+ (zero? (system* (string-append #+tar "/bin/tar")
+ "cf" "/dev/null" "--files-from=/dev/null"
+ "--sort=name")))
+
;; We need Guix here for 'guix-register'.
(setenv "PATH"
- (string-append #$guix "/sbin:" #$tar "/bin:"
+ (string-append #$(if localstatedir?
+ (file-append guix "/sbin:")
+ "")
+ #$tar "/bin:"
#$(compressor-package compressor) "/bin"))
;; Note: there is not much to gain here with deduplication and
@@ -94,33 +127,50 @@ and PROFILE is available as /root/.guix-profile."
(populate-single-profile-directory %root
#:profile #$profile
#:closure "profile"
- #:deduplicate? #f)
+ #:deduplicate? #f
+ #:register? #$localstatedir?)
+
+ ;; Create SYMLINKS.
+ (for-each (cut evaluate-populate-directive <> %root)
+ directives)
;; Create the tarball. Use GNU format so there's no file name
;; length limitation.
(with-directory-excursion %root
- (zero? (system* "tar" #$(compressor-tar-option compressor)
- "--format=gnu"
-
- ;; Avoid non-determinism in the archive. Use
- ;; mtime = 1, not zero, because that is what the
- ;; daemon does for files in the store (see the
- ;; 'mtimeStore' constant in local-store.cc.)
- "--sort=name"
- "--mtime=@1" ;for files in /var/guix
- "--owner=root:0"
- "--group=root:0"
-
- "--check-links"
- "-cvf" #$output
- ;; Avoid adding / and /var to the tarball, so
- ;; that the ownership and permissions of those
- ;; directories will not be overwritten when
- ;; extracting the archive. Do not include /root
- ;; because the root account might have a
- ;; different home directory.
- "./var/guix"
- (string-append "." (%store-directory))))))))
+ (exit
+ (zero? (apply system* "tar"
+ "-I" #$(string-join (compressor-command compressor))
+ "--format=gnu"
+
+ ;; Avoid non-determinism in the archive. Use
+ ;; mtime = 1, not zero, because that is what the
+ ;; daemon does for files in the store (see the
+ ;; 'mtimeStore' constant in local-store.cc.)
+ (if tar-supports-sort? "--sort=name" "--mtime=@1")
+ "--mtime=@1" ;for files in /var/guix
+ "--owner=root:0"
+ "--group=root:0"
+
+ "--check-links"
+ "-cvf" #$output
+ ;; Avoid adding / and /var to the tarball, so
+ ;; that the ownership and permissions of those
+ ;; directories will not be overwritten when
+ ;; extracting the archive. Do not include /root
+ ;; because the root account might have a
+ ;; different home directory.
+ #$@(if localstatedir?
+ '("./var/guix")
+ '())
+
+ (string-append "." (%store-directory))
+
+ (delete-duplicates
+ (filter-map (match-lambda
+ (('directory directory)
+ (string-append "." directory))
+ (_ #f))
+ directives)))))))))
(gexp->derivation (string-append name ".tar."
(compressor-extension compressor))
@@ -140,6 +190,7 @@ and PROFILE is available as /root/.guix-profile."
(graft? . #t)
(max-silent-time . 3600)
(verbosity . 0)
+ (symlinks . ())
(compressor . ,(first %compressors))))
(define %options
@@ -163,6 +214,22 @@ and PROFILE is available as /root/.guix-profile."
(lambda (opt name arg result)
(alist-cons 'compressor (lookup-compressor arg)
result)))
+ (option '(#\S "symlink") #t #f
+ (lambda (opt name arg result)
+ (match (string-tokenize arg
+ (char-set-complement
+ (char-set #\=)))
+ ((source target)
+ (let ((symlinks (assoc-ref result 'symlinks)))
+ (alist-cons 'symlinks
+ `((,source -> ,target) ,@symlinks)
+ (alist-delete 'symlinks result eq?))))
+ (x
+ (leave (_ "~a: invalid symlink specification~%")
+ arg)))))
+ (option '("localstatedir") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'localstatedir? #t result)))
(append %transformation-options
%standard-build-options)))
@@ -178,6 +245,10 @@ Create a bundle of PACKAGE.\n"))
-s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
(display (_ "
-C, --compression=TOOL compress using TOOL--e.g., \"lzip\""))
+ (display (_ "
+ -S, --symlink=SPEC create symlinks to the profile according to SPEC"))
+ (display (_ "
+ --localstatedir include /var/guix in the resulting pack"))
(newline)
(display (_ "
-h, --help display this help and exit"))
@@ -209,14 +280,20 @@ Create a bundle of PACKAGE.\n"))
(specification->package+output spec))
list))
specs))
- (compressor (assoc-ref opts 'compressor)))
+ (compressor (assoc-ref opts 'compressor))
+ (symlinks (assoc-ref opts 'symlinks))
+ (localstatedir? (assoc-ref opts 'localstatedir?)))
(with-store store
(run-with-store store
(mlet* %store-monad ((profile (profile-derivation
(packages->manifest packages)))
(drv (self-contained-tarball "pack" profile
#:compressor
- compressor)))
+ compressor
+ #:symlinks
+ symlinks
+ #:localstatedir?
+ localstatedir?)))
(mbegin %store-monad
(show-what-to-build* (list drv)
#:use-substitutes?
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 2334c4c0a6..a47a52be3f 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -131,7 +131,7 @@ correspond to the same version."
"Return an updater among UPDATERS that matches PACKAGE, or #f if none of
them matches."
(any (match-lambda
- (($ <upstream-updater> _ _ pred latest)
+ (($ <upstream-updater> name description pred latest)
(and (pred package) latest)))
updaters))
diff --git a/guix/zlib.scm b/guix/zlib.scm
index 74420129f6..3d830ef84e 100644
--- a/guix/zlib.scm
+++ b/guix/zlib.scm
@@ -149,21 +149,6 @@ the number of uncompressed bytes written, a strictly positive integer."
;; Z_DEFAULT_COMPRESSION.
-1)
-(define (close-procedure gzfile port)
- "Return a procedure that closes GZFILE, ensuring its underlying PORT is
-closed even if closing GZFILE triggers an exception."
- (lambda ()
- (catch 'zlib-error
- (lambda ()
- ;; 'gzclose' closes the underlying file descriptor. 'close-port'
- ;; calls close(2), gets EBADF, which is ignores.
- (gzclose gzfile)
- (close-port port))
- (lambda args
- ;; Make sure PORT is closed despite the zlib error.
- (close-port port)
- (apply throw args)))))
-
(define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size))
"Return an input port that decompresses data read from PORT, a file port.
PORT is automatically closed when the resulting port is closed. BUFFER-SIZE
@@ -173,7 +158,11 @@ buffered input, which would be lost (and is lost anyway)."
(define gzfile
(match (drain-input port)
("" ;PORT's buffer is empty
- (gzdopen (fileno port) "r"))
+ ;; Since 'gzclose' will eventually close the file descriptor beneath
+ ;; PORT, we increase PORT's revealed count and never call 'close-port'
+ ;; on PORT since we would get EBADF if 'gzclose' already closed it (on
+ ;; 2.0 EBADF is swallowed by 'fport_close' but on 2.2 it is raised).
+ (gzdopen (port->fdes port) "r"))
(_
;; This is unrecoverable but it's better than having the buffered input
;; be lost, leading to unclear end-of-file or corrupt-data errors down
@@ -188,7 +177,8 @@ buffered input, which would be lost (and is lost anyway)."
(gzbuffer! gzfile buffer-size))
(make-custom-binary-input-port "gzip-input" read! #f #f
- (close-procedure gzfile port)))
+ (lambda ()
+ (gzclose gzfile))))
(define* (make-gzip-output-port port
#:key
@@ -200,7 +190,7 @@ port is closed."
(define gzfile
(begin
(force-output port) ;empty PORT's buffer
- (gzdopen (fileno port)
+ (gzdopen (port->fdes port)
(string-append "w" (number->string level)))))
(define (write! bv start count)
@@ -210,7 +200,8 @@ port is closed."
(gzbuffer! gzfile buffer-size))
(make-custom-binary-output-port "gzip-output" write! #f #f
- (close-procedure gzfile port)))
+ (lambda ()
+ (gzclose gzfile))))
(define* (call-with-gzip-input-port port proc
#:key (buffer-size %default-buffer-size))