From fb26896560dbdfa80eb517d157e9afd2562e1f8e Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Sun, 29 Jan 2023 16:56:43 +0000
Subject: web: Do not temporarily checkout repository when serving it.
Now that snippet source texts are interred into the xapian index, the
web server does not need a repository checkout.
* bin/tissue (tissue-web): Do not temporarily checkout repositories
being served.
* tissue/web/server.scm (handler): Do not change into repository
directory.
* tissue/git.scm (call-with-temporary-checkouts): Delete function.
* .dir-locals.el (scheme-mode): Unregister it.
---
.dir-locals.el | 1 -
bin/tissue | 41 +++++++++++++++++--------------------
tissue/git.scm | 14 +------------
tissue/web/server.scm | 56 +++++++++++++++++++++++++--------------------------
4 files changed, 46 insertions(+), 66 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index 8c01904..38e25e1 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -9,7 +9,6 @@
(eval . (put 'call-with-current-directory 'scheme-indent-function 1))
(eval . (put 'call-with-file-in-git 'scheme-indent-function 2))
(eval . (put 'call-with-temporary-checkout 'scheme-indent-function 1))
- (eval . (put 'call-with-temporary-checkouts 'scheme-indent-function 1))
(eval . (put 'function-documentation 'scheme-indent-function 2))
(eval . (put 'docstring-function-documentation 'scheme-indent-function 2))
(eval . (put 'with-ellipsis 'scheme-indent-function 1))
diff --git a/bin/tissue b/bin/tissue
index f9524ac..606e36d 100755
--- a/bin/tissue
+++ b/bin/tissue
@@ -266,29 +266,24 @@ Serve repositories specified in CONFIG-FILE over HTTP.
(default-configuration))))
(when (assq-ref args 'listen-repl)
(start-repl (assq-ref args 'listen-repl)))
- (let* ((state-directory (assq-ref args 'state-directory))
- (hosts (assq-ref args 'hosts)))
- (call-with-temporary-checkouts (map (match-lambda
- ((name _ ...)
- (string-append state-directory "/" name "/repository")))
- hosts)
- (lambda checkouts
- (start-web-server (listen->socket-address (assq-ref args 'listen))
- (map (match-lambda*
- (((name parameters ...) repository-directory)
- ;; Add CSS, repository directory,
- ;; website directory, xapian
- ;; directory settings for each host.
- (parameterize ((%current-git-repository
- (repository-open repository-directory)))
- (cons name
- `((project . ,(load-config))
- (repository-directory . ,repository-directory)
- (website-directory . ,(string-append state-directory "/" name "/website"))
- (xapian-directory . ,(string-append state-directory "/" name "/xapian"))
- ,@parameters)))))
- hosts
- checkouts)))))))))
+ (start-web-server (listen->socket-address (assq-ref args 'listen))
+ (map (match-lambda
+ ((name parameters ...)
+ ;; Add CSS, repository directory,
+ ;; website directory, xapian
+ ;; directory settings for each host.
+ (let* ((state-directory (assq-ref args 'state-directory))
+ (repository-directory
+ (string-append state-directory "/" name "/repository")))
+ (parameterize ((%current-git-repository
+ (repository-open repository-directory)))
+ (cons name
+ `((project . ,(load-config))
+ (repository-directory . ,repository-directory)
+ (website-directory . ,(string-append state-directory "/" name "/website"))
+ (xapian-directory . ,(string-append state-directory "/" name "/xapian"))
+ ,@parameters))))))
+ (assq-ref args 'hosts)))))))
(define tissue-web-dev
(match-lambda*
diff --git a/tissue/git.scm b/tissue/git.scm
index b67d65c..4289d65 100644
--- a/tissue/git.scm
+++ b/tissue/git.scm
@@ -48,8 +48,7 @@
call-with-file-in-git
file-modification-table
clone-options
- call-with-temporary-checkout
- call-with-temporary-checkouts))
+ call-with-temporary-checkout))
;; We bind additional functions from libgit2 that are not already
;; bound in guile-git. TODO: Contribute them to guile-git.
@@ -223,14 +222,3 @@ checkout when PROC returns or exits non-locally."
(proc temporary-checkout))
;; The system-dependent temporary directory
(dirname (tmpnam))))
-
-(define (call-with-temporary-checkouts repositories proc)
- "Call PROC with temporary checkouts of REPOSITORIES, and delete the
-checkouts when PROC returns or exits non-locally."
- (match repositories
- ((repository other-repositories ...)
- (call-with-temporary-checkout repository
- (lambda (checkout)
- (call-with-temporary-checkouts other-repositories
- (cut proc checkout <...>)))))
- (() (proc))))
diff --git a/tissue/web/server.scm b/tissue/web/server.scm
index 43093f8..db89bae 100644
--- a/tissue/web/server.scm
+++ b/tissue/web/server.scm
@@ -157,35 +157,33 @@ See `start-web-server' for documentation of HOSTS."
(log-request request)
(parameterize ((%current-git-repository
(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))))))))
+ (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