From bb4091acb58f0724dca262bc137715f6ed882e5f Mon Sep 17 00:00:00 2001
From: Case Duckworth
Date: Fri, 8 Sep 2023 08:55:10 -0500
Subject: 1.0, why not

---
 boudin.page.post.scm | 77 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 77 insertions(+)
 create mode 100644 boudin.page.post.scm

(limited to 'boudin.page.post.scm')

diff --git a/boudin.page.post.scm b/boudin.page.post.scm
new file mode 100644
index 0000000..002d7bf
--- /dev/null
+++ b/boudin.page.post.scm
@@ -0,0 +1,77 @@
+(declare (module (boudin page post))
+         (export make-post
+                 post-path-transformers
+                 post-text-transformers
+                 post-template
+                 post-writer))
+
+(import (boudin page)
+        (boudin page write)
+        (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 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")))))
+
+(define post-template
+  (make-parameter
+   (lambda (pg)
+     (let ((title (page-ref pg "title")))
+       `(html (@ (lang "en-us"))
+              (head ,@(html-head)
+                    (title ,(or title "[untitled]")))
+              (body ,(if title `(h1 ,title) "")
+                    ,@(cdr (page-content pg))))))))
+
+(define post-writer
+  (make-parameter
+   sxml-display-as-html))
-- 
cgit 1.4.1-21-gabe81