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.

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
+        (values `((content-type . (application/x-nix-narinfo))
-                                   (charset . "UTF-8")))
-                  (x-nar-path . ,nar-path)
-                  (x-narinfo-compressions . ,compressions)
                   ,@(if ttl
                         `((cache-control (max-age . ,ttl)))
                         '()))
-                ;; Do not call narinfo-string directly here as it is an
+                (cut display
-                ;; expensive call that could potentially block the main
+                  (narinfo-string store store-path
-                ;; thread.  Instead, create the narinfo string in the
+                                  #:nar-path nar-path
-                ;; http-write procedure.
+                                  #:compressions compressions)
-                store-path))))
+                  <>)))))
 
 (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
+                   (match (call-with-input-string str read)
-                    (call-with-input-string str read)))
+                     (('compression type level)
+                      (compression type level))))
                  compression?
                  (lambda (compression port)
-                   (write (compression->sexp compression) port)))
+                   (match compression
-
+                     (($ <compression> type level)
-;; This header is used to pass the supported compressions to http-write in
+                      (write `(compression ,type ,level) port)))))
-;; 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)))
 
 (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
+        '(content-length x-raw-file x-nar-compression)))
-                         x-narinfo-compressions x-nar-path)))
 
 (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)

tests/publish.scm

@@ -41,12 +41,15 @@
   #: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 @@ FileSize: ~a\n"
     (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!"))