guix/cache.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   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 #:optional (timestamp stat:atime))
  51   "Return a procedure that, when passed a file, returns its \"expiration
  52 time\" computed as its timestamp + TTL seconds.  Call TIMESTAMP to obtain the
  53 relevant timestamp from the result of 'stat'."
  54   (lambda (file)
  55     (match (stat file #f)
  56       (#f 0)                       ;FILE may have been deleted in the meantime
  57       (st (+ (timestamp st) ttl)))))
  58
  59 (define* (remove-expired-cache-entries entries
  60                                        #:key
  61                                        (now (current-time time-monotonic))
  62                                        (entry-expiration
  63                                         (file-expiration-time 3600))
  64                                        (delete-entry delete-file*))
  65   "Given ENTRIES, a list of file names, remove those whose expiration time,
  66 as returned by ENTRY-EXPIRATION, has passed.  Use DELETE-ENTRY to delete
  67 them."
  68   (for-each (lambda (entry)
  69               (when (<= (entry-expiration entry) (time-second now))
  70                 (delete-entry entry)))
  71             entries))
  72
  73 (define* (maybe-remove-expired-cache-entries cache
  74                                              cache-entries
  75                                              #:key
  76                                              (entry-expiration
  77                                               (file-expiration-time 3600))
  78                                              (delete-entry delete-file*)
  79                                              (cleanup-period (* 24 3600)))
  80   "Remove expired narinfo entries from the cache if deemed necessary.  Call
  81 CACHE-ENTRIES with CACHE to retrieve the list of cache entries.
  82
  83 ENTRY-EXPIRATION must be a procedure that, when passed an entry, returns the
  84 expiration time of that entry in seconds since the Epoch.  DELETE-ENTRY is a
  85 procedure that removes the entry passed as an argument.  Finally,
  86 CLEANUP-PERIOD denotes the minimum time between two cache cleanups."
  87   (define now
  88     (current-time time-monotonic))
  89
  90   (define expiry-file
  91     (string-append cache "/last-expiry-cleanup"))
  92
  93   (define last-expiry-date
  94     (catch 'system-error
  95       (lambda ()
  96         (call-with-input-file expiry-file read))
  97       (const 0)))
  98
  99   (when (obsolete? last-expiry-date now cleanup-period)
 100     (remove-expired-cache-entries (cache-entries cache)
 101                                   #:now now
 102                                   #:entry-expiration entry-expiration
 103                                   #:delete-entry delete-entry)
 104     (call-with-output-file expiry-file
 105       (cute write (time-second now) <>))))
 106
 107 ;;; cache.scm ends here