diff options
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 270 |
1 files changed, 192 insertions, 78 deletions
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 85c2c74520..c21c50fe9f 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -28,7 +28,7 @@ #:use-module (guix base64) #:use-module (guix pk-crypto) #:use-module (guix pki) - #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) #:select (progress-proc uri-abbreviation)) #:use-module (ice-9 rdelim) @@ -48,6 +48,8 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (web uri) + #:use-module (web request) + #:use-module (web response) #:use-module (guix http-client) #:export (narinfo-signature->canonical-sexp read-narinfo @@ -218,7 +220,7 @@ failure." gonna have to wait." (delay (begin (format (current-error-port) - (_ "updating list of substitutes from '~a'...~%") + (_ "updating list of substitutes from '~a'...\r") url) (open-cache url)))) @@ -380,40 +382,56 @@ or is signed by an unauthorized key." the cache STR originates form." (call-with-input-string str (cut read-narinfo <> cache-uri))) -(define (fetch-narinfo cache path) - "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH." - (define (download url) - ;; Download the .narinfo from URL, and return its contents as a list of - ;; key/value pairs. Don't emit an error message upon 404. - (false-if-exception (fetch (string->uri url) - #:quiet-404? #t))) - - (and (string=? (cache-store-directory cache) (%store-prefix)) - (and=> (download (string-append (cache-url cache) "/" - (store-path-hash-part path) - ".narinfo")) - (cute read-narinfo <> (cache-url cache))))) - (define (obsolete? date now ttl) "Return #t if DATE is obsolete compared to NOW + TTL seconds." (time>? (subtract-duration now (make-time time-duration 0 ttl)) (make-time time-monotonic 0 date))) -(define %lookup-threads - ;; Number of threads spawned to perform lookup operations. This means we - ;; can have this many simultaneous HTTP GET requests to the server, which - ;; limits the impact of connection latency. - 20) -(define (lookup-narinfo cache path) - "Check locally if we have valid info about PATH, otherwise go to CACHE and -check what it has." +(define (narinfo-cache-file path) + "Return the name of the local file that contains an entry for PATH." + (string-append %narinfo-cache-directory "/" + (store-path-hash-part path))) + +(define (cached-narinfo path) + "Check locally if we have valid info about PATH. Return two values: a +Boolean indicating whether we have valid cached info, and that info, which may +be either #f (when PATH is unavailable) or the narinfo for PATH." (define now (current-time time-monotonic)) (define cache-file - (string-append %narinfo-cache-directory "/" - (store-path-hash-part path))) + (narinfo-cache-file path)) + + (catch 'system-error + (lambda () + (call-with-input-file cache-file + (lambda (p) + (match (read p) + (('narinfo ('version 1) + ('cache-uri cache-uri) + ('date date) ('value #f)) + ;; A cached negative lookup. + (if (obsolete? date now %narinfo-negative-ttl) + (values #f #f) + (values #t #f))) + (('narinfo ('version 1) + ('cache-uri cache-uri) + ('date date) ('value value)) + ;; A cached positive lookup + (if (obsolete? date now %narinfo-ttl) + (values #f #f) + (values #t (string->narinfo value cache-uri)))) + (('narinfo ('version v) _ ...) + (values #f #f)))))) + (lambda _ + (values #f #f)))) + +(define (cache-narinfo! cache path narinfo) + "Cache locally NARNIFO for PATH, which originates from CACHE. NARINFO may +be #f, in which case it indicates that PATH is unavailable at CACHE." + (define now + (current-time time-monotonic)) (define (cache-entry cache-uri narinfo) `(narinfo (version 1) @@ -421,43 +439,153 @@ check what it has." (date ,(time-second now)) (value ,(and=> narinfo narinfo->string)))) - (let*-values (((valid? cached) - (catch 'system-error - (lambda () - (call-with-input-file cache-file - (lambda (p) - (match (read p) - (('narinfo ('version 1) - ('cache-uri cache-uri) - ('date date) ('value #f)) - ;; A cached negative lookup. - (if (obsolete? date now %narinfo-negative-ttl) - (values #f #f) - (values #t #f))) - (('narinfo ('version 1) - ('cache-uri cache-uri) - ('date date) ('value value)) - ;; A cached positive lookup - (if (obsolete? date now %narinfo-ttl) - (values #f #f) - (values #t (string->narinfo value - cache-uri)))) - (('narinfo ('version v) _ ...) - (values #f #f)))))) - (lambda _ - (values #f #f))))) - (if valid? - cached ; including negative caches + (with-atomic-file-output (narinfo-cache-file path) + (lambda (out) + (write (cache-entry (cache-url cache) narinfo) out))) + narinfo) + +(define (narinfo-request cache-url path) + "Return an HTTP request for the narinfo of PATH at CACHE-URL." + (let ((url (string-append cache-url "/" (store-path-hash-part path) + ".narinfo"))) + (build-request (string->uri url) #:method 'GET))) + +(define (http-multiple-get base-url requests proc) + "Send all of REQUESTS to the server at BASE-URL. Call PROC for each +response, passing it the request object, the response, and a port from which +to read the response body. Return the list of results." + (let connect ((requests requests) + (result '())) + ;; (format (current-error-port) "connecting (~a requests left)..." + ;; (length requests)) + (let ((p (open-socket-for-uri base-url))) + ;; Send all of REQUESTS in a row. + (setvbuf p _IOFBF (expt 2 16)) + (for-each (cut write-request <> p) requests) + (force-output p) + + ;; Now start processing responses. + (let loop ((requests requests) + (result result)) + (match requests + (() + (reverse result)) + ((head tail ...) + (let* ((resp (read-response p)) + (body (response-body-port resp))) + ;; The server can choose to stop responding at any time, in which + ;; case we have to try again. Check whether that is the case. + (match (assq 'connection (response-headers resp)) + (('connection 'close) + (connect requests result)) ;try again + (_ + (loop tail ;keep going + (cons (proc head resp body) result))))))))))) + +(define (read-to-eof port) + "Read from PORT until EOF is reached. The data are discarded." + (dump-port port (%make-void-port "w"))) + +(define (narinfo-from-file file url) + "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f +if file doesn't exist, and the narinfo otherwise." + (catch 'system-error + (lambda () + (call-with-input-file file + (cut read-narinfo <> url))) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + +(define (fetch-narinfos cache paths) + "Retrieve all the narinfos for PATHS from CACHE and return them." + (define url + (cache-url cache)) + + (define update-progress! + (let ((done 0)) + (lambda () + (display #\cr (current-error-port)) + (force-output (current-error-port)) + (format (current-error-port) + (_ "updating list of substitutes from '~a'... ~5,1f%") + url (* 100. (/ done (length paths)))) + (set! done (+ 1 done))))) + + (define (handle-narinfo-response request response port) + (let ((len (response-content-length response))) + ;; Make sure to read no more than LEN bytes since subsequent bytes may + ;; belong to the next response. + (case (response-code response) + ((200) ; hit + (let ((narinfo (read-narinfo port url #:size len))) + (cache-narinfo! cache (narinfo-path narinfo) narinfo) + (update-progress!) + narinfo)) + ((404) ; failure + (let* ((path (uri-path (request-uri request))) + (hash-part (string-drop-right path 8))) ; drop ".narinfo" + (if len + (get-bytevector-n port len) + (read-to-eof port)) + (cache-narinfo! cache + (find (cut string-contains <> hash-part) paths) + #f) + (update-progress!)) + #f) + (else ; transient failure + (if len + (get-bytevector-n port len) + (read-to-eof port)) + #f)))) + + (and (string=? (cache-store-directory cache) (%store-prefix)) + (let ((uri (string->uri url))) + (case (and=> uri uri-scheme) + ((http) + (let ((requests (map (cut narinfo-request url <>) paths))) + (update-progress!) + (let ((result (http-multiple-get url requests + handle-narinfo-response))) + (newline (current-error-port)) + result))) + ((file #f) + (let* ((base (string-append (uri-path uri) "/")) + (files (map (compose (cut string-append base <> ".narinfo") + store-path-hash-part) + paths))) + (filter-map (cut narinfo-from-file <> url) files))) + (else + (leave (_ "~s: unsupported server URI scheme~%") + (if uri (uri-scheme uri) url))))))) + +(define (lookup-narinfos cache paths) + "Return the narinfos for PATHS, invoking the server at CACHE when no +information is available locally." + (let-values (((cached missing) + (fold2 (lambda (path cached missing) + (let-values (((valid? value) + (cached-narinfo path))) + (if valid? + (values (cons value cached) missing) + (values cached (cons path missing))))) + '() + '() + paths))) + (if (null? missing) + cached (let* ((cache (force cache)) - (narinfo (and cache (fetch-narinfo cache path)))) - ;; Cache NARINFO only when CACHE was actually accessible. This - ;; avoids caching negative hits when in fact we just lacked network - ;; access. - (when cache - (with-atomic-file-output cache-file - (lambda (out) - (write (cache-entry (cache-url cache) narinfo) out)))) - narinfo)))) + (missing (if cache + (fetch-narinfos cache missing) + '()))) + (append cached missing))))) + +(define (lookup-narinfo cache path) + "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was +found." + (match (lookup-narinfos cache (list path)) + ((answer) answer))) (define (remove-expired-cached-narinfos) "Remove expired narinfo entries from the cache. The sole purpose of this @@ -580,16 +708,6 @@ Internal tool to substitute a pre-built binary to a local build.\n")) ;;; Entry point. ;;; -(define n-par-map* - ;; We want the ability to run many threads in parallel, regardless of the - ;; number of cores. However, Guile 2.0.5 has a bug whereby 'n-par-map' ends - ;; up consuming a lot of memory, possibly leading to death. Thus, resort to - ;; 'par-map' on 2.0.5. - (if (guile-version>? "2.0.5") - n-par-map - (lambda (n proc lst) - (par-map proc lst)))) - (define (check-acl-initialized) "Warn if the ACL is uninitialized." (define (singleton? acl) @@ -698,9 +816,7 @@ substituter disabled~%") ;; Return the subset of PATHS available in CACHE. (let ((substitutable (if cache - (n-par-map* %lookup-threads - (cut lookup-narinfo cache <>) - paths) + (lookup-narinfos cache paths) '()))) (for-each (lambda (narinfo) (format #t "~a~%" (narinfo-path narinfo))) @@ -710,9 +826,7 @@ substituter disabled~%") ;; Reply info about PATHS if it's in CACHE. (let ((substitutable (if cache - (n-par-map* %lookup-threads - (cut lookup-narinfo cache <>) - paths) + (lookup-narinfos cache paths) '()))) (for-each (lambda (narinfo) (format #t "~a\n~a\n~a\n" |