From 2ea2aac6e9d58a07c029504f94fb5015cd407e31 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 18 Apr 2017 22:07:49 +0200 Subject: Add (guix cache) and use it in (guix scripts substitute). * guix/cache.scm, tests/cache.scm: New files. * Makefile.am (MODULES, SCM_TESTS): Add them. * guix/scripts/substitute.scm (obsolete?): Remove. (remove-expired-cached-narinfos): Rename to... (cached-narinfo-expiration-time): ... this. Remove the removal part and only keep the expiration time part. (narinfo-cache-directories): Add optional 'directory' parameter and honor it. (maybe-remove-expired-cached-narinfo): Remove. (cached-narinfo-files): New procedure. (guix-substitute): Use 'maybe-remove-expired-cache-entries' instead of 'maybe-remove-expired-cached-narinfo'. --- guix/scripts/substitute.scm | 97 +++++++++++++++++---------------------------- 1 file changed, 36 insertions(+), 61 deletions(-) (limited to 'guix/scripts') 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 -- cgit v1.2.3