{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Main where

import Control.Monad (forM)
import Data.List (isPrefixOf, isSuffixOf)
import Data.Time.Format (TimeLocale(..))
import Hakyll.Core.Compiler
    ( Compiler
    , load
    , loadAllSnapshots
    , makeItem
    , noResult
    , saveSnapshot, loadSnapshotBody
    )
import Hakyll.Core.Configuration (Configuration(..))
import Hakyll.Core.File (copyFileCompiler)
import Hakyll.Core.Identifier (Identifier(..), fromFilePath, toFilePath)
import Hakyll.Core.Identifier.Pattern (Pattern, fromCapture, fromGlob)
import Hakyll.Core.Item (Item(..))
import Hakyll.Core.Metadata (getMetadataField)
import Hakyll.Main (hakyllWith)
import Hakyll.Core.Routes (Routes, customRoute, idRoute)
import Hakyll.Core.Rules
    ( Rules
    , compile
    , route
    , match
    , create
    )
import Hakyll.Web.CompressCss (compressCssCompiler)
import Hakyll.Web.Html (demoteHeaders, withUrls)
import Hakyll.Web.Paginate
    ( Paginate(..)
    , PageNumber
    , buildPaginateWith
    , paginateContext
    , paginateEvery
    , paginateRules
    )
import Hakyll.Web.Pandoc
    ( defaultHakyllReaderOptions
    , defaultHakyllWriterOptions
    , pandocItemCompilerWithTransformM
    )
import Hakyll.Web.Pandoc.Biblio (biblioCompiler, cslCompiler, processPandocBiblio)
import Hakyll.Web.Tags (Tags(..), buildTags, tagsRules)
import Hakyll.Web.Template (loadAndApplyTemplate, templateBodyCompiler)
import Hakyll.Web.Template.Context
    ( Context(..)
    , ContextField(..)
    , boolField
    , constField
    , defaultContext
    , field
    , listField
    , listFieldWith
    , dateFieldWith
    )
import Hakyll.Web.Template.List (recentFirst, sortRecentFirst)
import System.FilePath
    ( (</>)
    , addTrailingPathSeparator
    , joinPath
    , replaceExtension
    , splitDirectories
    , dropFileName
    )
import System.Process (rawSystem)
import qualified Network.Wai.Application.Static as Static
import Text.Pandoc.Options
    ( Extension(Ext_latex_macros)
    , HTMLMathMethod(..)
    , ReaderOptions(..)
    , WriterOptions(..)
    , extensionsFromList
    )

--
-- Default configuration.
--
-- deployment.txt is expected to contain the remote deployment path
-- as its only content.
--
configuration :: Configuration
configuration = Configuration
    { destinationDirectory = "./var/web"
    , storeDirectory = "./var/cache"
    , tmpDirectory = "./var/cache/tmp"
    , providerDirectory = "."
    , ignoreFile = ignoreFile'
    , watchIgnore = watchIgnore'
    , deployCommand = "rsync"
    , deploySite = deploySite'
    , inMemoryCache = True
    , previewHost = "127.0.0.1"
    , previewPort = 8000
    , checkHtmlFile = const False
    , previewSettings = Static.defaultFileServerSettings
    }
  where
    watchIgnore' path
        | "src" : _ <- splitDirectories path = True
        | otherwise = False
    ignoreFile' path = isPrefixOf "." path || path == "var"
    deploySite' deploymentConfiguration
        = readFile "deployment.txt"
        >>= executeDeployment deploymentConfiguration
    executeDeployment Configuration{..} deploymentTarget = rawSystem deployCommand
        [ "-ave"
        , "ssh"
        , "--delete"
        , addTrailingPathSeparator destinationDirectory
        , deploymentTarget
        ]

--
-- Helpers.
--
loadAndApplyLayout :: String -> Context String -> Item String -> Compiler (Item String)
loadAndApplyLayout layout context item =
    let layoutPath = fromFilePath $ "templates/_layouts" </> layout
     in loadAndApplyTemplate layoutPath context item
        >>= loadAndApplyTemplate "templates/default.html" context

createIndex :: Tags -> Rules ()
createIndex tags = createPaginatedPage indexRules "posts/**" ""
  where
    indexRules paginate pageNumber pagePattern = do
        route idRoute
        compile $ do
            posts <- recentFirst =<< loadAllSnapshots pagePattern "content"
            let context
                    = listField "posts" previewContext (pure posts)
                    <> constField "title" "Startseite"
                    <> boolField "active-blog" (const True)
                    <> paginateContext paginate pageNumber
                    <> flevumContext tags
            makeItem ""
                >>= loadAndApplyLayout "blog.html" context
                >>= cleanIndexUrls

localizedTimeLocale :: TimeLocale
localizedTimeLocale = TimeLocale
    { wDays =
        [ ("Sonntag", "So")
        , ("Montag", "Mo")
        , ("Dienstag", "Di")
        , ("Mittwoch", "Mi")
        , ("Donnerstag", "Do")
        , ("Freitag", "Fr")
        , ("Samstag", "Sa")
        ]
    , months =
        [ ("Januar", "Jan.")
        , ("Februar", "Feb.")
        , ("März", "März")
        , ("April", "Apr.")
        , ("Mai", "Mai")
        , ("Juni", "Jun.")
        , ("Juli", "Jul.")
        , ("August", "Aug.")
        , ("September", "Sep.")
        , ("Oktober", "Okt.")
        , ("November", "Nov.")
        , ("Dezember", "Dez.")
        ]
    , timeFmt = "%H:%M:%S"
    , time12Fmt = "%I:%M:%S %p"
    , knownTimeZones = []
    , dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y"
    , dateFmt = "%d.%m.%y"
    , amPm = ("AM", "PM")
    }

-- Reads teaser metadata field and formats it as HTML.
teaserDescriptionField :: Context String
teaserDescriptionField = field "teaser" withItem
  where
    withItem item =
        let itemIdentifier' = itemIdentifier item
         in getMetadataField itemIdentifier' "teaser"
            >>= withMetadataField itemIdentifier'
    paragraphMap "" = "</p><p>"
    paragraphMap paragraph
        | " //" `isSuffixOf` paragraph
            = take (length paragraph - length (" //" :: String)) paragraph
            <> "<br>"
        | otherwise = paragraph
    withMetadataField _ (Just teaser) = pure $ "<p>"
        <> unlines (paragraphMap <$> lines teaser)
        <> "</p>"
    withMetadataField itemIdentifier' Nothing = fail
        $ "No teaser defined for " <> show itemIdentifier'

-- og:description meta tag content.
teaserMetaField :: Context String
teaserMetaField = field "teaser" withItem
  where
    withItem item = do
        let itemIdentifier' = itemIdentifier item

        body <- loadSnapshotBody itemIdentifier' "content"
        metadata <- getMetadataField itemIdentifier' "teaser"

        withMetadataField body metadata
    -- Keep only the first paragraph, replace newlines with whitespaces.
    paragraphFolder ("", True) paragraph = (paragraph, True)
    paragraphFolder (accumulator, True) "" = (accumulator, False)
    paragraphFolder (accumulator, True) paragraph =
        (accumulator <> " " <> paragraph, True)
    paragraphFolder (accumulator, False) _ = (accumulator, False)
    -- Remove HTML tags, keep only the first paragraph, replace explicit <br>
    -- with //.
    htmlFolder (accumulator, currentTag, False) _ = (accumulator, currentTag, False)
    htmlFolder (accumulator, Nothing, True) '<' = (accumulator, Just "<", True)
    htmlFolder (accumulator, Just currentTag, True) '>'
        | "<br" `isPrefixOf` currentTag = (accumulator <> " //", Nothing, True)
        | currentTag == "</p>" = (accumulator <> " ", Nothing, False)
        | otherwise = (accumulator, Nothing, True)
    htmlFolder (accumulator, Just currentTag, True) character =
        (accumulator, Just (currentTag <> [character]), True)
    htmlFolder (accumulator, currentTag, True) '\n' = (accumulator <> " ", currentTag, True)
    htmlFolder (accumulator, Nothing, True) character =
        (accumulator <> [character], Nothing, True)
    withMetadataField :: String -> Maybe String -> Compiler String
    withMetadataField _ (Just teaser) = pure
        $ fst
        $ foldl' paragraphFolder ("", True)
        $ lines teaser
    withMetadataField itemBody' Nothing =
        let (result, _, _) = foldl' htmlFolder ("", Nothing, True) itemBody'
         in pure result

publishedOnField :: forall a. Context a
publishedOnField =
    dateFieldWith localizedTimeLocale "published" "%e. %B %Y"

previewContext :: Context String
previewContext
    = publishedOnField
    <> teaserDescriptionField
    <> defaultContext

flevumContext :: Tags -> Context String
flevumContext = (<> defaultContext) . tagsCloud
  where
    tagsCloud :: Tags -> Context String
    tagsCloud tags
        = listFieldWith "categories" (Context categoryContextF)
        $ forM (tagsMap tags) . go tags
    categoryContextF "title" _ = pure . StringField . categoryTitle
    categoryContextF "url" _ = pure . StringField
        . ('/' :) . (++ "/") . categoryTitle
    categoryContextF "body" _ = pure . StringField . itemBody
    categoryContextF key _ = const $ noResult $ "Tried field " ++ key
    categoryTitle = last . directoryNames . itemIdentifier
    directoryNames = init . splitDirectories . toFilePath
    go :: Tags -> Item String -> (String, [Identifier]) -> Compiler (Item FilePath)
    go tags Item{ itemIdentifier = currentPage } (tag, _) = do
        let tagId = tagsMakeId tags tag
        tagsMetadata <- getMetadataField currentPage "tags"
        let isActiveClass = directoryNames currentPage == directoryNames tagId
                || Just tag == tagsMetadata
        pure $ Item tagId $ if isActiveClass then "active" else ""

withoutRootRoute :: Routes
withoutRootRoute = customRoute
    $ joinPath
    . drop 1 -- posts/
    . splitDirectories
    . flip replaceExtension "html"
    . toFilePath

cleanIndexUrls :: Item String -> Compiler (Item String)
cleanIndexUrls = return . fmap (withUrls cleanIndex)
  where
    cleanIndex url
        | "/index.html" `isSuffixOf` url = dropFileName url
        | otherwise = url

bibtexCompiler :: Compiler (Item String)
bibtexCompiler =
    let readerExtensions' = readerExtensions defaultHakyllReaderOptions
            <> extensionsFromList [Ext_latex_macros]
        readerOptions = defaultHakyllReaderOptions
                { readerExtensions = readerExtensions'
                }
        writerExtensions' = writerExtensions defaultHakyllWriterOptions
            <> extensionsFromList [Ext_latex_macros]
        writerOptions = defaultHakyllWriterOptions
            { writerHTMLMathMethod = MathML
            , writerExtensions = writerExtensions'
            }
     in fmap demoteHeaders
      <$> pandocItemCompilerWithTransformM readerOptions writerOptions transformPandoc
  where
    transformPandoc pandoc = do
        bib <- load "assets/bibliography/references.bib"
        csl <- load "assets/bibliography/theologie-und-philosophie.csl"

        processPandocBiblio csl bib pandoc

copyMatchedFiles :: Pattern -> Rules ()
copyMatchedFiles = flip match $ route idRoute >> compile copyFileCompiler

createTagPage :: Tags -> String -> Pattern -> Rules ()
createTagPage tags tagName tagPattern
    = createPaginatedPage paginateTag tagPattern $ "tags/" ++ tagName ++ "/"
  where
    paginateTag paginate pageNumber pagePattern = do
        route withoutRootRoute
        compile $ do
            posts <- recentFirst =<< loadAllSnapshots pagePattern "content"
            let context = listField "posts" previewContext (pure posts)
                    <> constField "title" tagName
                    <> paginateContext paginate pageNumber
                    <> flevumContext tags
            makeItem ""
                >>= loadAndApplyLayout "tag.html" context
                >>= cleanIndexUrls

createPaginatedPage
    :: (Paginate -> PageNumber -> Pattern -> Rules ())
    -> Pattern
    -> String
    -> Rules ()
createPaginatedPage rulesBuilder pagePattern prefix =
    buildPaginateWith grouper pagePattern makePagePath >>= paginateRules'
  where
    paginateRules' paginate = paginateRules paginate $ rulesBuilder paginate
    makePagePath = \case
        1 -> makePageFileName "index.html"
        pageNumber -> makePageFileName $ shows pageNumber ".html"
    makePageFileName = fromFilePath . (prefix ++)
    grouper :: [Identifier] -> Rules [[Identifier]]
    grouper = fmap (paginateEvery 25) . sortRecentFirst

-- The order of merging is significant.
styles :: Compiler [Item String]
styles = traverse load
    [ "assets/css/base/vars.css"
    , "assets/css/base/reset.css"
    , "assets/css/base/fonts.css"
    , "assets/css/base/syntax.css"
    , "assets/css/base/animations.css"
    , "assets/css/layout.css"
    , "assets/css/pages/fourofour.css"
    , "assets/css/components/post.css"
    , "assets/css/components/page.css"
    , "assets/css/components/pagination.css"
    , "assets/css/partials/header-separator.css"
    , "assets/css/partials/burger-menu.css"
    , "assets/css/custom.css"
    ]

--
-- Hakyll rules.
--
rules :: Rules ()
rules = do
    tags <- buildTags "posts/**" (fromCapture "tags/*/index.html")

    -- Home page.
    createIndex tags

    -- Bottom menu.
    match "pages/*.tex" $ do
        route withoutRootRoute
        compile $ bibtexCompiler
            >>= loadAndApplyLayout "page.html" (flevumContext tags)

    -- Categories.
    tagsRules tags $ createTagPage tags

    -- Blog posts.
    let postContext = publishedOnField
            <> teaserMetaField
            <> flevumContext tags

    match "posts/**.tex" $ do
        route withoutRootRoute
        compile $ bibtexCompiler
            >>= saveSnapshot "content"
            >>= loadAndApplyLayout "post.html" postContext

    match "assets/bibliography/*.bib" $ compile biblioCompiler
    match "assets/bibliography/*.csl" $ compile cslCompiler

    -- Templates.
    match (fromGlob "templates/**") $ compile templateBodyCompiler

    -- Copy files.
    copyMatchedFiles "assets/fonts/*.woff2"
    copyMatchedFiles "assets/images/**"

    -- Styles.
    match "assets/css/**.css" $ compile compressCssCompiler
    create ["assets/css/styles.css"]
        $ route idRoute
        >> compile (styles >>= makeItem . concatMap itemBody)

main :: IO ()
main = hakyllWith configuration rules