From 1b2b7c3eb939724696894f31ff27db97b0cac84c Mon Sep 17 00:00:00 2001 From: Andreas Widen Date: Sat, 25 Nov 2023 17:21:37 +0100 Subject: Initial commit. Signed-off-by: Andreas Widen --- apps/blog/builder.scm | 154 +++++++++++++++++++++++++++++++++++++ apps/blog/templates/components.scm | 78 +++++++++++++++++++ apps/blog/templates/feed.scm | 55 +++++++++++++ apps/blog/templates/post-list.scm | 56 ++++++++++++++ apps/blog/templates/post.scm | 69 +++++++++++++++++ apps/blog/templates/tag.scm | 61 +++++++++++++++ apps/blog/utils.scm | 143 ++++++++++++++++++++++++++++++++++ 7 files changed, 616 insertions(+) create mode 100644 apps/blog/builder.scm create mode 100644 apps/blog/templates/components.scm create mode 100644 apps/blog/templates/feed.scm create mode 100644 apps/blog/templates/post-list.scm create mode 100644 apps/blog/templates/post.scm create mode 100644 apps/blog/templates/tag.scm create mode 100644 apps/blog/utils.scm (limited to 'apps/blog') 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 () + A site object that defines all the properties of the website. See + Haunt objects for more information. + + POSTS (list of ) + A list of post objects that represent articles from the blog. See + Haunt objects for more information. + + RETURN (list of ) + A list of page objects that represent the web resources of the + application. See Haunt 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 tag." + (set-port-encoding! port "UTF-8") + (display "" 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 () + 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 () + 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'." + (stringsxml + ;; (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 tags in SXML that refer to WebM videos with proper