From d72b42064b3cdeca7adbf13cce00faff5b61472a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 18 Apr 2017 23:12:35 +0200
Subject: [PATCH] publish: Remove expired cache entries when '--ttl' is used.

* guix/scripts/publish.scm (narinfo-files): New procedure.
(render-narinfo/cached)[delete-file]: New procedure.  Add call to
'maybe-remove-expired-cache-entries'.
* doc/guix.texi (Invoking guix publish): Document the interation between
--cache and --ttl.
---
 doc/guix.texi            |  6 ++++++
 guix/scripts/publish.scm | 31 +++++++++++++++++++++++++++++--
 2 files changed, 35 insertions(+), 2 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index bbb2ba732d..f2eba59d9c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6600,6 +6600,9 @@ The ``baking'' process is performed by worker threads.  By default, one
 thread per CPU core is created, but this can be customized.  See
 @option{--workers} below.
 
+When @option{--ttl} is used, cached entries are automatically deleted
+when they have expired.
+
 @item --workers=@var{N}
 When @option{--cache} is used, request the allocation of @var{N} worker
 threads to ``bake'' archives.
@@ -6614,6 +6617,9 @@ This allows the user's Guix to keep substitute information in cache for
 guarantee that the store items it provides will indeed remain available
 for as long as @var{ttl}.
 
+Additionally, when @option{--cache} is used, cached entries that have
+not been accessed for @var{ttl} may be deleted.
+
 @item --nar-path=@var{path}
 Use @var{path} as the prefix for the URLs of ``nar'' files
 (@pxref{Invoking guix archive, normalized archives}).
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 70d914d60c..9dc006e7ab 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -50,11 +50,13 @@ (define-module (guix scripts publish)
   #:use-module (guix store)
   #:use-module ((guix serialization) #:select (write-file))
   #:use-module (guix zlib)
+  #:use-module (guix cache)
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module ((guix utils)
                 #:select (with-atomic-file-output compressed-file?))
-  #:use-module ((guix build utils) #:select (dump-port mkdir-p))
+  #:use-module ((guix build utils)
+                #:select (dump-port mkdir-p find-files))
   #:export (%public-key
             %private-key
 
@@ -365,6 +367,14 @@ (define-syntax-rule (single-baker item exp ...)
   (run-single-baker item (lambda () exp ...)))
 
 
+(define (narinfo-files cache)
+  "Return the list of .narinfo files under CACHE."
+  (if (file-is-directory? cache)
+      (find-files cache
+                  (lambda (file stat)
+                    (string-suffix? ".narinfo" file)))
+      '()))
+
 (define* (render-narinfo/cached store request hash
                                 #:key ttl (compression %no-compression)
                                 (nar-path "nar")
@@ -372,6 +382,14 @@ (define* (render-narinfo/cached store request hash
   "Respond to the narinfo request for REQUEST.  If the narinfo is available in
 CACHE, then send it; otherwise, return 404 and \"bake\" that nar and narinfo
 requested using POOL."
+  (define (delete-entry narinfo)
+    ;; Delete NARINFO and the corresponding nar from CACHE.
+    (let ((nar (string-append (string-drop-right narinfo
+                                                 (string-length ".narinfo"))
+                              ".nar")))
+      (delete-file* narinfo)
+      (delete-file* nar)))
+
   (let* ((item        (hash-part->path store hash))
          (compression (actual-compression item compression))
          (cached      (and (not (string-null? item))
@@ -398,7 +416,16 @@ (define* (render-narinfo/cached store request hash
                (bake-narinfo+nar cache item
                                  #:ttl ttl
                                  #:compression compression
-                                 #:nar-path nar-path)))
+                                 #:nar-path nar-path))
+
+             (when ttl
+               (single-baker 'cache-cleanup
+                 (maybe-remove-expired-cache-entries cache
+                                                     narinfo-files
+                                                     #:entry-expiration
+                                                     (file-expiration-time ttl)
+                                                     #:delete-entry delete-entry
+                                                     #:cleanup-period ttl))))
            (not-found request))
           (else
            (not-found request)))))