nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

substitute: Pass the cache URL instead of <cache> objects. 

* guix/scripts/substitute.scm (<cache>): Rename to...
  (<cache-info>): ... this.
  (open-cache): Rename to...
  (download-cache-info): ... this.  Return a <cache-info> or #f.
  (open-cache*): Remove.
  (cache-narinfo!): Take a URL instead of a <cache> as the first parameter.
  (fetch-narinfos): Likewise.  Call 'download-cache-info'.  Remove use of
  'force'.
  (guix-substitute): Replace calls to 'open-cache*' with %CACHE-URL.
This commit is contained in:
Ludovic Courtès 2015-07-13 11:38:31 +02:00
parent e4e099feca
commit 074efd63a8
1 changed files with 31 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
guix/scripts/substitute.scm
View File

@ -184,37 +184,29 @@ to the caller without emitting an error message."
(setvbuf port _IONBF))) (setvbuf port _IONBF)))
(http-fetch uri #:text? #f #:port port)))))))) (http-fetch uri #:text? #f #:port port))))))))
(define-record-type <cache> (define-record-type <cache-info>
(%make-cache url store-directory wants-mass-query?) (%make-cache-info url store-directory wants-mass-query?)
cache? cache-info?
(url cache-url) (url cache-info-url)
(store-directory cache-store-directory) (store-directory cache-info-store-directory)
(wants-mass-query? cache-wants-mass-query?)) (wants-mass-query? cache-info-wants-mass-query?))
(define (open-cache url) (define (download-cache-info url)
"Open the binary cache at URL. Return a <cache> object on success, or #f on "Download the information for the cache at URL. Return a <cache-info>
failure." object on success, or #f on failure."
(define (download-cache-info url) (define (download url)
;; Download the `nix-cache-info' from URL, and return its contents as an ;; Download the `nix-cache-info' from URL, and return its contents as an
;; list of key/value pairs. ;; list of key/value pairs.
(and=> (false-if-exception (fetch (string->uri url))) (and=> (false-if-exception (fetch (string->uri url)))
fields->alist)) fields->alist))
(and=> (download-cache-info (string-append url "/nix-cache-info")) (and=> (download (string-append url "/nix-cache-info"))
(lambda (properties) (lambda (properties)
(alist->record properties (alist->record properties
(cut %make-cache url <...>) (cut %make-cache-info url <...>)
'("StoreDir" "WantMassQuery"))))) '("StoreDir" "WantMassQuery")))))
(define-syntax-rule (open-cache* url)
"Delayed variant of 'open-cache' that also lets the user know that they're
gonna have to wait."
(delay (begin
(format (current-error-port)
(_ "updating list of substitutes from '~a'...\r")
url)
(open-cache url))))
(define-record-type <narinfo> (define-record-type <narinfo>
(%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size (%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size
references deriver system signature contents) references deriver system signature contents)
@ -418,9 +410,9 @@ be either #f (when PATH is unavailable) or the narinfo for PATH."
(lambda _ (lambda _
(values #f #f)))) (values #f #f))))
(define (cache-narinfo! cache path narinfo) (define (cache-narinfo! cache-url path narinfo)
"Cache locally NARNIFO for PATH, which originates from CACHE. NARINFO may "Cache locally NARNIFO for PATH, which originates from CACHE-URL. NARINFO
be #f, in which case it indicates that PATH is unavailable at CACHE." may be #f, in which case it indicates that PATH is unavailable at CACHE-URL."
(define now (define now
(current-time time-monotonic)) (current-time time-monotonic))
@ -432,7 +424,7 @@ be #f, in which case it indicates that PATH is unavailable at CACHE."
(with-atomic-file-output (narinfo-cache-file path) (with-atomic-file-output (narinfo-cache-file path)
(lambda (out) (lambda (out)
(write (cache-entry (cache-url cache) narinfo) out))) (write (cache-entry cache-url narinfo) out)))
narinfo) narinfo)
(define (narinfo-request cache-url path) (define (narinfo-request cache-url path)
@ -491,11 +483,8 @@ if file doesn't exist, and the narinfo otherwise."
#f #f
(apply throw args))))) (apply throw args)))))
(define (fetch-narinfos cache paths) (define (fetch-narinfos url paths)
"Retrieve all the narinfos for PATHS from CACHE and return them." "Retrieve all the narinfos for PATHS from the cache at URL and return them."
(define url
(cache-url cache))
(define update-progress! (define update-progress!
(let ((done 0)) (let ((done 0))
(lambda () (lambda ()
@ -513,7 +502,7 @@ if file doesn't exist, and the narinfo otherwise."
(case (response-code response) (case (response-code response)
((200) ; hit ((200) ; hit
(let ((narinfo (read-narinfo port url #:size len))) (let ((narinfo (read-narinfo port url #:size len)))
(cache-narinfo! cache (narinfo-path narinfo) narinfo) (cache-narinfo! url (narinfo-path narinfo) narinfo)
(update-progress!) (update-progress!)
narinfo)) narinfo))
((404) ; failure ((404) ; failure
@ -522,7 +511,7 @@ if file doesn't exist, and the narinfo otherwise."
(if len (if len
(get-bytevector-n port len) (get-bytevector-n port len)
(read-to-eof port)) (read-to-eof port))
(cache-narinfo! cache (cache-narinfo! url
(find (cut string-contains <> hash-part) paths) (find (cut string-contains <> hash-part) paths)
#f) #f)
(update-progress!)) (update-progress!))
@ -533,7 +522,12 @@ if file doesn't exist, and the narinfo otherwise."
(read-to-eof port)) (read-to-eof port))
#f)))) #f))))
(and (string=? (cache-store-directory cache) (%store-prefix)) (define cache-info
(download-cache-info url))
(and cache-info
(string=? (cache-info-store-directory cache-info)
(%store-prefix))
(let ((uri (string->uri url))) (let ((uri (string->uri url)))
(case (and=> uri uri-scheme) (case (and=> uri uri-scheme)
((http) ((http)
@ -568,11 +562,8 @@ information is available locally."
paths))) paths)))
(if (null? missing) (if (null? missing)
cached cached
(let* ((cache (force cache)) (let ((missing (fetch-narinfos cache missing)))
(missing (if cache (append cached (or missing '()))))))
(fetch-narinfos cache missing)
'())))
(append cached missing)))))
(define (lookup-narinfo cache path) (define (lookup-narinfo cache path)
"Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was "Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was
@ -788,7 +779,7 @@ substituter disabled~%")
(with-error-handling ; for signature errors (with-error-handling ; for signature errors
(match args (match args
(("--query") (("--query")
(let ((cache (open-cache* %cache-url)) (let ((cache %cache-url)
(acl (current-acl))) (acl (current-acl)))
(define (valid? obj) (define (valid? obj)
(and (narinfo? obj) (valid-narinfo? obj acl))) (and (narinfo? obj) (valid-narinfo? obj acl)))
@ -831,7 +822,7 @@ substituter disabled~%")
(loop (read-line))))))) (loop (read-line)))))))
(("--substitute" store-path destination) (("--substitute" store-path destination)
;; Download STORE-PATH and add store it as a Nar in file DESTINATION. ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
(let* ((cache (open-cache* %cache-url)) (let* ((cache %cache-url)
(narinfo (lookup-narinfo cache store-path)) (narinfo (lookup-narinfo cache store-path))
(uri (narinfo-uri narinfo))) (uri (narinfo-uri narinfo)))
;; Make sure it is signed and everything. ;; Make sure it is signed and everything.