Package: guix-patches;
Reported by: Ludovic Courtès <ludo <at> gnu.org>
Date: Sat, 19 Dec 2020 22:07:01 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Ludovic Courtès <ludo <at> gnu.org> To: 45327 <at> debbugs.gnu.org Cc: Guillaume Le Vaillant <glv <at> posteo.net>, Ludovic Courtès <ludo <at> gnu.org>, zimoun <zimon.toutoune <at> gmail.com> Subject: [bug#45327] [PATCH v2] git: Periodically delete least-recently-used cached checkouts. Date: Thu, 7 Jan 2021 11:09:47 +0100
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 <at> gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020, 2021 Ludovic Courtès <ludo <at> 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 <at> gmail.com>
-;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo <at> 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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.