dan
/
haunt
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add the `site-posts-output-directory` field. 

- Remove the "prefix" argument from the theme objects in the blog
  builder.
- Remove the "blog-prefix" argument from the rss and atom builders.

A user can specify the output directory for the posts in the SITE
record, this, together with the SITE-SLUG function, allows one to
generate relative and absolute URLs to the posts. This information is
used in all the builders that operate on posts collections.
This commit is contained in:
Dan Frumin 2019-06-29 14:29:28 +02:00
parent 65adbb052f
commit 0130760f3f
5 changed files with 56 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
haunt/builder/atom.scm
View File

@ -136,14 +136,9 @@
"Convert date to RFC-3339 formatted string."
(date->string date "~Y-~m-~dT~H:~M:~SZ"))
(define* (post->atom-entry site post #:key (blog-prefix ""))
(define* (post->atom-entry site post)
"Convert POST into an Atom <entry> XML node."
(let ((uri (uri->string
(build-uri (site-scheme site)
#:host (site-domain site)
#:path (string-append blog-prefix "/"
(site-post-slug site post)
".html")))))
(let ((uri (uri->string (site-post-url site post))))
`(entry
(title ,(post-ref post 'title))
(id ,uri)
@ -170,8 +165,7 @@
(file-name "feed.xml")
(subtitle "Recent Posts")
(filter posts/reverse-chronological)
(max-entries 20)
(blog-prefix ""))
(max-entries 20))
"Return a builder procedure that renders a list of posts as an Atom
feed. All arguments are optional:
@ -194,16 +188,14 @@ MAX-ENTRIES: The maximum number of posts to render in the feed"
"/" file-name))
(rel "self")))
(link (@ (href ,(site-domain site))))
,@(map (cut post->atom-entry site <>
#:blog-prefix blog-prefix)
,@(map (cut post->atom-entry site <>)
(take-up-to max-entries (filter posts))))
sxml->xml*))))
(define* (atom-feeds-by-tag #:key
(prefix "feeds/tags")
(filter posts/reverse-chronological)
(max-entries 20)
(blog-prefix ""))
(max-entries 20))
"Return a builder procedure that renders an atom feed for every tag
used in a post. All arguments are optional:
@ -217,7 +209,6 @@ MAX-ENTRIES: The maximum number of posts to render in each feed"
((atom-feed #:file-name (string-append prefix "/" tag ".xml")
#:subtitle (string-append "Tag: " tag)
#:filter filter
#:max-entries max-entries
#:blog-prefix blog-prefix)
#:max-entries max-entries)
site posts)))
tag-groups))))

29
haunt/builder/blog.scm
View File

@ -69,16 +69,12 @@
" — " ,(date->string* (post-date post)))
(div ,(post-sxml post))))
(define (ugly-default-collection-template site title posts prefix)
(define (post-uri post)
(string-append (or prefix "") "/"
(site-post-slug site post) ".html"))
(define (ugly-default-collection-template site title posts)
`((h3 ,title)
(ul
,@(map (lambda (post)
`(li
(a (@ (href ,(post-uri post)))
(a (@ (href ,(site-post-path site post)))
,(post-ref post 'title)
" — "
,(date->string* (post-date post)))))
@ -99,8 +95,8 @@
(body ((theme-post-template theme) post)))
(with-layout theme site title body)))
(define (render-collection theme site title posts prefix)
(let ((body ((theme-collection-template theme) site title posts prefix)))
(define (render-collection theme site title posts)
(let ((body ((theme-collection-template theme) site title posts)))
(with-layout theme site title body)))
(define (date->string* date)
@ -117,25 +113,24 @@
(collections
`(("Recent Posts" "index.html" ,posts/reverse-chronological))))
"Return a procedure that transforms a list of posts into pages
decorated by THEME, whose URLs start with PREFIX."
(define (make-file-name base-name)
decorated by THEME. The collection listing URL starts with PREFIX, and
the individual posts URLs start with POST-PREFIX."
(define (make-file-name prefix base-name)
(if prefix
(string-append prefix "/" base-name)
base-name))
(lambda (site posts)
(define (post->page post)
(let ((base-name (string-append (site-post-slug site post)
".html")))
(make-page (make-file-name base-name)
(render-post theme site post)
sxml->html)))
(make-page (site-post-relative-path site post)
(render-post theme site post)
sxml->html))
(define collection->page
(match-lambda
((title file-name filter)
(make-page (make-file-name file-name)
(render-collection theme site title (filter posts) prefix)
(make-page (make-file-name prefix file-name)
(render-collection theme site title (filter posts))
sxml->html))))
(append (map post->page posts)

11
haunt/builder/rss.scm
View File

@ -49,7 +49,7 @@
(display "<?xml version=\"1.0\" encoding=\"utf-8\"?>" port)
(sxml->xml sxml port))
(define* (post->rss-item site post #:key (blog-prefix ""))
(define* (post->rss-item site post)
"Convert POST into an RSS <item> node."
`(item
(title ,(post-ref post 'title))
@ -64,8 +64,7 @@
(string-append "(" author ")")
""))))
(pubDate ,(date->rfc822-str (post-date post)))
(link (@ (href ,(string-append blog-prefix "/"
(site-post-slug site post) ".html"))
(link (@ (href ,(site-post-url site post))
(rel "alternate")))
(description ,(sxml->html-string (post-sxml post)))
,@(map (lambda (enclosure)
@ -82,8 +81,7 @@
(file-name "rss-feed.xml")
(subtitle "Recent Posts")
(filter posts/reverse-chronological)
(max-entries 20)
(blog-prefix ""))
(max-entries 20))
"Return a builder procedure that renders a list of posts as an RSS
feed. All arguments are optional:
@ -101,7 +99,6 @@ MAX-ENTRIES: The maximum number of posts to render in the feed"
(description ,subtitle)
(pubDate ,(date->rfc822-str (current-date)))
(link (@ (href ,(site-domain site))))
,@(map (cut post->rss-item site <>
#:blog-prefix blog-prefix)
,@(map (cut post->rss-item site <>)
(take-up-to max-entries (filter posts)))))
sxml->xml*)))

37
haunt/site.scm
View File

@ -33,32 +33,37 @@
#:use-module (haunt page)
#:use-module (haunt post)
#:use-module (haunt asset)
#:use-module (web uri)
#:export (site
site?
site-title
site-domain
site-scheme
site-posts-directory
site-posts-output-directory
site-file-filter
site-build-directory
site-default-metadata
site-make-slug
site-readers
site-builders
site-post-slug
site-post-path
site-post-relative-path
site-post-url
build-site
make-file-filter
default-file-filter))
(define-record-type <site>
(make-site title domain scheme posts-directory file-filter build-directory
default-metadata make-slug readers builders)
(make-site title domain scheme posts-directory posts-output-directory file-filter
build-directory default-metadata make-slug readers builders)
site?
(title site-title)
(domain site-domain)
(scheme site-scheme) ; https or http
(posts-directory site-posts-directory)
(posts-output-directory site-posts-output-directory)
(file-filter site-file-filter)
(build-directory site-build-directory)
(default-metadata site-default-metadata)
@ -71,6 +76,7 @@
(domain "example.com")
(scheme 'https)
(posts-directory "posts")
(posts-output-directory "")
(file-filter default-file-filter)
(build-directory "site")
(default-metadata '())
@ -83,6 +89,7 @@ TITLE: The name of the site
DOMAIN: The domain that will host the site
SCHEME: Either 'https' or 'http' ('https' by default)
POSTS-DIRECTORY: The directory where posts are found
POSTS-OUTPUT-DIRECTORY: The directory to store the built posts in
FILE-FILTER: A predicate procedure that returns #f when a post file
should be ignored, and #f otherwise. Emacs temp files are ignored by
default.
@ -92,13 +99,33 @@ whose keys are symbols
MAKE-SLUG: A procedure generating a file name slug from a post
READERS: A list of reader objects for processing posts
BUILDERS: A list of procedures for building pages from posts"
(make-site title domain scheme posts-directory file-filter build-directory
default-metadata make-slug readers builders))
(make-site title domain scheme posts-directory posts-output-directory file-filter
build-directory default-metadata make-slug readers builders))
(define (site-post-slug site post)
"Return a slug string for POST using the slug generator for SITE."
((site-make-slug site) post))
(define (site-post-relative-path site post)
"Return a relative path to a POST, without the preceding slash `/'."
(let ((base-path (string-trim-right (site-posts-output-directory site)
(lambda (c) (equal? c #\/)))))
(string-append (if (equal? base-path "")
""
(string-append base-path "/"))
(site-post-slug site post)
".html")))
(define (site-post-path site post)
"Return a path to a POST, with the preceding slash `/'."
(string-append "/" (site-post-relative-path site post)))
(define (site-post-url site post)
"Return a full URL to a POST."
(build-uri (site-scheme site)
#:host (site-domain site)
#:path (site-post-path site post)))
(define (build-site site)
"Build SITE in the appropriate build directory."
(let ((posts (if (file-exists? (site-posts-directory site))

8
website/haunt.scm
View File

@ -117,11 +117,7 @@ culture works available under the " ,%cc-by-sa-link " license.")))))))
" — " ,(date->string* (post-date post)))
(div ,(post-sxml post))))
#:collection-template
(lambda (site title posts prefix)
(define (post-uri post)
(string-append "/" (or prefix "")
(site-post-slug site post) ".html"))
(lambda (site title posts)
`(,(jumbotron
`((p "Haunt is a simple, functional, hackable static site
generator written in Guile Scheme that gives authors the ability to
@ -164,7 +160,7 @@ without needing to upload the generated files to a web server.")
(ul
,@(map (lambda (post)
`(li
(a (@ (href ,(post-uri post)))
(a (@ (href ,(site-post-path site post)))
,(post-ref post 'title)
" — "
,(date->string* (post-date post)))))