web: Introduce <file> objects for web export.

With <file> 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).
(<tissue-configuration>)[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.
(<file>): 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 <file> objects to files.
(replace-extension): Export.

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 <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))