Initial commit.

Signed-off-by: Andreas Widen <andreas@harmonicflow.org>

7 files changed, 616 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)))
diff --git a/apps/blog/templates/components.scm b/apps/blog/templates/components.scm
new file mode 100644
index 0000000..6c49f94
--- /dev/null
+++ b/apps/blog/templates/components.scm
@@ -0,0 +1,78 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog templates components)
+  #:use-module (apps aux strings)
+  #:use-module (apps aux sxml)
+  #:use-module (apps aux web)
+  #:use-module (apps base utils)
+  #:use-module (apps blog utils)
+  #:use-module (apps i18n)
+  #:use-module (haunt post)
+  #:use-module (srfi srfi-19)
+  #:export (post-preview
+	    sidebar))
+
+
+;;;
+;;; Components.
+;;;
+
+(define (post-preview post)
+  "Return an SHTML representation of the given post object.
+
+   POST (<post>)
+     A post object (see Haunt's manual for more information)."
+  `(a
+    (@ (class "item-preview")
+       (href ,(hfweb-url (post-url-path post))))
+    (h3
+     (@ (lang "en"))
+     ,(post-ref post 'title))
+    (p
+     (@ (class "item-date"))
+     ,(date->string (post-date post) (C_ "SRFI-19 date->string format"
+                                         "~B ~e, ~Y")))
+    (p
+     (@ (class "item-summary") (lang "en"))
+     ,(string-summarize (sxml->string* (post-sxml post)) 30)
+     ,(C_ "blog post summary ellipsis" "…"))))
+
+
+(define* (sidebar tags #:optional (current-tag #false))
+  "Return an SHTML section element representing the sidebar of the blog.
+
+   TAGS (association list)
+     An association list of tags mapped to blog posts as returned by
+     Haunt's 'posts/group-by-tag' procedure in (haunt post) module."
+  `(section
+    (@ (class "side-bar"))
+    (h3 (@ (class "a11y-offset")) (G_ "Blog menu: "))
+
+    (h4
+     (@ (class "bar-title bar-title-top"))
+     ,(if current-tag
+          (G_ "Get topic updates")
+          (G_ "Get blog updates")))
+    (ul
+     (@ (class "bar-list"))
+     (li (@ (class "bar-item"))
+	 (a (@ (class "bar-link feed-link")
+	       ,(if current-tag
+		    `(href ,(hfweb-url
+			     (url-path-join "feeds" "blog"
+					    (string-append
+					     (slugify current-tag)
+					     ".atom"))))
+		    `(href ,(hfweb-url (url-path-join "feeds" "blog.atom")))))
+            ,(C_ "button" "Atom feed"))))
+
+    (h4 (@ (class "bar-title")) (G_ "Posts by topic"))
+    (ul
+     (@ (class "bar-list"))
+     ,@(map
+	(lambda (tag)
+	  `(li (@ (class "bar-item"))
+	       (a (@ (class "bar-link")
+		     (href ,(hfweb-url (url-path-join (tag-url-path tag) ""))))
+		  ,tag)))
+	(sort tags tag-first?)))))
diff --git a/apps/blog/templates/feed.scm b/apps/blog/templates/feed.scm
new file mode 100644
index 0000000..bfa1cc4
--- /dev/null
+++ b/apps/blog/templates/feed.scm
@@ -0,0 +1,55 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog templates feed)
+  #:use-module (apps aux strings)
+  #:use-module (apps aux sxml)
+  #:use-module (apps aux web)
+  #:use-module (apps base templates theme)
+  #:use-module (apps base types)
+  #:use-module (apps base utils)
+  #:use-module (apps blog utils)
+  #:use-module (apps i18n)
+  #:use-module (haunt html)
+  #:use-module (haunt post)
+  #:use-module (srfi srfi-19)
+  #:export (atom-feed-t))
+
+
+(define (atom-feed-t context)
+  "Return an SXML representation of a Blog's topic atom feed."
+  (let ((domain (context-datum context "domain"))
+	(title (context-datum context "title"))
+	(id (context-datum context "id"))
+	(alternate (context-datum context "alternate"))
+	(posts (context-datum context "posts")))
+    `(feed
+      ;; Feed info.
+      (@ (xmlns "http://www.w3.org/2005/Atom"))
+      (id ,id)
+      (title ,title)
+      (author (name (C_ "feed author name" "Harmonic Flow Blog")) (uri ,domain))
+      (icon ,(hfweb-url "static/base/img/icon.png"))
+      (updated ,(date->string (current-date) "~4"))
+      (link (@ (rel "alternate") (href ,alternate)))
+
+      ;; Feed entries.
+      ,@(map
+	 (lambda (post)
+	   `(entry
+	     (id ,(url-path-join domain (post-url-path post) ""))
+	     (title ,(post-ref post 'title))
+	     (author (name ,(post-ref post 'author)))
+	     (published ,(date->string (post-date post) "~4"))
+	     (updated ,(date->string (post-date post) "~4"))
+	     ;(rights (@ (type "text")) ,(post-copyright post))
+	     (link (@ (rel "alternate")
+		      (href ,(url-path-join domain
+					    (post-url-path post)
+					    ""))))
+	     ,@(map
+		(lambda (tag)
+		  `(category (@ (term ,tag))))
+		(post-ref post 'tags))
+	     (summary ,(string-summarize (sxml->string* (post-sxml post)) 100) "…")
+	     (content (@ (type "html")) ,(sxml->html-string (post-sxml post)))))
+	 posts))))
diff --git a/apps/blog/templates/post-list.scm b/apps/blog/templates/post-list.scm
new file mode 100644
index 0000000..c63b01a
--- /dev/null
+++ b/apps/blog/templates/post-list.scm
@@ -0,0 +1,56 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog templates post-list)
+  #:use-module (apps aux web)
+  #:use-module (apps base templates components)
+  #:use-module (apps base templates theme)
+  #:use-module (apps base types)
+  #:use-module (apps base utils)
+  #:use-module ((apps blog templates components) #:prefix blog:)
+  #:use-module (apps i18n)
+  #:export (post-list-t))
+
+
+(define (post-list-t context)
+  "Return a list of blog posts in SHTML with the data in CONTEXT."
+  (let ((page-number
+	 (number->string (context-datum context "page-number")))
+	(total-pages
+	 (number->string (context-datum context "total-pages"))))
+    (theme
+     #:title (list (G_ (string-append "Page " page-number ""))
+                   (C_ "webpage title" "Blog |"))
+     #:description
+     (G_ "Blog posts about programming and free software.")
+     #:keywords
+     (string-split ;TRANSLATORS: |-separated list of webpage keywords
+      (G_ "Harmonic Flow Blog|HFGE|Free Software|C++|Libre software|Graphics Programming|Vulkan") #\|)
+     #:index? #false
+     #:active-menu-item (C_ "website menu" "Blog")
+     #:css
+     (list (hfweb-url "static/base/css/page.css")
+	   (hfweb-url "static/base/css/item-preview.css")
+	   (hfweb-url "static/base/css/sidebar.css"))
+     #:crumbs
+     (list (crumb (C_ "website menu" "Blog") (hfweb-url "blog/"))
+           (crumb (G_ (string-append "Page " page-number ""))
+		  (hfweb-url (url-path-join "blog"
+					   "page"
+					   page-number
+					   ""))))
+     #:content
+     `(main
+       (section
+	(@ (class "page centered-text"))
+        (h2 (G_ "Blog")
+	    ,(page-indicator (string->number page-number)
+			     (string->number total-pages)))
+
+	(div
+	 (@ (class "sheet"))
+	 ,@(map blog:post-preview (context-datum context "items"))
+	 ,(page-selector (string->number total-pages)
+			 (string->number page-number)
+			 (hfweb-url "blog")))
+
+	,(blog:sidebar (context-datum context "tags")))))))
diff --git a/apps/blog/templates/post.scm b/apps/blog/templates/post.scm
new file mode 100644
index 0000000..8a4880d
--- /dev/null
+++ b/apps/blog/templates/post.scm
@@ -0,0 +1,69 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog templates post)
+  #:use-module (apps base templates components)
+  #:use-module (apps base templates theme)
+  #:use-module (apps base types)
+  #:use-module (apps base utils)
+  #:use-module (apps blog utils)
+  #:use-module ((apps blog templates components) #:prefix blog:)
+  #:use-module (apps i18n)
+  #:use-module (haunt post)
+  #:use-module (srfi srfi-19)
+  #:export (post-t))
+
+
+(define (post-t context)
+  "Return a page in SHTML for the post in the given CONTEXT."
+  (let* ((post (context-datum context "post"))
+	 (tags (post-ref post 'tags)))
+    (theme
+     #:title (list (post-ref post 'title)
+                   (C_ "webpage title" "|"))
+     #:description
+     (G_ (string-append "Blog post about "
+                        (post-ref post 'title)
+                        " on Harmonic Flow Blog."))
+     #:keywords tags
+     #:active-menu-item (C_ "website menu" "Blog")
+     #:css
+     (list (hfweb-url "static/base/css/page.css")
+	   (hfweb-url "static/blog/css/post.css"))
+     #:crumbs
+     (list (crumb (C_ "website menu" "Blog") (hfweb-url "blog/"))
+	   (crumb (post-ref post 'title)
+		  (hfweb-url (post-url-path post))))
+     #:content
+     `(main
+       (article
+        (@ (class "page centered-block limit-width") (lang "en"))
+	(h2 ,(post-ref post 'title))
+	(p
+         (@ (class "post-metadata centered-text") (lang ,%current-ietf-tag))
+	 ,(post-ref post 'author) " — "
+         ,(date->string (post-date post) (C_ "SRFI-19 date->string format"
+                                             "~B ~e, ~Y")))
+
+	,(change-image-to-video
+          (syntax-highlight (post-sxml post)))
+
+	(div
+         (@ (class "tag-list") (lang ,%current-ietf-tag))
+         ,(G_ `(p "Related topics:"))
+
+	 ,@(map
+	    (lambda (tag)
+	      (list
+	       (button-little
+		#:label tag
+		#:url (hfweb-url (tag-url-path tag)))
+	       " ")) ; NOTE: Force space for readability in non-CSS browsers.
+	    (sort tags tag-first?)))
+
+        (div
+         (@ (class "license") (lang ,%current-ietf-tag))
+         ,(G_ `(p "Unless otherwise stated, blog posts on this site are
+                   copyrighted by their respective authors and published under the terms of the "
+         ,(G_
+                    `(a (@ (href "https://creativecommons.org/licenses/by-sa/4.0/"))
+                        "CC-BY-SA 4.0 license."))))))))))
diff --git a/apps/blog/templates/tag.scm b/apps/blog/templates/tag.scm
new file mode 100644
index 0000000..865f27a
--- /dev/null
+++ b/apps/blog/templates/tag.scm
@@ -0,0 +1,61 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog templates tag)
+  #:use-module (apps aux web)
+  #:use-module (apps base templates components)
+  #:use-module (apps base templates theme)
+  #:use-module (apps base types)
+  #:use-module (apps base utils)
+  #:use-module ((apps blog templates components) #:prefix blog:)
+  #:use-module (apps blog utils)
+  #:use-module (apps i18n)
+  #:export (tag-t))
+
+
+(define (tag-t context)
+  "Return a list of blog posts in SHTML with the data in CONTEXT."
+  (let ((tag (context-datum context "tag"))
+	(page-number
+	    (number->string (context-datum context "page-number")))
+	(total-pages
+	 (number->string (context-datum context "total-pages"))))
+    (theme
+     #:title (list (G_ (string-append "Page " page-number ""))
+                   tag (C_ "webpage title" "Blog"))
+     #:description
+     (G_ (string-append "Blog posts about "
+                        tag
+                        " on Harmonic Flow Blog."))
+     #:keywords
+     (string-split ;TRANSLATORS: |-separated list of webpage keywords
+      (G_ "Harmonic Flow Blog|HFGE|Free Software|C++|Libre software|Graphics Programming|Vulkan") #\|)
+     #:index? #false
+     #:active-menu-item (C_ "website menu" "Blog")
+     #:css
+     (list (hfweb-url "static/base/css/page.css")
+	   (hfweb-url "static/base/css/item-preview.css")
+	   (hfweb-url "static/base/css/sidebar.css"))
+     #:crumbs
+     (list (crumb (C_ "website menu" "Blog") (hfweb-url "blog/"))
+	   (crumb tag (hfweb-url (tag-url-path tag)))
+           (crumb (G_ (string-append "Page " page-number ""))
+		  (hfweb-url (url-path-join (tag-url-path tag)
+					   "page"
+					   page-number
+					   ""))))
+     #:content
+     `(main
+       (section
+	(@ (class "page centered-text"))
+        (h2 ,(G_ "Blog — ") ,tag
+	    ,(page-indicator (string->number page-number)
+			     (string->number total-pages)))
+
+	(div
+	 (@ (class "sheet"))
+	 ,@(map blog:post-preview (context-datum context "items"))
+	 ,(page-selector (string->number total-pages)
+			 (string->number page-number)
+			 (hfweb-url "blog")))
+
+	,(blog:sidebar (context-datum context "tags") tag))))))
diff --git a/apps/blog/utils.scm b/apps/blog/utils.scm
new file mode 100644
index 0000000..6a3c4b2
--- /dev/null
+++ b/apps/blog/utils.scm
@@ -0,0 +1,143 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog utils)
+  #:use-module (apps aux lists)
+  #:use-module (apps aux web)
+  #:use-module (apps i18n)
+  #:use-module (haunt post)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (syntax-highlight)
+  #:use-module (syntax-highlight scheme)
+  #:use-module (syntax-highlight lexers)
+  #:export (post-groups->tag-list
+	    post-url-path
+	    posts/latest
+	    syntax-highlight
+            change-image-to-video
+	    tag-first?
+	    tag-system-path
+	    tag-url-path))
+
+
+(define (post-groups->tag-list groups)
+  "Return a list of Haunt tags from the list of grouped posts.
+
+   GROUPS (association list)
+     An association list of tags mapped to posts, as returned by the
+     posts/group-by-tag procedure from (haunt post) module."
+  (cond ((null? groups) '())
+	(else
+	 (cons (car (first groups))
+	       (post-groups->tag-list (rest groups))))))
+
+
+(define (post-url-path post)
+  "Return a URL path for the POST in the form blog/YYYY/POST-SLUG.
+
+   POST (<post>)
+     A post object as defined in (haunt post) module."
+  ;; Note: End the path with a slash so 'localized-root-path' down the road
+  ;; prepends the language tag.
+  (url-path-join "blog"
+		 (date->string (post-date post) "~Y")
+                 (post-slug post)
+                 ""))
+
+
+(define (posts/latest posts n)
+  "Return the latest N posts from the given list of posts."
+  (let ((latest-posts (posts/reverse-chronological posts)))
+    (cond
+     ((null? posts) '())
+     ((<= (length posts) n) latest-posts)
+     (else (list-head latest-posts n)))))
+
+
+(define (tag-first? tag-a tag-b)
+  "Return true if TAG-A goes first than TAG-B alphabetically.
+
+   This predicate is used for sorting tags.
+
+   TAG-A, TAG-B (string)
+     A tag as used by Haunt posts. For example: 'User interface'."
+  (string<? (string-downcase tag-a) (string-downcase tag-b)))
+
+
+(define (tag-system-path tag)
+  "Return a system path for the TAG in the form blog/tags/TAG-SLUG.
+
+   The path is relative to the website directory.
+
+   TAG (string)
+     A tag as used by Haunt posts. For example: 'Scheme API'."
+  (string-append "blog/tags/" (slugify tag)))
+
+
+(define (tag-url-path tag)
+  "Return a URL path for the TAG in the form blog/tags/TAG-SLUG.
+
+   TAG (string)
+     A tag as used by Haunt posts. For example: 'Scheme API'."
+  ;; Note: End the path with a slash so 'localized-root-path' down the road
+  ;; prepends the language tag.
+  (url-path-join "blog" "tags" (slugify tag) ""))
+
+
+
+;;;
+;;; Syntax highlighting.
+;;;
+
+(define %default-special-prefixes
+  '("define" "syntax"))
+
+(define lex-scheme/guix
+  ;; Specialized lexer for the Scheme we use in Guix.
+  ;; TODO: Add #~, #$, etc.
+  (make-scheme-lexer (cons* "with-imported-modules"
+                            "gexp" "ungexp"
+                            "ungexp-native" "ungexp-splicing"
+                            "ungexp-native-splicing"
+                            "mlet" "mlet*"
+                            "match"
+                            %default-special-symbols)
+                     %default-special-prefixes))
+
+(define (syntax-highlight sxml)
+  "Recurse over SXML and syntax-highlight code snippets."
+  (match sxml
+    ;; sceheme:
+    ;;(('code ('@ ('class "language-scheme")) code-snippet)
+    ;; `(code ,(highlights->sxml
+    ;;          (highlight lex-scheme/guix code-snippet))))
+    ((tag ('@ attributes ...) body ...)
+     `(,tag (@ ,@attributes) ,@(map syntax-highlight body)))
+    ((tag body ...)
+     `(,tag ,@(map syntax-highlight body)))
+    ((? string? str)
+     str)))
+
+(define (change-image-to-video sxml)
+  "Replace <img> tags in SXML that refer to WebM videos with proper <video>
+tags.  This hack allows one to refer to a video from a Markdown document."
+  (match sxml
+    (('img ('@ attributes ...) body ...)
+     (let ((src (match (assoc 'src attributes)
+                  ((_ url) url)))
+           (alt (match (assoc 'alt attributes)
+                  ((_ text) text))))
+       (if (string-suffix? ".webm" src)
+           `(video (@ (src ,src)
+                      (poster ,(string-append src ".poster.png"))
+                      (controls "controls"))
+                   (p ,(G_ `(a (@ (href ,src) (class "link-subtle"))
+                               "Download video."))))
+           sxml)))
+    ((tag ('@ attributes ...) body ...)
+     `(,tag (@ ,@attributes) ,@(map change-image-to-video body)))
+    ((tag body ...)
+     `(,tag ,@(map change-image-to-video body)))
+    ((? string? str)
+     str)))