Add redirect module to Hakyll

2 files changed, 85 insertions, 1 deletions

diff --git a/src/Hakyll.hs b/src/Hakyll.hs
index edc79a0..7b64bcb 100644
--- a/src/Hakyll.hs
+++ b/src/Hakyll.hs
@@ -21,10 +21,11 @@ module Hakyll
     , module Hakyll.Web.Html
     , module Hakyll.Web.Html.RelativizeUrls
     , module Hakyll.Web.Pandoc
+    , module Hakyll.Web.Paginate
     , module Hakyll.Web.Pandoc.Biblio
     , module Hakyll.Web.Pandoc.FileType
+    , module Hakyll.Web.Redirect
     , module Hakyll.Web.Tags
-    , module Hakyll.Web.Paginate
     , module Hakyll.Web.Template
     , module Hakyll.Web.Template.Context
     , module Hakyll.Web.Template.List
@@ -54,6 +55,7 @@ import           Hakyll.Web.Paginate
 import           Hakyll.Web.Pandoc
 import           Hakyll.Web.Pandoc.Biblio
 import           Hakyll.Web.Pandoc.FileType
+import           Hakyll.Web.Redirect
 import           Hakyll.Web.Tags
 import           Hakyll.Web.Template
 import           Hakyll.Web.Template.Context
diff --git a/src/Hakyll/Web/Redirect.hs b/src/Hakyll/Web/Redirect.hs
new file mode 100644
index 0000000..ead56fe
--- /dev/null
+++ b/src/Hakyll/Web/Redirect.hs
@@ -0,0 +1,82 @@
+-- | Module used for generating HTML redirect pages. This allows renaming pages
+-- to avoid breaking existing links without requiring server-side support for
+-- formal 301 Redirect error codes
+module Hakyll.Web.Redirect
+    ( Redirect (..)
+    , createRedirects
+    ) where
+
+import           Control.Applicative    ((<$>))
+import           Control.Monad          (forM_)
+import           Data.Binary            (Binary (..))
+import           Hakyll.Core.Compiler
+import           Hakyll.Core.Identifier
+import           Hakyll.Core.Routes
+import           Hakyll.Core.Rules
+import           Hakyll.Core.Writable   (Writable (..))
+
+-- | This function exposes a higher-level interface compared to using the
+-- 'Redirect' type manually.
+--
+-- This creates, using a database mapping broken URLs to working ones, HTML
+-- files which will do HTML META tag redirect pages (since, as a static site, we
+-- can't use web-server-level 301 redirects, and using JS is gross).
+--
+-- This is useful for sending people using old URLs to renamed versions, dealing
+-- with common typos etc, and will increase site traffic.  Such broken URLs can
+-- be found by looking at server logs or by using Google Webmaster Tools.
+-- Broken URLs must be valid Haskell strings, non-URL-escaped valid POSIX
+-- filenames, and relative links, since they will be defined in a @hakyll.hs@
+-- and during generation, written to disk with the filename corresponding to the
+-- broken URLs.  (Target URLs can be absolute or relative, but should be
+-- URL-escaped.) So broken incoming links like <http://www.gwern.net/foo/> which
+-- should be <http://www.gwern.net/foobar> cannot be fixed (since you cannot
+-- create a HTML file named @"foo/"@ on disk, as that would be a directory).
+--
+-- An example of a valid association list would be:
+--
+-- > brokenLinks = [("/Black-market archive", "/Black-market%20archives")]
+--
+-- In which case the functionality can then be used in `main` with a line like:
+--
+-- > createRedirects brokenLinks
+--
+-- The on-disk files can then be uploaded with HTML mimetypes
+-- (either explicitly by generating and uploading them separately, by
+-- auto-detection of the filetype, or an upload tool defaulting to HTML
+-- mimetype, such as calling @s3cmd@ with @--default-mime-type=text/html@) and
+-- will redirect browsers and search engines going to the old/broken URLs.
+--
+-- See also <https://groups.google.com/d/msg/hakyll/sWc6zxfh-uM/fUpZPsFNDgAJ>.
+createRedirects :: [(Identifier, String)] -> Rules ()
+createRedirects redirects =
+    forM_ redirects $ \(ident, to) ->
+        create [ident] $ do
+            route idRoute
+            compile $ makeItem $! Redirect to
+
+-- | This datatype can be used directly if you want a lower-level interface to
+-- generate redirects.  For example, if you want to redirect @foo.html@ to
+-- @bar.jpg@, you can use:
+--
+-- > create ["foo.html"] $ do
+-- >     route idRoute
+-- >     compile $ makeItem $ Redirect "bar.jpg"
+data Redirect = Redirect
+    { redirectTo :: String
+    } deriving (Eq, Ord, Show)
+
+instance Binary Redirect where
+    put (Redirect to) = put to
+    get = Redirect <$> get
+
+instance Writable Redirect where
+    write path = write path . fmap redirectToHtml
+
+redirectToHtml :: Redirect -> String
+redirectToHtml (Redirect working) =
+    "<!DOCTYPE html><html><head><meta charset=\"utf-8\"/><meta name=\"generator\" content=\"hakyll\"/>" ++
+    "<meta http-equiv=\"refresh\" content=\"0; url=" ++ working ++
+    "\"><link rel=\"canonical\" href=\"" ++ working ++
+    "\"><title>Permanent Redirect</title></head><body><p>The page has moved to: <a href=\"" ++ working ++
+    "\">this page</a></p></body></html>"