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.

configure.ac

@@ -11,7 +11,7 @@ AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
 AC_CONFIG_FILES([test-env], [chmod +x test-env])
 AC_CONFIG_FILES([scripts/haunt], [chmod +x scripts/haunt])
 
-GUILE_PKG([2.2 2.0])
+GUILE_PKG([3.0 2.2 2.0])
 GUILE_PROGS
 
 dnl Guile-reader is needed for Skribe support

doc/haunt.texi

@@ -803,7 +803,7 @@ files in @var{directory} that match @var{keep?}, recursively.
 
 Builders are procedures that return one or more page objects
 (@pxref{Pages}) when applied.  A builder accepts two arguments: A site
-(@pxref{Sites} and a list of posts (@pxref{Posts}).
+(@pxref{Sites}) and a list of posts (@pxref{Posts}).
 
 Haunt comes with a few convenient builders to help users who want to
 create a simple blog with an Atom feed.

guix.scm

@@ -35,6 +35,7 @@
              (gnu packages)
              (gnu packages autotools)
              (gnu packages guile)
+             (gnu packages guile-xyz)
              (gnu packages pkg-config)
              (gnu packages texinfo))
 

haunt/builder/atom.scm

@@ -35,6 +35,7 @@
   #:use-module (haunt utils)
   #:use-module (haunt html)
   #:use-module (haunt serve mime-types)
+  #:use-module (web uri)
   #:export (make-enclosure
             enclosure?
             enclosure-title
@@ -132,40 +133,39 @@
   (sxml->xml sxml port))
 
 (define (date->string* date)
-  "Convert date to ISO-8601 formatted string."
-  (date->string date "~4"))
+  "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."
-  `(entry
-    (title ,(post-ref post 'title))
-    (author
-     (name ,(post-ref post 'author))
-     ,(let ((email (post-ref post 'email)))
-        (if email `(email ,email) '())))
-    (updated ,(date->string* (post-date post)))
-    (link (@ (href ,(string-append blog-prefix "/"
-                                   (site-post-slug site post) ".html"))
-             (rel "alternate")))
-    (summary (@ (type "html"))
-             ,(sxml->html-string (post-sxml post)))
-    ,@(map (lambda (enclosure)
-             `(link (@ (rel "enclosure")
-                       (title ,(enclosure-title enclosure))
-                       (href ,(enclosure-url enclosure))
-                       (type ,(enclosure-mime-type enclosure))
-                       ,@(map (match-lambda
-                                ((key . value)
-                                 (list key value)))
-                              (enclosure-extra enclosure)))))
-           (post-ref-all post 'enclosure))))
+  (let ((uri (uri->string (site-post-url site post))))
+    `(entry
+      (title ,(post-ref post 'title))
+      (id ,uri)
+      (author
+       (name ,(post-ref post 'author))
+       ,(let ((email (post-ref post 'email)))
+          (if email `(email ,email) '())))
+      (updated ,(date->string* (post-date post)))
+      (link (@ (href ,uri) (rel "alternate")))
+      (summary (@ (type "html"))
+               ,(sxml->html-string (post-sxml post)))
+      ,@(map (lambda (enclosure)
+               `(link (@ (rel "enclosure")
+                         (title ,(enclosure-title enclosure))
+                         (href ,(enclosure-url enclosure))
+                         (type ,(enclosure-mime-type enclosure))
+                         ,@(map (match-lambda
+                                  ((key . value)
+                                   (list key value)))
+                                (enclosure-extra enclosure)))))
+             (post-ref-all post 'enclosure)))))
 
 (define* (atom-feed #:key
                     (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:
 
@@ -174,25 +174,28 @@ SUBTITLE: The feed subtitle
 FILTER: The procedure called to manipulate the posts list before rendering
 MAX-ENTRIES: The maximum number of posts to render in the feed"
   (lambda (site posts)
-    (make-page file-name
-               `(feed (@ (xmlns "http://www.w3.org/2005/Atom"))
-                      (title ,(site-title site))
-                      (subtitle ,subtitle)
-                      (updated ,(date->string* (current-date)))
-                      (link (@ (href ,(string-append (site-domain site)
-                                                     "/" file-name))
-                               (rel "self")))
-                      (link (@ (href ,(site-domain site))))
-                      ,@(map (cut post->atom-entry site <>
-                                  #:blog-prefix blog-prefix)
-                             (take-up-to max-entries (filter posts))))
-               sxml->xml*)))
+    (let ((uri (uri->string
+                (build-uri (site-scheme site)
+                           #:host (site-domain site)
+                           #:path (string-append "/" file-name)))))
+      (make-page file-name
+                 `(feed (@ (xmlns "http://www.w3.org/2005/Atom"))
+                        (title ,(site-title site))
+                        (id ,uri)
+                        (subtitle ,subtitle)
+                        (updated ,(date->string* (current-date)))
+                        (link (@ (href ,(string-append (site-domain site)
+                                                       "/" file-name))
+                                 (rel "self")))
+                        (link (@ (href ,(site-domain site))))
+                        ,@(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:
 
@@ -206,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))))

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)

haunt/builder/rss.scm

@@ -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*)))

haunt/reader.scm

@@ -105,8 +105,17 @@ post."
 
 (define (read-html-post port)
   (values (read-metadata-headers port)
-          (match (xml->sxml port)
-            (('*TOP* sxml) sxml))))
+          (let loop ()
+            (let ((next-char (peek-char port)))
+              (cond
+               ((eof-object? next-char)
+                '())
+               ((char-set-contains? char-set:whitespace next-char)
+                (read-char port)
+                (loop))
+               (else
+                (match (xml->sxml port)
+                  (('*TOP* sxml) (cons sxml (loop))))))))))
 
 (define html-reader
   (make-reader (make-file-extension-matcher "html")

haunt/site.scm

@@ -33,30 +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 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)
@@ -67,7 +74,9 @@
 (define* (site #:key
                (title "This Place is Haunted")
                (domain "example.com")
+               (scheme 'https)
                (posts-directory "posts")
+               (posts-output-directory "")
                (file-filter default-file-filter)
                (build-directory "site")
                (default-metadata '())
@@ -77,7 +86,10 @@
   "Create a new site object.  All arguments are optional:
 
 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.
@@ -87,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 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))

haunt/skribe/utils.scm

@@ -29,7 +29,9 @@
   #:export (post
 
             p blockquote em
-            h1 h2 h3 h4
+            h1 h2 h3 h4 h5 h6
+	    section
+	    nav aside
             code pre strong
             ul ol li dl dt dd
             anchor
@@ -60,7 +62,9 @@ contents from METADATA+SXML."
   em strong
   code samp pre kbd var
   cite dfn abbr
-  h1 h2 h3 h4
+  h1 h2 h3 h4 h5 h6
+  section
+  nav aside
   ul ol li dl dt dd)
 
 (define (anchor text uri)

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)))))