114 lines
4.4 KiB
Scheme
114 lines
4.4 KiB
Scheme
;;; 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:
|
|
|
|
(cond-expand
|
|
(guile-2.2
|
|
;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
|
|
;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
|
|
(define time-monotonic time-tai))
|
|
(else #t))
|
|
|
|
(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
|