summaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-12-12 11:42:12 +0100
committerLudovic Courtès <ludo@gnu.org>2015-12-12 11:48:46 +0100
commite82e55e58c67b0215e768c4612ca542bc670f633 (patch)
tree856c4512fa1fbde59c1d9845c5a763ef8c4a14b4 /guix/build
parent98bd851ee891ca4a84e061fe1e78ba78c292b096 (diff)
parente35dff973375266db253747140ddf25084ecddc2 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/build')
-rw-r--r--guix/build/download.scm82
-rw-r--r--guix/build/graft.scm62
-rw-r--r--guix/build/haskell-build-system.scm11
-rw-r--r--guix/build/python-build-system.scm7
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)