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