From: "Ludovic Courtès" <ludo@gnu.org>
To: 45327@debbugs.gnu.org
Subject: [bug#45327] [PATCH v2] git: Periodically delete least-recently-used cached checkouts.
Date: Thu, 7 Jan 2021 11:09:47 +0100 [thread overview]
Message-ID: <20210107100947.31189-1-ludo@gnu.org> (raw)
In-Reply-To: <86wnx97try.fsf@gmail.com>
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.
---
guix/cache.scm | 9 +++++----
guix/git.scm | 44 ++++++++++++++++++++++++++++++++++++++++++--
2 files changed, 47 insertions(+), 6 deletions(-)
Hi! This v2 changes two things:
• Increase the default expiration time to three months;
• Check the mtime rather than the atime of checkouts.
As zimoun proposed, I agree that we should make the expiration time
configurable. I started doing that but that requires ‘string->duration’,
which is currently in (guix ui), and this code is supposed to be
“UI-free”. So I’d first like to move this and similar tools to a new
(guix units) module…
Thoughts?
Ludo’.
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
--
2.29.2
next prev parent reply other threads:[~2021-01-07 10:11 UTC|newest]
Thread overview: 11+ messages / expand[flat|nested] mbox.gz Atom feed top
2020-12-19 22:06 [bug#45327] [PATCH] git: Periodically delete least-recently-used cached checkouts Ludovic Courtès
2020-12-20 10:46 ` 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 ` Ludovic Courtès [this message]
2021-01-07 12:40 ` [bug#45327] [PATCH v2] " 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=20210107100947.31189-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.