[bug#48557] [PATCH 1/4] scripts: publish: Add keep-alive support when sending NAR.

[bug#48557] [PATCH 1/4] scripts: publish: Add keep-alive support when sending NAR.

[Mathieu Othacehe]

The default Guile web server implementation supports the keep alive
mechanism. However, in our custom http-write implementation, the connection
is unconditionally close after sending NAR files.

To prevent that, when supported, add the client port to the server poll set so
that further requests can be handled without closing the connection.

* guix/scripts/publish.scm (nar-response-port): Duplicate the response port.
(http-write): Add keep-alive support when sending NAR files.
---
 guix/scripts/publish.scm | 150 ++++++++++++++++++++++++++-------------
 1 file changed, 102 insertions(+), 48 deletions(-)

diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index ef6fa5f074..19fed574c2 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -25,6 +25,7 @@
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 poll)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 threads)
@@ -872,57 +873,109 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
 (define (nar-response-port response compression)
   "Return a port on which to write the body of RESPONSE, the response of a
 /nar request, according to COMPRESSION."
-  (match compression
-    (($ <compression> 'gzip level)
-     ;; Note: We cannot used chunked encoding here because
-     ;; 'make-gzip-output-port' wants a file port.
-     (make-gzip-output-port (response-port response)
-                            #:level level
-                            #:buffer-size %default-buffer-size))
-    (($ <compression> 'lzip level)
-     (make-lzip-output-port (response-port response)
-                            #:level level))
-    (($ <compression> 'zstd level)
-     (make-zstd-output-port (response-port response)
-                            #:level level))
-    (($ <compression> 'none)
-     (response-port response))
-    (#f
-     (response-port response))))
+  ;; Duplicate the response port, so that it is not automatically closed when
+  ;; closing the returned port.  This is needed for the keep-alive mechanism.
+  (let ((port (duplicate-port
+               (response-port response) "w+0b")))
+    (match compression
+      (($ <compression> 'gzip level)
+       ;; Note: We cannot used chunked encoding here because
+       ;; 'make-gzip-output-port' wants a file port.
+       (make-gzip-output-port port
+                              #:level level
+                              #:buffer-size %default-buffer-size))
+      (($ <compression> 'lzip level)
+       (make-lzip-output-port port
+                              #:level level))
+      (($ <compression> 'zstd level)
+       (make-zstd-output-port port
+                              #:level level))
+      (($ <compression> 'none)
+       port)
+      (#f
+       port))))
 
 (define (http-write server client response body)
   "Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid
 blocking."
+  ;; XXX: The default Guile web server implementation supports the keep-alive
+  ;; mechanism.  However, as we run our own modified version of the http-write
+  ;; procedure, we need to access a few server implementation details to keep
+  ;; it functional.
+  (define *error-events*
+    (logior POLLHUP POLLERR))
+
+  (define *read-events*
+    POLLIN)
+
+  (define *events*
+    (logior *error-events* *read-events*))
+
+  ;; Access the server poll set variable.
+  (define http-poll-set
+    (@@ (web server http) http-poll-set))
+
+  ;; Copied from (web server http).
+  (define (keep-alive? response)
+    (let ((v (response-version response)))
+      (and (or (< (response-code response) 400)
+               (= (response-code response) 404))
+           (case (car v)
+             ((1)
+              (case (cdr v)
+                ((1) (not (memq 'close (response-connection response))))
+                ((0) (memq 'keep-alive (response-connection response)))))
+             (else #f)))))
+
+  (define (keep-alive port)
+    "Add the given PORT the server poll set."
+    (force-output port)
+    (poll-set-add! (http-poll-set server) port *events*))
+
+  (define compression
+    (assoc-ref (response-headers response) 'x-nar-compression))
+
   (match (response-content-type response)
     (('application/x-nix-archive . _)
-     ;; Sending the the whole archive can take time so do it in a separate
-     ;; thread so that the main thread can keep working in the meantime.
-     (call-with-new-thread
-      (lambda ()
-        (set-thread-name "publish nar")
-        (let* ((compression (assoc-ref (response-headers response)
-                                       'x-nar-compression))
-               (response    (write-response (sans-content-length response)
-                                            client))
-               (port        (begin
-                              (force-output client)
-                              (configure-socket client)
-                              (nar-response-port response compression))))
-          ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> in
-          ;; 'render-nar', BODY here is just the file name of the store item.
-          ;; We call 'write-file' from here because we know that's the only
-          ;; way to avoid building the whole nar in memory, which could
-          ;; quickly become a real problem.  As a bonus, we even do
-          ;; sendfile(2) directly from the store files to the socket.
-          (swallow-zlib-error
-           (swallow-EPIPE
-            (write-file (utf8->string body) port)))
-          (swallow-zlib-error
-           (close-port port))
-          (values)))))
+     ;; When compressing the NAR on the go, we cannot announce its size
+     ;; beforehand to the client. Hence, the keep-alive mechanism cannot work
+     ;; here.
+     (let ((keep-alive? (and (eq? (compression-type compression) 'none)
+                             (keep-alive? response))))
+       ;; Add the client to the server poll set, so that we can receive
+       ;; further requests without closing the connection.
+       (when keep-alive?
+         (keep-alive client))
+       ;; Sending the the whole archive can take time so do it in a separate
+       ;; thread so that the main thread can keep working in the meantime.
+       (call-with-new-thread
+        (lambda ()
+          (set-thread-name "publish nar")
+          (let* ((response    (write-response (sans-content-length response)
+                                              client))
+                 (port        (begin
+                                (force-output client)
+                                (configure-socket client)
+                                (nar-response-port response compression))))
+            ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093>
+            ;; in 'render-nar', BODY here is just the file name of the store
+            ;; item.  We call 'write-file' from here because we know that's
+            ;; the only way to avoid building the whole nar in memory, which
+            ;; could quickly become a real problem.  As a bonus, we even do
+            ;; sendfile(2) directly from the store files to the socket.
+            (swallow-zlib-error
+             (swallow-EPIPE
+              (write-file (utf8->string body) port)))
+            (swallow-zlib-error
+             (close-port port)
+             (unless keep-alive?
+               (close-port client)))
+            (values))))))
     (_
      (match (assoc-ref (response-headers response) 'x-raw-file)
        ((? string? file)
+        (when (keep-alive? response)
+          (keep-alive client))
         ;; Send a raw file in a separate thread.
         (call-with-new-thread
          (lambda ()
@@ -932,19 +985,20 @@ blocking."
                (call-with-input-file file
                  (lambda (input)
                    (let* ((size     (stat:size (stat input)))
-                          (response (write-response (with-content-length response
-                                                                         size)
-                                                    client))
+                          (response (write-response
+                                     (with-content-length response size)
+                                     client))
                           (output   (response-port response)))
                      (configure-socket client)
                      (if (file-port? output)
                          (sendfile output input size)
                          (dump-port input output))
-                     (close-port output)
+                     (unless (keep-alive? response)
+                       (close-port output))
                      (values)))))
              (lambda args
-               ;; If the file was GC'd behind our back, that's fine.  Likewise if
-               ;; the client closes the connection.
+               ;; If the file was GC'd behind our back, that's fine.  Likewise
+               ;; if the client closes the connection.
                (unless (memv (system-error-errno args)
                              (list ENOENT EPIPE ECONNRESET))
                  (apply throw args))
-- 
2.31.1

[bug#48559] [PATCH 2/4] scripts: publish: Forward the request connection header.

[Mathieu Othacehe]

The Guile web server is reading the response connection header to decide
whether to close the connection. However, as the request connection header is
not forwarded to the response, this mechanism cannot work.

* guix/scripts/publish.scm (add-extra-headers): New procedure.
(make-request-handler): Use it to forward the request connection header to the
response.
---
 guix/scripts/publish.scm | 21 +++++++++++++++++++--
 1 file changed, 19 insertions(+), 2 deletions(-)

diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 19fed574c2..260f98edf0 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -34,6 +34,7 @@
   #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
@@ -1034,6 +1035,14 @@ methods, return the applicable compression."
             compressions)
       (default-compression requested-type)))
 
+(define (add-extra-headers request response)
+  "Append the REQUEST connection header to the given RESPONSE headers and
+return them."
+  (if (pair? response)
+      `(,@response
+        ,(assq 'connection (request-headers request)))
+      response))
+
 (define* (make-request-handler store
                                #:key
                                cache pool
@@ -1047,7 +1056,7 @@ methods, return the applicable compression."
     (let ((expected (split-and-decode-uri-path nar-path)))
       (cut equal? expected <>)))
 
-  (lambda (request body)
+  (define (handle request body)
     (format #t "~a ~a~%"
             (request-method request)
             (uri-path (request-uri request)))
@@ -1119,7 +1128,15 @@ methods, return the applicable compression."
                (not-found request)))
 
           (x (not-found request)))
-        (not-found request))))
+        (not-found request)))
+
+  ;; Forward the request connection header to the response, so that the server
+  ;; can close the connection if this is requested by the client.
+  (lambda (request body)
+    (let-values (((response response-body)
+                  (handle request body)))
+      (values (add-extra-headers request response)
+              response-body))))
 
 (define (service-name)
   "Return the Avahi service name of the server."
-- 
2.31.1

[bug#48558] [PATCH 3/4] progress: Add a download-size argument to progress-report-port.

[Mathieu Othacehe]

* guix/progress.scm (progress-report-port): Add a download-size argument.
---
 guix/progress.scm | 16 +++++++++++++---
 1 file changed, 13 insertions(+), 3 deletions(-)

diff --git a/guix/progress.scm b/guix/progress.scm
index 334bd40547..0cbc804ec1 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -347,15 +347,25 @@ should be a <progress-reporter> object."
               (report total)
               (loop total (get-bytevector-n! in buffer 0 buffer-size))))))))
 
-(define* (progress-report-port reporter port #:key (close? #t))
+(define* (progress-report-port reporter port
+                               #:key
+                               (close? #t)
+                               download-size)
   "Return a port that continuously reports the bytes read from PORT using
 REPORTER, which should be a <progress-reporter> object.  When CLOSE? is true,
-PORT is closed when the returned port is closed."
+PORT is closed when the returned port is closed.
+
+When DOWNLOAD-SIZE is passed, do not read more than DOWNLOAD-SIZE bytes from
+PORT.  This is important to avoid blocking when the remote side won't close
+the underlying connection."
   (match reporter
     (($ <progress-reporter> start report stop)
      (let* ((total 0)
             (read! (lambda (bv start count)
-                     (let ((n (match (get-bytevector-n! port bv start count)
+                     (let* ((count (if download-size
+                                       (min count (- download-size total))
+                                       count))
+                            (n (match (get-bytevector-n! port bv start count)
                                 ((? eof-object?) 0)
                                 (x x))))
                        (set! total (+ total n))
-- 
2.31.1

[bug#48560] [PATCH 4/4] scripts: substitute: Add keep-alive support when reading NAR.

[Mathieu Othacehe]

* guix/scripts/substitute.scm (process-substitution): Pass the download size
to the progress-report-port procedure so that it doesn't block reading from
the input port when keep-alive is supported.
---
 guix/scripts/substitute.scm | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 8e4eae00b3..54311c3e08 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -518,8 +518,11 @@ PORT."
                                          (current-error-port)
                                          #:abbreviation nar-uri-abbreviation))))
                      ;; Keep RAW open upon completion so we can later reuse
-                     ;; the underlying connection.
-                     (progress-report-port reporter raw #:close? #f)))
+                     ;; the underlying connection.  Pass the download size so
+                     ;; that this procedure won't block reading from RAW.
+                     (progress-report-port reporter raw
+                                           #:close? #f
+                                           #:download-size dl-size)))
                   ((input pids)
                    ;; NOTE: This 'progress' port of current process will be
                    ;; closed here, while the child process doing the
-- 
2.31.1