From 9398c1869801f120927ca4c27188d43e2c0e4db2 Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Tue, 5 Jul 2022 01:46:26 +0530
Subject: web: server: Serve static files too.

* tissue/web/server.scm: Import (srfi srfi-171) and (ice-9
filesystem).
(%mime-types): New variable.
(handler): Serve static files too.
---
 tissue/web/server.scm | 38 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 38 insertions(+)

(limited to 'tissue')

diff --git a/tissue/web/server.scm b/tissue/web/server.scm
index d07e629..b5338b0 100644
--- a/tissue/web/server.scm
+++ b/tissue/web/server.scm
@@ -22,6 +22,8 @@
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-171)
+  #:use-module (ice-9 filesystem)
   #:use-module (ice-9 match)
   #:use-module (htmlprag)
   #:use-module (sxml simple)
@@ -168,6 +170,18 @@ operators "
            (string-split query #\&))
       '()))
 
+(define %mime-types
+  '(("gif" image/gif)
+    ("html" text/html)
+    ("jpeg" image/jpeg)
+    ("jpg" image/jpeg)
+    ("js" text/javascript)
+    ("json" application/json)
+    ("png" image/png)
+    ("pdf" application/pdf)
+    ("svg" image/svg+xml)
+    ("txt" text/plain)))
+
 (define (handler request body hosts state-directory)
   "Handle web REQUEST with BODY and return two values---the response
 headers and body.
@@ -189,6 +203,7 @@ STATE-DIRECTORY."
                     (repository-open
                      (string-append state-directory "/" hostname "/repository"))))
       (cond
+       ;; Search page
        ((member path (list "/" "/search"))
         (let ((search-query (or (assoc-ref parameters "query")
                                 "")))
@@ -212,6 +227,29 @@ STATE-DIRECTORY."
                           search-query
                           (MSet-get-matches-estimated mset)
                           (assq-ref host-parameters 'css)))))))))
+       ;; Static files
+       ((let ((file-path (string-append state-directory "/" hostname "/website" path)))
+          (and (file-exists? file-path)
+               ;; Check that the file really is within the document
+               ;; root.
+               (string-prefix? (string-append state-directory "/" hostname "/website/")
+                               (canonicalize-path file-path))
+               (canonicalize-path file-path)))
+        => (lambda (file-path)
+             (values `((content-type . ,(or (assoc-ref %mime-types (string-remove-prefix
+                                                                    "." (file-name-extension file-path)))
+                                            '(application/octet-stream))))
+                     ;; Return a procedure so that the file can be
+                     ;; read out a little at a time instead of having
+                     ;; to load it whole into memory.
+                     (lambda (out)
+                       (call-with-input-file file-path
+                         (lambda (in)
+                           (port-transduce (tmap (cut put-bytevector out <>))
+                                           (const #t)
+                                           get-bytevector-some
+                                           in)))))))
+       ;; Not found
        (else
         (values (build-response #:code 404)
                 (string-append "Resource not found: "
-- 
cgit v1.2.3