From 0c5e91c170639d50d1cc339fa0b0e68ea4fba68c Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <m.othacehe@gmail.com>
Date: Fri, 1 May 2020 15:03:12 +0200
Subject: [PATCH] cuirass: Use sendfiles instead of raw copies.

* src/cuirass/http.scm (respond-file): Send the file name as an UTF8
bytevector, instead of the raw file content,
(respond-gzipped-file): ditto. Also set 'content-disposition header.
* src/web/server/fiberized.scm (client-loop): Check if 'content-disposition is
set. If it's the case, assume that the bytevector is the file name, and use
sendfiles to send it. Otherwise, keep the existing behaviour and send directly
the received bytevector.
---
 src/cuirass/http.scm         | 25 ++++++++++---------------
 src/web/server/fiberized.scm | 21 +++++++++++++++++++--
 2 files changed, 29 insertions(+), 17 deletions(-)

diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 79fa246..bdc780c 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -40,7 +40,8 @@
   #:use-module (web uri)
   #:use-module (fibers)
   #:use-module (fibers channels)
-  #:use-module ((rnrs bytevectors) #:select (utf8->string))
+  #:use-module ((rnrs bytevectors) #:select (utf8->string
+                                             string->utf8))
   #:use-module (sxml simple)
   #:use-module (cuirass templates)
   #:use-module (guix utils)
@@ -246,19 +247,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)))))
+               #:body (string->utf8 file))))
 
   (define (respond-static-file path)
     ;; PATH is a list of path components
@@ -273,10 +269,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))))
+             #:body (string->utf8 file)))
 
   (define (respond-build-not-found build-id)
     (respond-json-with-error
@@ -521,7 +516,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..68ae132 100644
--- a/src/web/server/fiberized.scm
+++ b/src/web/server/fiberized.scm
@@ -37,6 +37,7 @@
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (web server)
+  #:use-module ((rnrs bytevectors) #:select (utf8->string))
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 match)
   #:use-module (fibers)
@@ -92,6 +93,8 @@
               ((0) (memq 'keep-alive (response-connection response)))))
            (else #f)))))
 
+(define extend-response (@@ (web server) extend-response))
+
 (define (client-loop client have-request)
   ;; Always disable Nagle's algorithm, as we handle buffering
   ;; ourselves.
@@ -119,9 +122,23 @@
                                               #:headers '((content-length . 0)))
                               #vu8()))))
               (lambda (response body)
-                (write-response response client)
                 (when body
-                  (put-bytevector client body))
+                  (let* ((headers (response-headers response))
+                         (file? (assq-ref headers 'content-disposition))
+                         (file (and file? (utf8->string body)))
+                         (file-size (and file? (stat:size (stat file)))))
+                    (cond
+                     (file?
+                      (call-with-input-file file
+                        (lambda (port)
+                          (write-response
+                           (extend-response response 'content-length
+                                            file-size)
+                           client)
+                          (sendfile client port file-size))))
+                     (else
+                      (write-response response client)
+                      (put-bytevector client body)))))
                 (force-output client)
                 (if (and (keep-alive? response)
                          (not (eof-object? (peek-char client))))
-- 
2.26.0