From ae1a4caa27cf49e3c9bdd40bd6ea04e99f0f2366 Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Sat, 28 Jan 2023 23:49:29 +0000
Subject: web: Change to repository directory when handling requests.

Files in the repository may be read. So, we must change into a
checkout of the repository when handling requests.

* tissue/web/server.scm (handler): Change to repository directory when
handling requests.
---
 tissue/web/server.scm | 62 ++++++++++++++++++++++++++-------------------------
 1 file changed, 32 insertions(+), 30 deletions(-)

(limited to 'tissue')

diff --git a/tissue/web/server.scm b/tissue/web/server.scm
index e794ed0..43093f8 100644
--- a/tissue/web/server.scm
+++ b/tissue/web/server.scm
@@ -152,38 +152,40 @@ See `start-web-server' for documentation of HOSTS."
          (host-parameters (or (assoc-ref hosts hostname)
                               (raise (condition
                                       (make-message-condition "Unknown host")
-                                      (make-irritants-condition hostname))))))
+                                      (make-irritants-condition hostname)))))
+         (repository-directory (assq-ref host-parameters 'repository-directory)))
     (log-request request)
     (parameterize ((%current-git-repository
-                    (repository-open
-                     (assq-ref host-parameters 'repository-directory))))
-      (cond
-       ;; Static files
-       ((let ((file-path
-               (find file-exists?
-                     (map (cut string-append (assq-ref host-parameters 'website-directory) <>)
-                          (try-paths path)))))
-          (and file-path
-               ;; Check that the file really is within the document
-               ;; root.
-               (string-prefix? (string-append (assq-ref host-parameters 'website-directory) "/")
-                               (canonicalize-path file-path))
-               (canonicalize-path file-path)))
-        => (lambda (file-path)
-             (values `((content-type . ,(mime-type-for-extension
-                                         (file-name-extension file-path))))
-                     (call-with-input-file file-path
-                       get-bytevector-all))))
-       ;; Search page. We look for the search page only after files
-       ;; because we want to let files shadow the search page if
-       ;; necessary.
-       ((member path (list "/" "/search"))
-        (search-handler request body
-                        (assq-ref host-parameters 'xapian-directory)
-                        (assq-ref host-parameters 'project)))
-       ;; Not found
-       (else
-        (404-response request))))))
+                    (repository-open repository-directory)))
+      (call-with-current-directory repository-directory
+        (lambda ()
+          (cond
+           ;; Static files
+           ((let ((file-path
+                   (find file-exists?
+                         (map (cut string-append (assq-ref host-parameters 'website-directory) <>)
+                              (try-paths path)))))
+              (and file-path
+                   ;; Check that the file really is within the document
+                   ;; root.
+                   (string-prefix? (string-append (assq-ref host-parameters 'website-directory) "/")
+                                   (canonicalize-path file-path))
+                   (canonicalize-path file-path)))
+            => (lambda (file-path)
+                 (values `((content-type . ,(mime-type-for-extension
+                                             (file-name-extension file-path))))
+                         (call-with-input-file file-path
+                           get-bytevector-all))))
+           ;; Search page. We look for the search page only after files
+           ;; because we want to let files shadow the search page if
+           ;; necessary.
+           ((member path (list "/" "/search"))
+            (search-handler request body
+                            (assq-ref host-parameters 'xapian-directory)
+                            (assq-ref host-parameters 'project)))
+           ;; Not found
+           (else
+            (404-response request))))))))
 
 (define (start-web-server socket-address hosts)
   "Start web server listening on SOCKET-ADDRESS.
-- 
cgit v1.2.3