03/06: substitute: Store cached narinfo in cache-specific sub-directories.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 895d1eda547708dd46074a2dd2f934de275fb102
Author: Ludovic Courtès <address@hidden>
Date:   Mon Jul 13 15:52:29 2015 +0200

    substitute: Store cached narinfo in cache-specific sub-directories.
    
    This ensures that switching between different substitute servers doesn't 
lead
    to a polluted narinfo cache.
    
    * guix/scripts/substitute.scm (narinfo-cache-file): Add 'cache-url'
      parameter.  Add the base32 of CACHE-URL as a sub-directory under
      %NARINFO-CACHE-DIRECTORY.  Update callers.
      (cached-narinfo): Likewise.  Call 'mkdir-p' on the dirname of the cache
      file.  Update callers.
      (remove-expired-cached-narinfos): Add 'directory' parameter and use it
      instead of %NARINFO-CACHE-DIRECTORY.
      (narinfo-cache-directories): New procedure.
      (maybe-remove-expired-cached-narinfo): Call 
'remove-expired-cached-narinfos'
      for each item returned by 'narinfo-cache-directories'.
---
 guix/scripts/substitute.scm |   58 ++++++++++++++++++++++++++++---------------
 tests/store.scm             |    6 ++--
 2 files changed, 41 insertions(+), 23 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 0e61f2f..df5234d 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -25,6 +25,7 @@
   #:use-module (guix records)
   #:use-module (guix serialization)
   #:use-module (guix hash)
+  #:use-module (guix base32)
   #:use-module (guix base64)
   #:use-module (guix pk-crypto)
   #:use-module (guix pki)
@@ -371,20 +372,23 @@ the cache STR originates form."
           (make-time time-monotonic 0 date)))
 
 
-(define (narinfo-cache-file path)
-  "Return the name of the local file that contains an entry for PATH."
+(define (narinfo-cache-file cache-url path)
+  "Return the name of the local file that contains an entry for PATH.  The
+entry is stored in a sub-directory specific to CACHE-URL."
   (string-append %narinfo-cache-directory "/"
-                 (store-path-hash-part path)))
-
-(define (cached-narinfo path)
-  "Check locally if we have valid info about PATH.  Return two values: a
-Boolean indicating whether we have valid cached info, and that info, which may
-be either #f (when PATH is unavailable) or the narinfo for PATH."
+                 (bytevector->base32-string (sha256 (string->utf8 cache-url)))
+                 "/" (store-path-hash-part path)))
+
+(define (cached-narinfo cache-url path)
+  "Check locally if we have valid info about PATH coming from CACHE-URL.
+Return two values: a Boolean indicating whether we have valid cached info, and
+that info, which may be either #f (when PATH is unavailable) or the narinfo
+for PATH."
   (define now
     (current-time time-monotonic))
 
   (define cache-file
-    (narinfo-cache-file path))
+    (narinfo-cache-file cache-url path))
 
   (catch 'system-error
     (lambda ()
@@ -422,9 +426,12 @@ may be #f, in which case it indicates that PATH is 
unavailable at CACHE-URL."
               (date ,(time-second now))
               (value ,(and=> narinfo narinfo->string))))
 
-  (with-atomic-file-output (narinfo-cache-file path)
-    (lambda (out)
-      (write (cache-entry cache-url narinfo) out)))
+  (let ((file (narinfo-cache-file cache-url path)))
+    (mkdir-p (dirname file))
+    (with-atomic-file-output file
+      (lambda (out)
+        (write (cache-entry cache-url narinfo) out))))
+
   narinfo)
 
 (define (narinfo-request cache-url path)
@@ -553,7 +560,7 @@ information is available locally."
   (let-values (((cached missing)
                 (fold2 (lambda (path cached missing)
                          (let-values (((valid? value)
-                                       (cached-narinfo path)))
+                                       (cached-narinfo cache path)))
                            (if valid?
                                (values (cons value cached) missing)
                                (values cached (cons path missing)))))
@@ -571,8 +578,8 @@ found."
   (match (lookup-narinfos cache (list path))
     ((answer) answer)))
 
-(define (remove-expired-cached-narinfos)
-  "Remove expired narinfo entries from the cache.  The sole purpose of this
+(define (remove-expired-cached-narinfos directory)
+  "Remove expired narinfo entries from DIRECTORY.  The sole purpose of this
 function is to make sure `%narinfo-cache-directory' doesn't grow
 indefinitely."
   (define now
@@ -596,16 +603,25 @@ indefinitely."
         #t)))
 
   (for-each (lambda (file)
-              (let ((file (string-append %narinfo-cache-directory
-                                         "/" file)))
+              (let ((file (string-append directory "/" file)))
                 (when (expired? file)
                   ;; Wrap in `false-if-exception' because FILE might have been
                   ;; deleted in the meantime (TOCTTOU).
                   (false-if-exception (delete-file file)))))
-            (scandir %narinfo-cache-directory
+            (scandir directory
                      (lambda (file)
                        (= (string-length file) 32)))))
 
+(define (narinfo-cache-directories)
+  "Return the list of narinfo cache directories (one per cache URL.)"
+  (map (cut string-append %narinfo-cache-directory "/" <>)
+       (scandir %narinfo-cache-directory
+                (lambda (item)
+                  (and (not (member item '("." "..")))
+                       (file-is-directory?
+                        (string-append %narinfo-cache-directory
+                                       "/" item)))))))
+
 (define (maybe-remove-expired-cached-narinfo)
   "Remove expired narinfo entries from the cache if deemed necessary."
   (define now
@@ -619,8 +635,10 @@ indefinitely."
          (call-with-input-file expiry-file read))
         0))
 
-  (when (obsolete? last-expiry-date now 
%narinfo-expired-cache-entry-removal-delay)
-    (remove-expired-cached-narinfos)
+  (when (obsolete? last-expiry-date now
+                   %narinfo-expired-cache-entry-removal-delay)
+    (for-each remove-expired-cached-narinfos
+              (narinfo-cache-directories))
     (call-with-output-file expiry-file
       (cute write (time-second now) <>))))
 
diff --git a/tests/store.scm b/tests/store.scm
index faa924f..f2d6d51 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -25,6 +25,7 @@
   #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module (guix serialization)
+  #:use-module (guix build utils)
   #:use-module (guix gexp)
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
@@ -371,9 +372,8 @@
       (with-derivation-narinfo d
         ;; Remove entry from the local cache.
         (false-if-exception
-         (delete-file (string-append (getenv "XDG_CACHE_HOME")
-                                     "/guix/substitute/"
-                                     (store-path-hash-part o))))
+         (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
+                                                 "/guix/substitute")))
 
         ;; Make sure 'guix substitute' correctly communicates the above
         ;; data.