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'.

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)