Browse Source

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'.
gn-latest-20200428
Ludovic Courtès 8 years ago
parent
commit
eba783b7b2
3 changed files with 156 additions and 11 deletions
  1. +145
    -10
      guix/scripts/substitute-binary.scm
  2. +5
    -1
      test-env.in
  3. +6
    -0
      tests/store.scm

+ 145
- 10
guix/scripts/substitute-binary.scm View File

@ -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))


+ 5
- 1
test-env.in View File

@ -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"


+ 6
- 0
tests/store.scm View File

@ -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…
Cancel
Save