Merge branch 'master' into core-updates

4 files changed, 107 insertions, 55 deletions

diff --git a/guix/build/download.scm b/guix/build/download.scm
index 240e79ee8d..8843804c40 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -20,6 +20,7 @@
 
 (define-module (guix build download)
   #:use-module (web uri)
+  #:use-module (web http)
   #:use-module ((web client) #:hide (open-socket-for-uri))
   #:use-module (web response)
   #:use-module (guix ftp-client)
@@ -277,26 +278,65 @@ host name without trailing dot."
       (add-weak-reference record port)
       record)))
 
-(define (open-socket-for-uri uri)
-  "Return an open port for URI.  This variant works around
-<http://bugs.gnu.org/15368> which affects Guile's 'open-socket-for-uri' up to
-2.0.11 included."
-  (define rmem-max
-    ;; The maximum size for a receive buffer on Linux, see socket(7).
-    "/proc/sys/net/core/rmem_max")
-
-  (define buffer-size
-    (if (file-exists? rmem-max)
-        (call-with-input-file rmem-max read)
-        126976))                    ;the default for Linux, per 'rmem_default'
-
-  (let ((s ((@ (web client) open-socket-for-uri) uri)))
-    ;; Work around <http://bugs.gnu.org/15368> by restoring a decent
-    ;; buffer size.
-    (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size)
-    s))
-
-(define (open-connection-for-uri uri)
+(define (ensure-uri uri-or-string)                ;XXX: copied from (web http)
+  (cond
+   ((string? uri-or-string) (string->uri uri-or-string))
+   ((uri? uri-or-string) uri-or-string)
+   (else (error "Invalid URI" uri-or-string))))
+
+(define current-http-proxy
+  ;; XXX: Add a dummy definition for Guile < 2.0.10; this is used in
+  ;; 'open-socket-for-uri'.
+  (or (and=> (module-variable (resolve-interface '(web client))
+                              'current-http-proxy)
+             variable-ref)
+      (const #f)))
+
+(define* (open-socket-for-uri uri-or-string #:key timeout)
+  "Return an open input/output port for a connection to URI.  When TIMEOUT is
+not #f, it must be a (possibly inexact) number denoting the maximum duration
+in seconds to wait for the connection to complete; passed TIMEOUT, an
+ETIMEDOUT error is raised."
+  ;; Includes a fix for <http://bugs.gnu.org/15368> which affects Guile's
+  ;; 'open-socket-for-uri' up to 2.0.11 included, uses 'connect*' instead
+  ;; of 'connect', and uses AI_ADDRCONFIG.
+
+  (define http-proxy (current-http-proxy))
+  (define uri (ensure-uri (or http-proxy uri-or-string)))
+  (define addresses
+    (let ((port (uri-port uri)))
+      (delete-duplicates
+       (getaddrinfo (uri-host uri)
+                    (cond (port => number->string)
+                          (else (symbol->string (uri-scheme uri))))
+                    (if (number? port)
+                        (logior AI_ADDRCONFIG AI_NUMERICSERV)
+                        AI_ADDRCONFIG))
+       (lambda (ai1 ai2)
+         (equal? (addrinfo:addr ai1) (addrinfo:addr ai2))))))
+
+  (let loop ((addresses addresses))
+    (let* ((ai (car addresses))
+           (s  (with-fluids ((%default-port-encoding #f))
+                 ;; Restrict ourselves to TCP.
+                 (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP))))
+      (catch 'system-error
+        (lambda ()
+          (connect* s (addrinfo:addr ai) timeout)
+
+          ;; Buffer input and output on this port.
+          (setvbuf s _IOFBF)
+          ;; If we're using a proxy, make a note of that.
+          (when http-proxy (set-http-proxy-port?! s #t))
+          s)
+        (lambda args
+          ;; Connection failed, so try one of the other addresses.
+          (close s)
+          (if (null? (cdr addresses))
+              (apply throw args)
+              (loop (cdr addresses))))))))
+
+(define* (open-connection-for-uri uri #:key timeout)
   "Like 'open-socket-for-uri', but also handle HTTPS connections."
   (define https?
     (eq? 'https (uri-scheme uri)))
@@ -319,7 +359,7 @@ host name without trailing dot."
                            (thunk))
                          (thunk)))))))
     (with-https-proxy
-     (let ((s (open-socket-for-uri uri)))
+     (let ((s (open-socket-for-uri uri #:timeout timeout)))
        ;; Buffer input and output on this port.
        (setvbuf s _IOFBF %http-receive-buffer-size)
 
diff --git a/guix/build/graft.scm b/guix/build/graft.scm
index 55f0f9410d..0a9cd3260c 100644
--- a/guix/build/graft.scm
+++ b/guix/build/graft.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,7 +21,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 threads)
   #:export (replace-store-references
             rewrite-directory))
 
@@ -93,38 +93,32 @@ file name pairs."
   (define (destination file)
     (string-append output (string-drop file prefix-len)))
 
-  (define (rewrite-leaf file stat result)
-    (case (stat:type stat)
-      ((symlink)
-       (let ((target (readlink file)))
-         (symlink (call-with-output-string
-                   (lambda (output)
-                     (replace-store-references (open-input-string target)
-                                               output mapping
-                                               store)))
-                  (destination file))))
-      ((regular)
-       (with-fluids ((%default-port-encoding #f))
-         (call-with-input-file file
-           (lambda (input)
-             (call-with-output-file (destination file)
-               (lambda (output)
-                 (replace-store-references input output mapping
-                                           store)
-                 (chmod output (stat:perms stat))))))))
-      (else
-       (error "unsupported file type" stat))))
+  (define (rewrite-leaf file)
+    (let ((stat (lstat file))
+          (dest (destination file)))
+      (mkdir-p (dirname dest))
+      (case (stat:type stat)
+        ((symlink)
+         (let ((target (readlink file)))
+           (symlink (call-with-output-string
+                      (lambda (output)
+                        (replace-store-references (open-input-string target)
+                                                  output mapping
+                                                  store)))
+                    dest)))
+        ((regular)
+         (with-fluids ((%default-port-encoding #f))
+           (call-with-input-file file
+             (lambda (input)
+               (call-with-output-file dest
+                 (lambda (output)
+                   (replace-store-references input output mapping
+                                             store)
+                   (chmod output (stat:perms stat))))))))
+        (else
+         (error "unsupported file type" stat)))))
 
-  (file-system-fold (const #t)
-                    rewrite-leaf
-                    (lambda (directory stat result) ;down
-                      (mkdir (destination directory)))
-                    (const #t)                      ;up
-                    (const #f)                      ;skip
-                    (lambda (file stat errno result) ;error
-                      (error "read error" file stat errno))
-                    #f
-                    directory
-                    lstat))
+  (n-par-for-each (parallel-job-count)
+                  rewrite-leaf (find-files directory)))
 
 ;;; graft.scm ends here
diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm
index 34e5247e07..8e2aee381d 100644
--- a/guix/build/haskell-build-system.scm
+++ b/guix/build/haskell-build-system.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -102,7 +103,17 @@ and parameters ~s~%"
     ;; Cabal errors if GHC_PACKAGE_PATH is set during 'configure', so unset
     ;; and restore it.
     (unsetenv "GHC_PACKAGE_PATH")
+
+    ;; For packages where the Cabal build-type is set to "Configure",
+    ;; ./configure will be executed.  In these cases, the following
+    ;; environment variable is needed to be able to find the shell executable.
+    ;; For other package types, the configure script isn't present.  For more
+    ;; information, see the Build Information section of
+    ;; <https://www.haskell.org/cabal/users-guide/developing-packages.html>.
+    (when (file-exists? "configure")
+      (setenv "CONFIG_SHELL" "sh"))
     (run-setuphs "configure" params)
+
     (setenv "GHC_PACKAGE_PATH" ghc-path)))
 
 (define* (build #:rest empty)
diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm
index 1ae42c00b4..8025b7fec6 100644
--- a/guix/build/python-build-system.scm
+++ b/guix/build/python-build-system.scm
@@ -136,11 +136,18 @@ installed with setuptools."
                #t))
     #t))
 
+(define* (set-SOURCE-DATE-EPOCH #:rest _)
+  "Set the 'SOURCE_DATE_EPOCH' environment variable."
+  ;; Use zero as the timestamp in .pyc files so that builds are deterministic.
+  ;; TODO: Remove it when this variable is set in GNU:%STANDARD-PHASES.
+  (setenv "SOURCE_DATE_EPOCH" "1"))
+
 (define %standard-phases
   ;; 'configure' and 'build' phases are not needed.  Everything is done during
   ;; 'install'.
   (modify-phases gnu:%standard-phases
     (add-after 'unpack 'ensure-no-mtimes-pre-1980 ensure-no-mtimes-pre-1980)
+    (add-after 'unpack 'set-SOURCE-DATE-EPOCH set-SOURCE-DATE-EPOCH)
     (delete 'configure)
     (replace 'install install)
     (replace 'check check)