diff options
Diffstat (limited to 'guix/scripts')
-rw-r--r-- | guix/scripts/size.scm | 33 | ||||
-rwxr-xr-x | guix/scripts/substitute.scm | 110 |
2 files changed, 89 insertions, 54 deletions
diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index e999cce1fd..8f0cb7decd 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,7 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix utils) + #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (gnu packages) @@ -274,19 +275,23 @@ Report the size of PACKAGE and its dependencies.\n")) (leave (_ "missing store item argument\n"))) ((file) (leave-on-EPIPE - (with-store store - (set-build-options store - #:use-substitutes? #t - #:substitute-urls urls) + ;; Turn off grafts because (1) hydra.gnu.org does not serve grafted + ;; packages, and (2) they do not make any difference on the + ;; resulting size. + (parameterize ((%graft? #f)) + (with-store store + (set-build-options store + #:use-substitutes? #t + #:substitute-urls urls) - (run-with-store store - (mlet* %store-monad ((item (ensure-store-item file)) - (profile (store-profile item))) - (if map-file - (begin - (profile->page-map profile map-file) - (return #t)) - (display-profile* profile))) - #:system system)))) + (run-with-store store + (mlet* %store-monad ((item (ensure-store-item file)) + (profile (store-profile item))) + (if map-file + (begin + (profile->page-map profile map-file) + (return #t)) + (display-profile* profile))) + #:system system))))) ((files ...) (leave (_ "too many arguments\n"))))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index b057e9b12a..524d453ffa 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -164,10 +164,9 @@ again." (sigaction SIGALRM SIG_DFL) (apply values result))))) -(define* (fetch uri #:key (buffered? #t) (timeout? #t) (quiet-404? #f)) +(define* (fetch uri #:key (buffered? #t) (timeout? #t)) "Return a binary input port to URI and the number of bytes it's expected to -provide. If QUIET-404? is true, HTTP 404 error conditions are passed through -to the caller without emitting an error message." +provide." (case (uri-scheme uri) ((file) (let ((port (open-file (uri-path uri) @@ -175,12 +174,10 @@ to the caller without emitting an error message." (values port (stat:size (stat port))))) ((http https) (guard (c ((http-get-error? c) - (let ((code (http-get-error-code c))) - (if (and (= code 404) quiet-404?) - (raise c) - (leave (_ "download from '~a' failed: ~a, ~s~%") - (uri->string (http-get-error-uri c)) - code (http-get-error-reason c)))))) + (leave (_ "download from '~a' failed: ~a, ~s~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)))) ;; Test this with: ;; sudo tc qdisc add dev eth0 root netem delay 1500ms ;; and then cancel with: @@ -219,19 +216,46 @@ to the caller without emitting an error message." (wants-mass-query? cache-info-wants-mass-query?)) (define (download-cache-info url) - "Download the information for the cache at URL. Return a <cache-info> -object on success, or #f on failure." - (define (download url) - ;; Download the `nix-cache-info' from URL, and return its contents as an - ;; list of key/value pairs. - (and=> (false-if-exception (fetch (string->uri url))) - fields->alist)) - - (and=> (download (string-append url "/nix-cache-info")) - (lambda (properties) - (alist->record properties - (cut %make-cache-info url <...>) - '("StoreDir" "WantMassQuery"))))) + "Download the information for the cache at URL. On success, return a +<cache-info> object and a port on which to send further HTTP requests. On +failure, return #f and #f." + (define uri + (string->uri (string-append url "/nix-cache-info"))) + + (define (read-cache-info port) + (alist->record (fields->alist port) + (cut %make-cache-info url <...>) + '("StoreDir" "WantMassQuery"))) + + (catch #t + (lambda () + (case (uri-scheme uri) + ((file) + (values (call-with-input-file (uri-path uri) + read-cache-info) + #f)) + ((http https) + (let ((port (open-connection-for-uri uri + #:timeout %fetch-timeout))) + (guard (c ((http-get-error? c) + (warning (_ "while fetching '~a': ~a (~s)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + (close-port port) + (warning (_ "ignoring substitute server at '~s'~%") url) + (values #f #f))) + (values (read-cache-info (http-fetch uri + #:port port + #:keep-alive? #t)) + port)))))) + (lambda (key . args) + (case key + ((getaddrinfo-error system-error) + ;; Silently ignore the error: probably due to lack of network access. + (values #f #f)) + (else + (apply throw key args)))))) (define-record-type <narinfo> @@ -480,16 +504,19 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." ".narinfo"))) (build-request (string->uri url) #:method 'GET))) -(define (http-multiple-get base-uri proc seed requests) +(define* (http-multiple-get base-uri proc seed requests + #:key port) "Send all of REQUESTS to the server at BASE-URI. Call PROC for each response, passing it the request object, the response, a port from which to read the response body, and the previous result, starting with SEED, à la -'fold'. Return the final result." - (let connect ((requests requests) +'fold'. Return the final result. When PORT is specified, use it as the +initial connection on which HTTP requests are sent." + (let connect ((port port) + (requests requests) (result seed)) ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) - (let ((p (open-connection-for-uri base-uri))) + (let ((p (or port (open-connection-for-uri base-uri)))) ;; For HTTPS, P is not a file port and does not support 'setvbuf'. (when (file-port? p) (setvbuf p _IOFBF (expt 2 16))) @@ -523,7 +550,7 @@ read the response body, and the previous result, starting with SEED, à la (match (assq 'connection (response-headers resp)) (('connection 'close) (close-port p) - (connect tail result)) ;try again + (connect #f tail result)) ;try again (_ (loop tail result)))))))))) ;keep going @@ -582,14 +609,17 @@ if file doesn't exist, and the narinfo otherwise." (read-to-eof port)) result)))) - (define (do-fetch uri) + (define (do-fetch uri port) (case (and=> uri uri-scheme) ((http https) (let ((requests (map (cut narinfo-request url <>) paths))) (update-progress!) (let ((result (http-multiple-get uri handle-narinfo-response '() - requests))) + requests + #:port port))) + (unless (port-closed? port) + (close-port port)) (newline (current-error-port)) result))) ((file #f) @@ -602,17 +632,17 @@ if file doesn't exist, and the narinfo otherwise." (leave (_ "~s: unsupported server URI scheme~%") (if uri (uri-scheme uri) url))))) - (define cache-info - (download-cache-info url)) - - (and cache-info - (if (string=? (cache-info-store-directory cache-info) - (%store-prefix)) - (do-fetch (string->uri url)) - (begin - (warning (_ "'~a' uses different store '~a'; ignoring it~%") - url (cache-info-store-directory cache-info)) - #f)))) + (let-values (((cache-info port) + (download-cache-info url))) + (and cache-info + (if (string=? (cache-info-store-directory cache-info) + (%store-prefix)) + (do-fetch (string->uri url) port) ;reuse PORT + (begin + (warning (_ "'~a' uses different store '~a'; ignoring it~%") + url (cache-info-store-directory cache-info)) + (close-port port) + #f))))) (define (lookup-narinfos cache paths) "Return the narinfos for PATHS, invoking the server at CACHE when no |