;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
+;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (guix scripts substitute)
#:use-module (guix ui)
- #:use-module ((guix store) #:hide (close-connection))
+ #:use-module (guix scripts)
+ #:use-module (guix narinfo)
+ #:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix combinators)
#:use-module (guix config)
#:use-module (guix records)
- #:use-module ((guix serialization) #:select (restore-file))
- #:use-module (guix hash)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
+ #:use-module ((guix serialization) #:select (restore-file dump-file))
+ #:autoload (guix store deduplication) (dump-file/deduplicate)
+ #:autoload (guix scripts discover) (read-substitute-urls)
+ #:use-module (gcrypt hash)
#:use-module (guix base32)
#:use-module (guix base64)
#:use-module (guix cache)
- #:use-module (guix pk-crypto)
+ #:use-module (gcrypt pk-crypto)
#:use-module (guix pki)
#:use-module ((guix build utils) #:select (mkdir-p dump-port))
#:use-module ((guix build download)
- #:select (current-terminal-columns
- progress-proc uri-abbreviation nar-uri-abbreviation
+ #:select (uri-abbreviation nar-uri-abbreviation
(open-connection-for-uri
. guix:open-connection-for-uri)
- close-connection
store-path-abbreviation byte-count->string))
+ #:autoload (gnutls) (error/invalid-session)
+ #:use-module (guix progress)
+ #:use-module ((guix build syscalls)
+ #:select (set-thread-name))
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 ftw)
#:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 vlist)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (web request)
#:use-module (web response)
#:use-module (guix http-client)
- #:export (narinfo-signature->canonical-sexp
-
- narinfo?
- narinfo-path
- narinfo-uri
- narinfo-uri-base
- narinfo-compression
- narinfo-file-hash
- narinfo-file-size
- narinfo-hash
- narinfo-size
- narinfo-references
- narinfo-deriver
- narinfo-system
- narinfo-signature
-
- narinfo-hash->sha256
- assert-valid-narinfo
-
- lookup-narinfos
+ #:export (lookup-narinfos
lookup-narinfos/diverse
- read-narinfo
- write-narinfo
+
+ %allow-unauthenticated-substitutes?
+ %error-to-file-descriptor-4?
+
+ substitute-urls
guix-substitute))
;;; Comment:
(or (and=> (getenv "XDG_CACHE_HOME")
(cut string-append <> "/guix/substitute"))
(string-append %state-directory "/substitute/cache"))
- (string-append (cache-directory) "/substitute")))
+ (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 (_ "authentication and authorization of substitutes \
-disabled!~%"))
- #t)))
+ (make-parameter
+ (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES")
+ (cut string-ci=? <> "yes"))))
(define %narinfo-ttl
;; Number of seconds during which cached narinfo lookups are considered
(define %narinfo-negative-ttl
;; Likewise, but for negative lookups---i.e., cached lookup failures (404).
- (* 3 3600))
+ (* 1 3600))
(define %narinfo-transient-error-ttl
;; Likewise, but for transient errors such as 504 ("Gateway timeout").
;; How often we want to remove files corresponding to expired cache entries.
(* 7 24 3600))
-(define fields->alist
- ;; The narinfo format is really just like recutils.
- recutils->alist)
-
(define %fetch-timeout
;; Number of seconds after which networking is considered "slow".
5)
(sigaction SIGALRM SIG_DFL)
(apply values result)))))
-(define* (fetch uri #:key (buffered? #t) (timeout? #t))
+(define* (fetch uri #:key (buffered? #t) (timeout? #t)
+ (keep-alive? #f) (port #f))
"Return a binary input port to URI and the number of bytes it's expected to
-provide."
+provide.
+
+When PORT is true, use it as the underlying I/O port for HTTP transfers; when
+PORT is false, open a new connection for URI. When KEEP-ALIVE? is true, the
+connection (typically PORT) is kept open once data has been fetched from URI."
(case (uri-scheme uri)
((file)
(let ((port (open-file (uri-path uri)
(values port (stat:size (stat port)))))
((http https)
(guard (c ((http-get-error? c)
- (leave (_ "download from '~a' failed: ~a, ~s~%")
+ (leave (G_ "download from '~a' failed: ~a, ~s~%")
(uri->string (http-get-error-uri c))
(http-get-error-code c)
(http-get-error-reason c))))
;; sudo tc qdisc add dev eth0 root netem delay 1500ms
;; and then cancel with:
;; sudo tc qdisc del dev eth0 root
- (let ((port #f))
- (with-timeout (if timeout?
- %fetch-timeout
- 0)
- (begin
- (warning (_ "while fetching ~a: server is somewhat slow~%")
- (uri->string uri))
- (warning (_ "try `--no-substitutes' if the problem persists~%"))
-
- ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user,
- ;; and thus PORT had to be closed and re-opened. This is not the
- ;; case afterward.
- (unless (or (guile-version>? "2.0.9")
- (version>? (version) "2.0.9.39"))
- (when port
- (close-connection port))))
- (begin
- (when (or (not port) (port-closed? port))
- (set! port (guix:open-connection-for-uri
- uri #:verify-certificate? #f))
- (unless (or buffered? (not (file-port? port)))
- (setvbuf port _IONBF)))
- (http-fetch uri #:text? #f #:port port
- #:verify-certificate? #f))))))
+ (with-timeout (if timeout?
+ %fetch-timeout
+ 0)
+ (begin
+ (warning (G_ "while fetching ~a: server is somewhat slow~%")
+ (uri->string uri))
+ (warning (G_ "try `--no-substitutes' if the problem persists~%")))
+ (http-fetch uri #:text? #f #:port port
+ #:keep-alive? keep-alive?
+ #:buffered? buffered?
+ #:verify-certificate? #f))))
(else
- (leave (_ "unsupported substitute URI scheme: ~a~%")
+ (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 (_ "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 (_ "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))))))
-
-\f
-(define-record-type <narinfo>
- (%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size
- references deriver system signature contents)
- narinfo?
- (path narinfo-path)
- (uri narinfo-uri)
- (uri-base narinfo-uri-base) ; URI of the cache it originates from
- (compression narinfo-compression)
- (file-hash narinfo-file-hash)
- (file-size narinfo-file-size)
- (nar-hash narinfo-hash)
- (nar-size narinfo-size)
- (references narinfo-references)
- (deriver narinfo-deriver)
- (system narinfo-system)
- (signature narinfo-signature) ; canonical sexp
- ;; The original contents of a narinfo file. This field is needed because we
- ;; want to preserve the exact textual representation for verification purposes.
- ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
- ;; for more information.
- (contents narinfo-contents))
-
-(define (narinfo-hash->sha256 hash)
- "If the string HASH denotes a sha256 hash, return it as a bytevector.
-Otherwise return #f."
- (and (string-prefix? "sha256:" hash)
- (nix-base32-string->bytevector (string-drop hash 7))))
-
-(define (narinfo-signature->canonical-sexp str)
- "Return the value of a narinfo's 'Signature' field as a canonical sexp."
- (match (string-split str #\;)
- ((version host-name sig)
- (let ((maybe-number (string->number version)))
- (cond ((not (number? maybe-number))
- (leave (_ "signature version must be a number: ~s~%")
- version))
- ;; Currently, there are no other versions.
- ((not (= 1 maybe-number))
- (leave (_ "unsupported signature version: ~a~%")
- maybe-number))
- (else
- (let ((signature (utf8->string (base64-decode sig))))
- (catch 'gcry-error
- (lambda ()
- (string->canonical-sexp signature))
- (lambda (key proc err)
- (leave (_ "signature is not a valid \
-s-expression: ~s~%")
- signature))))))))
- (x
- (leave (_ "invalid format of the signature field: ~a~%") x))))
-
-(define (narinfo-maker str cache-url)
- "Return a narinfo constructor for narinfos originating from CACHE-URL. STR
-must contain the original contents of a narinfo file."
- (lambda (path url compression file-hash file-size nar-hash nar-size
- references deriver system signature)
- "Return a new <narinfo> object."
- (%make-narinfo path
- ;; Handle the case where URL is a relative URL.
- (or (string->uri url)
- (string->uri (string-append cache-url "/" url)))
- cache-url
-
- compression file-hash
- (and=> file-size string->number)
- nar-hash
- (and=> nar-size string->number)
- (string-tokenize references)
- (match deriver
- ((or #f "") #f)
- (_ deriver))
- system
- (false-if-exception
- (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 (narinfo-uri narinfo))))
- (signature-case (signature hash acl)
- (valid-signature #t)
- (invalid-signature
- (leave (_ "invalid signature for '~a'~%") uri))
- (hash-mismatch
- (leave (_ "hash mismatch for '~a'~%") uri))
- (unauthorized-key
- (leave (_ "'~a' is signed with an unauthorized key~%") uri))
- (corrupt-signature
- (leave (_ "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
-build full URIs from relative URIs found while reading PORT. When SIZE is
-true, read at most SIZE bytes from PORT; otherwise, read as much as possible.
-
-No authentication and authorization checks are performed here!"
- (let ((str (utf8->string (if size
- (get-bytevector-n port size)
- (get-bytevector-all port)))))
- (alist->record (call-with-input-string str fields->alist)
- (narinfo-maker str url)
- '("StorePath" "URL" "Compression"
- "FileHash" "FileSize" "NarHash" "NarSize"
- "References" "Deriver" "System"
- "Signature"))))
-
-(define (narinfo-sha256 narinfo)
- "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
-'Signature' field."
- (let ((contents (narinfo-contents narinfo)))
- (match (string-contains contents "Signature:")
- (#f #f)
- (index
- (let ((above-signature (string-take contents index)))
- (sha256 (string->utf8 above-signature)))))))
-
-(define* (assert-valid-narinfo narinfo
- #:optional (acl (current-acl))
- #:key verbose?)
- "Raise an exception if NARINFO lacks a signature, has an invalid signature,
-or is signed by an unauthorized key."
- (let ((hash (narinfo-sha256 narinfo)))
- (if (not hash)
- (if %allow-unauthenticated-substitutes?
- narinfo
- (leave (_ "substitute at '~a' lacks a signature~%")
- (uri->string (narinfo-uri narinfo))))
- (let ((signature (narinfo-signature narinfo)))
- (unless %allow-unauthenticated-substitutes?
- (assert-valid-signature narinfo signature hash acl)
- (when verbose?
- (format (current-error-port)
- (_ "Found valid signature for ~a~%")
- (narinfo-path narinfo))
- (format (current-error-port)
- (_ "From ~a~%")
- (uri->string (narinfo-uri narinfo)))))
- narinfo))))
-
-(define* (valid-narinfo? narinfo #:optional (acl (current-acl)))
- "Return #t if NARINFO's signature is not valid."
- (or %allow-unauthenticated-substitutes?
- (let ((hash (narinfo-sha256 narinfo))
- (signature (narinfo-signature narinfo)))
- (and hash signature
- (signature-case (signature hash acl)
- (valid-signature #t)
- (else #f))))))
-
-(define (write-narinfo narinfo port)
- "Write NARINFO to PORT."
- (put-bytevector port (string->utf8 (narinfo-contents narinfo))))
-
-(define (narinfo->string narinfo)
- "Return the external representation of NARINFO."
- (call-with-output-string (cut write-narinfo narinfo <>)))
-
-(define (string->narinfo str cache-uri)
- "Return the narinfo represented by STR. Assume CACHE-URI as the base URI of
-the cache STR originates form."
- (call-with-input-string str (cut read-narinfo <> cache-uri)))
-
(define (narinfo-cache-file cache-url path)
"Return the name of the local file that contains an entry for PATH. The
entry is stored in a sub-directory specific to CACHE-URL."
;; "/gnu/store/foo". Gracefully handle that.
(match (store-path-hash-part path)
(#f
- (leave (_ "'~a' does not name a store item~%") path))
+ (leave (G_ "'~a' does not name a store item~%") path))
((? string? hash-part)
(string-append %narinfo-cache-directory "/"
(bytevector->base32-string (sha256 (string->utf8 cache-url)))
(match (read p)
(('narinfo ('version 2)
('cache-uri cache-uri)
- ('date date) ('ttl _) ('value #f))
+ ('date date) ('ttl ttl) ('value #f))
;; A cached negative lookup.
- (if (obsolete? date now %narinfo-negative-ttl)
+ (if (obsolete? date now ttl)
(values #f #f)
(values #t #f)))
(('narinfo ('version 2)
(headers '((User-Agent . "GNU Guile"))))
(build-request (string->uri url) #:method 'GET #:headers headers)))
-(define* (http-multiple-get base-uri proc seed requests
- #:key port (verify-certificate? #t))
- "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. 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 (or port (guix:open-connection-for-uri
- base-uri
- #:verify-certificate?
- verify-certificate?))))
- ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
- (when (file-port? p)
- (setvbuf p _IOFBF (expt 2 16)))
-
- ;; Send all of REQUESTS 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)))
- ;; On Guile > 2.0.9, inherit the HTTP proxying property from P.
- (when (module-variable (resolve-interface '(web http))
- 'http-proxy-port?)
- (set-http-proxy-port?! buffer (http-proxy-port? p)))
-
- (for-each (cut write-request <> buffer) requests)
- (put-bytevector p (get))
- (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))
- (result (proc head resp body result)))
- ;; The server can choose to stop responding at any time, in which
- ;; case we have to try again. Check whether that is the case.
- ;; Note that even upon "Connection: close", we can read from BODY.
- (match (assq 'connection (response-headers resp))
- (('connection 'close)
- (close-connection p)
- (connect #f tail result)) ;try again
- (_
- (loop tail result)))))))))) ;keep going
+(define (at-most max-length lst)
+ "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
+return its MAX-LENGTH first elements and its tail."
+ (let loop ((len 0)
+ (lst lst)
+ (result '()))
+ (match lst
+ (()
+ (values (reverse result) '()))
+ ((head . tail)
+ (if (>= len max-length)
+ (values (reverse result) lst)
+ (loop (+ 1 len) tail (cons head result)))))))
(define (read-to-eof port)
"Read from PORT until EOF is reached. The data are discarded."
#f
(apply throw args)))))
+(define %unreachable-hosts
+ ;; Set of names of unreachable hosts.
+ (make-hash-table))
+
+(define* (open-connection-for-uri/maybe uri
+ #:key
+ fresh?
+ (time %fetch-timeout)
+ verify-certificate?)
+ "Open a connection to URI via 'open-connection-for-uri/cached' and return a
+port to it, or, if connection failed, print a warning and return #f. Pass
+#:fresh? to 'open-connection-for-uri/cached'."
+ (define host
+ (uri-host uri))
+
+ (catch #t
+ (lambda ()
+ (open-connection-for-uri/cached uri #:timeout time
+ #:fresh? fresh?
+ #:verify-certificate? verify-certificate?))
+ (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!
- (let ((done 0))
+ (let ((done 0)
+ (total (length paths)))
(lambda ()
- (display #\cr (current-error-port))
+ (display "\r\x1b[K" (current-error-port)) ;erase current line
(force-output (current-error-port))
(format (current-error-port)
- (_ "updating list of substitutes from '~a'... ~5,1f%")
- url (* 100. (/ done (length paths))))
+ (G_ "updating substitutes from '~a'... ~5,1f%")
+ url (* 100. (/ done total)))
(set! done (+ 1 done)))))
+ (define hash-part->path
+ (let ((mapping (fold (lambda (path result)
+ (vhash-cons (store-path-hash-part path) path
+ result))
+ vlist-null
+ paths)))
+ (lambda (hash)
+ (match (vhash-assoc hash mapping)
+ (#f #f)
+ ((_ . path) path)))))
+
(define (handle-narinfo-response request response port result)
(let* ((code (response-code response))
(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"
(if len
(get-bytevector-n port len)
(read-to-eof port))
- (cache-narinfo! url
- (find (cut string-contains <> hash-part) paths)
- #f
- (if (= 404 code)
+ (cache-narinfo! url (hash-part->path hash-part) #f
+ (if (or (= 404 code) (= 202 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)))
+ ;; 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* ((requests (map (cut narinfo-request url <>) paths))
+ (result (begin
+ (update-progress!)
+ (http-multiple-get uri
+ handle-narinfo-response '()
+ requests
+ #:open-connection
+ open-connection-for-uri/maybe
+ #:verify-certificate? #f))))
+ (newline (current-error-port))
+ result))
((file #f)
(let* ((base (string-append (uri-path uri) "/"))
(files (map (compose (cut string-append base <> ".narinfo")
paths)))
(filter-map (cut narinfo-from-file <> url) files)))
(else
- (leave (_ "~s: unsupported server URI scheme~%")
+ (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 (_ "'~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
(let ((missing (fetch-narinfos cache missing)))
(append cached (or missing '()))))))
-(define (lookup-narinfos/diverse caches paths)
+(define (lookup-narinfos/diverse caches paths authorized?)
"Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
-That is, when a cache lacks a narinfo, look it up in the next cache, and so
-on. Return a list of narinfos for PATHS or a subset thereof."
+That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next
+cache, and so on.
+
+Return a list of narinfos for PATHS or a subset thereof. The returned
+narinfos are either AUTHORIZED?, or they claim a hash that matches an
+AUTHORIZED? narinfo."
+ (define (select-hit result)
+ (lambda (path)
+ (match (vhash-fold* cons '() path result)
+ ((one)
+ one)
+ ((several ..1)
+ (let ((authorized (find authorized? (reverse several))))
+ (and authorized
+ (find (cut equivalent-narinfo? <> authorized)
+ several)))))))
+
(let loop ((caches caches)
(paths paths)
- (result '()))
+ (result vlist-null) ;path->narinfo vhash
+ (hits '())) ;paths
(match paths
(() ;we're done
- result)
+ ;; Now iterate on all the HITS, and return exactly one match for each
+ ;; hit: the first narinfo that is authorized, or that has the same hash
+ ;; as an authorized narinfo, in the order of CACHES.
+ (filter-map (select-hit result) hits))
(_
(match caches
((cache rest ...)
(let* ((narinfos (lookup-narinfos cache paths))
- (hits (map narinfo-path narinfos))
- (missing (lset-difference string=? paths hits))) ;XXX: perf
- (loop rest missing (append narinfos result))))
+ (definite (map narinfo-path (filter authorized? narinfos)))
+ (missing (lset-difference string=? paths definite))) ;XXX: perf
+ (loop rest missing
+ (fold vhash-cons result
+ (map narinfo-path narinfos) narinfos)
+ (append definite hits))))
(() ;that's it
- result))))))
+ (filter-map (select-hit result) hits)))))))
-(define (lookup-narinfo caches path)
+(define (lookup-narinfo caches path authorized?)
"Return the narinfo for PATH in CACHES, or #f when no substitute for PATH
was found."
- (match (lookup-narinfos/diverse caches (list path))
+ (match (lookup-narinfos/diverse caches (list path) authorized?)
((answer) answer)
(_ #f)))
(match (read port)
(('narinfo ('version 2) ('cache-uri uri)
('date date) ('ttl ttl) ('value #f))
- (+ date %narinfo-negative-ttl))
+ (+ date ttl))
(('narinfo ('version 2) ('cache-uri uri)
('date date) ('ttl ttl) ('value value))
(+ date ttl))
(= (string-length file) 32)))))
(narinfo-cache-directories directory)))
-(define (progress-report-port report-progress port)
- "Return a port that calls REPORT-PROGRESS every time something is read from
-PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by
-`progress-proc'."
- (define total 0)
- (define (read! bv start count)
- (let ((n (match (get-bytevector-n! port bv start count)
- ((? eof-object?) 0)
- (x x))))
- (set! total (+ total n))
- (report-progress total (const n))
- ;; XXX: We're not in control, so we always return anyway.
- n))
-
- (make-custom-binary-input-port "progress-port-proc"
- read! #f #f
- (cut close-connection port)))
-
(define-syntax with-networking
(syntax-rules ()
"Catch DNS lookup errors and TLS errors and gracefully exit."
(lambda () exp ...)
(match-lambda*
(('getaddrinfo-error error)
- (leave (_ "host name lookup error: ~a~%")
+ (leave (G_ "host name lookup error: ~a~%")
(gai-strerror error)))
(('gnutls-error error proc . rest)
(let ((error->string (module-ref (resolve-interface '(gnutls))
'error->string)))
- (leave (_ "TLS error in procedure '~a': ~a~%")
+ (leave (G_ "TLS error in procedure '~a': ~a~%")
proc (error->string error))))
(args
(apply throw args)))))))
;;;
(define (show-help)
- (display (_ "Usage: guix substitute [OPTION]...
+ (display (G_ "Usage: guix substitute [OPTION]...
Internal tool to substitute a pre-built binary to a local build.\n"))
- (display (_ "
+ (display (G_ "
--query report on the availability of substitutes for the
store file names passed on the standard input"))
- (display (_ "
+ (display (G_ "
--substitute STORE-FILE DESTINATION
download STORE-FILE and store it as a Nar in file
DESTINATION"))
(newline)
- (display (_ "
+ (display (G_ "
-h, --help display this help and exit"))
- (display (_ "
+ (display (G_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
(length (narinfo-references narinfo)))
(for-each (cute format #t "~a/~a~%" (%store-prefix) <>)
(narinfo-references narinfo))
- (format #t "~a\n~a\n"
- (or (narinfo-file-size narinfo) 0)
- (or (narinfo-size narinfo) 0)))
+
+ (let-values (((uri compression file-size) (narinfo-best-uri narinfo)))
+ (format #t "~a\n~a\n"
+ (or file-size 0)
+ (or (narinfo-size narinfo) 0))))
(define* (process-query command
#:key cache-urls acl)
"Reply to COMMAND, a query as written by the daemon to this process's
standard input. Use ACL as the access-control list against which to check
authorized substitutes."
- (define (valid? obj)
- (valid-narinfo? obj acl))
+ (define valid?
+ (if (%allow-unauthenticated-substitutes?)
+ (begin
+ (warn-about-missing-authentication)
+
+ (const #t))
+ (lambda (obj)
+ (valid-narinfo? obj acl))))
(match (string-tokenize command)
(("have" paths ..1)
;; Return the subset of PATHS available in CACHE-URLS.
- (let ((substitutable (lookup-narinfos/diverse cache-urls paths)))
+ (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?)))
(for-each (lambda (narinfo)
(format #t "~a~%" (narinfo-path narinfo)))
- (filter valid? substitutable))
+ substitutable)
(newline)))
(("info" paths ..1)
;; Reply info about PATHS if it's in CACHE-URLS.
- (let ((substitutable (lookup-narinfos/diverse cache-urls paths)))
- (for-each display-narinfo-data (filter valid? substitutable))
+ (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid?)))
+ (for-each display-narinfo-data substitutable)
(newline)))
(wtf
(error "unknown `--query' command" wtf))))
+(define %max-cached-connections
+ ;; Maximum number of connections kept in cache by
+ ;; 'open-connection-for-uri/cached'.
+ 16)
+
+(define open-connection-for-uri/cached
+ (let ((cache '()))
+ (lambda* (uri #:key fresh? timeout verify-certificate?)
+ "Return a connection for URI, possibly reusing a cached connection.
+When FRESH? is true, delete any cached connections for URI and open a new one.
+Return #f if URI's scheme is 'file' or #f.
+
+When true, TIMEOUT is the maximum number of milliseconds to wait for
+connection establishment. When VERIFY-CERTIFICATE? is true, verify HTTPS
+server certificates."
+ (define host (uri-host uri))
+ (define scheme (uri-scheme uri))
+ (define key (list host scheme (uri-port uri)))
+
+ (and (not (memq scheme '(file #f)))
+ (match (assoc-ref cache key)
+ (#f
+ ;; Open a new connection to URI and evict old entries from
+ ;; CACHE, if any.
+ (let-values (((socket)
+ (guix:open-connection-for-uri
+ uri
+ #:verify-certificate? verify-certificate?
+ #:timeout timeout))
+ ((new-cache evicted)
+ (at-most (- %max-cached-connections 1) cache)))
+ (for-each (match-lambda
+ ((_ . port)
+ (false-if-exception (close-port port))))
+ evicted)
+ (set! cache (alist-cons key socket new-cache))
+ socket))
+ (socket
+ (if (or fresh? (port-closed? socket))
+ (begin
+ (false-if-exception (close-port socket))
+ (set! cache (alist-delete key cache))
+ (open-connection-for-uri/cached uri #:timeout timeout
+ #:verify-certificate?
+ verify-certificate?))
+ (begin
+ ;; Drain input left from the previous use.
+ (drain-input socket)
+ socket))))))))
+
+(define* (call-with-cached-connection uri proc
+ #:optional
+ (open-connection
+ open-connection-for-uri/cached))
+ (let ((port (open-connection uri)))
+ (catch #t
+ (lambda ()
+ (proc port))
+ (lambda (key . args)
+ ;; If PORT was cached and the server closed the connection in the
+ ;; meantime, we get EPIPE. In that case, open a fresh connection and
+ ;; retry. We might also get 'bad-response or a similar exception from
+ ;; (web response) later on, once we've sent the request, or a
+ ;; ERROR/INVALID-SESSION from GnuTLS.
+ (if (or (and (eq? key 'system-error)
+ (= EPIPE (system-error-errno `(,key ,@args))))
+ (and (eq? key 'gnutls-error)
+ (eq? (first args) error/invalid-session))
+ (memq key '(bad-response bad-header bad-header-component)))
+ (proc (open-connection uri #:fresh? #t))
+ (apply throw key args))))))
+
+(define-syntax-rule (with-cached-connection uri port exp ...)
+ "Bind PORT with EXP... to a socket connected to URI."
+ (call-with-cached-connection uri (lambda (port) exp ...)))
+
(define* (process-substitution store-item destination
- #:key cache-urls acl)
+ #:key cache-urls acl
+ deduplicate? print-build-trace?)
"Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
-DESTINATION as a nar file. Verify the substitute against ACL."
- (let* ((narinfo (lookup-narinfo cache-urls store-item))
- (uri (narinfo-uri narinfo)))
- ;; Make sure it is signed and everything.
- (assert-valid-narinfo narinfo acl)
-
- ;; Tell the daemon what the expected hash of the Nar itself is.
- (format #t "~a~%" (narinfo-hash narinfo))
-
- (format (current-error-port)
- ;; TRANSLATORS: The second part of this message looks like
- ;; "(4.1MiB installed)"; it shows the size of the package once
- ;; installed.
- (_ "Downloading ~a~:[~*~; (~a installed)~]...~%")
- (uri->string uri)
- ;; Use the Nar size as an estimate of the installed size.
- (narinfo-size narinfo)
- (and=> (narinfo-size narinfo)
- (cute byte-count->string <>)))
+DESTINATION as a nar file. Verify the substitute against ACL, and verify its
+hash against what appears in the narinfo. When DEDUPLICATE? is true, and if
+DESTINATION is in the store, deduplicate its files. Print a status line on
+the current output port."
+ (define narinfo
+ (lookup-narinfo cache-urls store-item
+ (if (%allow-unauthenticated-substitutes?)
+ (const #t)
+ (cut valid-narinfo? <> acl))))
+
+ (define destination-in-store?
+ (string-prefix? (string-append (%store-prefix) "/")
+ destination))
+
+ (define (dump-file/deduplicate* . args)
+ ;; Make sure deduplication looks at the right store (necessary in test
+ ;; environments).
+ (apply dump-file/deduplicate
+ (append args (list #:store (%store-prefix)))))
+
+ (unless narinfo
+ (leave (G_ "no valid substitute for '~a'~%")
+ store-item))
+
+ (let-values (((uri compression file-size)
+ (narinfo-best-uri narinfo)))
+ (unless print-build-trace?
+ (format (current-error-port)
+ (G_ "Downloading ~a...~%") (uri->string uri)))
+
(let*-values (((raw download-size)
- ;; Note that Hydra currently generates Nars on the fly
- ;; and doesn't specify a Content-Length, so
- ;; DOWNLOAD-SIZE is #f in practice.
- (fetch uri #:buffered? #f #:timeout? #f))
+ ;; 'guix publish' without '--cache' doesn't specify a
+ ;; Content-Length, so DOWNLOAD-SIZE is #f in this case.
+ (with-cached-connection uri port
+ (fetch uri #:buffered? #f #:timeout? #f
+ #:port port
+ #:keep-alive? #t)))
((progress)
- (let* ((comp (narinfo-compression narinfo))
- (dl-size (or download-size
- (and (equal? comp "none")
+ (let* ((dl-size (or download-size
+ (and (equal? compression "none")
(narinfo-size narinfo))))
- (progress (progress-proc (uri->string uri)
- dl-size
- (current-error-port)
- #:abbreviation
- nar-uri-abbreviation)))
- (progress-report-port progress raw)))
+ (reporter (if print-build-trace?
+ (progress-reporter/trace
+ destination
+ (uri->string uri) dl-size
+ (current-error-port))
+ (progress-reporter/file
+ (uri->string uri) dl-size
+ (current-error-port)
+ #:abbreviation nar-uri-abbreviation))))
+ ;; Keep RAW open upon completion so we can later reuse
+ ;; the underlying connection.
+ (progress-report-port reporter raw #:close? #f)))
((input pids)
- (decompressed-port (and=> (narinfo-compression narinfo)
- string->symbol)
- progress)))
+ ;; NOTE: This 'progress' port of current process will be
+ ;; closed here, while the child process doing the
+ ;; reporting will close it upon exit.
+ (decompressed-port (string->symbol compression)
+ progress))
+
+ ;; Compute the actual nar hash as we read it.
+ ((algorithm expected)
+ (narinfo-hash-algorithm+value narinfo))
+ ((hashed get-hash)
+ (open-hash-input-port algorithm input)))
;; Unpack the Nar at INPUT into DESTINATION.
- (restore-file input destination)
-
- ;; Skip a line after what 'progress-proc' printed, and another one to
- ;; visually separate substitutions.
+ (restore-file hashed destination
+ #:dump-file (if (and destination-in-store?
+ deduplicate?)
+ dump-file/deduplicate*
+ dump-file))
+ (close-port hashed)
+ (close-port input)
+
+ ;; Wait for the reporter to finish.
+ (every (compose zero? cdr waitpid) pids)
+
+ ;; Skip a line after what 'progress-reporter/file' printed, and another
+ ;; one to visually separate substitutions.
(display "\n\n" (current-error-port))
- (every (compose zero? cdr waitpid) pids))))
+ ;; Check whether we got the data announced in NARINFO.
+ (let ((actual (get-hash)))
+ (if (bytevector=? actual expected)
+ ;; Tell the daemon that we're done.
+ (format (current-output-port) "success ~a ~a~%"
+ (narinfo-hash narinfo) (narinfo-size narinfo))
+ ;; The actual data has a different hash than that in NARINFO.
+ (format (current-output-port) "hash-mismatch ~a ~a ~a~%"
+ (hash-algorithm-name algorithm)
+ (bytevector->nix-base32-string expected)
+ (bytevector->nix-base32-string actual)))))))
\f
;;;
(let ((acl (acl->public-keys (current-acl))))
(when (or (null? acl) (singleton? acl))
- (warning (_ "ACL for archive imports seems to be uninitialized, \
+ (warning (G_ "ACL for archive imports seems to be uninitialized, \
substitutes may be unavailable\n")))))
(define (daemon-options)
found."
(assoc-ref (daemon-options) option))
-(define %cache-urls
+(define %default-substitute-urls
(match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client
(find-daemon-option "substitute-urls")) ;admin
string-tokenize)
(#f
;; This can only happen when this script is not invoked by the
;; daemon.
- '("http://hydra.gnu.org"))))
+ '("http://ci.guix.gnu.org"))))
+
+;; In order to prevent using large number of discovered local substitute
+;; servers, limit the local substitute urls list size.
+(define %max-substitute-urls 50)
+
+(define* (randomize-substitute-urls urls
+ #:key
+ (max %max-substitute-urls))
+ "Return a list containing MAX urls from URLS, picked randomly. If URLS list
+is shorter than MAX elements, then it is directly returned."
+ (define (random-item list)
+ (list-ref list (random (length list))))
+
+ (if (<= (length urls) max)
+ urls
+ (let loop ((res '())
+ (urls urls))
+ (if (eq? (length res) max)
+ res
+ (let ((url (random-item urls)))
+ (loop (cons url res) (delete url urls)))))))
+
+(define %local-substitute-urls
+ ;; If the following option is passed to the daemon, use the substitutes list
+ ;; provided by "guix discover" process.
+ (let* ((option (find-daemon-option "discover"))
+ (discover? (and option (string=? option "yes"))))
+ (if discover?
+ (randomize-substitute-urls (read-substitute-urls))
+ '())))
+
+(define substitute-urls
+ ;; List of substitute URLs.
+ (make-parameter (append %local-substitute-urls
+ %default-substitute-urls)))
(define (client-terminal-columns)
"Return the number of columns in the client's terminal, if it is known, or a
(and number (max 20 (- number 1))))))
80))
-(define (guix-substitute . args)
- "Implement the build daemon's substituter protocol."
- (mkdir-p %narinfo-cache-directory)
- (maybe-remove-expired-cache-entries %narinfo-cache-directory
- cached-narinfo-files
- #:entry-expiration
- cached-narinfo-expiration-time
- #:cleanup-period
- %narinfo-expired-cache-entry-removal-delay)
- (check-acl-initialized)
-
- ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly
- ;; when we know we cannot substitute, but we must emit a newline on stdout
- ;; when everything is alright.
- (when (null? %cache-urls)
- (exit 0))
-
- ;; Say hello (see above.)
- (newline)
- (force-output (current-output-port))
-
- ;; Attempt to install the client's locale, mostly so that messages are
- ;; suitably translated.
- (match (or (find-daemon-option "untrusted-locale")
- (find-daemon-option "locale"))
- (#f #f)
- (locale (false-if-exception (setlocale LC_ALL locale))))
-
- (with-networking
- (with-error-handling ; for signature errors
- (match args
- (("--query")
- (let ((acl (current-acl)))
- (let loop ((command (read-line)))
- (or (eof-object? command)
- (begin
- (process-query command
- #:cache-urls %cache-urls
- #:acl acl)
- (loop (read-line)))))))
- (("--substitute" store-path destination)
- ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
- ;; Specify the number of columns of the terminal so the progress
- ;; report displays nicely.
- (parameterize ((current-terminal-columns (client-terminal-columns)))
- (process-substitution store-path destination
- #:cache-urls %cache-urls
- #:acl (current-acl))))
- (("--version")
- (show-version-and-exit "guix substitute"))
- (("--help")
- (show-help))
- (opts
- (leave (_ "~a: unrecognized options~%") opts))))))
+(define (validate-uri uri)
+ (unless (string->uri uri)
+ (leave (G_ "~a: invalid URI~%") uri)))
+
+(define %error-to-file-descriptor-4?
+ ;; Whether to direct 'current-error-port' to file descriptor 4 like
+ ;; 'guix-daemon' expects.
+ (make-parameter #t))
+
+(define-command (guix-substitute . args)
+ (category internal)
+ (synopsis "implement the build daemon's substituter protocol")
+
+ (define print-build-trace?
+ (match (or (find-daemon-option "untrusted-print-extended-build-trace")
+ (find-daemon-option "print-extended-build-trace"))
+ (#f #f)
+ ((= string->number number) (> number 0))
+ (_ #f)))
+
+ (define deduplicate?
+ (find-daemon-option "deduplicate"))
+
+ ;; The daemon's agent code opens file descriptor 4 for us and this is where
+ ;; stderr should go.
+ (parameterize ((current-error-port (if (%error-to-file-descriptor-4?)
+ (fdopen 4 "wl")
+ (current-error-port))))
+ ;; Redirect diagnostics to file descriptor 4 as well.
+ (guix-warning-port (current-error-port))
+
+ (mkdir-p %narinfo-cache-directory)
+ (maybe-remove-expired-cache-entries %narinfo-cache-directory
+ cached-narinfo-files
+ #:entry-expiration
+ cached-narinfo-expiration-time
+ #:cleanup-period
+ %narinfo-expired-cache-entry-removal-delay)
+ (check-acl-initialized)
+
+ ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error
+ ;; message.
+ (for-each validate-uri (substitute-urls))
+
+ ;; Attempt to install the client's locale so that messages are suitably
+ ;; translated. LC_CTYPE must be a UTF-8 locale; it's the case by default
+ ;; so don't change it.
+ (match (or (find-daemon-option "untrusted-locale")
+ (find-daemon-option "locale"))
+ (#f #f)
+ (locale (false-if-exception (setlocale LC_MESSAGES locale))))
+
+ (catch 'system-error
+ (lambda ()
+ (set-thread-name "guix substitute"))
+ (const #t)) ;GNU/Hurd lacks 'prctl'
+
+ (with-networking
+ (with-error-handling ; for signature errors
+ (match args
+ (("--query")
+ (let ((acl (current-acl)))
+ (let loop ((command (read-line)))
+ (or (eof-object? command)
+ (begin
+ (process-query command
+ #:cache-urls (substitute-urls)
+ #:acl acl)
+ (loop (read-line)))))))
+ (("--substitute")
+ ;; Download STORE-PATH and store it as a Nar in file DESTINATION.
+ ;; Specify the number of columns of the terminal so the progress
+ ;; report displays nicely.
+ (parameterize ((current-terminal-columns (client-terminal-columns)))
+ (let loop ()
+ (match (read-line)
+ ((? eof-object?)
+ #t)
+ ((= string-tokenize ("substitute" store-path destination))
+ (process-substitution store-path destination
+ #:cache-urls (substitute-urls)
+ #:acl (current-acl)
+ #:deduplicate? deduplicate?
+ #:print-build-trace?
+ print-build-trace?)
+ (loop))))))
+ ((or ("-V") ("--version"))
+ (show-version-and-exit "guix substitute"))
+ (("--help")
+ (show-help))
+ (opts
+ (leave (G_ "~a: unrecognized options~%") opts)))))))
;;; Local Variables:
;;; eval: (put 'with-timeout 'scheme-indent-function 1)
+;;; eval: (put 'with-cached-connection 'scheme-indent-function 2)
+;;; eval: (put 'call-with-cached-connection 'scheme-indent-function 1)
;;; End:
;;; substitute.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff