Merge branch 'master' into core-updates

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))