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.

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.