diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/download.scm | 7 | ||||
| -rw-r--r-- | guix/derivations.scm | 5 | ||||
| -rw-r--r-- | guix/download.scm | 3 | ||||
| -rw-r--r-- | guix/hash.scm | 131 | ||||
| -rw-r--r-- | guix/scripts/download.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/hash.scm | 21 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 3 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 38 | ||||
| -rw-r--r-- | guix/store.scm | 11 | ||||
| -rw-r--r-- | guix/ui.scm | 15 | ||||
| -rw-r--r-- | guix/utils.scm | 18 | ||||
| -rw-r--r-- | guix/web.scm | 112 |
12 files changed, 260 insertions, 107 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index dcce0bfc89..ac2086d96e 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -65,8 +65,11 @@ abbreviation of URI showing the scheme, host, and basename of the file." (define (elide-path) (let ((path (uri-path uri))) - (string-append (symbol->string (uri-scheme uri)) - "://" (uri-host uri) + (string-append (symbol->string (uri-scheme uri)) "://" + + ;; `file' URIs have no host part. + (or (uri-host uri) "") + (string-append "/.../" (basename path))))) (if (> (string-length uri-as-string) max-length) diff --git a/guix/derivations.scm b/guix/derivations.scm index 3c433a2685..8ddef117d4 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -26,6 +26,7 @@ #:use-module (ice-9 rdelim) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix hash) #:use-module (guix base32) #:export (<derivation> derivation? @@ -468,6 +469,10 @@ in SIZE bytes." inputs)) (drv (make-derivation outputs inputs sources system builder args env-vars))) + + ;; XXX: At this point this remains faster than `port-sha256', because + ;; the SHA256 port's `write' method gets called for every single + ;; character. (sha256 (with-fluids ((%default-port-encoding "UTF-8")) (string->utf8 (call-with-output-string diff --git a/guix/download.scm b/guix/download.scm index fc6c815792..b12659f683 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -84,7 +84,8 @@ "http://mirror.csclub.uwaterloo.ca/nongnu/" "http://nongnu.askapache.com/" "http://savannah.c3sl.ufpr.br/" - "http://www.centervenus.com/mirrors/nongnu/") + "http://www.centervenus.com/mirrors/nongnu/" + "http://download.savannah.gnu.org/releases-noredirect/") (sourceforge "http://prdownloads.sourceforge.net/" "http://heanet.dl.sourceforge.net/sourceforge/" diff --git a/guix/hash.scm b/guix/hash.scm new file mode 100644 index 0000000000..92ecaf78d5 --- /dev/null +++ b/guix/hash.scm @@ -0,0 +1,131 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix hash) + #:use-module (guix config) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (system foreign) + #:use-module ((guix build utils) #:select (dump-port)) + #:use-module (srfi srfi-11) + #:export (sha256 + open-sha256-port + port-sha256)) + +;;; Commentary: +;;; +;;; Cryptographic hashes. +;;; +;;; Code: + + +;;; +;;; Hash. +;;; + +(define-syntax GCRY_MD_SHA256 + ;; Value as of Libgcrypt 1.5.2. + (identifier-syntax 8)) + +(define sha256 + (let ((hash (pointer->procedure void + (dynamic-func "gcry_md_hash_buffer" + (dynamic-link %libgcrypt)) + `(,int * * ,size_t)))) + (lambda (bv) + "Return the SHA256 of BV as a bytevector." + (let ((digest (make-bytevector (/ 256 8)))) + (hash GCRY_MD_SHA256 (bytevector->pointer digest) + (bytevector->pointer bv) (bytevector-length bv)) + digest)))) + +(define open-sha256-md + (let ((open (pointer->procedure int + (dynamic-func "gcry_md_open" + (dynamic-link %libgcrypt)) + `(* ,int ,unsigned-int)))) + (lambda () + (let* ((md (bytevector->pointer (make-bytevector (sizeof '*)))) + (err (open md GCRY_MD_SHA256 0))) + (if (zero? err) + (dereference-pointer md) + (throw 'gcrypt-error err)))))) + +(define md-write + (pointer->procedure void + (dynamic-func "gcry_md_write" + (dynamic-link %libgcrypt)) + `(* * ,size_t))) + +(define md-read + (pointer->procedure '* + (dynamic-func "gcry_md_read" + (dynamic-link %libgcrypt)) + `(* ,int))) + +(define md-close + (pointer->procedure void + (dynamic-func "gcry_md_close" + (dynamic-link %libgcrypt)) + '(*))) + + +(define (open-sha256-port) + "Return two values: an output port, and a thunk. When the thunk is called, +it returns the SHA256 hash (a bytevector) of all the data written to the +output port." + (define sha256-md + (open-sha256-md)) + + (define digest #f) + + (define (finalize!) + (let ((ptr (md-read sha256-md 0))) + (set! digest (bytevector-copy (pointer->bytevector ptr 32))) + (md-close sha256-md))) + + (define (write! bv offset len) + (if (zero? len) + (begin + (finalize!) + 0) + (let ((ptr (bytevector->pointer bv offset))) + (md-write sha256-md ptr len) + len))) + + (define (close) + (unless digest + (finalize!))) + + (values (make-custom-binary-output-port "sha256" + write! #f #f + close) + (lambda () + (unless digest + (finalize!)) + digest))) + +(define (port-sha256 port) + "Return the SHA256 hash (a bytevector) of all the data drained from PORT." + (let-values (((out get) + (open-sha256-port))) + (dump-port port out) + (close-port out) + (get))) + +;;; hash.scm ends here diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index da5fa5be9e..87b420405c 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -19,6 +19,7 @@ (define-module (guix scripts download) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix hash) #:use-module (guix utils) #:use-module (guix base32) #:use-module (guix download) @@ -115,7 +116,7 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (or path (leave (_ "~a: download failed~%") arg)) - (compose sha256 get-bytevector-all))) + port-sha256)) (fmt (assq-ref opts 'format))) (format #t "~a~%~a~%" path (fmt hash)) #t))) diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index 1b14aaadd0..ca3928b8e3 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -18,16 +18,17 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts hash) - #:use-module (guix base32) - #:use-module (guix ui) - #:use-module (guix utils) - #:use-module (rnrs io ports) - #:use-module (rnrs files) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-37) - #:export (guix-hash)) + #:use-module (guix base32) + #:use-module (guix hash) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (rnrs io ports) + #:use-module (rnrs files) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-hash)) ;;; diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index b8d4efd204..c75ec4f091 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -19,6 +19,7 @@ (define-module (guix scripts refresh) #:use-module (guix ui) + #:use-module (guix hash) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) @@ -136,7 +137,7 @@ values: 'interactive' (default), 'always', and 'never'." (package-name package) (package-version package) version) (let ((hash (call-with-input-file tarball - (compose sha256 get-bytevector-all)))) + port-sha256))) (update-package-source package version hash))) (warning (_ "~a: version ~a could not be \ downloaded and authenticated; not updating") diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 271a22541a..24e5d68c4f 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -124,6 +124,9 @@ pairs." ;; Number of seconds after which networking is considered "slow". 3) +(define %random-state + (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid)))) + (define-syntax-rule (with-timeout duration handler body ...) "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY again." @@ -140,11 +143,15 @@ again." (lambda () body ...) (lambda args - ;; The SIGALRM triggers EINTR. When that happens, try again. - ;; Note: SA_RESTART cannot be used because of - ;; <http://bugs.gnu.org/14640>. + ;; The SIGALRM triggers EINTR, because of the bug at + ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>. + ;; When that happens, try again. Note: SA_RESTART cannot be + ;; used because of <http://bugs.gnu.org/14640>. (if (= EINTR (system-error-errno args)) - (try) + (begin + ;; Wait a little to avoid bursts. + (usleep (random 3000000 %random-state)) + (try)) (apply throw args)))))) (lambda result (alarm 0) @@ -168,14 +175,19 @@ provide." ;; sudo tc qdisc add dev eth0 root netem delay 1500ms ;; and then cancel with: ;; sudo tc qdisc del dev eth0 root - (with-timeout (if (or timeout? (version>? (version) "2.0.5")) - %fetch-timeout - 0) - (begin - (warning (_ "while fetching ~a: server is unresponsive~%") - (uri->string uri)) - (warning (_ "try `--no-substitutes' if the problem persists~%"))) - (http-fetch uri #:text? #f #:buffered? buffered?))))) + (let ((port #f)) + (with-timeout (if (or timeout? (version>? (version) "2.0.5")) + %fetch-timeout + 0) + (begin + (warning (_ "while fetching ~a: server is unresponsive~%") + (uri->string uri)) + (warning (_ "try `--no-substitutes' if the problem persists~%")) + (when port + (close-port port))) + (begin + (set! port (open-socket-for-uri uri #:buffered? buffered?)) + (http-fetch uri #:text? #f #:port port))))))) (define-record-type <cache> (%make-cache url store-directory wants-mass-query?) @@ -535,7 +547,7 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by (show-version-and-exit "guix substitute-binary"))))) -;;; Local Variable: +;;; Local Variables: ;;; eval: (put 'with-atomic-file-output 'scheme-indent-function 1) ;;; eval: (put 'with-timeout 'scheme-indent-function 1) ;;; End: diff --git a/guix/store.scm b/guix/store.scm index 57e1ca06aa..343da91506 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -266,8 +266,15 @@ operate, should the disk become full. Return a server object." (socket PF_UNIX SOCK_STREAM 0))) (a (make-socket-address PF_UNIX file))) - ;; Enlarge the receive buffer. - (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024)) + (catch 'system-error + (lambda () + ;; Enlarge the receive buffer. + (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))) + (lambda args + ;; On the Hurd, the pflocal server's implementation of `socket_setopt' + ;; always returns ENOPROTOOPT. Ignore it. + (unless (= (system-error-errno args) ENOPROTOOPT) + (apply throw args)))) (catch 'system-error (cut connect s a) diff --git a/guix/ui.scm b/guix/ui.scm index 370b41b9dc..fd35c6a8c8 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -223,12 +223,15 @@ available for download." drv) (map derivation-input-path build)))) ((download) ; add the references of DOWNLOAD - (delete-duplicates - (append download - (remove (cut valid-path? store <>) - (append-map - substitutable-references - (substitutable-path-info store download))))))) + (if use-substitutes? + (delete-duplicates + (append download + (remove (cut valid-path? store <>) + (append-map + substitutable-references + (substitutable-path-info store + download))))) + download))) (if dry-run? (begin (format (current-error-port) diff --git a/guix/utils.scm b/guix/utils.scm index 2478fb6939..4187efde41 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -36,7 +36,6 @@ #:autoload (system foreign) (pointer->procedure) #:export (bytevector->base16-string base16-string->bytevector - sha256 %nixpkgs-directory nixpkgs-derivation @@ -138,23 +137,6 @@ evaluate to a simple datum." s) bv))) - -;;; -;;; Hash. -;;; - -(define sha256 - (let ((hash (pointer->procedure void - (dynamic-func "gcry_md_hash_buffer" - (dynamic-link %libgcrypt)) - `(,int * * ,size_t))) - (sha256 8)) ; GCRY_MD_SHA256, as of 1.5.0 - (lambda (bv) - "Return the SHA256 of BV as a bytevector." - (let ((digest (make-bytevector (/ 256 8)))) - (hash sha256 (bytevector->pointer digest) - (bytevector->pointer bv) (bytevector-length bv)) - digest)))) ;;; diff --git a/guix/web.scm b/guix/web.scm index d24f15853d..321c38391d 100644 --- a/guix/web.scm +++ b/guix/web.scm @@ -27,7 +27,8 @@ #:use-module (rnrs bytevectors) #:use-module (guix ui) #:use-module (guix utils) - #:export (http-fetch)) + #:export (open-socket-for-uri + http-fetch)) ;;; Commentary: ;;; @@ -141,62 +142,67 @@ closed it will also close PORT, unless the KEEP-ALIVE? is true." (module-define! (resolve-module '(web client)) 'shutdown (const #f)) -(define* (http-fetch uri #:key (text? #f) (buffered? #t)) +(define* (open-socket-for-uri uri #:key (buffered? #t)) + "Return an open port for URI. When BUFFERED? is false, the returned port is +unbuffered." + (let ((s ((@ (web client) open-socket-for-uri) uri))) + (unless buffered? + (setvbuf s _IONBF)) + s)) + +(define* (http-fetch uri #:key port (text? #f) (buffered? #t)) "Return an input port containing the data at URI, and the expected number of bytes available or #f. If TEXT? is true, the data at URI is considered to be textual. Follow any HTTP redirection. When BUFFERED? is #f, return an unbuffered port, suitable for use in `filtered-port'." (let loop ((uri uri)) - (define port - (let ((s (open-socket-for-uri uri))) - (unless buffered? - (setvbuf s _IONBF)) - s)) - - (let*-values (((resp data) - ;; Try hard to use the API du jour to get an input port. - ;; On Guile 2.0.5 and before, we can only get a string or - ;; bytevector, and not an input port. Work around that. - (if (version>? (version) "2.0.7") - (http-get uri #:streaming? #t #:port port) ; 2.0.9+ - (if (defined? 'http-get*) - (http-get* uri #:decode-body? text? - #:port port) ; 2.0.7 - (http-get uri #:decode-body? text? - #:port port)))) ; 2.0.5- - ((code) - (response-code resp))) - (case code - ((200) - (let ((len (response-content-length resp))) - (cond ((not data) - (begin - ;; Guile 2.0.5 and earlier did not support chunked - ;; transfer encoding, which is required for instance when - ;; fetching %PACKAGE-LIST-URL (see - ;; <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>). - ;; Normally the `when-guile<=2.0.5' block above fixes - ;; that, but who knows what could happen. - (warning (_ "using Guile ~a, which does not support ~s encoding~%") - (version) - (response-transfer-encoding resp)) - (leave (_ "download failed; use a newer Guile~%") - uri resp))) - ((string? data) ; `http-get' from 2.0.5- - (values (open-input-string data) len)) - ((bytevector? data) ; likewise - (values (open-bytevector-input-port data) len)) - (else ; input port - (values data len))))) - ((301 ; moved permanently - 302) ; found (redirection) - (let ((uri (response-location resp))) - (close-port port) - (format #t (_ "following redirection to `~a'...~%") - (uri->string uri)) - (loop uri))) - (else - (error "download failed" uri code - (response-reason-phrase resp))))))) + (let ((port (or port + (open-socket-for-uri uri + #:buffered? buffered?)))) + (let*-values (((resp data) + ;; Try hard to use the API du jour to get an input port. + ;; On Guile 2.0.5 and before, we can only get a string or + ;; bytevector, and not an input port. Work around that. + (if (version>? (version) "2.0.7") + (http-get uri #:streaming? #t #:port port) ; 2.0.9+ + (if (defined? 'http-get*) + (http-get* uri #:decode-body? text? + #:port port) ; 2.0.7 + (http-get uri #:decode-body? text? + #:port port)))) ; 2.0.5- + ((code) + (response-code resp))) + (case code + ((200) + (let ((len (response-content-length resp))) + (cond ((not data) + (begin + ;; Guile 2.0.5 and earlier did not support chunked + ;; transfer encoding, which is required for instance when + ;; fetching %PACKAGE-LIST-URL (see + ;; <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>). + ;; Normally the `when-guile<=2.0.5' block above fixes + ;; that, but who knows what could happen. + (warning (_ "using Guile ~a, which does not support ~s encoding~%") + (version) + (response-transfer-encoding resp)) + (leave (_ "download failed; use a newer Guile~%") + uri resp))) + ((string? data) ; `http-get' from 2.0.5- + (values (open-input-string data) len)) + ((bytevector? data) ; likewise + (values (open-bytevector-input-port data) len)) + (else ; input port + (values data len))))) + ((301 ; moved permanently + 302) ; found (redirection) + (let ((uri (response-location resp))) + (close-port port) + (format #t (_ "following redirection to `~a'...~%") + (uri->string uri)) + (loop uri))) + (else + (error "download failed" uri code + (response-reason-phrase resp)))))))) ;;; web.scm ends here |