git: Periodically delete least-recently-used cached checkouts.

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/cache.scm (file-expiration-time): Add optional 'timestamp'
parameter and honor it.

2 files changed, 47 insertions, 6 deletions

diff --git a/guix/cache.scm b/guix/cache.scm
index feff131068..0401a9d428 100644
--- a/guix/cache.scm
+++ b/guix/cache.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -47,13 +47,14 @@
       (unless (= ENOENT (system-error-errno args))
         (apply throw args)))))
 
-(define (file-expiration-time ttl)
+(define* (file-expiration-time ttl #:optional (timestamp stat:atime))
   "Return a procedure that, when passed a file, returns its \"expiration
-time\" computed as its last-access time + TTL seconds."
+time\" computed as its timestamp + TTL seconds.  Call TIMESTAMP to obtain the
+relevant timestamp from the result of 'stat'."
   (lambda (file)
     (match (stat file #f)
       (#f 0)                       ;FILE may have been deleted in the meantime
-      (st (+ (stat:atime st) ttl)))))
+      (st (+ (timestamp st) ttl)))))
 
 (define* (remove-expired-cache-entries entries
                                        #:key
diff --git a/guix/git.scm b/guix/git.scm
index ca77b9f54b..a5103547d3 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -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,24 @@ definitely available in REPOSITORY, false otherwise."
     (_
      #f)))
 
+(define cached-checkout-expiration
+  ;; Return the expiration time procedure for a cached checkout.
+  ;; TODO: Honor $GUIX_GIT_CACHE_EXPIRATION.
+
+  ;; Use the mtime rather than the atime to cope with file systems mounted
+  ;; with 'noatime'.
+  (file-expiration-time (* 90 24 3600) stat:mtime))
+
+(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 +362,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 +416,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