A newerer beginning

1 files changed, 79 insertions, 0 deletions

@@ -0,0 +1,79 @@
+(declare (module (boudin page instances))
+         (export make-feed
+                 make-index
+                 make-post
+                 post-path-transformers
+                 post-text-transformers))
+
+(import (boudin page write)
+        (boudin page)
+        (boudin site)
+        (boudin util)
+        (chicken pathname)
+        (html-parser)
+        (except (schmaltz)
+                render-specials
+                render-unprintables)
+        (schmaltz chicken)
+        (srfi 152))
+
+(define (make-post path)
+  (let ((sxml ((apply o (post-text-transformers))
+               (with-input-from-file path slurp))))
+    (make-page sxml
+               ((apply o (post-path-transformers)) path)
+               (post-template)
+               (post-writer)
+               (cons (cons "source" path)
+                     (*extract-metadata sxml)))))
+
+(define (*extract-metadata sxml)
+  (let loop ((tree sxml)
+             (acc '()))
+    (cond
+     ((not (pair? tree))
+      (reverse acc))
+     ((and (list? (car tree))
+           (eq? (caar tree) '*COMMENT*))
+      (loop (cdr tree)
+            (map (lambda (ln)
+                   (let ((kv (string-split ln ":" 'infix 1)))
+                     (cons (string-trim-both (car kv))
+                           (string-trim (cdr kv)))))
+                 (string-split (cadar tree) "\n"))))
+     ((list? (car tree))
+      (loop (cdr tree)
+            (let ((subtree (loop (car tree) '())))
+              (if (null? subtree)
+                  acc
+                  (cons subtree acc)))))
+     (else (loop (cdr tree) acc)))))
+
+(define (make-index pgs)
+  (make-page ((index-template) pgs)
+             (make-pathname (site-output) "index.html")
+             page-content
+             (index-writer)
+             `()))
+
+(define (make-feed pgs)
+  (make-page ((feed-template) pgs)
+             (make-pathname (site-output) "feed.xml")
+             page-content
+             (feed-writer)
+             `()))
+
+;; Configurables
+
+(define post-text-transformers
+  (make-parameter
+   (list html->sxml
+         wrap-paragraphs
+         render-string->string)))
+
+(define post-path-transformers
+  (make-parameter
+   (list (lambda (path)
+           (make-pathname (list (site-output)
+                                (pathname-strip-extension path))
+                          "index.html")))))