diff options
Diffstat (limited to 'guix/scripts/substitute.scm')
| -rwxr-xr-x | guix/scripts/substitute.scm | 438 |
1 files changed, 316 insertions, 122 deletions
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index ddb885d344..e53de8c304 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -26,7 +26,11 @@ #:use-module (guix combinators) #:use-module (guix config) #:use-module (guix records) - #:use-module ((guix serialization) #:select (restore-file)) + #: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) @@ -39,6 +43,7 @@ (open-connection-for-uri . guix:open-connection-for-uri) store-path-abbreviation byte-count->string)) + #:autoload (gnutls) (error/invalid-session) #:use-module (guix progress) #:use-module ((guix build syscalls) #:select (set-thread-name)) @@ -87,6 +92,7 @@ write-narinfo %allow-unauthenticated-substitutes? + %error-to-file-descriptor-4? substitute-urls guix-substitute)) @@ -123,11 +129,7 @@ disabled!~%")) ;; purposes, and should be avoided otherwise. (make-parameter (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") - (cut string-ci=? <> "yes")) - (lambda (value) - (when value - (warn-about-missing-authentication)) - value))) + (cut string-ci=? <> "yes")))) (define %narinfo-ttl ;; Number of seconds during which cached narinfo lookups are considered @@ -190,9 +192,14 @@ again." (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) @@ -208,7 +215,7 @@ provide." ;; sudo tc qdisc add dev eth0 root netem delay 1500ms ;; and then cancel with: ;; sudo tc qdisc del dev eth0 root - (let ((port #f)) + (let ((port port)) (with-timeout (if timeout? %fetch-timeout 0) @@ -219,10 +226,11 @@ provide." (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 'none))) + uri #:verify-certificate? #f))) + (unless (or buffered? (not (file-port? port))) + (setvbuf port 'none)) (http-fetch uri #:text? #f #:port port + #:keep-alive? keep-alive? #:verify-certificate? #f)))))) (else (leave (G_ "unsupported substitute URI scheme: ~a~%") @@ -252,6 +260,18 @@ provide." ;; for more information. (contents narinfo-contents)) +(define (narinfo-hash-algorithm+value narinfo) + "Return two values: the hash algorithm used by NARINFO and its value as a +bytevector." + (match (string-tokenize (narinfo-hash narinfo) + (char-set-complement (char-set #\:))) + ((algorithm base32) + (values (lookup-hash-algorithm (string->symbol algorithm)) + (nix-base32-string->bytevector base32))) + (_ + (raise (formatted-message + (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo)))))) + (define (narinfo-hash->sha256 hash) "If the string HASH denotes a sha256 hash, return it as a bytevector. Otherwise return #f." @@ -480,27 +500,33 @@ indicates that PATH is unavailable at CACHE-URL." (build-request (string->uri url) #:method 'GET #:headers headers))) (define (at-most max-length lst) - "If LST is shorter than MAX-LENGTH, return it; otherwise return its -MAX-LENGTH first elements." + "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 (() - (reverse result)) + (values (reverse result) '())) ((head . tail) (if (>= len max-length) - (reverse result) + (values (reverse result) lst) (loop (+ 1 len) tail (cons head result))))))) (define* (http-multiple-get base-uri proc seed requests #:key port (verify-certificate? #t) + (open-connection guix:open-connection-for-uri) + (keep-alive? #t) (batch-size 1000)) "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." +'fold'. Return the final result. + +When PORT is specified, use it as the initial connection on which HTTP +requests are sent; otherwise call OPEN-CONNECTION to open a new connection for +a URI. When KEEP-ALIVE? is false, close the connection port before +returning." (let connect ((port port) (requests requests) (result seed)) @@ -509,10 +535,9 @@ initial connection on which HTTP requests are sent." ;; (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?)))) + (let ((p (or port (open-connection 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 'block (expt 2 16))) @@ -537,7 +562,8 @@ initial connection on which HTTP requests are sent." (() (match (drop requests processed) (() - (close-port p) + (unless keep-alive? + (close-port p)) (reverse result)) (remainder (connect p remainder result)))) @@ -579,18 +605,18 @@ if file doesn't exist, and the narinfo otherwise." (define* (open-connection-for-uri/maybe uri #:key - (verify-certificate? #f) + fresh? (time %fetch-timeout)) - "Open a connection to URI and return a port to it, or, if connection failed, -print a warning and return #f." + "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 () - (guix:open-connection-for-uri uri - #:verify-certificate? verify-certificate? - #:timeout time)) + (open-connection-for-uri/cached uri #:timeout time + #:fresh? fresh?)) (match-lambda* (('getaddrinfo-error error) (unless (hash-ref %unreachable-hosts host) @@ -664,23 +690,26 @@ print a warning and return #f." (define (do-fetch uri) (case (and=> uri uri-scheme) ((http https) - (let ((requests (map (cut narinfo-request url <>) paths))) - (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))))) + ;; 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 (call-with-cached-connection uri + (lambda (port) + (if port + (begin + (update-progress!) + (http-multiple-get uri + handle-narinfo-response '() + requests + #:open-connection + open-connection-for-uri/cached + #:verify-certificate? #f + #:port port)) + '())) + open-connection-for-uri/maybe))) + (newline (current-error-port)) + result)) ((file #f) (let* ((base (string-append (uri-path uri) "/")) (files (map (compose (cut string-append base <> ".narinfo") @@ -892,6 +921,9 @@ authorized substitutes." (define (valid? obj) (valid-narinfo? obj acl)) + (when (%allow-unauthenticated-substitutes?) + (warn-about-missing-authentication)) + (match (string-tokenize command) (("have" paths ..1) ;; Return the subset of PATHS available in CACHE-URLS. @@ -961,32 +993,121 @@ the URI, its compression method (a string), and the compressed file size." (((uri compression file-size) _ ...) (values uri compression file-size)))) +(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 print-build-trace?) + #: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." +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 (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))) - ;; Tell the daemon what the expected hash of the Nar itself is. - (format #t "~a~%" (narinfo-hash 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* ((dl-size (or download-size (and (equal? compression "none") @@ -1000,15 +1121,28 @@ DESTINATION as a nar file. Verify the substitute against ACL." (uri->string uri) dl-size (current-error-port) #:abbreviation nar-uri-abbreviation)))) - (progress-report-port reporter raw))) + ;; Keep RAW open upon completion so we can later reuse + ;; the underlying connection. + (progress-report-port reporter raw #:close? #f))) ((input pids) ;; 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))) + 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) + (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. @@ -1016,7 +1150,19 @@ DESTINATION as a nar file. Verify the substitute against ACL." ;; Skip a line after what 'progress-reporter/file' printed, and another ;; one to visually separate substitutions. - (display "\n\n" (current-error-port))))) + (display "\n\n" (current-error-port)) + + ;; 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))))))) ;;; @@ -1078,9 +1224,40 @@ found." ;; daemon. '("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 %default-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 @@ -1096,6 +1273,11 @@ default value." (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") @@ -1107,71 +1289,83 @@ default value." ((= string->number number) (> number 0)) (_ #f))) - (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? (substitute-urls)) - (exit 0)) - - ;; Say hello (see above.) - (newline) - (force-output (current-output-port)) - - ;; 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" 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 (substitute-urls) - #:acl (current-acl) - #:print-build-trace? print-build-trace?))) - ((or ("-V") ("--version")) - (show-version-and-exit "guix substitute")) - (("--help") - (show-help)) - (opts - (leave (G_ "~a: unrecognized options~%") opts)))))) + (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 |