Changed the blog html generater to scheme as well

1 files changed, 71 insertions, 0 deletions

diff --git a/blog/generate_html.scm b/blog/generate_html.scm
new file mode 100755
index 0000000..2d9baeb
--- /dev/null
+++ b/blog/generate_html.scm
@@ -0,0 +1,71 @@
+#! /usr/bin/guile \
+-e main -s
+!#
+
+(use-modules (sxml simple))
+
+;; Loads an entire text file into a string
+(define (read-entire-file file)
+  (call-with-input-file file
+    (lambda (fp)
+      (letrec ((read-characters
+                (lambda (fp)
+                  (let ((character (read-char fp)))
+                    (cond
+                     ((eof-object? character) "")
+                     (else (string-append (string character)
+                                          (read-characters fp))))))))
+        (read-characters fp)))))
+
+;; Make a link for the article
+(define (make-article-list-link article)
+  (let ((title (cadr (list-ref article 0)))
+        (name (cadr (list-ref article 2))))
+    (string-append "    <li><a href=\"#" name "\">" title "</a></li/>\n")))
+
+;; Reads the article file and formats some stuff out
+(define (get-raw-article file)
+  (letrec ((article (read-entire-file file))
+        (article-open (string-contains article "<article>"))
+        (article-close (string-contains article "</article>")))
+    (substring article (+ article-open 9) article-close)))
+
+;; Makes a card for the article
+(define (make-article-card article)
+  (let ((title (cadr (list-ref article 0)))
+        (name (cadr (list-ref article 2)))
+        (pub-date (cadr (list-ref article 4)))
+        (file (cadr (list-ref article 6))))
+    (string-append
+     "\n<table border=\"1\" width=\"60%\">\n"
+     "    <tr><td><h2 id=\"" name "\">" title "</h2>--- " pub-date
+     "</td></tr>\n"
+     "    <tr><td>" (get-raw-article file) "    </td></tr>\n"
+     "</table>\n")))
+
+;; Generates a html blog from xml data
+(define (generate-html)
+  (let ((template (read-entire-file "template.html"))
+        (article-list "<ul>\n")
+        (article-cards "")
+        (articles (call-with-input-file "articles.xml"
+                    (lambda (fp)
+                      (xml->sxml fp)))))
+    (for-each (lambda (article)
+                (when (list? article)
+                  ;; Add a article link
+                  (set! article-list
+                        (string-append article-list
+                                       (make-article-list-link
+                                        (cddr article))))
+                  ;; Add article card
+                  (set! article-cards
+                        (string-append article-cards
+                                       (make-article-card
+                                        (cddr article))))))
+              (cdr (cadr articles)))
+    (set! article-list (string-append article-list "</ul>\n"))
+    (format #t template article-list article-cards)))
+
+(define (main args)
+  (generate-html))