aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xguix/scripts/substitute-binary.scm155
-rw-r--r--test-env.in6
-rw-r--r--tests/store.scm6
3 files changed, 156 insertions, 11 deletions
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 2b447ce7f2..453a29a5ea 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -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))
diff --git a/test-env.in b/test-env.in
index 9a6257197c..64440fb86a 100644
--- a/test-env.in
+++ b/test-env.in
@@ -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"
diff --git a/tests/store.scm b/tests/store.scm
index 4ee20a9352..677e39e75d 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -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)