M Makefile.am => Makefile.am +2 -0
@@ 60,6 60,7 @@ MODULES = \
guix/upstream.scm \
guix/licenses.scm \
guix/graph.scm \
+ guix/cache.scm \
guix/cve.scm \
guix/workers.scm \
guix/zlib.scm \
@@ 296,6 297,7 @@ SCM_TESTS = \
tests/size.scm \
tests/graph.scm \
tests/challenge.scm \
+ tests/cache.scm \
tests/cve.scm \
tests/workers.scm \
tests/zlib.scm \
A guix/cache.scm => guix/cache.scm +106 -0
@@ 0,0 1,106 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix cache)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:export (obsolete?
+ delete-file*
+ file-expiration-time
+ remove-expired-cache-entries
+ maybe-remove-expired-cache-entries))
+
+;;; Commentary:
+;;;
+;;; This module provides tools to manage a simple on-disk cache consisting of
+;;; individual files.
+;;;
+;;; Code:
+
+(define (obsolete? date now ttl)
+ "Return #t if DATE is obsolete compared to NOW + TTL seconds."
+ (time>? (subtract-duration now (make-time time-duration 0 ttl))
+ (make-time time-monotonic 0 date)))
+
+(define (delete-file* file)
+ "Like 'delete-file', but does not raise an error when FILE does not exist."
+ (catch 'system-error
+ (lambda ()
+ (delete-file file))
+ (lambda args
+ (unless (= ENOENT (system-error-errno args))
+ (apply throw args)))))
+
+(define (file-expiration-time ttl)
+ "Return a procedure that, when passed a file, returns its \"expiration
+time\" computed as its last-access time + TTL seconds."
+ (lambda (file)
+ (match (stat file #f)
+ (#f 0) ;FILE may have been deleted in the meantime
+ (st (+ (stat:atime st) ttl)))))
+
+(define* (remove-expired-cache-entries entries
+ #:key
+ (now (current-time time-monotonic))
+ (entry-expiration
+ (file-expiration-time 3600))
+ (delete-entry delete-file*))
+ "Given ENTRIES, a list of file names, remove those whose expiration time,
+as returned by ENTRY-EXPIRATION, has passed. Use DELETE-ENTRY to delete
+them."
+ (for-each (lambda (entry)
+ (when (<= (entry-expiration entry) (time-second now))
+ (delete-entry entry)))
+ entries))
+
+(define* (maybe-remove-expired-cache-entries cache
+ cache-entries
+ #:key
+ (entry-expiration
+ (file-expiration-time 3600))
+ (delete-entry delete-file*)
+ (cleanup-period (* 24 3600)))
+ "Remove expired narinfo entries from the cache if deemed necessary. Call
+CACHE-ENTRIES with CACHE to retrieve the list of cache entries.
+
+ENTRY-EXPIRATION must be a procedure that, when passed an entry, returns the
+expiration time of that entry in seconds since the Epoch. DELETE-ENTRY is a
+procedure that removes the entry passed as an argument. Finally,
+CLEANUP-PERIOD denotes the minimum time between two cache cleanups."
+ (define now
+ (current-time time-monotonic))
+
+ (define expiry-file
+ (string-append cache "/last-expiry-cleanup"))
+
+ (define last-expiry-date
+ (catch 'system-error
+ (lambda ()
+ (call-with-input-file expiry-file read))
+ (const 0)))
+
+ (when (obsolete? last-expiry-date now cleanup-period)
+ (remove-expired-cache-entries (cache-entries cache)
+ #:now now
+ #:entry-expiration entry-expiration
+ #:delete-entry delete-entry)
+ (call-with-output-file expiry-file
+ (cute write (time-second now) <>))))
+
+;;; cache.scm ends here
M guix/scripts/substitute.scm => guix/scripts/substitute.scm +36 -61
@@ 28,6 28,7 @@
#:use-module (guix hash)
#:use-module (guix base32)
#:use-module (guix base64)
+ #:use-module (guix cache)
#:use-module (guix pk-crypto)
#:use-module (guix pki)
#:use-module ((guix build utils) #:select (mkdir-p dump-port))
@@ 440,12 441,6 @@ or is signed by an unauthorized key."
the cache STR originates form."
(call-with-input-string str (cut read-narinfo <> cache-uri)))
-(define (obsolete? date now ttl)
- "Return #t if DATE is obsolete compared to NOW + TTL seconds."
- (time>? (subtract-duration now (make-time time-duration 0 ttl))
- (make-time time-monotonic 0 date)))
-
-
(define (narinfo-cache-file cache-url path)
"Return the name of the local file that contains an entry for PATH. The
entry is stored in a sub-directory specific to CACHE-URL."
@@ 718,43 713,28 @@ was found."
((answer) answer)
(_ #f)))
-(define (remove-expired-cached-narinfos directory)
- "Remove expired narinfo entries from DIRECTORY. The sole purpose of this
-function is to make sure `%narinfo-cache-directory' doesn't grow
-indefinitely."
- (define now
- (current-time time-monotonic))
+(define (cached-narinfo-expiration-time file)
+ "Return the expiration time for FILE, which is a cached narinfo."
+ (catch 'system-error
+ (lambda ()
+ (call-with-input-file file
+ (lambda (port)
+ (match (read port)
+ (('narinfo ('version 2) ('cache-uri uri)
+ ('date date) ('ttl ttl) ('value #f))
+ (+ date %narinfo-negative-ttl))
+ (('narinfo ('version 2) ('cache-uri uri)
+ ('date date) ('ttl ttl) ('value value))
+ (+ date ttl))
+ (x
+ 0)))))
+ (lambda args
+ ;; FILE may have been deleted.
+ 0)))
- (define (expired? file)
- (catch 'system-error
- (lambda ()
- (call-with-input-file file
- (lambda (port)
- (match (read port)
- (('narinfo ('version 2) ('cache-uri _)
- ('date date) ('ttl _) ('value #f))
- (obsolete? date now %narinfo-negative-ttl))
- (('narinfo ('version 2) ('cache-uri _)
- ('date date) ('ttl ttl) ('value _))
- (obsolete? date now ttl))
- (_ #t)))))
- (lambda args
- ;; FILE may have been deleted.
- #t)))
-
- (for-each (lambda (file)
- (let ((file (string-append directory "/" file)))
- (when (expired? file)
- ;; Wrap in `false-if-exception' because FILE might have been
- ;; deleted in the meantime (TOCTTOU).
- (false-if-exception (delete-file file)))))
- (scandir directory
- (lambda (file)
- (= (string-length file) 32)))))
-
-(define (narinfo-cache-directories)
+(define (narinfo-cache-directories directory)
"Return the list of narinfo cache directories (one per cache URL.)"
- (map (cut string-append %narinfo-cache-directory "/" <>)
+ (map (cut string-append directory "/" <>)
(scandir %narinfo-cache-directory
(lambda (item)
(and (not (member item '("." "..")))
@@ 762,25 742,15 @@ indefinitely."
(string-append %narinfo-cache-directory
"/" item)))))))
-(define (maybe-remove-expired-cached-narinfo)
- "Remove expired narinfo entries from the cache if deemed necessary."
- (define now
- (current-time time-monotonic))
-
- (define expiry-file
- (string-append %narinfo-cache-directory "/last-expiry-cleanup"))
-
- (define last-expiry-date
- (or (false-if-exception
- (call-with-input-file expiry-file read))
- 0))
-
- (when (obsolete? last-expiry-date now
- %narinfo-expired-cache-entry-removal-delay)
- (for-each remove-expired-cached-narinfos
- (narinfo-cache-directories))
- (call-with-output-file expiry-file
- (cute write (time-second now) <>))))
+(define* (cached-narinfo-files #:optional
+ (directory %narinfo-cache-directory))
+ "Return the list of cached narinfo files under DIRECTORY."
+ (append-map (lambda (directory)
+ (map (cut string-append directory "/" <>)
+ (scandir directory
+ (lambda (file)
+ (= (string-length file) 32)))))
+ (narinfo-cache-directories directory)))
(define (progress-report-port report-progress port)
"Return a port that calls REPORT-PROGRESS every time something is read from
@@ 1013,7 983,12 @@ default value."
(define (guix-substitute . args)
"Implement the build daemon's substituter protocol."
(mkdir-p %narinfo-cache-directory)
- (maybe-remove-expired-cached-narinfo)
+ (maybe-remove-expired-cache-entries %narinfo-cache-directory
+ cached-narinfo-files
+ #:entry-expiration
+ cached-narinfo-expiration-time
+ #:cleanup-period
+ %narinfo-expired-cache-entry-removal-delay)
(check-acl-initialized)
;; Starting from commit 22144afa in Nix, we are allowed to bail out directly
A tests/cache.scm => tests/cache.scm +81 -0
@@ 0,0 1,81 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-cache)
+ #:use-module (guix cache)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-64)
+ #:use-module ((guix utils) #:select (call-with-temporary-directory))
+ #:use-module (ice-9 match))
+
+(test-begin "cache")
+
+(test-equal "remove-expired-cache-entries"
+ '("o" "l" "d")
+ (let* ((removed '())
+ (now (time-second (current-time time-monotonic)))
+ (ttl 100)
+ (stamp (match-lambda
+ ((or "n" "e" "w") (+ now 100))
+ ((or "o" "l" "d") (- now 100))))
+ (delete (lambda (entry)
+ (set! removed (cons entry removed)))))
+ (remove-expired-cache-entries (reverse '("n" "e" "w"
+ "o" "l" "d"))
+ #:entry-expiration stamp
+ #:delete-entry delete)
+ removed))
+
+(define-syntax-rule (test-cache-cleanup cache exp ...)
+ (call-with-temporary-directory
+ (lambda (cache)
+ (let* ((deleted '())
+ (delete! (lambda (entry)
+ (set! deleted (cons entry deleted)))))
+ exp ...
+ (maybe-remove-expired-cache-entries cache
+ (const '("a" "b" "c"))
+ #:entry-expiration (const 0)
+ #:delete-entry delete!)
+ (reverse deleted)))))
+
+(test-equal "maybe-remove-expired-cache-entries, first cleanup"
+ '("a" "b" "c")
+ (test-cache-cleanup cache))
+
+(test-equal "maybe-remove-expired-cache-entries, no cleanup needed"
+ '()
+ (test-cache-cleanup cache
+ (call-with-output-file (string-append cache "/last-expiry-cleanup")
+ (lambda (port)
+ (display (+ (time-second (current-time time-monotonic)) 100)
+ port)))))
+
+(test-equal "maybe-remove-expired-cache-entries, cleanup needed"
+ '("a" "b" "c")
+ (test-cache-cleanup cache
+ (call-with-output-file (string-append cache "/last-expiry-cleanup")
+ (lambda (port)
+ (display 0 port)))))
+
+(test-end "cache")
+
+;;; Local Variables:
+;;; eval: (put 'test-cache-cleanup 'scheme-indent-function 1)
+;;; End: