summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--haunt/builder/blog.scm47
1 files changed, 31 insertions, 16 deletions
diff --git a/haunt/builder/blog.scm b/haunt/builder/blog.scm
index 5087885..eb49efa 100644
--- a/haunt/builder/blog.scm
+++ b/haunt/builder/blog.scm
@@ -1,5 +1,5 @@
;;; Haunt --- Static site generator for GNU Guile
-;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2015, 2022 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;;
;;; This file is part of Haunt.
@@ -45,6 +45,8 @@
render-collection
date->string*
+ slug->file-name/default
+ make-compat-slug->file-name
blog))
@@ -123,6 +125,19 @@
"Convert DATE to human readable string."
(date->string date "~a ~d ~B ~Y"))
+(define* (slug->file-name/default slug)
+ (string-append slug ".html"))
+
+(define (make-compat-slug->file-name prefix)
+ ;; Strip leading/trailing slashes from prefix, if present.
+ (define (strip-leading-slash s)
+ (if (string-prefix? "/" s) (string-drop s 1) s))
+ (define (strip-trailing-slash s)
+ (if (string-suffix? "/" s) (string-drop-right s 1) s))
+ (let ((prefix* (strip-leading-slash (strip-trailing-slash prefix))))
+ (lambda* (slug)
+ (string-append prefix* "/" slug ".html"))))
+
(define ugly-theme
(theme #:name "Ugly"
#:layout ugly-default-layout
@@ -131,6 +146,7 @@
#:pagination-template ugly-default-pagination-template))
(define* (blog #:key (theme ugly-theme) prefix
+ (slug->file-name slug->file-name/default)
(collections
`(("Recent Posts" "index.html" ,posts/reverse-chronological)))
posts-per-page)
@@ -138,31 +154,30 @@
decorated by THEME, whose URLs start with PREFIX. If POSTS-PER-PAGE
is specified, collections will be broken up into several pages with up
to POSTS-PER-PAGE posts on each page."
- (define (make-file-name base-name)
- (if prefix
- (string-append prefix "/" base-name)
- base-name))
+ ;; Preserve compatibility with older versions, for now.
+ (define slug->file-name*
+ (if (string? prefix)
+ (begin
+ (display "warning: #:prefix keyword of 'blog' procedure is deprecated, switch to #:slug->file-name\n")
+ (make-compat-slug->file-name prefix))
+ slug->file-name))
(lambda (site posts)
(define (post->page post)
- (let ((base-name (string-append (site-post-slug site post)
- ".html"))
- (title (post-ref post 'title))
+ (let ((title (post-ref post 'title))
(body ((theme-post-template theme) post)))
- (serialized-artifact (make-file-name base-name)
+ (serialized-artifact (slug->file-name* (site-post-slug site post))
(with-layout theme site title body)
sxml->html)))
(define (paginate base-name items)
(define (make-page-file-name i)
- (make-file-name
- ;; First page does not get a page number added to the file
- ;; name.
+ ;; First page does not get a page number added to the file
+ ;; name.
+ (slug->file-name*
(if (= 0 i)
- (string-append base-name ".html")
- (string-append base-name "-"
- (number->string i)
- ".html"))))
+ base-name
+ (string-append base-name "-" (number->string i)))))
(define (make-page i items)
(list (make-page-file-name i) (reverse items)))
(let loop ((items items)