summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-11-28 00:02:23 +0100
committerLudovic Courtès <ludo@gnu.org>2015-11-28 00:02:23 +0100
commitae4427e3f39a32094ced6206ae4bcd12683f9127 (patch)
treeb13e8356f58c94afc373f5a2306be8db4fe07e34
parent6629099a635118a9fd72892ec4b13442b811059c (diff)
downloadgnu-guix-ae4427e3f39a32094ced6206ae4bcd12683f9127.tar
gnu-guix-ae4427e3f39a32094ced6206ae4bcd12683f9127.tar.gz
substitute: Warn upon store prefix mismatches.
Suggested by Hynek Urban <hynek.urban@gmail.com>. * guix/scripts/substitute.scm (fetch-narinfos): Move body to... [do-fetch]: ... here. New procedure. Emit a warning when CACHE-INFO's prefix does not match.
-rwxr-xr-xguix/scripts/substitute.scm48
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