diff --git a/Makefile.am b/Makefile.am index 46f9547117..a997ed8b99 100644 --- a/Makefile.am +++ b/Makefile.am @@ -60,6 +60,7 @@ MODULES = \ guix/upstream.scm \ guix/licenses.scm \ guix/graph.scm \ + guix/cache.scm \ guix/cve.scm \ guix/workers.scm \ guix/zlib.scm \ @@ -296,6 +297,7 @@ SCM_TESTS = \ tests/size.scm \ tests/graph.scm \ tests/challenge.scm \ + tests/cache.scm \ tests/cve.scm \ tests/workers.scm \ tests/zlib.scm \ diff --git a/guix/cache.scm b/guix/cache.scm new file mode 100644 index 0000000000..077b0780bd --- /dev/null +++ b/guix/cache.scm @@ -0,0 +1,106 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; +;;; 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 . + +(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 diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index d3bccf4ddb..748c334e3c 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -28,6 +28,7 @@ #:use-module (guix hash) #:use-module (guix base32) #:use-module (guix base64) + #:use-module (guix cache) #:use-module (guix pk-crypto) #:use-module (guix pki) #:use-module ((guix build utils) #:select (mkdir-p dump-port)) @@ -440,12 +441,6 @@ or is signed by an unauthorized key." the cache STR originates form." (call-with-input-string str (cut read-narinfo <> cache-uri))) -(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 (narinfo-cache-file cache-url path) "Return the name of the local file that contains an entry for PATH. The entry is stored in a sub-directory specific to CACHE-URL." @@ -718,43 +713,28 @@ was found." ((answer) answer) (_ #f))) -(define (remove-expired-cached-narinfos directory) - "Remove expired narinfo entries from DIRECTORY. The sole purpose of this -function is to make sure `%narinfo-cache-directory' doesn't grow -indefinitely." - (define now - (current-time time-monotonic)) +(define (cached-narinfo-expiration-time file) + "Return the expiration time for FILE, which is a cached narinfo." + (catch 'system-error + (lambda () + (call-with-input-file file + (lambda (port) + (match (read port) + (('narinfo ('version 2) ('cache-uri uri) + ('date date) ('ttl ttl) ('value #f)) + (+ date %narinfo-negative-ttl)) + (('narinfo ('version 2) ('cache-uri uri) + ('date date) ('ttl ttl) ('value value)) + (+ date ttl)) + (x + 0))))) + (lambda args + ;; FILE may have been deleted. + 0))) - (define (expired? file) - (catch 'system-error - (lambda () - (call-with-input-file file - (lambda (port) - (match (read port) - (('narinfo ('version 2) ('cache-uri _) - ('date date) ('ttl _) ('value #f)) - (obsolete? date now %narinfo-negative-ttl)) - (('narinfo ('version 2) ('cache-uri _) - ('date date) ('ttl ttl) ('value _)) - (obsolete? date now ttl)) - (_ #t))))) - (lambda args - ;; FILE may have been deleted. - #t))) - - (for-each (lambda (file) - (let ((file (string-append directory "/" file))) - (when (expired? file) - ;; Wrap in `false-if-exception' because FILE might have been - ;; deleted in the meantime (TOCTTOU). - (false-if-exception (delete-file file))))) - (scandir directory - (lambda (file) - (= (string-length file) 32))))) - -(define (narinfo-cache-directories) +(define (narinfo-cache-directories directory) "Return the list of narinfo cache directories (one per cache URL.)" - (map (cut string-append %narinfo-cache-directory "/" <>) + (map (cut string-append directory "/" <>) (scandir %narinfo-cache-directory (lambda (item) (and (not (member item '("." ".."))) @@ -762,25 +742,15 @@ indefinitely." (string-append %narinfo-cache-directory "/" item))))))) -(define (maybe-remove-expired-cached-narinfo) - "Remove expired narinfo entries from the cache if deemed necessary." - (define now - (current-time time-monotonic)) - - (define expiry-file - (string-append %narinfo-cache-directory "/last-expiry-cleanup")) - - (define last-expiry-date - (or (false-if-exception - (call-with-input-file expiry-file read)) - 0)) - - (when (obsolete? last-expiry-date now - %narinfo-expired-cache-entry-removal-delay) - (for-each remove-expired-cached-narinfos - (narinfo-cache-directories)) - (call-with-output-file expiry-file - (cute write (time-second now) <>)))) +(define* (cached-narinfo-files #:optional + (directory %narinfo-cache-directory)) + "Return the list of cached narinfo files under DIRECTORY." + (append-map (lambda (directory) + (map (cut string-append directory "/" <>) + (scandir directory + (lambda (file) + (= (string-length file) 32))))) + (narinfo-cache-directories directory))) (define (progress-report-port report-progress port) "Return a port that calls REPORT-PROGRESS every time something is read from @@ -1013,7 +983,12 @@ default value." (define (guix-substitute . args) "Implement the build daemon's substituter protocol." (mkdir-p %narinfo-cache-directory) - (maybe-remove-expired-cached-narinfo) + (maybe-remove-expired-cache-entries %narinfo-cache-directory + cached-narinfo-files + #:entry-expiration + cached-narinfo-expiration-time + #:cleanup-period + %narinfo-expired-cache-entry-removal-delay) (check-acl-initialized) ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly diff --git a/tests/cache.scm b/tests/cache.scm new file mode 100644 index 0000000000..0e1e08b693 --- /dev/null +++ b/tests/cache.scm @@ -0,0 +1,81 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès +;;; +;;; 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 . + +(define-module (test-cache) + #:use-module (guix cache) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-64) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (ice-9 match)) + +(test-begin "cache") + +(test-equal "remove-expired-cache-entries" + '("o" "l" "d") + (let* ((removed '()) + (now (time-second (current-time time-monotonic))) + (ttl 100) + (stamp (match-lambda + ((or "n" "e" "w") (+ now 100)) + ((or "o" "l" "d") (- now 100)))) + (delete (lambda (entry) + (set! removed (cons entry removed))))) + (remove-expired-cache-entries (reverse '("n" "e" "w" + "o" "l" "d")) + #:entry-expiration stamp + #:delete-entry delete) + removed)) + +(define-syntax-rule (test-cache-cleanup cache exp ...) + (call-with-temporary-directory + (lambda (cache) + (let* ((deleted '()) + (delete! (lambda (entry) + (set! deleted (cons entry deleted))))) + exp ... + (maybe-remove-expired-cache-entries cache + (const '("a" "b" "c")) + #:entry-expiration (const 0) + #:delete-entry delete!) + (reverse deleted))))) + +(test-equal "maybe-remove-expired-cache-entries, first cleanup" + '("a" "b" "c") + (test-cache-cleanup cache)) + +(test-equal "maybe-remove-expired-cache-entries, no cleanup needed" + '() + (test-cache-cleanup cache + (call-with-output-file (string-append cache "/last-expiry-cleanup") + (lambda (port) + (display (+ (time-second (current-time time-monotonic)) 100) + port))))) + +(test-equal "maybe-remove-expired-cache-entries, cleanup needed" + '("a" "b" "c") + (test-cache-cleanup cache + (call-with-output-file (string-append cache "/last-expiry-cleanup") + (lambda (port) + (display 0 port))))) + +(test-end "cache") + +;;; Local Variables: +;;; eval: (put 'test-cache-cleanup 'scheme-indent-function 1) +;;; End: