[jackhill/guix/guix.git] / guix / cache.scm

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