You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

106 lines
4.2 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020 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. (define-module (guix cache)
  19. #:use-module (srfi srfi-19)
  20. #:use-module (srfi srfi-26)
  21. #:use-module (ice-9 match)
  22. #:export (obsolete?
  23. delete-file*
  24. file-expiration-time
  25. remove-expired-cache-entries
  26. maybe-remove-expired-cache-entries))
  27. ;;; Commentary:
  28. ;;;
  29. ;;; This module provides tools to manage a simple on-disk cache consisting of
  30. ;;; individual files.
  31. ;;;
  32. ;;; Code:
  33. (define (obsolete? date now ttl)
  34. "Return #t if DATE is obsolete compared to NOW + TTL seconds."
  35. (time>? (subtract-duration now (make-time time-duration 0 ttl))
  36. (make-time time-monotonic 0 date)))
  37. (define (delete-file* file)
  38. "Like 'delete-file', but does not raise an error when FILE does not exist."
  39. (catch 'system-error
  40. (lambda ()
  41. (delete-file file))
  42. (lambda args
  43. (unless (= ENOENT (system-error-errno args))
  44. (apply throw args)))))
  45. (define (file-expiration-time ttl)
  46. "Return a procedure that, when passed a file, returns its \"expiration
  47. time\" computed as its last-access time + TTL seconds."
  48. (lambda (file)
  49. (match (stat file #f)
  50. (#f 0) ;FILE may have been deleted in the meantime
  51. (st (+ (stat:atime st) ttl)))))
  52. (define* (remove-expired-cache-entries entries
  53. #:key
  54. (now (current-time time-monotonic))
  55. (entry-expiration
  56. (file-expiration-time 3600))
  57. (delete-entry delete-file*))
  58. "Given ENTRIES, a list of file names, remove those whose expiration time,
  59. as returned by ENTRY-EXPIRATION, has passed. Use DELETE-ENTRY to delete
  60. them."
  61. (for-each (lambda (entry)
  62. (when (<= (entry-expiration entry) (time-second now))
  63. (delete-entry entry)))
  64. entries))
  65. (define* (maybe-remove-expired-cache-entries cache
  66. cache-entries
  67. #:key
  68. (entry-expiration
  69. (file-expiration-time 3600))
  70. (delete-entry delete-file*)
  71. (cleanup-period (* 24 3600)))
  72. "Remove expired narinfo entries from the cache if deemed necessary. Call
  73. CACHE-ENTRIES with CACHE to retrieve the list of cache entries.
  74. ENTRY-EXPIRATION must be a procedure that, when passed an entry, returns the
  75. expiration time of that entry in seconds since the Epoch. DELETE-ENTRY is a
  76. procedure that removes the entry passed as an argument. Finally,
  77. CLEANUP-PERIOD denotes the minimum time between two cache cleanups."
  78. (define now
  79. (current-time time-monotonic))
  80. (define expiry-file
  81. (string-append cache "/last-expiry-cleanup"))
  82. (define last-expiry-date
  83. (catch 'system-error
  84. (lambda ()
  85. (call-with-input-file expiry-file read))
  86. (const 0)))
  87. (when (obsolete? last-expiry-date now cleanup-period)
  88. (remove-expired-cache-entries (cache-entries cache)
  89. #:now now
  90. #:entry-expiration entry-expiration
  91. #:delete-entry delete-entry)
  92. (call-with-output-file expiry-file
  93. (cute write (time-second now) <>))))
  94. ;;; cache.scm ends here