diff options
Diffstat (limited to 'tissue/web/static.scm')
| -rw-r--r-- | tissue/web/static.scm | 89 |
1 files changed, 46 insertions, 43 deletions
diff --git a/tissue/web/static.scm b/tissue/web/static.scm index 69a9d90..2b910cb 100644 --- a/tissue/web/static.scm +++ b/tissue/web/static.scm @@ -1,5 +1,5 @@ ;;; tissue --- Text based issue tracker -;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2022, 2023 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of tissue. ;;; @@ -30,24 +30,22 @@ #:use-module (skribilo evaluator) #:use-module (skribilo reader) #:use-module (web uri) + #:use-module (git) #:use-module (tissue git) #:use-module (tissue issue) #:use-module (tissue utils) - #:export (%project-name - file + #:export (file file? file-name file-writer replace-extension copier + html-engine gemtext-reader gemtext-exporter skribe-exporter build-website)) -(define %project-name - (make-parameter #f)) - (define-record-type <file> (file name writer) file? @@ -61,15 +59,15 @@ NEW-EXTENSION." new-extension)) (define (exporter file proc) - "Return a writer function that exports FILE using PROC. PROC is -passed two arguments---the input port to read from and the output port -to write to." + "Return a writer function that exports @var{file} using +@var{proc}. @var{proc} is passed two arguments---the input port to +read from and the output port to write to." (lambda (out) - (call-with-file-in-git (current-git-repository) file + (call-with-input-file file (cut proc <> out)))) (define (copier file) - "Return a writer function that copies FILE." + "Return a writer function that copies @var{file}." (exporter file (lambda (in out) (port-transduce (tmap (cut put-bytevector out <>)) @@ -77,56 +75,63 @@ to write to." get-bytevector-some in)))) +(define (engine-custom-set engine key value) + "Set custom @var{key} of @var{engine} to @var{value}. This is a purely +functional setter that operates on a copy of @var{engine}. It does not +mutate @var{engine}." + (let ((clone (copy-engine (engine-ident engine) engine))) + (engine-custom-set! clone key value) + clone)) + +(define* (html-engine #:key css) + "Return a new HTML engine. + +@var{css} is the URI to a CSS stylesheet. If it is @code{#f}, no +stylesheet is included in the generated web pages." + (if css + (engine-custom-set (find-engine 'html) + 'css + (list css)) + (find-engine 'html))) + (define (gemtext-reader) "Return a skribilo reader for gemtext." ((reader:make (lookup-reader 'gemtext)) ;; Relax the gemtext standard by joining adjacent lines. #:join-lines? #t)) -(define* (gemtext-exporter file #:optional (reader (gemtext-reader))) - "Return a writer function that exports FILE, a gemtext file." - (exporter file - (lambda (in out) - (with-output-to-port out - (cut evaluate-document - (evaluate-ast-from-port in #:reader reader) - (find-engine 'html)))))) +(define* (gemtext-exporter file #:key (reader (gemtext-reader)) + (engine (html-engine))) + "Return a writer function that reads gemtext @var{file} using +@var{reader} and exports it using @var{engine}." + (skribe-exporter file + #:reader reader + #:engine engine)) -(define* (skribe-exporter file #:optional (reader (make-reader 'skribe))) - "Return a writer function that exports FILE, a skribe file." +(define* (skribe-exporter file #:key (reader (make-reader 'skribe)) + (engine (html-engine))) + "Return a writer function that reads skribe @var{file} using +@var{reader} and exports it using @var{engine}." (exporter file (lambda (in out) (with-output-to-port out (cut evaluate-document (evaluate-ast-from-port in #:reader reader) - (find-engine 'html)))))) + engine))))) -(define (with-current-directory directory thunk) - "Change current directory to DIRECTORY, execute THUNK and restore -original current directory." - (let ((previous-current-directory (getcwd))) - (dynamic-wind (const #t) - thunk - (cut chdir previous-current-directory)))) - -(define* (build-website repository-top-level output-directory css files +(define* (build-website output-directory files #:key (log-port (current-error-port))) - "Export git repository with REPOSITORY-TOP-LEVEL to OUTPUT-DIRECTORY -as a website. - -CSS is the path to a CSS stylesheet. If it is #f, no stylesheet is -included in the generated web pages. + "Export git repository to OUTPUT-DIRECTORY as a website. The current +directory must be the top level of the repository being exported. FILES is a list of <file> objects representing files to be written to the web output. Log to LOG-PORT. When LOG-PORT is #f, do not log." - ;; Set CSS. - (when css - (engine-custom-set! (find-engine 'html) 'css css)) ;; Create output directory. (make-directories output-directory) - ;; Write each of the <file> objects. + ;; Move into a temporary clone of the git repository, and write each + ;; of the <file> objects. (for-each (lambda (file) (let ((output-file (string-append output-directory "/" (file-name file)))) @@ -135,7 +140,5 @@ Log to LOG-PORT. When LOG-PORT is #f, do not log." (newline log-port)) (make-directories (dirname output-file)) (call-with-output-file output-file - (lambda (port) - (with-current-directory repository-top-level - (cut (file-writer file) port)))))) + (cut (file-writer file) <>)))) files)) |