{-# LANGUAGE OverloadedStrings #-}

import Control.Monad (msum)
import Control.Monad.Fail (MonadFail)
import Data.Time (TimeLocale, formatTime, parseTimeM, defaultTimeLocale, UTCTime)
import Hakyll
import System.FilePath.Posix ((</>), (<.>), splitExtension, splitFileName, takeDirectory)

main :: IO ()
main = hakyllWith hakyllConfig $ do
  match ("images/*" .||. "files/*" .||. "robots.txt" .||. "health") $ do
    route idRoute
    compile copyFileCompiler

  match "css/*" $ do
    route idRoute
    -- WORKAROUND: compressCssCompiler removes copyright notices
    compile copyFileCompiler

  match (fromList ["about.md", "contact.md", "privacy.md"]) $ do
    route $ setExtension "html" `composeRoutes` appendIndex
    let context = dropIndexHtml "url" <> defaultContext
    compile $ pandocCompiler
      >>= loadAndApplyTemplate "templates/direct.html" context
      >>= loadAndApplyTemplate "templates/default.html" context
      >>= relativizeUrls

  match "posts/*" $ do
    route $ setExtension "html" `composeRoutes` appendIndex
    compile $ pandocCompiler
      >>= loadAndApplyTemplate "templates/post.html" postContext
      >>= saveSnapshot "content"
      >>= loadAndApplyTemplate "templates/default.html" postContext
      >>= relativizeUrls

  create ["posts.html"] $ do
    route appendIndex
    compile $ do
      posts <- recentFirst =<< loadAll "posts/*"
      let archiveContext =
            listField "posts" postContext (return posts) <>
            constField "title" "Blog" <>
            dropIndexHtml "url" <>
            defaultContext

      makeItem ""
        >>= loadAndApplyTemplate "templates/posts.html" archiveContext
        >>= loadAndApplyTemplate "templates/default.html" archiveContext
        >>= relativizeUrls

  create ["feeds/posts.rss"] $ do
    route idRoute
    compileFeed renderRss rfc822DateTimeFormat

  create ["feeds/posts.atom"] $ do
    route idRoute
    compileFeed renderAtom rfc3339DateTimeFormat

  create ["sitemap.xml"] $ do
    route idRoute
    compile $ do
      posts <- recentFirst =<< loadAll "posts/*"
      singles <- loadAll (fromList ["about.md", "contact.md", "privacy.md", "posts.html"])
      let
        pages = posts <> singles
        sitemapContext =
          constField "root" root <>
          listField "pages" postContext (return pages)
      makeItem ""
        >>= loadAndApplyTemplate "templates/sitemap.xml" sitemapContext

  match "index.html" $ do
    route idRoute
    compile $ do
      posts <- recentFirst =<< loadAll "posts/*"
      let indexContext =
            listField "posts" postContext (return posts) <>
            defaultContext

      getResourceBody
        >>= applyAsTemplate indexContext
        >>= loadAndApplyTemplate "templates/default.html" indexContext
        -- >>= relativizeUrls

  match "404.html" $ do
    route idRoute
    compile $ pandocCompiler
      >>= loadAndApplyTemplate "templates/default.html" defaultContext
      >>= relativizeUrls

  match "templates/*" $ compile templateBodyCompiler

hakyllConfig :: Configuration
hakyllConfig = defaultConfiguration
  { previewPort = 8080
  , deployCommand = "./deploy"
  }

postContext :: Context String
postContext =
  constField "root" root <>
  dateField "date" "%-e %B %Y" <>
  dateField "formalDate" "%Y-%m-%d" <>
  dropIndexHtml "url" <>
  defaultContext

appendIndex :: Routes
appendIndex =
  customRoute $ append . splitExtension . toFilePath
  where append (path, extension) = path </> "index" <.> extension

dropIndexHtml :: String -> Context a
dropIndexHtml key = mapContext transform (urlField key)
  where
    transform url = case splitFileName url of
      (p, "index.html") -> takeDirectory p <> "/"
      _ -> url

root :: String
root = "https://www.skreutz.com"

feedConfiguration :: FeedConfiguration
feedConfiguration = FeedConfiguration
  { feedTitle = "Stefan Kreutz' Blog"
  , feedDescription = "Random bits from a passionate software engineer."
  , feedAuthorName = "Stefan Kreutz"
  , feedAuthorEmail = "mail@skreutz.com"
  , feedRoot = root
  }

type FeedRenderer = FeedConfiguration -> Context String -> [Item String] -> Compiler (Item String)

-- | Compile a feed of posts with a given time format.
compileFeed :: FeedRenderer -> [Char] -> Rules ()
compileFeed render format = compile $ do
  let feedContext =
        -- Format built-in fields @published@ and @updated@.
        -- TODO: Consider to vendor hakyll.
        updatedField format <>
        dateField "published" format <>
        bodyField "description" <>
        postContext
  posts <- fmap (take 100) . recentFirst =<<
    loadAllSnapshots "posts/*" "content"
  render feedConfiguration feedContext posts

-- | RFC 822 compliant date and time format.
--
-- This format string differs in two ways from
-- 'Data.Time.Format.rfc822DateFormat' from package time-1.10. First, it padds
-- days with zeros instead of spaces. Second, it uses the offset of the time
-- zone instead of its name because RFC 822 does not define common time zone
-- names like UTC. See
-- https://validator.w3.org/feed/docs/warning/ProblematicalRFC822Date.html
rfc822DateTimeFormat :: String
rfc822DateTimeFormat = "%a, %d %b %Y %H:%M:%S %z"

-- | RFC 3339 compliant date and time format.
rfc3339DateTimeFormat :: String
rfc3339DateTimeFormat = "%Y-%m-%dT%H:%M:%S%EZ"

-- | Format field @updated@.
--
-- Copied from Hakyll's 'dateFieldWith'. Falls back to field @published@.
updatedFieldWith
  :: TimeLocale  -- ^ Output time locale
  -> String      -- ^ Format to use on the date
  -> Context a   -- ^ Resulting context
updatedFieldWith locale format = field "updated" $ \i -> do
  time <- getUpdatedUTC locale $ itemIdentifier i
  return $ formatTime locale format time

-- | Format field @updated@.
--
-- Copied from Hakyll's 'dateField'. Falls back to field @published@.
updatedField
  :: String      -- ^ Format to use on the date
  -> Context a   -- ^ Resulting context
updatedField = updatedFieldWith defaultTimeLocale

-- | Parse field @updated@.
--
-- Copied from Hakyll's 'getItemUTC'. Falls back to field @published@.
getUpdatedUTC
  :: (MonadMetadata m, MonadFail m)
  => TimeLocale        -- ^ Output time locale
  -> Identifier        -- ^ Input page
  -> m UTCTime         -- ^ Parsed UTCTime
getUpdatedUTC locale id' = do
  metadata <- getMetadata id'
  let tryField k fmt = lookupString k metadata >>= parseTime' fmt
  maybe empty' return $ msum $
    [ tryField "updated" fmt | fmt <- formats ] ++
    [ tryField "published" fmt | fmt <- formats ]
  where
    empty'     = fail $ "getUpdatedUTC: could not parse time for " ++ show id'
    parseTime' = parseTimeM True locale
    formats    =
      [ "%a, %d %b %Y %H:%M:%S %Z"
      , "%a, %d %b %Y %H:%M:%S"
      , "%Y-%m-%dT%H:%M:%S%Z"
      , "%Y-%m-%dT%H:%M:%S"
      , "%Y-%m-%d %H:%M:%S%Z"
      , "%Y-%m-%d %H:%M:%S"
      , "%Y-%m-%d"
      , "%B %e, %Y %l:%M %p"
      , "%B %e, %Y"
      , "%b %d, %Y"
      ]