From: "Ludovic Courtès" <ludo@gnu.org>
To: 45327@debbugs.gnu.org
Subject: [bug#45327] [PATCH] git: Periodically delete least-recently-used cached checkouts.
Date: Sat, 19 Dec 2020 23:06:30 +0100 [thread overview]
Message-ID: <20201219220630.24605-1-ludo@gnu.org> (raw)
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
next reply other threads:[~2020-12-19 22:07 UTC|newest]
Thread overview: 11+ messages / expand[flat|nested] mbox.gz Atom feed top
2020-12-19 22:06 Ludovic Courtès [this message]
2020-12-20 10:46 ` [bug#45327] [PATCH] git: Periodically delete least-recently-used cached checkouts Guillaume Le Vaillant
2020-12-20 13:47 ` Ludovic Courtès
2020-12-20 14:16 ` Guillaume Le Vaillant
2020-12-21 10:26 ` zimoun
2020-12-22 13:33 ` Ludovic Courtès
2020-12-22 15:19 ` zimoun
2021-01-07 9:39 ` Ludovic Courtès
2021-01-07 10:09 ` [bug#45327] [PATCH v2] " Ludovic Courtès
2021-01-07 12:40 ` zimoun
2021-01-13 15:47 ` bug#45327: [PATCH] " Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20201219220630.24605-1-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=45327@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.