substitute-binary: Add a local cache.
* guix/scripts/substitute-binary.scm (%narinfo-cache-directory, %narinfo-ttl, %narinfo-negative-ttl): New variables. (with-atomic-file-output, object->fields, read-narinfo, write-narinfo, narinfo->string, string->narinfo, lookup-narinfo): New procedures. (fetch-narinfo): Adjust to use `read-narinfo'. (guix-substitute-binary): Ensure the existence of %NARINFO-CACHE-DIRECTORY. Use `lookup-narinfo' instead of `fetch-narinfo'.
This commit is contained in:
Ludovic Courtès
parent
63b7c6c1f8
commit
eba783b7b2
|
|
@ -22,6 +22,7 @@
|
|||
#:use-module (guix utils)
|
||||
#:use-module (guix config)
|
||||
#:use-module (guix nar)
|
||||
#:use-module ((guix build utils) #:select (mkdir-p))
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 match)
|
||||
|
|
@ -30,6 +31,7 @@
|
|||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (srfi srfi-19)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (web uri)
|
||||
#:use-module (web client)
|
||||
|
|
@ -47,6 +49,36 @@
|
|||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define %narinfo-cache-directory
|
||||
;; A local cache of narinfos, to avoid going to the network.
|
||||
(or (and=> (getenv "XDG_CACHE_HOME")
|
||||
(cut string-append <> "/guix/substitute-binary"))
|
||||
(string-append %state-directory "/substitute-binary/cache")))
|
||||
|
||||
(define %narinfo-ttl
|
||||
;; Number of seconds during which cached narinfo lookups are considered
|
||||
;; valid.
|
||||
(* 24 3600))
|
||||
|
||||
(define %narinfo-negative-ttl
|
||||
;; Likewise, but for negative lookups---i.e., cached lookup failures.
|
||||
(* 3 3600))
|
||||
|
||||
(define (with-atomic-file-output file proc)
|
||||
"Call PROC with an output port for the file that is going to replace FILE.
|
||||
Upon success, FILE is atomically replaced by what has been written to the
|
||||
output port, and PROC's result is returned."
|
||||
(let* ((template (string-append file ".XXXXXX"))
|
||||
(out (mkstemp! template)))
|
||||
(with-throw-handler #t
|
||||
(lambda ()
|
||||
(let ((result (proc out)))
|
||||
(close out)
|
||||
(rename-file template file)
|
||||
result))
|
||||
(lambda (key . args)
|
||||
(false-if-exception (delete-file template))))))
|
||||
|
||||
(define (fields->alist port)
|
||||
"Read recutils-style record from PORT and return them as a list of key/value
|
||||
pairs."
|
||||
|
|
@ -72,6 +104,17 @@ pairs."
|
|||
(let ((args (map (cut assoc-ref alist <>) keys)))
|
||||
(apply make args)))
|
||||
|
||||
(define (object->fields object fields port)
|
||||
"Write OBJECT (typically a record) as a series of recutils-style fields to
|
||||
PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs."
|
||||
(let loop ((fields fields))
|
||||
(match fields
|
||||
(()
|
||||
object)
|
||||
(((field . get) rest ...)
|
||||
(format port "~a: ~a~%" field (get object))
|
||||
(loop rest)))))
|
||||
|
||||
(define (fetch uri)
|
||||
"Return a binary input port to URI and the number of bytes it's expected to
|
||||
provide."
|
||||
|
|
@ -161,22 +204,113 @@ failure."
|
|||
(_ deriver))
|
||||
system)))
|
||||
|
||||
(define* (read-narinfo port #:optional url)
|
||||
"Read a narinfo from PORT in its standard external form. If URL is true, it
|
||||
must be a string used to build full URIs from relative URIs found while
|
||||
reading PORT."
|
||||
(alist->record (fields->alist port)
|
||||
(narinfo-maker url)
|
||||
'("StorePath" "URL" "Compression"
|
||||
"FileHash" "FileSize" "NarHash" "NarSize"
|
||||
"References" "Deriver" "System")))
|
||||
|
||||
(define (write-narinfo narinfo port)
|
||||
"Write NARINFO to PORT."
|
||||
(define (empty-string-if-false x)
|
||||
(or x ""))
|
||||
|
||||
(define (number-or-empty-string x)
|
||||
(if (number? x)
|
||||
(number->string x)
|
||||
""))
|
||||
|
||||
(object->fields narinfo
|
||||
`(("StorePath" . ,narinfo-path)
|
||||
("URL" . ,(compose uri->string narinfo-uri))
|
||||
("Compression" . ,narinfo-compression)
|
||||
("FileHash" . ,(compose empty-string-if-false
|
||||
narinfo-file-hash))
|
||||
("FileSize" . ,(compose number-or-empty-string
|
||||
narinfo-file-size))
|
||||
("NarHash" . ,(compose empty-string-if-false
|
||||
narinfo-hash))
|
||||
("NarSize" . ,(compose number-or-empty-string
|
||||
narinfo-size))
|
||||
("References" . ,(compose string-join narinfo-references))
|
||||
("Deriver" . ,(compose empty-string-if-false
|
||||
narinfo-deriver))
|
||||
("System" . ,narinfo-system))
|
||||
port))
|
||||
|
||||
(define (narinfo->string narinfo)
|
||||
"Return the external representation of NARINFO."
|
||||
(call-with-output-string (cut write-narinfo narinfo <>)))
|
||||
|
||||
(define (string->narinfo str)
|
||||
"Return the narinfo represented by STR."
|
||||
(call-with-input-string str (cut read-narinfo <>)))
|
||||
|
||||
(define (fetch-narinfo cache path)
|
||||
"Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH."
|
||||
(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))
|
||||
(false-if-exception (fetch (string->uri url))))
|
||||
|
||||
(and=> (download (string-append (cache-url cache) "/"
|
||||
(store-path-hash-part path)
|
||||
".narinfo"))
|
||||
(lambda (properties)
|
||||
(alist->record properties (narinfo-maker (cache-url cache))
|
||||
'("StorePath" "URL" "Compression"
|
||||
"FileHash" "FileSize" "NarHash" "NarSize"
|
||||
"References" "Deriver" "System")))))
|
||||
(cute read-narinfo <> (cache-url cache))))
|
||||
|
||||
(define (lookup-narinfo cache path)
|
||||
"Check locally if we have valid info about PATH, otherwise go to CACHE and
|
||||
check what it has."
|
||||
(define now
|
||||
(current-time time-monotonic))
|
||||
|
||||
(define (->time seconds)
|
||||
(make-time time-monotonic 0 seconds))
|
||||
|
||||
(define (obsolete? date ttl)
|
||||
(time>? (subtract-duration now (make-time time-duration 0 ttl))
|
||||
(->time date)))
|
||||
|
||||
(define cache-file
|
||||
(string-append %narinfo-cache-directory "/"
|
||||
(store-path-hash-part path)))
|
||||
|
||||
(define (cache-entry narinfo)
|
||||
`(narinfo (version 0)
|
||||
(date ,(time-second now))
|
||||
(value ,(and=> narinfo narinfo->string))))
|
||||
|
||||
(let*-values (((valid? cached)
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(call-with-input-file cache-file
|
||||
(lambda (p)
|
||||
(match (read p)
|
||||
(('narinfo ('version 0) ('date date)
|
||||
('value #f))
|
||||
;; A cached negative lookup.
|
||||
(if (obsolete? date %narinfo-negative-ttl)
|
||||
(values #f #f)
|
||||
(values #t #f)))
|
||||
(('narinfo ('version 0) ('date date)
|
||||
('value value))
|
||||
;; A cached positive lookup
|
||||
(if (obsolete? date %narinfo-ttl)
|
||||
(values #f #f)
|
||||
(values #t (string->narinfo value))))))))
|
||||
(lambda _
|
||||
(values #f #f)))))
|
||||
(if valid?
|
||||
cached ; including negative caches
|
||||
(let ((narinfo (fetch-narinfo cache path)))
|
||||
(with-atomic-file-output cache-file
|
||||
(lambda (out)
|
||||
(write (cache-entry narinfo) out)))
|
||||
narinfo))))
|
||||
|
||||
(define (filtered-port command input)
|
||||
"Return an input port (and PID) where data drained from INPUT is filtered
|
||||
|
|
@ -214,6 +348,7 @@ through COMMAND. INPUT must be a file input port."
|
|||
|
||||
(define (guix-substitute-binary . args)
|
||||
"Implement the build daemon's substituter protocol."
|
||||
(mkdir-p %narinfo-cache-directory)
|
||||
(match args
|
||||
(("--query")
|
||||
(let ((cache (open-cache %cache-url)))
|
||||
|
|
@ -225,7 +360,7 @@ through COMMAND. INPUT must be a file input port."
|
|||
;; Return the subset of PATHS available in CACHE.
|
||||
(let ((substitutable
|
||||
(if cache
|
||||
(par-map (cut fetch-narinfo cache <>)
|
||||
(par-map (cut lookup-narinfo cache <>)
|
||||
paths)
|
||||
'())))
|
||||
(for-each (lambda (narinfo)
|
||||
|
|
@ -237,7 +372,7 @@ through COMMAND. INPUT must be a file input port."
|
|||
;; Reply info about PATHS if it's in CACHE.
|
||||
(let ((substitutable
|
||||
(if cache
|
||||
(par-map (cut fetch-narinfo cache <>)
|
||||
(par-map (cut lookup-narinfo cache <>)
|
||||
paths)
|
||||
'())))
|
||||
(for-each (lambda (narinfo)
|
||||
|
|
@ -263,7 +398,7 @@ through COMMAND. INPUT must be a file input port."
|
|||
(("--substitute" store-path destination)
|
||||
;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
|
||||
(let* ((cache (open-cache %cache-url))
|
||||
(narinfo (fetch-narinfo cache store-path))
|
||||
(narinfo (lookup-narinfo cache store-path))
|
||||
(uri (narinfo-uri narinfo)))
|
||||
;; Tell the daemon what the expected hash of the Nar itself is.
|
||||
(format #t "~a~%" (narinfo-hash narinfo))
|
||||
|
|
|
|||
|
|
@ -45,9 +45,13 @@ then
|
|||
rm -rf "$NIX_STATE_DIR/substituter-data"
|
||||
mkdir -p "$NIX_STATE_DIR/substituter-data"
|
||||
|
||||
# Place for the substituter's cache.
|
||||
XDG_CACHE_HOME="$NIX_STATE_DIR/cache-$$"
|
||||
|
||||
export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR \
|
||||
NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR \
|
||||
NIX_ROOT_FINDER NIX_SETUID_HELPER GUIX_BINARY_SUBSTITUTE_URL
|
||||
NIX_ROOT_FINDER NIX_SETUID_HELPER GUIX_BINARY_SUBSTITUTE_URL \
|
||||
XDG_CACHE_HOME
|
||||
|
||||
# Do that because store.scm calls `canonicalize-path' on it.
|
||||
mkdir -p "$NIX_STORE_DIR"
|
||||
|
|
|
|||
|
|
@ -159,6 +159,12 @@ Deriver: ~a~%"
|
|||
(%current-system) ; System
|
||||
(basename d)))) ; Deriver
|
||||
|
||||
;; Remove entry from the local cache.
|
||||
(false-if-exception
|
||||
(delete-file (string-append (getenv "XDG_CACHE_HOME")
|
||||
"/guix/substitute-binary/"
|
||||
(store-path-hash-part o))))
|
||||
|
||||
;; Make sure `substitute-binary' correctly communicates the above data.
|
||||
(set-build-options s #:use-substitutes? #t)
|
||||
(and (has-substitutes? s o)
|
||||
|
|
|
|||
Loading…
Reference in New Issue