summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2017-04-18 22:07:49 +0200
committerLudovic Courtès <ludo@gnu.org>2017-04-18 23:19:30 +0200
commit2ea2aac6e9d58a07c029504f94fb5015cd407e31 (patch)
tree28bb3ebe5f80fdcf84ca9464857c6f39754aaa2f /guix/scripts
parent00753f7038234a0f5a79be3ec9ab949840a18743 (diff)
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'.
Diffstat (limited to 'guix/scripts')
-rwxr-xr-xguix/scripts/substitute.scm97
1 files changed, 36 insertions, 61 deletions
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