diff options
Diffstat (limited to 'guix/scripts/substitute.scm')
| -rwxr-xr-x | guix/scripts/substitute.scm | 243 |
1 files changed, 165 insertions, 78 deletions
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index feae2df9cb..25075eedff 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -88,6 +88,7 @@ write-narinfo %allow-unauthenticated-substitutes? + %error-to-file-descriptor-4? substitute-urls guix-substitute)) @@ -124,11 +125,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 @@ -191,9 +188,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) @@ -209,7 +211,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) @@ -220,10 +222,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~%") @@ -481,17 +484,17 @@ 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 @@ -893,6 +896,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. @@ -962,6 +968,68 @@ 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?) + "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." + (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? #f)) + ((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)) + (begin + ;; Drain input left from the previous use. + (drain-input socket) + socket)))))))) + +(define (call-with-cached-connection uri proc) + (let ((port (open-connection-for-uri/cached 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. + (if (or (and (eq? key 'system-error) + (= EPIPE (system-error-errno `(,key ,@args)))) + (memq key '(bad-response bad-header bad-header-component))) + (proc (open-connection-for-uri/cached 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?) "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to @@ -984,10 +1052,12 @@ DESTINATION as a nar file. Verify the substitute against ACL." (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") @@ -1001,7 +1071,9 @@ 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 @@ -1017,7 +1089,10 @@ 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)) + + ;; Tell the daemon that we're done. + (display "success\n" (current-output-port))))) ;;; @@ -1128,6 +1203,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") @@ -1139,71 +1219,78 @@ 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) + ;; 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)) - ;; 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)) + (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)) + ;; 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)))) + ;; 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' + (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)))))) + (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) + #: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) ;;; End: ;;; substitute.scm ends here |