guix/cache.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 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 (cond-expand
  37   (guile-2.2
  38    ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
  39    ;; nanoseconds swapped (fixed in Guile commit 886ac3e).  Work around it.
  40    (define time-monotonic time-tai))
  41   (else #t))
  42
  43 (define (obsolete? date now ttl)
  44   "Return #t if DATE is obsolete compared to NOW + TTL seconds."
  45   (time>? (subtract-duration now (make-time time-duration 0 ttl))
  46           (make-time time-monotonic 0 date)))
  47
  48 (define (delete-file* file)
  49   "Like 'delete-file', but does not raise an error when FILE does not exist."
  50   (catch 'system-error
  51     (lambda ()
  52       (delete-file file))
  53     (lambda args
  54       (unless (= ENOENT (system-error-errno args))
  55         (apply throw args)))))
  56
  57 (define (file-expiration-time ttl)
  58   "Return a procedure that, when passed a file, returns its \"expiration
  59 time\" computed as its last-access time + TTL seconds."
  60   (lambda (file)
  61     (match (stat file #f)
  62       (#f 0)                       ;FILE may have been deleted in the meantime
  63       (st (+ (stat:atime st) ttl)))))
  64
  65 (define* (remove-expired-cache-entries entries
  66                                        #:key
  67                                        (now (current-time time-monotonic))
  68                                        (entry-expiration
  69                                         (file-expiration-time 3600))
  70                                        (delete-entry delete-file*))
  71   "Given ENTRIES, a list of file names, remove those whose expiration time,
  72 as returned by ENTRY-EXPIRATION, has passed.  Use DELETE-ENTRY to delete
  73 them."
  74   (for-each (lambda (entry)
  75               (when (<= (entry-expiration entry) (time-second now))
  76                 (delete-entry entry)))
  77             entries))
  78
  79 (define* (maybe-remove-expired-cache-entries cache
  80                                              cache-entries
  81                                              #:key
  82                                              (entry-expiration
  83                                               (file-expiration-time 3600))
  84                                              (delete-entry delete-file*)
  85                                              (cleanup-period (* 24 3600)))
  86   "Remove expired narinfo entries from the cache if deemed necessary.  Call
  87 CACHE-ENTRIES with CACHE to retrieve the list of cache entries.
  88
  89 ENTRY-EXPIRATION must be a procedure that, when passed an entry, returns the
  90 expiration time of that entry in seconds since the Epoch.  DELETE-ENTRY is a
  91 procedure that removes the entry passed as an argument.  Finally,
  92 CLEANUP-PERIOD denotes the minimum time between two cache cleanups."
  93   (define now
  94     (current-time time-monotonic))
  95
  96   (define expiry-file
  97     (string-append cache "/last-expiry-cleanup"))
  98
  99   (define last-expiry-date
 100     (catch 'system-error
 101       (lambda ()
 102         (call-with-input-file expiry-file read))
 103       (const 0)))
 104
 105   (when (obsolete? last-expiry-date now cleanup-period)
 106     (remove-expired-cache-entries (cache-entries cache)
 107                                   #:now now
 108                                   #:entry-expiration entry-expiration
 109                                   #:delete-entry delete-entry)
 110     (call-with-output-file expiry-file
 111       (cute write (time-second now) <>))))
 112
 113 ;;; cache.scm ends here