diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/lint.scm | 7 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 113 |
2 files changed, 60 insertions, 60 deletions
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index f135bde9df..27b9e155ec 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -20,7 +20,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts lint) - #:use-module (guix store) + #:use-module ((guix store) #:hide (close-connection)) #:use-module (guix base32) #:use-module (guix download) #:use-module (guix ftp-client) @@ -41,7 +41,8 @@ #:use-module (web uri) #:use-module ((guix build download) #:select (maybe-expand-mirrors - open-connection-for-uri)) + open-connection-for-uri + close-connection)) #:use-module (web request) #:use-module (web response) #:use-module (srfi srfi-1) @@ -296,7 +297,7 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." (force-output port) (read-response port)) (lambda () - (close port)))) + (close-connection port)))) (case (response-code response) ((301 302 307) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 524d453ffa..4563f3df0f 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -19,7 +19,7 @@ (define-module (guix scripts substitute) #:use-module (guix ui) - #:use-module (guix store) + #:use-module ((guix store) #:hide (close-connection)) #:use-module (guix utils) #:use-module (guix config) #:use-module (guix records) @@ -33,6 +33,7 @@ #:use-module ((guix build download) #:select (progress-proc uri-abbreviation open-connection-for-uri + close-connection store-path-abbreviation byte-count->string)) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) @@ -108,15 +109,18 @@ disabled!~%")) (define %narinfo-ttl ;; Number of seconds during which cached narinfo lookups are considered - ;; valid. This is a reasonable default value (corresponds to the TTL for - ;; nginx's .nar cache on hydra.gnu.org) but we'd rather want publishers to - ;; state what their TTL is in /nix-cache-info. (XXX) + ;; valid for substitute servers that do not advertise a TTL via the + ;; 'Cache-Control' response header. (* 36 3600)) (define %narinfo-negative-ttl - ;; Likewise, but for negative lookups---i.e., cached lookup failures. + ;; Likewise, but for negative lookups---i.e., cached lookup failures (404). (* 3 3600)) +(define %narinfo-transient-error-ttl + ;; Likewise, but for transient errors such as 504 ("Gateway timeout"). + (* 10 60)) + (define %narinfo-expired-cache-entry-removal-delay ;; How often we want to remove files corresponding to expired cache entries. (* 7 24 3600)) @@ -197,7 +201,7 @@ provide." (unless (or (guile-version>? "2.0.9") (version>? (version) "2.0.9.39")) (when port - (close-port port)))) + (close-connection port)))) (begin (when (or (not port) (port-closed? port)) (set! port (open-connection-for-uri uri)) @@ -242,7 +246,7 @@ failure, return #f and #f." (uri->string (http-get-error-uri c)) (http-get-error-code c) (http-get-error-reason c)) - (close-port port) + (close-connection port) (warning (_ "ignoring substitute server at '~s'~%") url) (values #f #f))) (values (read-cache-info (http-fetch uri @@ -452,18 +456,18 @@ for PATH." (call-with-input-file cache-file (lambda (p) (match (read p) - (('narinfo ('version 1) + (('narinfo ('version 2) ('cache-uri cache-uri) - ('date date) ('value #f)) + ('date date) ('ttl _) ('value #f)) ;; A cached negative lookup. (if (obsolete? date now %narinfo-negative-ttl) (values #f #f) (values #t #f))) - (('narinfo ('version 1) + (('narinfo ('version 2) ('cache-uri cache-uri) - ('date date) ('value value)) + ('date date) ('ttl ttl) ('value value)) ;; A cached positive lookup - (if (obsolete? date now %narinfo-ttl) + (if (obsolete? date now ttl) (values #f #f) (values #t (string->narinfo value cache-uri)))) (('narinfo ('version v) _ ...) @@ -471,16 +475,19 @@ for PATH." (lambda _ (values #f #f)))) -(define (cache-narinfo! cache-url path narinfo) - "Cache locally NARNIFO for PATH, which originates from CACHE-URL. NARINFO -may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." +(define (cache-narinfo! cache-url path narinfo ttl) + "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the +given TTL (a number of seconds or #f). NARINFO may be #f, in which case it +indicates that PATH is unavailable at CACHE-URL." (define now (current-time time-monotonic)) (define (cache-entry cache-uri narinfo) - `(narinfo (version 1) + `(narinfo (version 2) (cache-uri ,cache-uri) (date ,(time-second now)) + (ttl ,(or ttl + (if narinfo %narinfo-ttl %narinfo-negative-ttl))) (value ,(and=> narinfo narinfo->string)))) (let ((file (narinfo-cache-file cache-url path))) @@ -549,7 +556,7 @@ initial connection on which HTTP requests are sent." ;; Note that even upon "Connection: close", we can read from BODY. (match (assq 'connection (response-headers resp)) (('connection 'close) - (close-port p) + (close-connection p) (connect #f tail result)) ;try again (_ (loop tail result)))))))))) ;keep going @@ -583,31 +590,30 @@ if file doesn't exist, and the narinfo otherwise." (set! done (+ 1 done))))) (define (handle-narinfo-response request response port result) - (let ((len (response-content-length response))) + (let* ((code (response-code response)) + (len (response-content-length response)) + (cache (response-cache-control response)) + (ttl (and cache (assoc-ref cache 'max-age)))) ;; Make sure to read no more than LEN bytes since subsequent bytes may ;; belong to the next response. - (case (response-code response) - ((200) ; hit - (let ((narinfo (read-narinfo port url #:size len))) - (cache-narinfo! url (narinfo-path narinfo) narinfo) - (update-progress!) - (cons narinfo result))) - ((404) ; failure - (let* ((path (uri-path (request-uri request))) - (hash-part (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) - (update-progress!) - result)) - (else ; transient failure - (if len - (get-bytevector-n port len) - (read-to-eof port)) - result)))) + (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)) + (let* ((path (uri-path (request-uri request))) + (hash-part (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) + ttl + %narinfo-transient-error-ttl)) + (update-progress!) + result)))) (define (do-fetch uri port) (case (and=> uri uri-scheme) @@ -618,8 +624,7 @@ if file doesn't exist, and the narinfo otherwise." handle-narinfo-response '() requests #:port port))) - (unless (port-closed? port) - (close-port port)) + (close-connection port) (newline (current-error-port)) result))) ((file #f) @@ -641,7 +646,7 @@ if file doesn't exist, and the narinfo otherwise." (begin (warning (_ "'~a' uses different store '~a'; ignoring it~%") url (cache-info-store-directory cache-info)) - (close-port port) + (close-connection port) #f))))) (define (lookup-narinfos cache paths) @@ -704,12 +709,12 @@ indefinitely." (call-with-input-file file (lambda (port) (match (read port) - (('narinfo ('version 1) ('cache-uri _) ('date date) - ('value #f)) + (('narinfo ('version 2) ('cache-uri _) + ('date date) ('ttl _) ('value #f)) (obsolete? date now %narinfo-negative-ttl)) - (('narinfo ('version 1) ('cache-uri _) ('date date) - ('value _)) - (obsolete? date now %narinfo-ttl)) + (('narinfo ('version 2) ('cache-uri _) + ('date date) ('ttl ttl) ('value _)) + (obsolete? date now ttl)) (_ #t))))) (lambda args ;; FILE may have been deleted. @@ -771,7 +776,7 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by (make-custom-binary-input-port "progress-port-proc" read! #f #f - (cut close-port port))) + (cut close-connection port))) (define-syntax with-networking (syntax-rules () @@ -949,15 +954,9 @@ substitutes may be unavailable\n"))))) found." (assoc-ref (daemon-options) option)) -(define-syntax-rule (or* a b) - (let ((first a)) - (if (or (not first) (string-null? first)) - b - first))) - (define %cache-urls - (match (and=> (or* (find-daemon-option "untrusted-substitute-urls") ;client - (find-daemon-option "substitute-urls")) ;admin + (match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client + (find-daemon-option "substitute-urls")) ;admin string-tokenize) ((urls ...) urls) |