ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 23:46:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

substitute: Don't fetch /nix-cache-info.

Browse source 
This avoids one GET request every time 'fetch-narinfos' is called.
The file itself was essentially useless.

* guix/scripts/substitute.scm (<cache-info>, download-cache-info):
Remove.
(%unreachable-hosts): New variable.
(open-connection-for-uri/maybe): New procedure.
(fetch-narinfos)[handle-narinfo-response]: Check whether NARINFO has its
'path' under (%store-prefix) and ignore it otherwise.  Move
'update-progress!' call before 'if'.
[do-fetch]: Remove 'port' parameter.  Use
'open-connection-for-uri/maybe'.
Remove call to 'download-cache-info'.
This commit is contained in:
Ludovic Courtès 2019-11-21 20:36:20 +01:00
parent 4e2e84d856
commit 4f5234be03
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 61 additions and 81 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

142
guix/scripts/substitute.scm
View file

@ -227,58 +227,6 @@ (define* (fetch uri #:key (buffered? #t) (timeout? #t))
(leave (G_ "unsupported substitute URI scheme: ~a~%") (leave (G_ "unsupported substitute URI scheme: ~a~%")
(uri->string uri))))) (uri->string uri)))))
(define-record-type <cache-info>
(%make-cache-info url store-directory wants-mass-query?)
cache-info?
(url cache-info-url)
(store-directory cache-info-store-directory)
(wants-mass-query? cache-info-wants-mass-query?))
(define (download-cache-info url)
"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 (guix:open-connection-for-uri
uri
#:verify-certificate? #f
#:timeout %fetch-timeout)))
(guard (c ((http-get-error? c)
(warning (G_ "while fetching '~a': ~a (~s)~%")
(uri->string (http-get-error-uri c))
(http-get-error-code c)
(http-get-error-reason c))
(close-connection port)
(warning (G_ "ignoring substitute server at '~s'~%") url)
(values #f #f)))
(values (read-cache-info (http-fetch uri
#:verify-certificate? #f
#: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> (define-record-type <narinfo>
(%make-narinfo path uri-base uris compressions file-sizes file-hashes (%make-narinfo path uri-base uris compressions file-sizes file-hashes
@ -628,6 +576,41 @@ (define (narinfo-from-file file url)
#f #f
(apply throw args))))) (apply throw args)))))
(define %unreachable-hosts
;; Set of names of unreachable hosts.
(make-hash-table))
(define* (open-connection-for-uri/maybe uri
#:key
(verify-certificate? #f)
(time %fetch-timeout))
"Open a connection to URI and return a port to it, or, if connection failed,
print a warning and return #f."
(define host
(uri-host uri))
(catch #t
(lambda ()
(guix:open-connection-for-uri uri
#:verify-certificate? verify-certificate?
#:timeout time))
(match-lambda*
(('getaddrinfo-error error)
(unless (hash-ref %unreachable-hosts host)
(hash-set! %unreachable-hosts host #t) ;warn only once
(warning (G_ "~a: host not found: ~a~%")
host (gai-strerror error)))
#f)
(('system-error . args)
(unless (hash-ref %unreachable-hosts host)
(hash-set! %unreachable-hosts host #t)
(warning (G_ "~a: connection failed: ~a~%") host
(strerror
(system-error-errno `(system-error ,@args)))))
#f)
(args
(apply throw args)))))
(define (fetch-narinfos url paths) (define (fetch-narinfos url paths)
"Retrieve all the narinfos for PATHS from the cache at URL and return them." "Retrieve all the narinfos for PATHS from the cache at URL and return them."
(define update-progress! (define update-progress!
@ -657,13 +640,18 @@ (define (handle-narinfo-response request response port result)
(len (response-content-length response)) (len (response-content-length response))
(cache (response-cache-control response)) (cache (response-cache-control response))
(ttl (and cache (assoc-ref cache 'max-age)))) (ttl (and cache (assoc-ref cache 'max-age))))
(update-progress!)
;; Make sure to read no more than LEN bytes since subsequent bytes may ;; Make sure to read no more than LEN bytes since subsequent bytes may
;; belong to the next response. ;; belong to the next response.
(if (= code 200) ; hit (if (= code 200) ; hit
(let ((narinfo (read-narinfo port url #:size len))) (let ((narinfo (read-narinfo port url #:size len)))
(cache-narinfo! url (narinfo-path narinfo) narinfo ttl) (if (string=? (dirname (narinfo-path narinfo))
(update-progress!) (%store-prefix))
(cons narinfo result)) (begin
(cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
(cons narinfo result))
result))
(let* ((path (uri-path (request-uri request))) (let* ((path (uri-path (request-uri request)))
(hash-part (basename (hash-part (basename
(string-drop-right path 8)))) ;drop ".narinfo" (string-drop-right path 8)))) ;drop ".narinfo"
@ -674,26 +662,28 @@ (define (handle-narinfo-response request response port result)
(if (= 404 code) (if (= 404 code)
ttl ttl
%narinfo-transient-error-ttl)) %narinfo-transient-error-ttl))
(update-progress!)
result)))) result))))
(define (do-fetch uri port) (define (do-fetch uri)
(case (and=> uri uri-scheme) (case (and=> uri uri-scheme)
((http https) ((http https)
(let ((requests (map (cut narinfo-request url <>) paths))) (let ((requests (map (cut narinfo-request url <>) paths)))
(update-progress!) (match (open-connection-for-uri/maybe uri)
(#f
;; Note: Do not check HTTPS server certificates to avoid depending on '())
;; the X.509 PKI. We can do it because we authenticate narinfos, (port
;; which provides a much stronger guarantee. (update-progress!)
(let ((result (http-multiple-get uri ;; Note: Do not check HTTPS server certificates to avoid depending
handle-narinfo-response '() ;; on the X.509 PKI. We can do it because we authenticate
requests ;; narinfos, which provides a much stronger guarantee.
#:verify-certificate? #f (let ((result (http-multiple-get uri
#:port port))) handle-narinfo-response '()
(close-connection port) requests
(newline (current-error-port)) #:verify-certificate? #f
result))) #:port port)))
(close-port port)
(newline (current-error-port))
result)))))
((file #f) ((file #f)
(let* ((base (string-append (uri-path uri) "/")) (let* ((base (string-append (uri-path uri) "/"))
(files (map (compose (cut string-append base <> ".narinfo") (files (map (compose (cut string-append base <> ".narinfo")
@ -704,17 +694,7 @@ (define (do-fetch uri port)
(leave (G_ "~s: unsupported server URI scheme~%") (leave (G_ "~s: unsupported server URI scheme~%")
(if uri (uri-scheme uri) url))))) (if uri (uri-scheme uri) url)))))
(let-values (((cache-info port) (do-fetch (string->uri url)))
(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 (G_ "'~a' uses different store '~a'; ignoring it~%")
url (cache-info-store-directory cache-info))
(close-connection port)
#f)))))
(define (lookup-narinfos cache paths) (define (lookup-narinfos cache paths)
"Return the narinfos for PATHS, invoking the server at CACHE when no "Return the narinfos for PATHS, invoking the server at CACHE when no