1 files changed, 154 insertions, 0 deletions
diff --git a/apps/blog/builder.scm b/apps/blog/builder.scm
new file mode 100644
index 0000000..969d056
--- /dev/null
+++ b/apps/blog/builder.scm
@@ -0,0 +1,154 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog builder)
+  #:use-module (apps aux system)
+  #:use-module (apps aux web)
+  #:use-module (apps base utils)
+  #:use-module (apps blog templates feed)
+  #:use-module (apps blog templates post-list)
+  #:use-module (apps blog templates post)
+  #:use-module (apps blog templates tag)
+  #:use-module (apps blog utils)
+  #:use-module (haunt html)
+  #:use-module (haunt artifact)
+  #:use-module (haunt post)
+  #:use-module (haunt site)
+  #:use-module (haunt utils)
+  #:use-module (sxml simple)
+  #:export (builder))
+
+
+;;;
+;;; Application builder.
+;;;
+
+(define (builder site posts)
+  "Return the list of web resources that compose the app.
+
+   This procedure is a Haunt builder procedure.
+
+   SITE (<site>)
+     A site object that defines all the properties of the website. See
+     Haunt <site> objects for more information.
+
+   POSTS (list of <post>)
+     A list of post objects that represent articles from the blog. See
+     Haunt <post> objects for more information.
+
+   RETURN (list of <page>)
+     A list of page objects that represent the web resources of the
+     application. See Haunt <page> objects for more information."
+  (flatten
+   (list
+    (blog-feed-builder site posts)
+    (post-list-builder posts)
+    (posts-builder posts)
+    (tag-feed-builder site posts)
+    (tags-builder posts))))
+
+
+
+;;;
+;;; Helper builders.
+;;;
+
+(define (sxml->xml* sxml port)                    ;from (haunt builder atom)
+  "Write SXML to PORT, preceded by an <?xml> tag."
+  (set-port-encoding! port "UTF-8")
+  (display "<?xml version=\"1.0\" encoding=\"utf-8\"?>" port)
+  (sxml->xml sxml port))
+
+(define (blog-feed-builder site posts)
+  "Return a Haunt page representing the atom feed of the blog."
+  (let* ((domain (site-domain site))
+	 (sorted-posts (posts/reverse-chronological posts))
+	 (max-posts 10) ; Number of posts to add to the feed.
+	 (context
+	  (list
+	   (cons "domain" domain)
+	   (cons "title" "Harmonic Flow Blog")
+	   (cons "id" (url-path-join domain "feeds" "blog.atom"))
+	   (cons "alternate" (url-path-join domain "blog" ""))
+	   (cons "posts"
+		 (if (> (length sorted-posts) max-posts)
+		     (list-head sorted-posts max-posts)
+		     sorted-posts)))))
+    (serialized-artifact (path-join "feeds" "blog.atom")
+	       (atom-feed-t context)
+	       sxml->xml*)))
+
+
+(define (post-list-builder posts)
+  "Return a list of Haunt pages representing paginated POSTS."
+  (let ((context
+	 (list
+	  (cons "tags" (post-groups->tag-list
+			(posts/group-by-tag posts))))))
+    (paginate #:dataset (posts/reverse-chronological posts)
+	      #:base-path "blog"
+	      #:template post-list-t
+	      #:context context
+	      #:writer sxml->html)))
+
+
+(define (posts-builder posts)
+  "Return a list of Haunt pages representing blog posts."
+  (map
+   (lambda (post)
+     (let ((context (list (cons "post" post))))
+       (serialized-artifact (path-join (post-url-path post) "index.html")
+		  (post-t context)
+		  sxml->html)))
+   posts))
+
+
+(define (tag-feed-builder site posts)
+  "Return a Haunt page representing the atom feed of a blog topic."
+  (let ((post-groups (posts/group-by-tag posts)))
+    (map
+     (lambda (tagged-posts)
+       (let* ((domain (site-domain site))
+	      (tag-name (car tagged-posts))
+	      (tag-slug (slugify tag-name))
+	      (file-name (string-append tag-slug ".atom"))
+	      (context
+	       (list
+		(cons "domain" domain)
+		(cons "title"
+		      (string-append "Harmonic Flow Blog — " tag-name))
+		(cons "id" (url-path-join domain
+					  "feeds"
+					  "blog"
+					  file-name))
+		(cons "alternate" (url-path-join domain
+						 "blog"
+						 "tags"
+						 tag-slug
+						 ""))
+		(cons "posts"
+		      (posts/reverse-chronological (cdr tagged-posts))))))
+	 (serialized-artifact (path-join "feeds" "blog" file-name)
+		    (atom-feed-t context)
+		    sxml->xml)))
+     post-groups)))
+
+
+(define (tags-builder posts)
+  "Return a list of lists of Haunt pages representing POSTS grouped by
+   tag.
+
+   Each list of pages corresponds to the paginated blog posts of one
+   tag."
+  (let ((post-groups (posts/group-by-tag posts)))
+    (map
+     (lambda (tagged-posts)
+       (let ((context
+	      (list
+	       (cons "tag" (car tagged-posts))
+	       (cons "tags" (post-groups->tag-list post-groups)))))
+	 (paginate #:dataset (posts/reverse-chronological (cdr tagged-posts))
+		   #:base-path (tag-system-path (car tagged-posts))
+		   #:template tag-t
+		   #:context context
+		   #:writer sxml->html)))
+     post-groups)))