kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

substitute: Warn upon store prefix mismatches.

Browse Source 
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.
This commit is contained in:
Ludovic Courtès 2015-11-28 00:02:23 +01:00
parent 6629099a63
commit ae4427e3f3
1 changed files with 27 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
guix/scripts/substitute.scm
View File

@ -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