summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-05-26 01:18:53 +0200
committerLudovic Courtès <ludo@gnu.org>2019-05-26 01:34:17 +0200
commit493375cdb23fc1416348da584f17bec7171faadd (patch)
treed418a5f8526b61df0eb61eec57de9f7859325486
parented90104cc82fdd6b762a159b06c0ea37b417a9a5 (diff)
publish: Maintain a hash-part-to-store-item mapping in cache.
Fixes <https://bugs.gnu.org/33897>. * guix/scripts/publish.scm (hash-part-mapping-cache-file) (hash-part->path*): New procedures. * guix/scripts/publish.scm (render-narinfo/cached)[delete-entry]: Delete the 'hash-part-mapping-cache-file'. Use 'hash-part->path*' instead of 'hash-part->path'. * tests/publish.scm ("with cache, vanishing item"): New test.
-rw-r--r--guix/scripts/publish.scm38
-rw-r--r--tests/publish.scm29
2 files changed, 62 insertions, 5 deletions
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index a236f3e45c..db64d6483e 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -350,6 +350,9 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs."
"/" (basename item)
".narinfo"))
+(define (hash-part-mapping-cache-file directory hash)
+ (string-append directory "/hashes/" hash))
+
(define run-single-baker
(let ((baking (make-weak-value-hash-table))
(mutex (make-mutex)))
@@ -403,6 +406,27 @@ items. Failing that, we could eventually have to recompute them and return
+inf.0
(expiration-time file))))))
+(define (hash-part->path* store hash cache)
+ "Like 'hash-part->path' but cached results under CACHE. This ensures we can
+still map HASH to the corresponding store file name, even if said store item
+vanished from the store in the meantime."
+ (let ((cached (hash-part-mapping-cache-file cache hash)))
+ (catch 'system-error
+ (lambda ()
+ (call-with-input-file cached read-string))
+ (lambda args
+ (if (= ENOENT (system-error-errno args))
+ (match (hash-part->path store hash)
+ ("" "")
+ (result
+ (mkdir-p (dirname cached))
+ (call-with-output-file (string-append cached ".tmp")
+ (lambda (port)
+ (display result port)))
+ (rename-file (string-append cached ".tmp") cached)
+ result))
+ (apply throw args))))))
+
(define* (render-narinfo/cached store request hash
#:key ttl (compression %no-compression)
(nar-path "nar")
@@ -412,13 +436,17 @@ CACHE, then send it; otherwise, return 404 and \"bake\" that nar and narinfo
requested using POOL."
(define (delete-entry narinfo)
;; Delete NARINFO and the corresponding nar from CACHE.
- (let ((nar (string-append (string-drop-right narinfo
- (string-length ".narinfo"))
- ".nar")))
+ (let* ((nar (string-append (string-drop-right narinfo
+ (string-length ".narinfo"))
+ ".nar"))
+ (base (basename narinfo ".narinfo"))
+ (hash (string-take base (string-index base #\-)))
+ (mapping (hash-part-mapping-cache-file cache hash)))
(delete-file* narinfo)
- (delete-file* nar)))
+ (delete-file* nar)
+ (delete-file* mapping)))
- (let* ((item (hash-part->path store hash))
+ (let* ((item (hash-part->path* store hash cache))
(compression (actual-compression item compression))
(cached (and (not (string-null? item))
(narinfo-cache-file cache item
diff --git a/tests/publish.scm b/tests/publish.scm
index 097ac036e0..7f44bc700f 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -469,6 +469,35 @@ FileSize: ~a~%"
(assoc-ref narinfo "FileSize"))
(response-code compressed))))))))))
+(test-equal "with cache, vanishing item" ;<https://bugs.gnu.org/33897>
+ 200
+ (call-with-temporary-directory
+ (lambda (cache)
+ (let ((thread (with-separate-output-ports
+ (call-with-new-thread
+ (lambda ()
+ (guix-publish "--port=6795"
+ (string-append "--cache=" cache)))))))
+ (wait-until-ready 6795)
+
+ ;; Make sure that, even if ITEM disappears, we're still able to fetch
+ ;; it.
+ (let* ((base "http://localhost:6795/")
+ (item (add-text-to-store %store "random" (random-text)))
+ (part (store-path-hash-part item))
+ (url (string-append base part ".narinfo"))
+ (cached (string-append cache
+ (if (zlib-available?)
+ "/gzip/" "/none/")
+ (basename item)
+ ".narinfo"))
+ (response (http-get url)))
+ (and (= 404 (response-code response))
+ (wait-for-file cached)
+ (begin
+ (delete-paths %store (list item))
+ (response-code (pk 'response (http-get url))))))))))
+
(test-equal "/log/NAME"
`(200 #t application/x-bzip2)
(let ((drv (run-with-store %store