substitute: Store cached narinfo in cache-specific sub-directories.
This ensures that switching between different substitute servers doesn't lead to a polluted narinfo cache. * guix/scripts/substitute.scm (narinfo-cache-file): Add 'cache-url' parameter. Add the base32 of CACHE-URL as a sub-directory under %NARINFO-CACHE-DIRECTORY. Update callers. (cached-narinfo): Likewise. Call 'mkdir-p' on the dirname of the cache file. Update callers. (remove-expired-cached-narinfos): Add 'directory' parameter and use it instead of %NARINFO-CACHE-DIRECTORY. (narinfo-cache-directories): New procedure. (maybe-remove-expired-cached-narinfo): Call 'remove-expired-cached-narinfos' for each item returned by 'narinfo-cache-directories'.
This commit is contained in:
parent
074efd63a8
commit
895d1eda54
|
@ -25,6 +25,7 @@
|
||||||
#:use-module (guix records)
|
#:use-module (guix records)
|
||||||
#:use-module (guix serialization)
|
#:use-module (guix serialization)
|
||||||
#:use-module (guix hash)
|
#:use-module (guix hash)
|
||||||
|
#:use-module (guix base32)
|
||||||
#:use-module (guix base64)
|
#:use-module (guix base64)
|
||||||
#:use-module (guix pk-crypto)
|
#:use-module (guix pk-crypto)
|
||||||
#:use-module (guix pki)
|
#:use-module (guix pki)
|
||||||
|
@ -371,20 +372,23 @@ the cache STR originates form."
|
||||||
(make-time time-monotonic 0 date)))
|
(make-time time-monotonic 0 date)))
|
||||||
|
|
||||||
|
|
||||||
(define (narinfo-cache-file path)
|
(define (narinfo-cache-file cache-url path)
|
||||||
"Return the name of the local file that contains an entry for 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."
|
||||||
(string-append %narinfo-cache-directory "/"
|
(string-append %narinfo-cache-directory "/"
|
||||||
(store-path-hash-part path)))
|
(bytevector->base32-string (sha256 (string->utf8 cache-url)))
|
||||||
|
"/" (store-path-hash-part path)))
|
||||||
|
|
||||||
(define (cached-narinfo path)
|
(define (cached-narinfo cache-url path)
|
||||||
"Check locally if we have valid info about PATH. Return two values: a
|
"Check locally if we have valid info about PATH coming from CACHE-URL.
|
||||||
Boolean indicating whether we have valid cached info, and that info, which may
|
Return two values: a Boolean indicating whether we have valid cached info, and
|
||||||
be either #f (when PATH is unavailable) or the narinfo for PATH."
|
that info, which may be either #f (when PATH is unavailable) or the narinfo
|
||||||
|
for PATH."
|
||||||
(define now
|
(define now
|
||||||
(current-time time-monotonic))
|
(current-time time-monotonic))
|
||||||
|
|
||||||
(define cache-file
|
(define cache-file
|
||||||
(narinfo-cache-file path))
|
(narinfo-cache-file cache-url path))
|
||||||
|
|
||||||
(catch 'system-error
|
(catch 'system-error
|
||||||
(lambda ()
|
(lambda ()
|
||||||
|
@ -422,9 +426,12 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL."
|
||||||
(date ,(time-second now))
|
(date ,(time-second now))
|
||||||
(value ,(and=> narinfo narinfo->string))))
|
(value ,(and=> narinfo narinfo->string))))
|
||||||
|
|
||||||
(with-atomic-file-output (narinfo-cache-file path)
|
(let ((file (narinfo-cache-file cache-url path)))
|
||||||
|
(mkdir-p (dirname file))
|
||||||
|
(with-atomic-file-output file
|
||||||
(lambda (out)
|
(lambda (out)
|
||||||
(write (cache-entry cache-url narinfo) out)))
|
(write (cache-entry cache-url narinfo) out))))
|
||||||
|
|
||||||
narinfo)
|
narinfo)
|
||||||
|
|
||||||
(define (narinfo-request cache-url path)
|
(define (narinfo-request cache-url path)
|
||||||
|
@ -553,7 +560,7 @@ information is available locally."
|
||||||
(let-values (((cached missing)
|
(let-values (((cached missing)
|
||||||
(fold2 (lambda (path cached missing)
|
(fold2 (lambda (path cached missing)
|
||||||
(let-values (((valid? value)
|
(let-values (((valid? value)
|
||||||
(cached-narinfo path)))
|
(cached-narinfo cache path)))
|
||||||
(if valid?
|
(if valid?
|
||||||
(values (cons value cached) missing)
|
(values (cons value cached) missing)
|
||||||
(values cached (cons path missing)))))
|
(values cached (cons path missing)))))
|
||||||
|
@ -571,8 +578,8 @@ found."
|
||||||
(match (lookup-narinfos cache (list path))
|
(match (lookup-narinfos cache (list path))
|
||||||
((answer) answer)))
|
((answer) answer)))
|
||||||
|
|
||||||
(define (remove-expired-cached-narinfos)
|
(define (remove-expired-cached-narinfos directory)
|
||||||
"Remove expired narinfo entries from the cache. The sole purpose of this
|
"Remove expired narinfo entries from DIRECTORY. The sole purpose of this
|
||||||
function is to make sure `%narinfo-cache-directory' doesn't grow
|
function is to make sure `%narinfo-cache-directory' doesn't grow
|
||||||
indefinitely."
|
indefinitely."
|
||||||
(define now
|
(define now
|
||||||
|
@ -596,16 +603,25 @@ indefinitely."
|
||||||
#t)))
|
#t)))
|
||||||
|
|
||||||
(for-each (lambda (file)
|
(for-each (lambda (file)
|
||||||
(let ((file (string-append %narinfo-cache-directory
|
(let ((file (string-append directory "/" file)))
|
||||||
"/" file)))
|
|
||||||
(when (expired? file)
|
(when (expired? file)
|
||||||
;; Wrap in `false-if-exception' because FILE might have been
|
;; Wrap in `false-if-exception' because FILE might have been
|
||||||
;; deleted in the meantime (TOCTTOU).
|
;; deleted in the meantime (TOCTTOU).
|
||||||
(false-if-exception (delete-file file)))))
|
(false-if-exception (delete-file file)))))
|
||||||
(scandir %narinfo-cache-directory
|
(scandir directory
|
||||||
(lambda (file)
|
(lambda (file)
|
||||||
(= (string-length file) 32)))))
|
(= (string-length file) 32)))))
|
||||||
|
|
||||||
|
(define (narinfo-cache-directories)
|
||||||
|
"Return the list of narinfo cache directories (one per cache URL.)"
|
||||||
|
(map (cut string-append %narinfo-cache-directory "/" <>)
|
||||||
|
(scandir %narinfo-cache-directory
|
||||||
|
(lambda (item)
|
||||||
|
(and (not (member item '("." "..")))
|
||||||
|
(file-is-directory?
|
||||||
|
(string-append %narinfo-cache-directory
|
||||||
|
"/" item)))))))
|
||||||
|
|
||||||
(define (maybe-remove-expired-cached-narinfo)
|
(define (maybe-remove-expired-cached-narinfo)
|
||||||
"Remove expired narinfo entries from the cache if deemed necessary."
|
"Remove expired narinfo entries from the cache if deemed necessary."
|
||||||
(define now
|
(define now
|
||||||
|
@ -619,8 +635,10 @@ indefinitely."
|
||||||
(call-with-input-file expiry-file read))
|
(call-with-input-file expiry-file read))
|
||||||
0))
|
0))
|
||||||
|
|
||||||
(when (obsolete? last-expiry-date now %narinfo-expired-cache-entry-removal-delay)
|
(when (obsolete? last-expiry-date now
|
||||||
(remove-expired-cached-narinfos)
|
%narinfo-expired-cache-entry-removal-delay)
|
||||||
|
(for-each remove-expired-cached-narinfos
|
||||||
|
(narinfo-cache-directories))
|
||||||
(call-with-output-file expiry-file
|
(call-with-output-file expiry-file
|
||||||
(cute write (time-second now) <>))))
|
(cute write (time-second now) <>))))
|
||||||
|
|
||||||
|
|
|
@ -25,6 +25,7 @@
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
#:use-module (guix derivations)
|
#:use-module (guix derivations)
|
||||||
#:use-module (guix serialization)
|
#:use-module (guix serialization)
|
||||||
|
#:use-module (guix build utils)
|
||||||
#:use-module (guix gexp)
|
#:use-module (guix gexp)
|
||||||
#:use-module (gnu packages)
|
#:use-module (gnu packages)
|
||||||
#:use-module (gnu packages bootstrap)
|
#:use-module (gnu packages bootstrap)
|
||||||
|
@ -371,9 +372,8 @@
|
||||||
(with-derivation-narinfo d
|
(with-derivation-narinfo d
|
||||||
;; Remove entry from the local cache.
|
;; Remove entry from the local cache.
|
||||||
(false-if-exception
|
(false-if-exception
|
||||||
(delete-file (string-append (getenv "XDG_CACHE_HOME")
|
(delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
|
||||||
"/guix/substitute/"
|
"/guix/substitute")))
|
||||||
(store-path-hash-part o))))
|
|
||||||
|
|
||||||
;; Make sure 'guix substitute' correctly communicates the above
|
;; Make sure 'guix substitute' correctly communicates the above
|
||||||
;; data.
|
;; data.
|
||||||
|
|
Loading…
Reference in New Issue