-- | 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.Monad          (forM_, when)
import           Data.Binary            (Binary (..))
import           Data.List              (sort, group)
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 =
-- >     [ ("projects.html", "http://github.com/gwern")
-- >     , ("/Black-market archive", "Black-market%20archives")
-- >     ]
--
-- In which case the functionality can then be used in `main` with a line like:
--
-- > version "redirects" $ createRedirects brokenLinks
--
-- The 'version' is recommended to separate these items from your other pages.
--
-- 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 :: [(Identifier, FilePath)] -> Rules ()
createRedirects [(Identifier, FilePath)]
redirects =
 do -- redirects are many-to-fewer; keys must be unique, and must point somewhere else:
    let gkeys :: [[Identifier]]
gkeys = [Identifier] -> [[Identifier]]
forall a. Eq a => [a] -> [[a]]
group ([Identifier] -> [[Identifier]]) -> [Identifier] -> [[Identifier]]
forall a b. (a -> b) -> a -> b
$ [Identifier] -> [Identifier]
forall a. Ord a => [a] -> [a]
sort ([Identifier] -> [Identifier]) -> [Identifier] -> [Identifier]
forall a b. (a -> b) -> a -> b
$ ((Identifier, FilePath) -> Identifier)
-> [(Identifier, FilePath)] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, FilePath) -> Identifier
forall a b. (a, b) -> a
fst [(Identifier, FilePath)]
redirects
    [[Identifier]] -> ([Identifier] -> Rules ()) -> Rules ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Identifier]]
gkeys (([Identifier] -> Rules ()) -> Rules ())
-> ([Identifier] -> Rules ()) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \[Identifier]
gkey -> case [Identifier]
gkey of
        (Identifier
k : Identifier
_ : [Identifier]
_) -> FilePath -> Rules ()
forall a. FilePath -> Rules a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Rules ()) -> FilePath -> Rules ()
forall a b. (a -> b) -> a -> b
$
            FilePath
"Duplicate 301 redirects; " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Identifier -> FilePath
forall a. Show a => a -> FilePath
show Identifier
k FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" is ambiguous."
        [Identifier]
_           -> () -> Rules ()
forall a. a -> Rules a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    [(Identifier, FilePath)]
-> ((Identifier, FilePath) -> Rules ()) -> Rules ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Identifier, FilePath)]
redirects (((Identifier, FilePath) -> Rules ()) -> Rules ())
-> ((Identifier, FilePath) -> Rules ()) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \(Identifier
r, FilePath
t) ->
        Bool -> Rules () -> Rules ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Identifier -> FilePath
toFilePath Identifier
r FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
t) (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Rules ()
forall a. FilePath -> Rules a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Rules ()) -> FilePath -> Rules ()
forall a b. (a -> b) -> a -> b
$
            FilePath
"Self-redirect detected: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Identifier -> FilePath
forall a. Show a => a -> FilePath
show Identifier
r FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" points to itself."

    [(Identifier, FilePath)]
-> ((Identifier, FilePath) -> Rules ()) -> Rules ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Identifier, FilePath)]
redirects (((Identifier, FilePath) -> Rules ()) -> Rules ())
-> ((Identifier, FilePath) -> Rules ()) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \(Identifier
ident, FilePath
to) ->
        [Identifier] -> Rules () -> Rules ()
