diff options
| -rw-r--r-- | .dir-locals.el | 1 | ||||
| -rwxr-xr-x | bin/tissue | 41 | ||||
| -rw-r--r-- | tissue/git.scm | 14 | ||||
| -rw-r--r-- | 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)) @@ -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. |