Refactor whole thing to use in-memory DB as source of truth

1 files changed, 247 insertions, 70 deletions

diff --git a/main.scm b/main.scm
index cedc290..3adf9c8 100644
--- a/main.scm
+++ b/main.scm
@@ -1,5 +1,5 @@
 (load "utils.scm")
-(load "feed.scm")
+(load "md-parser.scm")
 
 (import (chicken base)
 	(chicken io)
@@ -10,11 +10,14 @@
 	(chicken format)
 	(chicken process-context)
 	(chicken process)
+	(chicken irregex)
+	(chicken sort)
+	(only srfi-13 string-join)
 	srfi-18
 	matchable
 
 	utils
-	feed
+	md-parser
 	)
 
 ;; application
@@ -26,41 +29,26 @@
 (define template-path (or (get-environment-variable "TEMPLATE_PATH")
 			  "template.html"))
 (define archive-subdir (or (get-environment-variable "ARCHIVE_SUBDIR")
-		     "archive"))
+			   "archive"))
 (define static-dir (or (get-environment-variable "STATIC_DIR")
 		       "static"))
 
-(define md-work-dir (create-temporary-directory))
-(define html-work-dir (create-temporary-directory))
+(define archive-index-md-path (create-temporary-file ".md"))
+(define feed-xml-path (create-temporary-file ".xml"))
+(define work-dir (create-temporary-directory))
 
 (assert (> (string-length src-dir) 0))
 (assert (> (string-length out-dir) 0))
 (assert (> (string-length template-path) 0))
 
-(define (process-path path)
-  (match path
-    [(? is-md?) (process-md path)]
-    [(? directory?) (process-dir (format "~A" path))]
-    [other (process-other-file other)]))
-
-(define (is-md? path)
-  (define parts (string-split path "."))
-  (string=? "md" (last parts)))
 
