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.

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