diff options
| -rwxr-xr-x | bin/tissue | 12 | ||||
| -rw-r--r-- | tissue/tissue.scm | 41 | ||||
| -rw-r--r-- | tissue/web.scm | 195 |
3 files changed, 160 insertions, 88 deletions
@@ -365,11 +365,13 @@ Export the repository as a website to OUTPUT-DIRECTORY. " (command-line-program))) ((output-directory) - (let ((config (load-config))) - (build-website output-directory - #:title (tissue-configuration-project config) - #:css (tissue-configuration-web-css config) - #:tags-path (tissue-configuration-web-tags-path config)))))) + (parameterize ((%project-name (tissue-configuration-project (load-config))) + (%tags-path (tissue-configuration-web-tags-path + (load-config)))) + (build-website (git-top-level) + output-directory + (tissue-configuration-web-css (load-config)) + (tissue-configuration-web-files (load-config))))))) (define (print-usage) (format #t "Usage: ~a COMMAND [OPTIONS] [ARGS] diff --git a/tissue/tissue.scm b/tissue/tissue.scm index c1add7a..4af4886 100644 --- a/tissue/tissue.scm +++ b/tissue/tissue.scm @@ -17,25 +17,40 @@ ;;; along with tissue. If not, see <https://www.gnu.org/licenses/>. (define-module (tissue tissue) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-71) #:export (tissue-configuration tissue-configuration? tissue-configuration-project tissue-configuration-aliases tissue-configuration-web-css - tissue-configuration-web-tags-path)) + tissue-configuration-web-tags-path + tissue-configuration-web-files)) (define-record-type <tissue-configuration> - (make-tissue-configuration project aliases web-css web-tags-path) + (make-tissue-configuration project aliases web-css web-tags-path web-files) tissue-configuration? (project tissue-configuration-project) (aliases tissue-configuration-aliases) (web-css tissue-configuration-web-css) - (web-tags-path tissue-configuration-web-tags-path)) + (web-tags-path tissue-configuration-web-tags-path) + (web-files delayed-tissue-configuration-web-files)) -(define* (tissue-configuration #:key project (aliases '()) web-css (web-tags-path "/tags")) - "PROJECT is the name of the project. It is used in the title of the -generated web pages, among other places. +(define tissue-configuration-web-files + (compose force delayed-tissue-configuration-web-files)) + +(define-syntax tissue-configuration + (lambda (x) + (syntax-case x () + ((_ args ...) + (let ((before after (break (lambda (arg) + (eq? (syntax->datum arg) + #:web-files)) + #'(args ...)))) + #`(apply (lambda* (#:key project (aliases '()) web-css (web-tags-path "/tags") (web-files '())) + "PROJECT is the name of the project. It is used in +the title of the generated web pages, among other places. ALIASES is a list of aliases used to refer to authors in the repository. Each element is in turn a list of aliases an author goes @@ -46,6 +61,14 @@ document root and must begin with a /. If it is #f, no stylesheet is used in the generated web pages. WEB-TAGS-PATH is the path relative to the document root where the -per-tag issue listings are put. It must begin with a /. If it is #f, -per-tag issue listings are not generated." - (make-tissue-configuration project aliases web-css web-tags-path)) +per-tag issue listings are put. It must begin with a /. + +WEB-FILES is a list of <file> objects representing files to be written +to the web output." + (make-tissue-configuration project aliases web-css web-tags-path web-files)) + (list #,@(append before + (syntax-case after () + ((web-files-key web-files rest ...) + #`(web-files-key (delay web-files) + rest ...)) + (() #'())))))))))) diff --git a/tissue/web.scm b/tissue/web.scm index 8406afc..0117f3e 100644 --- a/tissue/web.scm +++ b/tissue/web.scm @@ -20,6 +20,7 @@ #:use-module (rnrs exceptions) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-28) #:use-module (srfi srfi-171) @@ -36,12 +37,34 @@ #:use-module (tissue conditions) #:use-module (tissue issue) #:use-module (tissue utils) - #:export (issue-listing + #:export (%project-name + %tags-path + file + file? + file-name + file-writer + issue-listing + replace-extension + copier + gemtext-reader + gemtext-exporter + skribe-exporter + tag-issue-lister + tag-pages build-website)) +(define %project-name + (make-parameter #f)) + (define %tags-path (make-parameter #f)) +(define-record-type <file> + (file name writer) + file? + (name file-name) + (writer file-writer)) + (define (mkdir-p directory) "Create DIRECTORY and all its parents." (unless (or (string=? directory "/") @@ -192,87 +215,111 @@ default, all issues are listed newest first." #:posts (issue-posts issue))) issues))) -(define* (build-issue-listing issues output-file #:key title) - "Write an issues listing page listing ISSUES to OUTPUT-FILE." - (mkdir-p (dirname output-file)) - (with-output-to-file output-file - (cut evaluate-document - (document #:title title - (issue-listing issues)) - (find-engine 'html)))) +(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." + (lambda (out) + ;; Files may be renamed or deleted, but not committed. Therefore, + ;; raise an exception if the file does not exist. + (if (file-exists? file) + (call-with-input-file file + (cut proc <> out)) + (raise (issue-file-not-found-error file))))) -;; TODO: Use guile-filesystem. -(define* (build-website output-directory #:key title css (tags-path "/tags")) - "Export current git repository to OUTPUT-DIRECTORY as a website. +(define (copier file) + "Return a writer function that copies FILE." + (exporter file + (lambda (in out) + (port-transduce (tmap (cut put-bytevector out <>)) + (const #t) + get-bytevector-some + in)))) + +(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* (skribe-exporter file #:optional (reader (make-reader 'skribe))) + "Return a writer function that exports FILE, a skribe file." + (exporter file + (lambda (in out) + (with-output-to-port out + (cut evaluate-document + (evaluate-ast-from-port in #:reader reader) + (find-engine 'html)))))) -TITLE is the title to use head of the generated HTML, among other -places. +(define* (tag-issue-lister tag #:key title) + "Return a writer function that writes a issue listing of issues with TAG. + +TITLE is the title to use in the head of the generated HTML, among +other places." + (lambda (port) + (with-output-to-port port + (cut evaluate-document + (document #:title title + (issue-listing + (reverse (filter (lambda (issue) + (member tag (issue-keywords issue))) + (issues))))) + (find-engine 'html))))) + +(define (tag-pages) + "Return a list of <file> objects representing tag pages to be +exported to the web output." + (map (lambda (tag) + (file (string-append (%tags-path) "/" (sanitize-string tag) ".html") + (tag-issue-lister tag + #:title (string-append tag " — " (%project-name))))) + (delete-duplicates (append-map issue-keywords (issues))))) + +(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)))) + +;; TODO: Use guile-filesystem. +(define* (build-website repository-top-level output-directory css files) + "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. TAGS-PATH is the path relative to the document root where the per-tag issue listings are put. It must begin with a /. If it is #f, per-tag -issue listings are not generated." +issue listings are not generated. + +FILES is a list of <file> objects representing files to be written to +the web output." + ;; Set CSS. (when css (engine-custom-set! (find-engine 'html) 'css css)) + ;; Create output directory. (mkdir-p output-directory) - ;; Export auto-generated files. We must do this before exporting - ;; user-created files to allow users to be able to override - ;; auto-generated files. - (parameterize ((%tags-path tags-path)) - ;; Export home page listing all issues. - (let ((output-file (string-append output-directory "/index.html"))) - (display (format "~a~%" output-file)) - (build-issue-listing (reverse (issues)) output-file - #:title title)) - ;; Export per-tag listings. - (when tags-path - (for-each (lambda (tag) - (let ((output-file (string-append output-directory - tags-path "/" - (sanitize-string tag) ".html"))) - (display (format "tag: ~a -> ~a~%" tag output-file)) - (build-issue-listing (reverse (filter (lambda (issue) - (member tag (issue-keywords issue))) - (issues))) - output-file - #:title title))) - (delete-duplicates (append-map issue-keywords (issues))))) - ;; Export user-created files. - (call-with-input-pipe - (lambda (port) - (port-transduce - (tmap (lambda (input-file) - (unless (string-prefix? "." (basename input-file)) - (let* ((relative-input-file input-file) - (output-file (string-append output-directory "/" - (if (or (string-suffix? ".gmi" relative-input-file) - (string-suffix? ".skb" relative-input-file)) - (replace-extension relative-input-file "html") - relative-input-file)))) - (display (format "~a -> ~a~%" input-file output-file)) - (mkdir-p (dirname output-file)) - (if (or (string-suffix? ".gmi" input-file) - (string-suffix? ".skb" input-file)) - (with-output-to-file output-file - (cut evaluate-document - ;; Files may be renamed or deleted, but - ;; not committed. Therefore, raise an - ;; exception if the file does not exist. - (if (file-exists? input-file) - (call-with-input-file input-file - (cut evaluate-ast-from-port <> - ;; Relax the gemtext standard - ;; by joining adjacent lines. - #:reader (cond - ((string-suffix? ".gmi" input-file) - ((reader:make (lookup-reader 'gemtext)) - #:join-lines? #t)) - ((string-suffix? ".skb" input-file) - ((reader:make (lookup-reader 'skribe))))))) - (raise (issue-file-not-found-error input-file))) - (find-engine 'html))) - (copy-file input-file output-file)))))) - rcons get-line port)) - "git" "ls-files"))) + ;; Write each of the <file> objects. + (for-each (lambda (file) + (let ((output-file + (string-append output-directory "/" (file-name file)))) + (display output-file (current-error-port)) + (newline (current-error-port)) + (mkdir-p (dirname output-file)) + (call-with-output-file output-file + (lambda (port) + (with-current-directory repository-top-level + (cut (file-writer file) port)))))) + files)) |