From e94110b8b12645aa22469a73951905b6e55d3120 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Wed, 27 Dec 2023 17:42:32 -0500
Subject: Add redirects builder.

---
 Makefile.am                 |  1 +
 doc/haunt.texi              | 29 +++++++++++++++++++++++
 haunt/builder/redirects.scm | 57 +++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 87 insertions(+)
 create mode 100644 haunt/builder/redirects.scm

diff --git a/Makefile.am b/Makefile.am
index 555d2bc..cfe85bd 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -58,6 +58,7 @@ SOURCES =					\
   haunt/builder/atom.scm			\
   haunt/builder/blog.scm			\
   haunt/builder/rss.scm				\
+  haunt/builder/redirects.scm			\
   haunt/reader/texinfo.scm			\
   haunt/publisher/rsync.scm			\
   haunt/publisher/sourcehut.scm			\
diff --git a/doc/haunt.texi b/doc/haunt.texi
index 6f9d226..7857b38 100644
--- a/doc/haunt.texi
+++ b/doc/haunt.texi
@@ -821,6 +821,7 @@ specification of Markdown, learn more about CommomMark
 * Blog::                       Dear diary...
 * Atom::                       Atom feeds.
 * RSS::                        RSS feeds.
+* Redirects::                  Client-side redirects.
 @end menu
 
 Builders are procedures that return one or more artifacts
@@ -1018,6 +1019,34 @@ prefix and post prefix.  @xref{Blog} for more information.
 
 @end deffn
 
+@node Redirects
+@subsection Redirects
+
+@example
+(use-modules (haunt builder redirects))
+@end example
+
+The redirects builder creates pages that trigger browser redirects to
+another URL.  This allows for easily specifying redirects as part of a
+Haunt site configuration and without the need for modifying the
+configuration of the production web server that is hosting the site.
+
+@deffn {Procedure} redirects specs
+Return a procedure that transforms a list of redirect tuples in
+@var{specs}, with the form @code{(from to)}, into a list of pages that
+trigger a browser-initiated redirect.
+
+@code{from} values must be local page file names, @emph{not} URLs, but
+@var{to} values may be either local page file names or full URLs to
+other websites.
+
+@example
+(redirects '(("/about.html" "/about/me.html") ; local
+             ("/guile.html" "https://gnu.org/software/guile"))) ; remote
+@end example
+
+@end deffn
+
 @node Publishers
 @section Publishers
 
diff --git a/haunt/builder/redirects.scm b/haunt/builder/redirects.scm
new file mode 100644
index 0000000..9f88db5
--- /dev/null
+++ b/haunt/builder/redirects.scm
@@ -0,0 +1,57 @@
+;;; Haunt --- Static site generator for GNU Guile
+;;; Copyright © 2023 David Thompson <davet@gnu.org>
+;;;
+;;; This file is part of Haunt.
+;;;
+;;; Haunt is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Haunt is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Haunt.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Redirect builder.
+;;
+;;; Code:
+
+(define-module (haunt builder redirects)
+  #:use-module (haunt artifact)
+  #:use-module (haunt site)
+  #:use-module (haunt utils)
+  #:use-module (haunt html)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (web uri)
+  #:export (redirects))
+
+(define (redirects specs)
+  "Return a procedure that transforms a list of redirect tuples in SPECS,
+with the form (FROM TO), into a list of pages that trigger a
+browser-initiated redirect.  This is a convenient way to redirect
+without needing to modify web server configuration to issue 302
+permanent redirects.
+
+FROM values must be local page file names, not URLs, but TO values may
+be either local page file names or full URLs to other websites."
+  (lambda (site posts)
+    (define (render-redirect url)
+      `((doctype "html")
+        (head
+         (meta (@ (http-equiv "Refresh")
+                  (content ,(string-append "0; url='" url "'")))))
+        (body
+         "Redirecting to "
+         (a (@ (href ,url)) ,url))))
+
+    (map (match-lambda
+           ((from to)
+            (serialized-artifact from (render-redirect to) sxml->html)))
+         specs)))
-- 
cgit v1.2.3