[bug#50040] [PATCH 1/2] publish: Defer narinfo string creation to the http-write.

[Mathieu Othacehe <othacehe@gnu.org>]

The "narinfo-string" procedure is expensive in term of IO operations and can
take a while under IO pressure, such a GC collecting. Defer its call to a new
thread created in the http-write procedure.

Fixes: <https://issues.guix.gnu.org/48468>
Partially fixes: <https://issues.guix.gnu.org/49089>

* guix/scripts/publish.scm (render-narinfo): Defer the narinfo string creation
to the http-write procedure.
(compression->sexp, sexp->compression): New procedures.
("X-Nar-Compression"): Use them.
("X-Narinfo-Compressions"): New custom header.
(strip-headers): Add the x-nar-path header.
(http-write): Add narinfo on-the-fly creation support. It happens in a
separated thread to prevent blocking the main thread.
---
 guix/scripts/publish.scm | 82 +++++++++++++++++++++++++++++++++-------
 1 file changed, 69 insertions(+), 13 deletions(-)

diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 913cbd4fda..981ef8d267 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -24,6 +24,7 @@
   #: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)
@@ -409,15 +410,18 @@ 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)))
                         '()))
-                (cut display
-                  (narinfo-string store store-path
-                                  #:nar-path nar-path
-                                  #:compressions compressions)
-                  <>)))))
+                ;; 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))))
 
 (define* (nar-cache-file directory item
                              #:key (compression %no-compression))
@@ -672,19 +676,38 @@ 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)
-                   (match (call-with-input-string str read)
-                     (('compression type level)
-                      (compression type level))))
+                   (sexp->compression
+                    (call-with-input-string str read)))
                  compression?
                  (lambda (compression port)
-                   (match compression
-                     (($ <compression> type level)
-                      (write `(compression ,type ,level) 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)))
 
 (define* (render-nar store request store-item
                      #:key (compression %no-compression))
@@ -839,7 +862,8 @@ 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."
@@ -973,6 +997,38 @@ 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)
-- 
2.32.0