TakeV/guix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

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

Browse source 
* 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 @@ (define* (fetch uri #:key (buffered? #t) (timeout? #t) (quiet-404? #f))
(setvbuf port _IONBF)))
(http-fetch uri #:text? #f #:port port))))))))
(define-record-type <cache>
(%make-cache url store-directory wants-mass-query?)
cache?
(url cache-url)
(store-directory cache-store-directory)
(wants-mass-query? cache-wants-mass-query?))
(define-record-type <cache-info>
(%make-cache-info url store-directory wants-mass-query?)
cache-info?
(url cache-info-url)
(store-directory cache-info-store-directory)
(wants-mass-query? cache-info-wants-mass-query?))
(define (open-cache url)
"Open the binary cache at URL. Return a <cache> object on success, or #f on
failure."
(define (download-cache-info url)
(define (download-cache-info url)
"Download the information for the cache at URL. Return a <cache-info>
object on success, or #f on failure."
(define (download url)
;; Download the `nix-cache-info' from URL, and return its contents as an
;; list of key/value pairs.
(and=> (false-if-exception (fetch (string->uri url)))
fields->alist))
(and=> (download-cache-info (string-append url "/nix-cache-info"))
(and=> (download (string-append url "/nix-cache-info"))
(lambda (properties)
(alist->record properties
(cut %make-cache url <...>)
(cut %make-cache-info url <...>)
'("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>
(%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size
references deriver system signature contents)
@ -418,9 +410,9 @@ (define cache-file
(lambda _
(values #f #f))))
(define (cache-narinfo! cache path narinfo)
"Cache locally NARNIFO for PATH, which originates from CACHE. NARINFO may
be #f, in which case it indicates that PATH is unavailable at CACHE."
(define (cache-narinfo! cache-url path narinfo)
"Cache locally NARNIFO for PATH, which originates from CACHE-URL. NARINFO
may be #f, in which case it indicates that PATH is unavailable at CACHE-URL."
(define now
(current-time time-monotonic))
@ -432,7 +424,7 @@ (define (cache-entry cache-uri narinfo)
(with-atomic-file-output (narinfo-cache-file path)
(lambda (out)
(write (cache-entry (cache-url cache) narinfo) out)))
(write (cache-entry cache-url narinfo) out)))
narinfo)
(define (narinfo-request cache-url path)
@ -491,11 +483,8 @@ (define (narinfo-from-file file url)
#f
(apply throw args)))))
(define (fetch-narinfos cache paths)
"Retrieve all the narinfos for PATHS from CACHE and return them."
(define url
(cache-url cache))
(define (fetch-narinfos url paths)
"Retrieve all the narinfos for PATHS from the cache at URL and return them."
(define update-progress!
(let ((done 0))
(lambda ()
@ -513,7 +502,7 @@ (define (handle-narinfo-response request response port)
(case (response-code response)
((200) ; hit
(let ((narinfo (read-narinfo port url #:size len)))
(cache-narinfo! cache (narinfo-path narinfo) narinfo)
(cache-narinfo! url (narinfo-path narinfo) narinfo)
(update-progress!)
narinfo))
((404) ; failure
@ -522,7 +511,7 @@ (define (handle-narinfo-response request response port)
(if len
(get-bytevector-n port len)
(read-to-eof port))
(cache-narinfo! cache
(cache-narinfo! url
(find (cut string-contains <> hash-part) paths)
#f)
(update-progress!))
@ -533,7 +522,12 @@ (define (handle-narinfo-response request response port)
(read-to-eof port))
#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)))
(case (and=> uri uri-scheme)
((http)
@ -568,11 +562,8 @@ (define (lookup-narinfos cache paths)
paths)))
(if (null? missing)
cached
(let* ((cache (force cache))
(missing (if cache
(fetch-narinfos cache missing)
'())))
(append cached missing)))))
(let ((missing (fetch-narinfos cache missing)))
(append cached (or missing '()))))))
(define (lookup-narinfo cache path)
"Return the narinfo for PATH in CACHE, or #f when no substitute for PATH was
@ -788,7 +779,7 @@ (define (guix-substitute . args)
(with-error-handling ; for signature errors
(match args
(("--query")
(let ((cache (open-cache* %cache-url))
(let ((cache %cache-url)
(acl (current-acl)))
(define (valid? obj)
(and (narinfo? obj) (valid-narinfo? obj acl)))
@ -831,7 +822,7 @@ (define (valid? obj)
(loop (read-line)))))))
(("--substitute" store-path 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))
(uri (narinfo-uri narinfo)))
;; Make sure it is signed and everything.