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 2013-04-15 23:42:27 +02:00
parent 63b7c6c1f8
commit eba783b7b2
3 changed files with 156 additions and 11 deletions

View File

@ -22,6 +22,7 @@
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix nar) #:use-module (guix nar)
#:use-module ((guix build utils) #:select (mkdir-p))
#:use-module (ice-9 rdelim) #:use-module (ice-9 rdelim)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -30,6 +31,7 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (web uri) #:use-module (web uri)
#:use-module (web client) #:use-module (web client)
@ -47,6 +49,36 @@
;;; ;;;
;;; Code: ;;; 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) (define (fields->alist port)
"Read recutils-style record from PORT and return them as a list of key/value "Read recutils-style record from PORT and return them as a list of key/value
pairs." pairs."
@ -72,6 +104,17 @@ pairs."
(let ((args (map (cut assoc-ref alist <>) keys))) (let ((args (map (cut assoc-ref alist <>) keys)))
(apply make args))) (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) (define (fetch uri)
"Return a binary input port to URI and the number of bytes it's expected to "Return a binary input port to URI and the number of bytes it's expected to
provide." provide."
@ -161,22 +204,113 @@ failure."
(_ deriver)) (_ deriver))
system))) 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) (define (fetch-narinfo cache path)
"Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH." "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH."
(define (download 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))) (false-if-exception (fetch (string->uri url))))
fields->alist))
(and=> (download (string-append (cache-url cache) "/" (and=> (download (string-append (cache-url cache) "/"
(store-path-hash-part path) (store-path-hash-part path)
".narinfo")) ".narinfo"))
(lambda (properties) (cute read-narinfo <> (cache-url cache))))
(alist->record properties (narinfo-maker (cache-url cache))
'("StorePath" "URL" "Compression" (define (lookup-narinfo cache path)
"FileHash" "FileSize" "NarHash" "NarSize" "Check locally if we have valid info about PATH, otherwise go to CACHE and
"References" "Deriver" "System"))))) 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) (define (filtered-port command input)
"Return an input port (and PID) where data drained from INPUT is filtered "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) (define (guix-substitute-binary . args)
"Implement the build daemon's substituter protocol." "Implement the build daemon's substituter protocol."
(mkdir-p %narinfo-cache-directory)
(match args (match args
(("--query") (("--query")
(let ((cache (open-cache %cache-url))) (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. ;; Return the subset of PATHS available in CACHE.
(let ((substitutable (let ((substitutable
(if cache (if cache
(par-map (cut fetch-narinfo cache <>) (par-map (cut lookup-narinfo cache <>)
paths) paths)
'()))) '())))
(for-each (lambda (narinfo) (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. ;; Reply info about PATHS if it's in CACHE.
(let ((substitutable (let ((substitutable
(if cache (if cache
(par-map (cut fetch-narinfo cache <>) (par-map (cut lookup-narinfo cache <>)
paths) paths)
'()))) '())))
(for-each (lambda (narinfo) (for-each (lambda (narinfo)
@ -263,7 +398,7 @@ through COMMAND. INPUT must be a file input port."
(("--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 (open-cache %cache-url))
(narinfo (fetch-narinfo cache store-path)) (narinfo (lookup-narinfo cache store-path))
(uri (narinfo-uri narinfo))) (uri (narinfo-uri narinfo)))
;; Tell the daemon what the expected hash of the Nar itself is. ;; Tell the daemon what the expected hash of the Nar itself is.
(format #t "~a~%" (narinfo-hash narinfo)) (format #t "~a~%" (narinfo-hash narinfo))

View File

@ -45,9 +45,13 @@ then
rm -rf "$NIX_STATE_DIR/substituter-data" rm -rf "$NIX_STATE_DIR/substituter-data"
mkdir -p "$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 \ export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR \
NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_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. # Do that because store.scm calls `canonicalize-path' on it.
mkdir -p "$NIX_STORE_DIR" mkdir -p "$NIX_STORE_DIR"

View File

@ -159,6 +159,12 @@ Deriver: ~a~%"
(%current-system) ; System (%current-system) ; System
(basename d)))) ; Deriver (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. ;; Make sure `substitute-binary' correctly communicates the above data.
(set-build-options s #:use-substitutes? #t) (set-build-options s #:use-substitutes? #t)
(and (has-substitutes? s o) (and (has-substitutes? s o)