Commit | Line | Data |
---|---|---|
2ea2aac6 | 1 | ;;; GNU Guix --- Functional package management for GNU |
87b00013 | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
104b4e25 | 3 | ;;; Copyright © 2022 Simon Tournier <zimon.toutoune@gmail.com> |
2ea2aac6 LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix cache) | |
104b4e25 | 21 | #:use-module ((guix utils) #:select (with-atomic-file-output)) |
2ea2aac6 LC |
22 | #:use-module (srfi srfi-19) |
23 | #:use-module (srfi srfi-26) | |
24 | #:use-module (ice-9 match) | |
104b4e25 | 25 | #:use-module ((ice-9 textual-ports) #:select (get-string-all)) |
2ea2aac6 LC |
26 | #:export (obsolete? |
27 | delete-file* | |
28 | file-expiration-time | |
29 | remove-expired-cache-entries | |
30 | maybe-remove-expired-cache-entries)) | |
31 | ||
32 | ;;; Commentary: | |
33 | ;;; | |
34 | ;;; This module provides tools to manage a simple on-disk cache consisting of | |
35 | ;;; individual files. | |
36 | ;;; | |
37 | ;;; Code: | |
38 | ||
39 | (define (obsolete? date now ttl) | |
40 | "Return #t if DATE is obsolete compared to NOW + TTL seconds." | |
41 | (time>? (subtract-duration now (make-time time-duration 0 ttl)) | |
42 | (make-time time-monotonic 0 date))) | |
43 | ||
44 | (define (delete-file* file) | |
45 | "Like 'delete-file', but does not raise an error when FILE does not exist." | |
46 | (catch 'system-error | |
47 | (lambda () | |
48 | (delete-file file)) | |
49 | (lambda args | |
50 | (unless (= ENOENT (system-error-errno args)) | |
51 | (apply throw args))))) | |
52 | ||
87b00013 | 53 | (define* (file-expiration-time ttl #:optional (timestamp stat:atime)) |
2ea2aac6 | 54 | "Return a procedure that, when passed a file, returns its \"expiration |
87b00013 LC |
55 | time\" computed as its timestamp + TTL seconds. Call TIMESTAMP to obtain the |
56 | relevant timestamp from the result of 'stat'." | |
2ea2aac6 LC |
57 | (lambda (file) |
58 | (match (stat file #f) | |
59 | (#f 0) ;FILE may have been deleted in the meantime | |
87b00013 | 60 | (st (+ (timestamp st) ttl))))) |
2ea2aac6 LC |
61 | |
62 | (define* (remove-expired-cache-entries entries | |
63 | #:key | |
64 | (now (current-time time-monotonic)) | |
65 | (entry-expiration | |
66 | (file-expiration-time 3600)) | |
67 | (delete-entry delete-file*)) | |
68 | "Given ENTRIES, a list of file names, remove those whose expiration time, | |
69 | as returned by ENTRY-EXPIRATION, has passed. Use DELETE-ENTRY to delete | |
70 | them." | |
71 | (for-each (lambda (entry) | |
72 | (when (<= (entry-expiration entry) (time-second now)) | |
73 | (delete-entry entry))) | |
74 | entries)) | |
75 | ||
76 | (define* (maybe-remove-expired-cache-entries cache | |
77 | cache-entries | |
78 | #:key | |
79 | (entry-expiration | |
80 | (file-expiration-time 3600)) | |
81 | (delete-entry delete-file*) | |
82 | (cleanup-period (* 24 3600))) | |
83 | "Remove expired narinfo entries from the cache if deemed necessary. Call | |
84 | CACHE-ENTRIES with CACHE to retrieve the list of cache entries. | |
85 | ||
86 | ENTRY-EXPIRATION must be a procedure that, when passed an entry, returns the | |
87 | expiration time of that entry in seconds since the Epoch. DELETE-ENTRY is a | |
88 | procedure that removes the entry passed as an argument. Finally, | |
89 | CLEANUP-PERIOD denotes the minimum time between two cache cleanups." | |
90 | (define now | |
91 | (current-time time-monotonic)) | |
92 | ||
93 | (define expiry-file | |
94 | (string-append cache "/last-expiry-cleanup")) | |
95 | ||
96 | (define last-expiry-date | |
97 | (catch 'system-error | |
98 | (lambda () | |
104b4e25 | 99 | (or (string->number |
100 | (call-with-input-file expiry-file get-string-all)) | |
101 | 0)) | |
2ea2aac6 LC |
102 | (const 0))) |
103 | ||
104 | (when (obsolete? last-expiry-date now cleanup-period) | |
105 | (remove-expired-cache-entries (cache-entries cache) | |
106 | #:now now | |
107 | #:entry-expiration entry-expiration | |
108 | #:delete-entry delete-entry) | |
2cb0b370 LC |
109 | (catch 'system-error |
110 | (lambda () | |
104b4e25 | 111 | (with-atomic-file-output expiry-file |
2cb0b370 LC |
112 | (cute write (time-second now) <>))) |
113 | (lambda args | |
114 | ;; ENOENT means CACHE does not exist. | |
115 | (unless (= ENOENT (system-error-errno args)) | |
116 | (apply throw args)))))) | |
2ea2aac6 LC |
117 | |
118 | ;;; cache.scm ends here |