222 lines
8.1 KiB
Scheme
222 lines
8.1 KiB
Scheme
(use-modules (haunt artifact)
|
||
(haunt builder blog)
|
||
(haunt builder assets)
|
||
(haunt post)
|
||
(haunt reader)
|
||
(haunt site)
|
||
(srfi srfi-19)
|
||
(sxml simple)
|
||
(web uri))
|
||
|
||
(define (map-with-index fun lst)
|
||
(define (worker index lst)
|
||
(if (null? lst)
|
||
'()
|
||
(cons
|
||
(fun index (car lst))
|
||
(worker (+ index 1) (cdr lst)))))
|
||
(worker 0 lst))
|
||
|
||
(define (h heading-level . contents)
|
||
(cons
|
||
(case heading-level
|
||
((1) 'h1) ((2) 'h2) ((3) 'h3) ((4) 'h4) ((5) 'h5) ((6) 'h6)
|
||
(else (raise `(heading-level-out-of-range . ,heading-level))))
|
||
contents))
|
||
|
||
(define (date->rfc3339 date)
|
||
(date->string date "~Y-~m-~dT~H:~M:~SZ"))
|
||
|
||
(define (time date)
|
||
`(time (@ (datetime ,(date->rfc3339 date)))
|
||
,(date->string date "~Y-~m-~d")))
|
||
|
||
(define (slug->path prefix slug)
|
||
(string-append prefix "/" slug ".html"))
|
||
|
||
(define (path->url site path)
|
||
(uri->string (build-uri (site-scheme site)
|
||
#:host (site-domain site)
|
||
#:path path
|
||
#:validate? #t)))
|
||
|
||
(define* (related-posts #:key prefix post)
|
||
(if (post-ref post 'related)
|
||
`(p "Related:"
|
||
,@(map-with-index
|
||
(lambda (index slug)
|
||
`(" " (a (@ (href ,(slug->path prefix slug)))
|
||
,(+ index 1))))
|
||
(post-ref post 'related)))
|
||
'()))
|
||
|
||
(define (zola-slug post)
|
||
(let ((originally-zola (post-ref post 'originally-zola)))
|
||
(if (string= originally-zola "")
|
||
(post-slug-v2 post)
|
||
originally-zola)))
|
||
|
||
(define (make-slug post)
|
||
(or (post-ref post 'slug)
|
||
(if (post-ref post 'originally-zola)
|
||
(string-append (zola-slug post) "/index")
|
||
(string-append (date->string (post-date post) "~Y-~m-~d")
|
||
"-"
|
||
(post-slug-v2 post)))))
|
||
|
||
(define* (static-directory-under #:key prefix path)
|
||
(static-directory path (string-append prefix "/" path)))
|
||
|
||
(define* (render-post #:key post heading-level prefix target-slug)
|
||
`(article (@ (lang ,(post-ref post 'lang)))
|
||
(header ,(h heading-level
|
||
(if target-slug
|
||
`(a (@ (href ,(slug->path prefix target-slug)))
|
||
,(post-title post))
|
||
(post-title post)))
|
||
,(time (post-date post))
|
||
,(related-posts #:prefix prefix #:post post))
|
||
,(post-sxml post)))
|
||
|
||
(define* (head-block #:key site title prefix)
|
||
`(head (meta (@ (charset "utf-8")))
|
||
; We don't set the lang attribute, since we don't have access
|
||
; to the page's full metadata, only the title
|
||
(title ,title)
|
||
(meta (@ (name "viewport")
|
||
(content "width=device-width, initial-scale=1.0")))
|
||
(link (@ (rel "alternate")
|
||
(type "application/atom+xml")
|
||
(title ,(string-append (site-title site) " – All posts"))
|
||
(href ,(string-append prefix "/everything.xml"))))
|
||
(link (@ (rel "alternate")
|
||
(type "application/atom+xml")
|
||
(title ,(string-append (site-title site) " – No shares"))
|
||
(href ,(string-append prefix "/no-shares.xml"))))))
|
||
|
||
(define (collection-template site title posts prefix)
|
||
`((h1 ,title)
|
||
(nav "Feeds:"
|
||
(ul (li (a (@ (href ,(string-append prefix "/everything.xml")))
|
||
"All posts"))
|
||
(li (a (@ (href ,(string-append prefix "/no-shares.xml")))
|
||
"No shares"))))
|
||
,@(map (lambda (post)
|
||
(render-post #:post post
|
||
#:heading-level 2
|
||
#:prefix prefix
|
||
#:target-slug (site-post-slug site post)))
|
||
posts)))
|
||
|
||
(define (pagination-template site tree previous-page next-page)
|
||
`(,tree
|
||
,(if previous-page
|
||
`(a (@ (href ,previous-page)) "Prev")
|
||
'())
|
||
" "
|
||
,(if next-page
|
||
`(a (@ (href ,next-page)) "Next")
|
||
'())))
|
||
|
||
(define (post-id site prefix post)
|
||
(path->url site
|
||
(if (post-ref post 'originally-zola)
|
||
(string-append prefix "/" (zola-slug post) "/")
|
||
(slug->path prefix (make-slug post)))))
|
||
|
||
(define* (feed-entry #:key site prefix post)
|
||
`(entry (@ (xml:lang ,(post-ref post 'lang)))
|
||
(id ,(post-id site prefix post))
|
||
(title ,(post-title post))
|
||
(updated ,(date->rfc3339 (post-date post)))
|
||
(author
|
||
(name ,(post-author post)))
|
||
(content (@ (type "xhtml"))
|
||
(div (@ (xmlns "http://www.w3.org/1999/xhtml"))
|
||
,(post-sxml post)))
|
||
(link (@ (rel "alternate")
|
||
(href ,(path->url site
|
||
(slug->path prefix
|
||
(make-slug post))))))))
|
||
|
||
(define* (feed #:key prefix file-name (filter posts/reverse-chronological))
|
||
(lambda (site posts)
|
||
(let* ((own-path (string-append prefix "/" file-name))
|
||
(own-url (path->url site own-path))
|
||
(site-home-url (path->url site prefix))
|
||
(posts (filter posts))
|
||
(last-update (if (null? posts)
|
||
%default-date
|
||
(post-date (car posts)))))
|
||
(serialized-artifact
|
||
own-path
|
||
`(feed (@ (xmlns "http://www.w3.org/2005/Atom")
|
||
(xml:lang "en"))
|
||
(id ,own-url)
|
||
(title ,(site-title site))
|
||
(updated ,(date->rfc3339 last-update))
|
||
(link (@ (rel "self")
|
||
(href ,own-url)))
|
||
(link (@ (rel "alternate")
|
||
(type "text/html")
|
||
(href ,site-home-url)))
|
||
,@(map (lambda (post) (feed-entry #:site site
|
||
#:prefix prefix
|
||
#:post post))
|
||
posts))
|
||
(lambda (sxml port)
|
||
(display "<?xml version=\"1.0\" encoding=\"utf-8\"?>" port)
|
||
(sxml->xml sxml port))))))
|
||
|
||
(define* (microblog #:key domain author)
|
||
(define prefix (string-append "/" author))
|
||
|
||
(define (layout site title body)
|
||
`((doctype "html")
|
||
(html (@ (lang "en"))
|
||
,(head-block #:site site
|
||
#:title title
|
||
#:prefix prefix)
|
||
(body ,body))))
|
||
|
||
(define (post-template post)
|
||
`((nav (a (@ (href ,prefix))
|
||
"Posts"))
|
||
(main ,(render-post #:post post
|
||
#:heading-level 1
|
||
#:prefix prefix))))
|
||
|
||
(define microblog-theme (theme #:name "Microblog"
|
||
#:layout layout
|
||
#:post-template post-template
|
||
#:collection-template collection-template
|
||
#:pagination-template pagination-template))
|
||
|
||
(define site-name (string-append author "'s microblog"))
|
||
|
||
(site #:title site-name
|
||
#:domain domain
|
||
#:default-metadata
|
||
`((author . ,author)
|
||
(lang . "en"))
|
||
#:make-slug make-slug
|
||
#:readers (list html-reader)
|
||
#:builders
|
||
(list (feed #:prefix prefix #:file-name "everything.xml")
|
||
(feed #:prefix prefix #:file-name "no-shares.xml")
|
||
(blog #:prefix prefix
|
||
#:theme microblog-theme
|
||
#:collections
|
||
`((,site-name
|
||
"index.html"
|
||
,posts/reverse-chronological))
|
||
#:posts-per-page 10)
|
||
(static-directory-under #:prefix prefix #:path "img")
|
||
(static-directory-under #:prefix prefix #:path "processed_images"))))
|
||
|
||
(register-metadata-parser! 'related
|
||
(lambda (str)
|
||
(map string-trim-both (string-split str #\,))))
|
||
|
||
(microblog #:domain "microblog.ahti.space"
|
||
#:author "nortti")
|