kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

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

Browse Source 
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.
This commit is contained in:
Ludovic Courtès 2020-12-19 22:59:01 +01:00
parent 56bfc71f0b
commit 87b0001325
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 47 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
guix/cache.scm
View File

@ -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

44
guix/git.scm
View File

@ -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