From 25104d4422e43b18b7fc4bf17a7ca8440394eda8 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Tue, 5 Apr 2022 15:44:45 +0530 Subject: web: Introduce objects for web export. With objects specifying the files to export to the web, the user has ultimate flexibility in their choice of what to export and how to export. * bin/tissue (tissue-web): Parameterize %project-name and %tags-path. Use new signature of build-website. * tissue/tissue.scm: Import (srfi srfi-1) and (srfi srfi-71). ()[web-files]: New field. (tissue-configuration-web-files): New public function. (tissue-configuration): New macro. * tissue/web.scm: Import (srfi srfi-9). (%project-name): New public parameter. (): New type. (build-issue-listing): Delete function. (copier, gemtext-reader, gemtext-exporter, skribe-exporter, tag-issue-lister, tag-pages): New public functions. (exporter, with-current-directory): New functions. (build-website): Simply write objects to files. (replace-extension): Export. --- bin/tissue | 12 ++-- tissue/tissue.scm | 41 +++++++++--- tissue/web.scm | 195 +++++++++++++++++++++++++++++++++--------------------- 3 files changed, 160 insertions(+), 88 deletions(-) diff --git a/bin/tissue b/bin/tissue index 2d05ba9..3e92f16 100755 --- a/bin/tissue +++ b/bin/tissue @@ -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 . (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 - (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 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 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 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 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 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)) -- cgit v1.2.3