Add (guix cache) and use it in (guix scripts substitute).
* guix/cache.scm, tests/cache.scm: New files. * Makefile.am (MODULES, SCM_TESTS): Add them. * guix/scripts/substitute.scm (obsolete?): Remove. (remove-expired-cached-narinfos): Rename to... (cached-narinfo-expiration-time): ... this. Remove the removal part and only keep the expiration time part. (narinfo-cache-directories): Add optional 'directory' parameter and honor it. (maybe-remove-expired-cached-narinfo): Remove. (cached-narinfo-files): New procedure. (guix-substitute): Use 'maybe-remove-expired-cache-entries' instead of 'maybe-remove-expired-cached-narinfo'.
This commit is contained in:
Ludovic Courtès
parent
00753f7038
commit
2ea2aac6e9
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
Loading…
Reference in New Issue