From 0130760f3f9034804d3a87d2f0a09db6a2a58083 Mon Sep 17 00:00:00 2001 From: Dan Frumin Date: Sat, 29 Jun 2019 14:29:28 +0200 Subject: [PATCH] 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. --- haunt/builder/atom.scm | 21 ++++++--------------- haunt/builder/blog.scm | 29 ++++++++++++----------------- haunt/builder/rss.scm | 11 ++++------- haunt/site.scm | 37 ++++++++++++++++++++++++++++++++----- website/haunt.scm | 8 ++------ 5 files changed, 56 insertions(+), 50 deletions(-) diff --git a/haunt/builder/atom.scm b/haunt/builder/atom.scm index 2a6c356..1f4c784 100644 --- a/haunt/builder/atom.scm +++ b/haunt/builder/atom.scm @@ -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 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)))) diff --git a/haunt/builder/blog.scm b/haunt/builder/blog.scm index 2830881..957f71b 100644 --- a/haunt/builder/blog.scm +++ b/haunt/builder/blog.scm @@ -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) diff --git a/haunt/builder/rss.scm b/haunt/builder/rss.scm index 1d988a7..683da11 100644 --- a/haunt/builder/rss.scm +++ b/haunt/builder/rss.scm @@ -49,7 +49,7 @@ (display "" 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 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*))) diff --git a/haunt/site.scm b/haunt/site.scm index 09f6bd7..2ec5501 100644 --- a/haunt/site.scm +++ b/haunt/site.scm @@ -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 - (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)) diff --git a/website/haunt.scm b/website/haunt.scm index c3becb4..aeabe31 100644 --- a/website/haunt.scm +++ b/website/haunt.scm @@ -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)))))