projects/guix·blob master · refs

124 lines · 4.4 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2017, 2020, 2024 Ludovic Courtès <[email protected]>
3;;; Copyright © 2022 Simon Tournier <[email protected]>
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 (test-cache)
21 #:use-module (guix cache)
22 #:use-module (srfi srfi-1)
23 #:use-module (srfi srfi-19)
24 #:use-module (srfi srfi-64)
25 #:use-module ((guix build syscalls) #:select (lock-file))
26 #:use-module ((guix utils) #:select (call-with-temporary-directory))
27 #:use-module ((rnrs io ports) #:select (get-string-all))
28 #:use-module (ice-9 match))
29
30(test-begin "cache")
31
32(test-equal "remove-expired-cache-entries"
33 '("o" "l" "d")
34 (let* ((removed '())
35 (now (time-second (current-time time-monotonic)))
36 (ttl 100)
37 (stamp (match-lambda
38 ((or "n" "e" "w") (+ now 100))
39 ((or "o" "l" "d") (- now 100))))
40 (delete (lambda (entry)
41 (set! removed (cons entry removed)))))
42 (remove-expired-cache-entries (reverse '("n" "e" "w"
43 "o" "l" "d"))
44 #:entry-expiration stamp
45 #:delete-entry delete)
46 removed))
47
48(define-syntax-rule (test-cache-cleanup cache exp ...)
49 (call-with-temporary-directory
50 (lambda (cache)
51 (let* ((deleted '())
52 (delete! (lambda (entry)
53 (set! deleted (cons entry deleted)))))
54 exp ...
55 (maybe-remove-expired-cache-entries cache
56 (const '("a" "b" "c"))
57 #:entry-expiration (const 0)
58 #:delete-entry delete!)
59 (reverse deleted)))))
60
61(test-equal "maybe-remove-expired-cache-entries, first cleanup"
62 '("a" "b" "c")
63 (test-cache-cleanup cache))
64
65(test-equal "maybe-remove-expired-cache-entries, no cleanup needed"
66 '()
67 (test-cache-cleanup cache
68 (call-with-output-file (string-append cache "/last-expiry-cleanup")
69 (lambda (port)
70 (display (+ (time-second (current-time time-monotonic)) 100)
71 port)))))
72
73(test-equal "maybe-remove-expired-cache-entries, cleanup needed"
74 '("a" "b" "c")
75 (test-cache-cleanup cache
76 (call-with-output-file (string-append cache "/last-expiry-cleanup")
77 (lambda (port)
78 (display 0 port)))))
79
80(let ((pid #f))
81 (test-equal "maybe-remove-expired-cache-entries, cleanup needed but lock taken"
82 '()
83 (test-cache-cleanup cache
84 (let ((in+out (pipe)))
85 (match (primitive-fork)
86 (0 (dynamic-wind
87 (const #t)
88 (lambda ()
89 (close-port (car in+out))
90 (let ((port (lock-file
91 (string-append cache "/last-expiry-cleanup"))))
92 (display 0 port)
93 (display "done!\n" (cdr in+out))
94 (close-port (cdr in+out))
95 (sleep 100)))
96 (lambda ()
97 (primitive-exit 0))))
98 (n
99 (set! pid n)
100 (close-port (cdr in+out))
101 (pk 'chr (get-string-all (car in+out)))
102 (close-port (car in+out)))))))
103
104 (when pid (kill pid SIGKILL)))
105
106(test-equal "maybe-remove-expired-cache-entries, empty cache"
107 '("a" "b" "c")
108 (test-cache-cleanup cache
109 (call-with-output-file (string-append cache "/last-expiry-cleanup")
110 (lambda (port)
111 (display "" port)))))
112
113(test-equal "maybe-remove-expired-cache-entries, corrupted cache"
114 '("a" "b" "c")
115 (test-cache-cleanup cache
116 (call-with-output-file (string-append cache "/last-expiry-cleanup")
117 (lambda (port)
118 (display "1\"34657890" port)))))
119
120(test-end "cache")
121
122;;; Local Variables:
123;;; eval: (put 'test-cache-cleanup 'scheme-indent-function 1)
124;;; End: