summaryrefslogtreecommitdiff
path: root/guix/scripts/substitute.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts/substitute.scm')
-rwxr-xr-xguix/scripts/substitute.scm206
1 files changed, 94 insertions, 112 deletions
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index dba08edf50..b6034a75d2 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -86,6 +86,8 @@
read-narinfo
write-narinfo
+ %allow-unauthenticated-substitutes?
+
substitute-urls
guix-substitute))
@@ -118,15 +120,21 @@
(string-append %state-directory "/substitute/cache"))
(string-append (cache-directory #:ensure? #f) "/substitute")))
+(define (warn-about-missing-authentication)
+ (warning (G_ "authentication and authorization of substitutes \
+disabled!~%"))
+ #t)
+
(define %allow-unauthenticated-substitutes?
;; Whether to allow unchecked substitutes. This is useful for testing
;; purposes, and should be avoided otherwise.
- (and (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES")
- (cut string-ci=? <> "yes"))
- (begin
- (warning (G_ "authentication and authorization of substitutes \
-disabled!~%"))
- #t)))
+ (make-parameter
+ (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES")
+ (cut string-ci=? <> "yes"))
+ (lambda (value)
+ (when value
+ (warn-about-missing-authentication))
+ value)))
(define %narinfo-ttl
;; Number of seconds during which cached narinfo lookups are considered
@@ -227,58 +235,6 @@ provide."
(leave (G_ "unsupported substitute URI scheme: ~a~%")
(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>
(%make-narinfo path uri-base uris compressions file-sizes file-hashes
@@ -366,22 +322,6 @@ must contain the original contents of a narinfo file."
(and=> signature narinfo-signature->canonical-sexp))
str)))
-(define* (assert-valid-signature narinfo signature hash
- #:optional (acl (current-acl)))
- "Bail out if SIGNATURE, a canonical sexp representing the signature of
-NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO."
- (let ((uri (uri->string (first (narinfo-uris narinfo)))))
- (signature-case (signature hash acl)
- (valid-signature #t)
- (invalid-signature
- (leave (G_ "invalid signature for '~a'~%") uri))
- (hash-mismatch
- (leave (G_ "hash mismatch for '~a'~%") uri))
- (unauthorized-key
- (leave (G_ "'~a' is signed with an unauthorized key~%") uri))
- (corrupt-signature
- (leave (G_ "signature on '~a' is corrupt~%") uri)))))
-
(define* (read-narinfo port #:optional url
#:key size)
"Read a narinfo from PORT. If URL is true, it must be a string used to
@@ -422,7 +362,7 @@ No authentication and authorization checks are performed here!"
(define* (valid-narinfo? narinfo #:optional (acl (current-acl))
#:key verbose?)
"Return #t if NARINFO's signature is not valid."
- (or %allow-unauthenticated-substitutes?
+ (or (%allow-unauthenticated-substitutes?)
(let ((hash (narinfo-sha256 narinfo))
(signature (narinfo-signature narinfo))
(uri (uri->string (first (narinfo-uris narinfo)))))
@@ -570,6 +510,9 @@ initial connection on which HTTP requests are sent."
(let connect ((port port)
(requests requests)
(result seed))
+ (define batch
+ (at-most 1000 requests))
+
;; (format (current-error-port) "connecting (~a requests left)..."
;; (length requests))
(let ((p (or port (guix:open-connection-for-uri
@@ -580,7 +523,7 @@ initial connection on which HTTP requests are sent."
(when (file-port? p)
(setvbuf p 'block (expt 2 16)))
- ;; Send REQUESTS, up to a certain number, in a row.
+ ;; Send BATCH in a row.
;; XXX: Do our own caching to work around inefficiencies when
;; communicating over TLS: <http://bugs.gnu.org/22966>.
(let-values (((buffer get) (open-bytevector-output-port)))
@@ -588,16 +531,21 @@ initial connection on which HTTP requests are sent."
(set-http-proxy-port?! buffer (http-proxy-port? p))
(for-each (cut write-request <> buffer)
- (at-most 1000 requests))
+ batch)
(put-bytevector p (get))
(force-output p))
;; Now start processing responses.
- (let loop ((requests requests)
- (result result))
- (match requests
+ (let loop ((sent batch)
+ (processed 0)
+ (result result))
+ (match sent
(()
- (reverse result))
+ (match (drop requests processed)
+ (()
+ (reverse result))
+ (remainder
+ (connect port remainder result))))
((head tail ...)
(let* ((resp (read-response p))
(body (response-body-port resp))
@@ -608,9 +556,11 @@ initial connection on which HTTP requests are sent."
(match (assq 'connection (response-headers resp))
(('connection 'close)
(close-connection p)
- (connect #f tail result)) ;try again
+ (connect #f ;try again
+ (append tail (drop requests processed))
+ result))
(_
- (loop tail result)))))))))) ;keep going
+ (loop tail (+ 1 processed) result)))))))))) ;keep going
(define (read-to-eof port)
"Read from PORT until EOF is reached. The data are discarded."
@@ -628,6 +578,41 @@ if file doesn't exist, and the narinfo otherwise."
#f
(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)
"Retrieve all the narinfos for PATHS from the cache at URL and return them."
(define update-progress!
@@ -657,13 +642,18 @@ if file doesn't exist, and the narinfo otherwise."
(len (response-content-length response))
(cache (response-cache-control response))
(ttl (and cache (assoc-ref cache 'max-age))))
+ (update-progress!)
+
;; Make sure to read no more than LEN bytes since subsequent bytes may
;; belong to the next response.
(if (= code 200) ; hit
(let ((narinfo (read-narinfo port url #:size len)))
- (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
- (update-progress!)
- (cons narinfo result))
+ (if (string=? (dirname (narinfo-path narinfo))
+ (%store-prefix))
+ (begin
+ (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
+ (cons narinfo result))
+ result))
(let* ((path (uri-path (request-uri request)))
(hash-part (basename
(string-drop-right path 8)))) ;drop ".narinfo"
@@ -674,26 +664,28 @@ if file doesn't exist, and the narinfo otherwise."
(if (= 404 code)
ttl
%narinfo-transient-error-ttl))
- (update-progress!)
result))))
- (define (do-fetch uri port)
+ (define (do-fetch uri)
(case (and=> uri uri-scheme)
((http https)
(let ((requests (map (cut narinfo-request url <>) paths)))
- (update-progress!)
-
- ;; Note: Do not check HTTPS server certificates to avoid depending on
- ;; the X.509 PKI. We can do it because we authenticate narinfos,
- ;; which provides a much stronger guarantee.
- (let ((result (http-multiple-get uri
- handle-narinfo-response '()
- requests
- #:verify-certificate? #f
- #:port port)))
- (close-connection port)
- (newline (current-error-port))
- result)))
+ (match (open-connection-for-uri/maybe uri)
+ (#f
+ '())
+ (port
+ (update-progress!)
+ ;; Note: Do not check HTTPS server certificates to avoid depending
+ ;; on the X.509 PKI. We can do it because we authenticate
+ ;; narinfos, which provides a much stronger guarantee.
+ (let ((result (http-multiple-get uri
+ handle-narinfo-response '()
+ requests
+ #:verify-certificate? #f
+ #:port port)))
+ (close-port port)
+ (newline (current-error-port))
+ result)))))
((file #f)
(let* ((base (string-append (uri-path uri) "/"))
(files (map (compose (cut string-append base <> ".narinfo")
@@ -704,17 +696,7 @@ if file doesn't exist, and the narinfo otherwise."
(leave (G_ "~s: unsupported server URI scheme~%")
(if uri (uri-scheme uri) url)))))
- (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 (G_ "'~a' uses different store '~a'; ignoring it~%")
- url (cache-info-store-directory cache-info))
- (close-connection port)
- #f)))))
+ (do-fetch (string->uri url)))
(define (lookup-narinfos cache paths)
"Return the narinfos for PATHS, invoking the server at CACHE when no