[bug#40993] cuirass: Add build products download support.

[Mathieu Othacehe]

Hey Danny,

> very cool!

Thanks :)

> Though I agree using sendfile would be much better, especially since the user
> can download 800 MB image files there.
>
> The guile (web server) module allows passing a procedure as the #:body, but
> then it makes a bytevector out of the result and hard-codes the content-type 
> :P.
>
> Eventually (web server http) http-write is reached, which only supports 
> encoding
> bytevectors and #f, that's it.  No files.
>
> So we'd have to overwrite http-write.
>
> But we are using our own (web server fiberized) impl already.
>
> So our impl chould be extended to be able to get and process FDs.
>
> client-loop there has
>
>               (lambda (response body)
>                 (write-response response client)
>                 (when body
>                   (put-bytevector client body))
>
> which means the "when body" part should be extended to also handle files, not 
> just bytevectors.

The problem is that even with our fiberized implementation, what we pass
as "body" is checked in "sanitize-response" procedure of Guile's (web
server) module.

With the (very) hacky patch attached, I fool sanitize-response, by
sending the file name as a bytevector. This allows me to save gigabytes
of RAM when downloading disk images.

WDYT?

Thanks,

Mathieu

>From 0c5e91c170639d50d1cc339fa0b0e68ea4fba68c Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <address@hidden>
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