[bug#45327] [PATCH] git: Periodically delete least-recently-used cached checkouts.

[Ludovic Courtès]

This ensures ~/.cache/guix/checkouts is periodically cleaned up.

* guix/git.scm (cached-checkout-expiration)
(%checkout-cache-cleanup-period): New variables.
(delete-checkout): New procedure.
(update-cached-checkout)[cache-entries]: New procedure.
Add call to 'maybe-remove-expired-cache-entries'.
---
 guix/git.scm | 38 +++++++++++++++++++++++++++++++++++++-
 1 file changed, 37 insertions(+), 1 deletion(-)

Hi!

I noticed that my ~/.cache/guix/checkouts directory had accumulated
a lot of cruft from channels, playing with ‘--with-branch’ and such,
and that it would be nice to clean it up once in a while.

This is what this patch does.  It uses the (guix cache) default
strategy, which consists in deleting least-recently-used items by
looking at their atime.

Thoughts?

Ludo’.

diff --git a/guix/git.scm b/guix/git.scm
index ca77b9f54b..5df11db38e 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -23,8 +23,10 @@
   #:use-module (git submodule)
   #:use-module (guix i18n)
   #:use-module (guix base32)
+  #:use-module (guix cache)
   #:use-module (gcrypt hash)
-  #:use-module ((guix build utils) #:select (mkdir-p))
+  #:use-module ((guix build utils)
+                #:select (mkdir-p delete-file-recursively))
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix records)
@@ -35,6 +37,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 ftw)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-34)
@@ -318,6 +321,20 @@ definitely available in REPOSITORY, false otherwise."
     (_
      #f)))
 
+(define cached-checkout-expiration
+  ;; Return the expiration time of a cached checkout.
+  (file-expiration-time (* 30 24 3600)))
+
+(define %checkout-cache-cleanup-period
+  ;; Period for the removal of expired cached checkouts.
+  (* 5 24 3600))
+
+(define (delete-checkout directory)
+  "Delete DIRECTORY recursively, in an atomic fashion."
+  (let ((trashed (string-append directory ".trashed")))
+    (rename-file directory trashed)
+    (delete-file-recursively trashed)))
+
 (define* (update-cached-checkout url
                                  #:key
                                  (ref '(branch . "master"))
@@ -341,6 +358,14 @@ When RECURSIVE? is true, check out submodules as well, if 
any.
 
 When CHECK-OUT? is true, reset the cached working tree to REF; otherwise leave
 it unchanged."
+  (define (cache-entries directory)
+    (filter-map (match-lambda
+                  ((or "." "..")
+                   #f)
+                  (file
+                   (string-append directory "/" file)))
+                (or (scandir directory) '())))
+
   (define canonical-ref
     ;; We used to require callers to specify "origin/" for each branch, which
     ;; made little sense since the cache should be transparent to them.  So
@@ -387,6 +412,17 @@ it unchanged."
        ;; REPOSITORY as soon as possible.
        (repository-close! repository)
 
+       ;; When CACHE-DIRECTORY is a sub-directory of the default cache
+       ;; directory, remove expired checkouts that are next to it.
+       (let ((parent (dirname cache-directory)))
+         (when (string=? parent (%repository-cache-directory))
+           (maybe-remove-expired-cache-entries parent cache-entries
+                                               #:entry-expiration
+                                               cached-checkout-expiration
+                                               #:delete-entry delete-checkout
+                                               #:cleanup-period
+                                               
%checkout-cache-cleanup-period)))
+
        (values cache-directory (oid->string oid) relation)))))
 
 (define* (latest-repository-commit store url
-- 
2.29.2