create [Identifier
ident] (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$ do
            Routes -> Rules ()
route Routes
idRoute
            Compiler (Item Redirect) -> Rules ()
forall a.
(Binary a, Typeable a, Writable a) =>
Compiler (Item a) -> Rules ()
compile (Compiler (Item Redirect) -> Rules ())
-> Compiler (Item Redirect) -> Rules ()
forall a b. (a -> b) -> a -> b
$ Redirect -> Compiler (Item Redirect)
forall a. a -> Compiler (Item a)
makeItem (Redirect -> Compiler (Item Redirect))
-> Redirect -> Compiler (Item Redirect)
forall a b. (a -> b) -> a -> b
$! FilePath -> Redirect
Redirect FilePath
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
    { Redirect -> FilePath
redirectTo :: String
    } deriving (Redirect -> Redirect -> Bool
(Redirect -> Redirect -> Bool)
-> (Redirect -> Redirect -> Bool) -> Eq Redirect
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Redirect -> Redirect -> Bool
== :: Redirect -> Redirect -> Bool
$c/= :: Redirect -> Redirect -> Bool
/= :: Redirect -> Redirect -> Bool
Eq, Eq Redirect
Eq Redirect =>
(Redirect -> Redirect -> Ordering)
-> (Redirect -> Redirect -> Bool)
-> (Redirect -> Redirect -> Bool)
-> (Redirect -> Redirect -> Bool)
-> (Redirect -> Redirect -> Bool)
-> (Redirect -> Redirect -> Redirect)
-> (Redirect -> Redirect -> Redirect)
-> Ord Redirect
Redirect -> Redirect -> Bool
Redirect -> Redirect -> Ordering
Redirect -> Redirect -> Redirect
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Redirect -> Redirect -> Ordering
compare :: Redirect -> Redirect -> Ordering
$c< :: Redirect -> Redirect -> Bool
< :: Redirect -> Redirect -> Bool
$c<= :: Redirect -> Redirect -> Bool
<= :: Redirect -> Redirect -> Bool
$c> :: Redirect -> Redirect -> Bool
> :: Redirect -> Redirect -> Bool
$c>= :: Redirect -> Redirect -> Bool
>= :: Redirect -> Redirect -> Bool
$cmax :: Redirect -> Redirect -> Redirect
max :: Redirect -> Redirect -> Redirect
$cmin :: Redirect -> Redirect -> Redirect
min :: Redirect -> Redirect -> Redirect
Ord, Int -> Redirect -> FilePath -> FilePath
[Redirect] -> FilePath -> FilePath
Redirect -> FilePath
(Int -> Redirect -> FilePath -> FilePath)
-> (Redirect -> FilePath)
-> ([Redirect] -> FilePath -> FilePath)
-> Show Redirect
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> Redirect -> FilePath -> FilePath
showsPrec :: Int -> Redirect -> FilePath -> FilePath
$cshow :: Redirect -> FilePath
show :: Redirect -> FilePath
$cshowList :: [Redirect] -> FilePath -> FilePath
showList :: [Redirect] -> FilePath -> FilePath
Show)

instance Binary Redirect where
    put :: Redirect -> Put
put (Redirect FilePath
to) = FilePath -> Put
forall t. Binary t => t -> Put
put FilePath
to
    get :: Get Redirect
get = FilePath -> Redirect
Redirect (FilePath -> Redirect) -> Get FilePath -> Get Redirect
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get FilePath
forall t. Binary t => Get t
get

instance Writable Redirect where
    write :: FilePath -> Item Redirect -> IO ()
write FilePath
path = FilePath -> Item FilePath -> IO ()
forall a. Writable a => FilePath -> Item a -> IO ()
write FilePath
path (Item FilePath -> IO ())
-> (Item Redirect -> Item FilePath) -> Item Redirect -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redirect -> FilePath) -> Item Redirect -> Item FilePath
forall a b. (a -> b) -> Item a -> Item b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Redirect -> FilePath
redirectToHtml

redirectToHtml :: Redirect -> String
redirectToHtml :: Redirect -> FilePath
redirectToHtml (Redirect FilePath
working) =
    FilePath
"<!DOCTYPE html><html><head><meta charset=\"utf-8\"/><meta name=\"generator\" content=\"hakyll\"/>" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
    FilePath
"<meta name=\"viewport\" content=\"width=device-width, initial-scale=1.0\">" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
    FilePath
"<meta http-equiv=\"refresh\" content=\"0; url=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
working FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
    FilePath
"\"><link rel=\"canonical\" href=\"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
working FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
    FilePath
"\"><title>Permanent Redirect</title></head><body><p>The page has moved to: <a href=\"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
working FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
    FilePath
"\">this page</a></p></body></html>"