publish: Send uncached narinfo replies from the main thread.

Fixes <https://issues.guix.gnu.org/54723>.
Reported by Guillaume Le Vaillant <glv@posteo.net>.

Regression introduced in f743f2046be2c5a338ab871ae8666d8f6de7440b.

With commit f743f2046be2c5a338ab871ae8666d8f6de7440b, responses to
pipelined GETs would end up being written concurrently by many threads.
Thus the body of those responses could be interleaved and garbled.

* guix/scripts/publish.scm: Revert
f743f2046be2c5a338ab871ae8666d8f6de7440b.
* tests/publish.scm ("/*.narinfo pipeline"): New test.

1 files changed, 13 insertions, 69 deletions

diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index e8197eb47a..3bf3bd9c7c 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -25,7 +25,6 @@
   #:use-module ((system repl server) #:prefix repl:)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 format)
-  #:use-module (ice-9 iconv)
   #:use-module (ice-9 match)
   #:use-module (ice-9 poll)
   #:use-module (ice-9 regex)
@@ -406,18 +405,15 @@ appropriate duration.  NAR-PATH specifies the prefix for nar URLs."
   (let ((store-path (hash-part->path store hash)))
     (if (string-null? store-path)
         (not-found request #:phrase "" #:ttl negative-ttl)
-        (values `((content-type . (application/x-nix-narinfo
-                                   (charset . "UTF-8")))
-                  (x-nar-path . ,nar-path)
-                  (x-narinfo-compressions . ,compressions)
+        (values `((content-type . (application/x-nix-narinfo))
                   ,@(if ttl
                         `((cache-control (max-age . ,ttl)))
                         '()))
-                ;; Do not call narinfo-string directly here as it is an
-                ;; expensive call that could potentially block the main
-                ;; thread.  Instead, create the narinfo string in the
-                ;; http-write procedure.
-                store-path))))
+                (cut display
+                  (narinfo-string store store-path
+                                  #:nar-path nar-path
+                                  #:compressions compressions)
+                  <>)))))
 
 (define* (nar-cache-file directory item
                              #:key (compression %no-compression))
@@ -672,38 +668,19 @@ requested using POOL."
                        (link narinfo other)))
                    others))))))
 
-(define (compression->sexp compression)
-  "Return the SEXP representation of COMPRESSION."
-  (match compression
-    (($ <compression> type level)
-     `(compression ,type ,level))))
-
-(define (sexp->compression sexp)
-  "Turn the given SEXP into a <compression> record and return it."
-  (match sexp
-    (('compression type level)
-     (compression type level))))
-
 ;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for
 ;; internal consumption: it allows us to pass the compression info to
 ;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>.
 (declare-header! "X-Nar-Compression"
                  (lambda (str)
-                   (sexp->compression
-                    (call-with-input-string str read)))
+                   (match (call-with-input-string str read)
+                     (('compression type level)
+                      (compression type level))))
                  compression?
                  (lambda (compression port)
-                   (write (compression->sexp compression) port)))
-
-;; This header is used to pass the supported compressions to http-write in
-;; order to format on-the-fly narinfo responses.
-(declare-header! "X-Narinfo-Compressions"
-                 (lambda (str)
-                   (map sexp->compression
-                        (call-with-input-string str read)))
-                 (cut every compression? <>)
-                 (lambda (compressions port)
-                   (write (map compression->sexp compressions) port)))
+                   (match compression
+                     (($ <compression> type level)
+                      (write `(compression ,type ,level) port)))))
 
 (define* (render-nar store request store-item
                      #:key (compression %no-compression))
@@ -858,8 +835,7 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
   "Return RESPONSE's headers minus 'Content-Length' and our internal headers."
   (fold alist-delete
         (response-headers response)
-        '(content-length x-raw-file x-nar-compression
-                         x-narinfo-compressions x-nar-path)))
+        '(content-length x-raw-file x-nar-compression)))
 
 (define (sans-content-length response)
   "Return RESPONSE without its 'content-length' header."
@@ -993,38 +969,6 @@ blocking."
              (unless keep-alive?
                (close-port client)))
             (values))))))
-    (('application/x-nix-narinfo . _)
-     (let ((compressions (assoc-ref (response-headers response)
-                                    'x-narinfo-compressions))
-           (nar-path (assoc-ref (response-headers response)
-                                'x-nar-path)))
-       (if nar-path
-           (begin
-             (when (keep-alive? response)
-               (keep-alive client))
-             (call-with-new-thread
-              (lambda ()
-                (set-thread-name "publish narinfo")
-                (let* ((narinfo
-                        (with-store store
-                          (narinfo-string store (utf8->string body)
-                                          #:nar-path nar-path
-                                          #:compressions compressions)))
-                       (narinfo-bv (string->bytevector narinfo "UTF-8"))
-                       (narinfo-length
-                        (bytevector-length narinfo-bv))
-                       (response (write-response
-                                  (with-content-length response
-                                                       narinfo-length)
-                                  client))
-                       (output (response-port response)))
-                  (configure-socket client)
-                  (put-bytevector output narinfo-bv)
-                  (force-output output)
-                  (unless (keep-alive? response)
-                    (close-port output))
-                  (values)))))
-           (%http-write server client response body))))
     (_
      (match (assoc-ref (response-headers response) 'x-raw-file)
        ((? string? file)