diff options
| -rwxr-xr-x | guix/scripts/substitute.scm | 48 |
1 files changed, 27 insertions, 21 deletions
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 964df9422c..01cc3f129e 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -565,31 +565,37 @@ if file doesn't exist, and the narinfo otherwise." (read-to-eof port)) result)))) + (define (do-fetch uri) + (case (and=> uri uri-scheme) + ((http) + (let ((requests (map (cut narinfo-request url <>) paths))) + (update-progress!) + (let ((result (http-multiple-get url + handle-narinfo-response '() + requests))) + (newline (current-error-port)) + result))) + ((file #f) + (let* ((base (string-append (uri-path uri) "/")) + (files (map (compose (cut string-append base <> ".narinfo") + store-path-hash-part) + paths))) + (filter-map (cut narinfo-from-file <> url) files))) + (else + (leave (_ "~s: unsupported server URI scheme~%") + (if uri (uri-scheme uri) url))))) + (define cache-info (download-cache-info url)) (and cache-info - (string=? (cache-info-store-directory cache-info) - (%store-prefix)) - (let ((uri (string->uri url))) - (case (and=> uri uri-scheme) - ((http) - (let ((requests (map (cut narinfo-request url <>) paths))) - (update-progress!) - (let ((result (http-multiple-get url - handle-narinfo-response '() - requests))) - (newline (current-error-port)) - result))) - ((file #f) - (let* ((base (string-append (uri-path uri) "/")) - (files (map (compose (cut string-append base <> ".narinfo") - store-path-hash-part) - paths))) - (filter-map (cut narinfo-from-file <> url) files))) - (else - (leave (_ "~s: unsupported server URI scheme~%") - (if uri (uri-scheme uri) url))))))) + (if (string=? (cache-info-store-directory cache-info) + (%store-prefix)) + (do-fetch (string->uri url)) + (begin + (warning (_ "'~a' uses different store '~a'; ignoring it~%") + url (cache-info-store-directory cache-info)) + #f)))) (define (lookup-narinfos cache paths) "Return the narinfos for PATHS, invoking the server at CACHE when no |