cuirass: Use sendfiles instead of raw copies.

* src/cuirass/http.scm (respond-file): Send the file name as 'x-raw-file
header argument, instead of the raw file content,
(respond-gzipped-file): ditto. Also set 'content-disposition header.
* src/web/server/fiberized.scm (strip-headers, with-content-length): New procedures,
(client-loop): Check if 'x-raw-file is set. If it's the case, use sendfiles to
send the given file. Otherwise, keep the existing behaviour and send directly
the received bytevector.

2 files changed, 54 insertions, 24 deletions

diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 79fa246..0b2f056 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -246,19 +246,14 @@ Hydra format."
         "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")
        (sxml->xml body port))))
 
-  (define* (respond-file file
-                         #:key name)
+  (define* (respond-file file)
     (let ((content-type (or (assoc-ref %file-mime-types
                                        (file-extension file))
                             '(application/octet-stream))))
       (respond `((content-type . ,content-type)
-                 ,@(if name
-                       `((content-disposition
-                          . (form-data (filename . ,name))))
-                       '()))
-               ;; FIXME: FILE is potentially big so it'd be better to not load
-               ;; it in memory and instead 'sendfile' it.
-               #:body (call-with-input-file file get-bytevector-all))))
+                 (content-disposition
+                  . (form-data (filename . ,(basename file))))
+                 (x-raw-file . ,file)))))
 
   (define (respond-static-file path)
     ;; PATH is a list of path components
@@ -273,10 +268,9 @@ Hydra format."
   (define (respond-gzipped-file file)
     ;; Return FILE with 'gzip' content-encoding.
     (respond `((content-type . (text/plain (charset . "UTF-8")))
-               (content-encoding . (gzip)))
-             ;; FIXME: FILE is potentially big so it'd be better to not load
-             ;; it in memory and instead 'sendfile' it.
-             #:body (call-with-input-file file get-bytevector-all)))
+               (content-encoding . (gzip))
+               (content-disposition . (form-data (filename . ,file)))
+               (x-raw-file . ,file))))
 
   (define (respond-build-not-found build-id)
     (respond-json-with-error
@@ -521,7 +515,7 @@ Hydra format."
 
     (('GET "download" id)
      (let ((path (db-get-build-product-path id)))
-       (respond-file path #:name (basename path))))
+       (respond-file path)))
 
     (('GET "static" path ...)
      (respond-static-file path))
diff --git a/src/web/server/fiberized.scm b/src/web/server/fiberized.scm
index 308b642..7769202 100644
--- a/src/web/server/fiberized.scm
+++ b/src/web/server/fiberized.scm
@@ -31,8 +31,12 @@
 ;;; Code:
 
 (define-module (web server fiberized)
-  #:use-module ((srfi srfi-1) #:select (fold))
+  #:use-module (guix build utils)
+  #:use-module ((srfi srfi-1) #:select (fold
+                                        alist-delete
+                                        alist-cons))
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (web http)
   #:use-module (web request)
   #:use-module (web response)
@@ -41,7 +45,8 @@
   #:use-module (ice-9 match)
   #:use-module (fibers)
   #:use-module (fibers channels)
-  #:use-module (cuirass logging))
+  #:use-module (cuirass logging)
+  #:use-module (cuirass utils))
 
 (define (make-default-socket family addr port)
   (let ((sock (socket PF_INET SOCK_STREAM 0)))
@@ -92,6 +97,19 @@
               ((0) (memq 'keep-alive (response-connection response)))))
            (else #f)))))
 
+;; This procedure and the next one are copied from (guix scripts publish).
+(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)))
+
+(define (with-content-length response length)
+  "Return RESPONSE with a 'content-length' header set to LENGTH."
+  (set-field response (response-headers)
+             (alist-cons 'content-length length
+                         (strip-headers response))))
+
 (define (client-loop client have-request)
   ;; Always disable Nagle's algorithm, as we handle buffering
   ;; ourselves.
@@ -119,14 +137,32 @@
                                               #:headers '((content-length . 0)))
                               #vu8()))))
               (lambda (response body)
-                (write-response response client)
-                (when body
-                  (put-bytevector client body))
-                (force-output client)
-                (if (and (keep-alive? response)
-                         (not (eof-object? (peek-char client))))
-                    (loop)
-                    (close-port client)))))))))
+                (match (assoc-ref (response-headers response) 'x-raw-file)
+                  ((? string? file)
+                   (non-blocking
+                    (call-with-input-file file
+                      (lambda (input)
+                        (let* ((size     (stat:size (stat input)))
+                               (response (write-response
+                                          (with-content-length response size)
+                                          client))
+                               (output   (response-port response)))
+                          (setsockopt client SOL_SOCKET SO_SNDBUF
+                                      (* 128 1024))
+                          (if (file-port? output)
+                              (sendfile output input size)
+                              (dump-port input output))
+                          (close-port output)
+                          (values))))))
+                  (#f (begin
+                        (write-response response client)
+                        (when body
+                          (put-bytevector client body))
+                        (force-output client))
+                      (if (and (keep-alive? response)
+                               (not (eof-object? (peek-char client))))
+                          (loop)
+                          (close-port client)))))))))))
     (lambda (k . args)
       (catch #t
         (lambda () (close-port client))