mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-25 13:58:15 -05:00
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.
This commit is contained in:
parent
6629099a63
commit
ae4427e3f3
1 changed files with 27 additions and 21 deletions
|
@ -565,31 +565,37 @@ (define (handle-narinfo-response request response port result)
|
|||
(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
|
||||
|
|
Loading…
Reference in a new issue