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