-(define (process-md md-path)
-  (printf "[info] converting markdown file \"~A\"" md-path)
-  (define out-html-file (pipe md-path
-			      (@ replace (format "^~A" md-work-dir) html-work-dir)
-			      (@ replace "\\.md$" ".html")))
-  (printf " to \"~A\"~%" out-html-file)
-  (define preprocessed-md-path (preprocess-md md-path))
-  (pandoc-md-to-html preprocessed-md-path out-html-file))
-
-(define (preprocess-md md-path)
+(define (preprocess-md md-path out-path)
   (define md (with-input-from-file md-path
 	       (λ () (read-string #f))))
 
   (define cwd (decompose-pathname md-path))
+  (define out-path-dir (decompose-pathname out-path))
+  (create-directory out-path-dir #t)
 
   ;; Matches markdown links
   (define irx "\\[(.+?)\\]\\((.+?)\\)")
@@ -79,16 +67,137 @@
 	  (normalize-pathname (make-pathname cwd link))))
 
     ;; replace src-dir prefix with webroot prefix
-    (define rooted (replace (format "^~A\\/?" md-work-dir) "/" ret-link))
+    (define rooted (replace (format "^~A\\/?" src-dir) "/" ret-link))
     (format "[~A](~A)" alt rooted))
 
   (define result (replace-all irx link-replace md))
 
-  (define out-file (create-temporary-file ".md"))
-  (with-output-to-file out-file
-    (λ () (print result)))
+  (with-output-to-file out-path
+    (λ () (print result))))
+
+(define (preprocess-md-files db)
+  (define (is-md? entry)
+    (string=? "md" (assocdr "file-type" entry)))
+
+  (define (act entry)
+    (if (is-md? entry) (preprocess-md (assocdr "src-path" entry)
+				      (assocdr "work-md-path" entry))))
+
+  (for-each act db)
+
+  db)
+
+(define (add-static-to-db db)
+  (define paths (find-files static-dir))
+  (define new-entries '())
+  (define (act src-path)
+    (define out-path (replace (format "^~A" static-dir)
+			      (make-pathname out-dir "static")
+			      src-path))
+    (set! new-entries
+      (cons (list `("file-type" . "other")
+		  `("src-path" . ,src-path)
+		  `("out-path" . ,out-path))
+	    new-entries)))
+
+  (for-each act paths)
+  (append new-entries db))
+
+(define (add-now-page-to-db db)
+  (define (inner return)
+    (define (find-newest-now-page newest entries)
+      (if (null? entries)
+	  newest
+	  (let* ((head (car entries))
+		 (tail (cdr entries))
+		 (head-file-type (lookup "file-type" head))
+		 (head-date (lookup "date" head))
+		 (head-kind (lookup "kind" head))
+		 (newest-date (lookup "date" newest)))
+
+	    (if (and head-date
+		     (equal? head-file-type "md")
+		     (truthy? (lookup "is-archive?" head))
+		     (equal? head-kind "now")
+		     (or (not newest)
+			 (string>? head-date newest-date)))
+		(find-newest-now-page head tail)
+		(find-newest-now-page newest tail)))
+	  ))
+
+    (define newest (find-newest-now-page #f db))
+    (if (not newest) (return db))
+
+    (define out-path (format "~A/now.html" out-dir))
+
+    (define now-page (apply list
+			    `("out-path" . ,out-path)
+			    `("hide-body-title" . "defined")
+			    newest))
+
+    (cons now-page db))
+
+  (call/cc inner))
+
+(define (is-md-path? path)
+  (truthy? (irregex-match ".*?\\.md$" path)))
+
+(define (construct-db-from path)
+  (match path
+    [(? is-md-path?) (list (construct-db-md path))]
+    [(? directory?) (construct-db-dir path)]
+    [_ (list (construct-db-other path))]))
+
+(define (construct-db-md path)
+  (define fm (or (read-md-frontmatter path) '()))
+  (define-values (_ slug _) (decompose-pathname path))
+  (define work-md-file (pipe path (@ replace (format "^~A" src-dir) work-dir)))
+  (define work-html-file (replace "\\.md$" ".html" work-md-file))
+  (define out-file (pipe path (@ replace (format "^~A" src-dir) out-dir)
+			 (@ replace "\\.md$" ".html")))
+  (define is-archive? (pipe path
+			    (@ irregex-match (format "^~A/~A.*" src-dir archive-subdir))
+			    (λ (m) (not (eq? #f m)))))
+
+  (apply list
+	 `("file-type" . "md")
+	 `("src-path" . ,path)
+	 `("work-md-path" . ,work-md-file)
+	 `("work-html-path" . ,work-html-file)
+	 `("out-path" . ,out-file)
+	 `("slug" . ,slug)
+	 `("is-archive?" . ,is-archive?)
+	 fm))
+
+(define (construct-db-dir path)
+  (define paths (pipe path
+		      (@ format "~A/*")
+		      (@ glob)
+		      (@ map (@ replace "^\\.\\/" ""))))
+
+  (flatmap construct-db-from paths))
+
+(define (construct-db-other path)
+  (define out-path (replace (format "^~A" src-dir) out-dir path))
+
+  `(("file-type" . "other")
+    ("src-path" . ,path)
+    ("out-path" . ,out-path)))
+
+(define (apply-pandoc-to-md-files db)
+  (define (is-md? entry)
+    (equal? "md" (assocdr "file-type" entry)))
 
-  out-file)
+  (define posts (filter is-md? db))
+
+  (define (act post)
+    (define from (assocdr "work-md-path" post))
+    (define to (assocdr "work-html-path" post))
+    (pandoc-md-to-html from to))
+
+  (for-each act posts)
+
+  db)
 
 (define (pandoc-md-to-html md-path html-path)
   (define args (list md-path
@@ -101,23 +210,6 @@
   (read-string #f output-port)
   #f)
 
-(define (process-other-file path)
-  (printf "[info] copying other file \"~A\"" path)
-  (define out-path (replace (format "^~A" md-work-dir) html-work-dir path))
-  (printf " to \"~A\"~%" out-path)
-  (copy-file path out-path))
-
-(define (process-dir dir)
-  (printf "[info] processing directory \"~A\"~%" dir)
-  (define out-dir-path (replace (format "^~A" md-work-dir) html-work-dir dir))
-  (create-directory out-dir-path #t)
-  (define paths (pipe dir
-		      (@ format "~A/*")
-		      (@ glob)
-		      (@ map (@ replace "^\\.\\/" ""))))
-
-  (for-each process-path paths))
-
 (define (clean-dir dir)
   (define (delete path)
     (if (directory? path)
@@ -125,32 +217,117 @@
 	(delete-file path)))
   (for-each (@ delete) (glob (format "~A/*" dir))))
 
-(define (copy-directory from to)
-  (read-string #f (process "cp" (list "-r" from to))))
+(define (move-all-to-out-dir db out-dir)
+  (define (move-entry entry)
+    (define file-type (assocdr "file-type" entry))
+    (define from
+      (match file-type
+	["md" (assocdr "work-html-path" entry)]
+	[other (assocdr "src-path" entry)]))
+    (define to (assocdr "out-path" entry))
+
+    (define to-dir (decompose-pathname to))
+    (create-directory to-dir #t)
+
+    (read-string #f (process "cp" (list from to))))
+
+  (for-each move-entry db))
+
+(define (generate-feed db)
+  (define (is-archive-post? post) (assocdr "is-archive?" post))
+  (define paths (pipe db
+		      (@ filter (@ assocdr "is-archive?"))
+		      (@ map (@ assocdr "work-md-path"))))
+
+  (define link-format (format "~A/%s" archive-subdir))
+  (define output-port
+    (process "vendor/bin/pandoc-rss"
+	     (apply list "-s"
+		    "-t" "jan's garden"
+		    "-d" "RSS feed for Jan's personal digital garden"
+		    "-l" "https://jan.systems"
+		    "-f" link-format
+		    "-n" "en-GB"
+		    "-c" "CC BY-SA 4.0"
+		    "-w" "https://jan.systems"
+		    paths)))
+  (define output (read-string #f output-port))
+  (printf "[info] writing RSS feed to \"~A\"~%" feed-xml-path)
+  (with-output-to-file feed-xml-path
+    (λ () (print output)))
 
-(define (copy-all from to)
-  (define args (append (list "-r")
-		       (glob (format "~A/*" from))
-		       (list to)))
-  (read-string #f (process "cp" args)))
+  (define entry (list `("file-type" . "other")
+		      `("src-path" . ,feed-xml-path)
+		      `("out-path" . ,(make-pathname out-dir "feed.xml"))))
+
+  (cons entry db))
+
+(define (generate-archive-index db)
+  (define (is-archive-post? post) (assocdr "is-archive?" post))
+  (define posts (filter (@ assocdr "is-archive?") db))
+
+  ;; newest first
+  (define (less? a b)
+    (string>? (assocdr "date" (cdr a)) (assocdr "date" (cdr b))))
+
+  (define posts-sorted (sort posts less?))
+
+  (define (to-li post)
+    (printf "[info] indexing post ")
+    (define title (assocdr "title" post))
+    (printf "\"~A\"~%" title)
+    (define date (assocdr "date" post))
+    (define kind (assocdr "kind" post))
+    (define slug (assocdr "slug" post))
+    (define link (format "~A/~A" archive-subdir slug))
+    (format "<li class=\"archive-entry\"><a href=\"~A\">~A</a><small><span>[~A]</span> (~A)</small></li>"
+	    link title kind date))
+
+  (define index-lis (map to-li posts-sorted))
+  (define out-md (string-append "---\n"
+				"title: archive – jan's garden\n"
+				"hide-body-title: defined\n"
+				"---\n"
+				"# Archive\n\n"
+				"Follow via [RSS](/feed.xml) ([Huh?](https://aboutfeeds.com/))\n\n"
+				(string-append "<ul class=\"archive-list\">"
+					       (string-join index-lis "\n")
+					       "</ul>")))
+
+  (define work-md-path (make-pathname work-dir "_archive-index.md"))
+  (define work-html-path (make-pathname work-dir "_archive-index.html"))
+  (define out-path (make-pathname (list out-dir archive-subdir) "index.html"))
+
+  (with-output-to-file work-md-path
+    (λ () (print out-md)))
+
+  (define archive-entry (list `("file-type" . "md")
+			      `("src-path" . ,work-md-path)
+			      `("work-md-path" . ,work-md-path)
+			      `("work-html-path" . ,work-html-path)
+			      `("out-path" . ,out-path)))
+
+  (cons archive-entry db))
+
+(define (install-output db)
+  (clean-dir out-dir)
+  (move-all-to-out-dir db out-dir)
+  (delete-directory work-dir #t)
+
+  db)
 
 ;; run
 
-(printf "[info] copying pages to Markdown work directory \"~A\"~%" md-work-dir)
-(copy-all src-dir md-work-dir)
-(printf "[info] generating feed from archive subdirectory \"~A\"~%" archive-subdir)
-(generate-feed md-work-dir archive-subdir html-work-dir)
-(printf "[info] generating archive index.md~%")
-(generate-archive-index md-work-dir archive-subdir)
-(printf "[info] generating site with pages from \"~A\"~%" md-work-dir)
-(process-dir md-work-dir)
-(printf "[info] copying static files from \"~A\"~%" static-dir)
-(copy-directory static-dir (make-pathname html-work-dir static-dir))
-(printf "[info] cleaning up output directory \"~A\"~%" out-dir)
-(clean-dir out-dir)
-(printf "[info] copying output files from work dir to out dir \"~A\"~%" out-dir)
-(copy-all html-work-dir out-dir)
-(printf "[info] removing temporary directories~%")
-(delete-directory md-work-dir #t)
-(delete-directory html-work-dir #t)
+(printf "[info] building...~%")
+
+(pipe src-dir
+      (@ construct-db-from)
+      (@ add-static-to-db)
+      (@ generate-archive-index)
+      (@ add-now-page-to-db)
+      (@ preprocess-md-files)
+      (@ generate-feed)
+      (@ apply-pandoc-to-md-files)
+      (@ install-output))
+
 (printf "[info] done.~%")