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 f743f2046b.

With commit f743f2046b, 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
f743f2046b.
* tests/publish.scm ("/*.narinfo pipeline"): New test.

guix/scripts/publish.scm

@@ -25,7 +25,6 @@ (define-module (guix scripts publish)
   #: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 @@ (define* (render-narinfo store request hash
   (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 @@ (define (compressed-nar-size compression)
                        (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 @@ (define (strip-headers response)
   "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 @@ (define compression
              (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)

tests/publish.scm

@@ -41,12 +41,15 @@ (define-module (test-publish)
   #:autoload   (zstd) (call-with-zstd-input-port)
   #:use-module (web uri)
   #:use-module (web client)
+  #:use-module (web request)
   #:use-module (web response)
+  #:use-module ((guix http-client) #:select (http-multiple-get))
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
+  #:use-module (srfi srfi-71)
   #:use-module (ice-9 threads)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
@@ -166,6 +169,26 @@ (define %gzip-magic-bytes
     (publish-uri
      (string-append "/" (store-path-hash-part %item) ".narinfo")))))
 
+(test-equal "/*.narinfo pipeline"
+  (make-list 500 200)
+  ;; Make sure clients can pipeline requests and correct responses, in the
+  ;; right order.  See <https://issues.guix.gnu.org/54723>.
+  (let* ((uri (string->uri (publish-uri
+                            (string-append "/"
+                                           (store-path-hash-part %item)
+                                           ".narinfo"))))
+         (_ expected (http-get uri #:streaming? #f #:decode-body? #f)))
+    (http-multiple-get (string->uri (publish-uri ""))
+                       (lambda (request response port result)
+                         (and (bytevector=? expected
+                                            (get-bytevector-n port
+                                                              (response-content-length
+                                                               response)))
+                              (cons (response-code response) result)))
+                       '()
+                       (make-list 500 (build-request uri))
+                       #:batch-size 77)))
+
 (test-equal "/*.narinfo with properly encoded '+' sign"
   ;; See <http://bugs.gnu.org/21888>.
   (let* ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))