path: root/src/Main.hs

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

module Main where

import Control.Monad (forM)
import Data.List (isPrefixOf, isSuffixOf)
import Data.Time.Format (formatTime, FormatTime)
import Data.Time.Locale.Compat (defaultTimeLocale)
import Hakyll.Core.Compiler
    ( Compiler
    , load
    , loadAllSnapshots
    , makeItem
    , noResult
    , saveSnapshot
    , getResourceBody
    )
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
    )
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
    , writePandocWith
    )
import Hakyll.Web.Pandoc.Biblio (biblioCompiler, cslCompiler, readPandocBiblio)
import Hakyll.Web.Tags (Tags(..), buildTags, tagsRules)
import Hakyll.Web.Template (loadAndApplyTemplate, templateBodyCompiler)
import Hakyll.Web.Template.Context
    ( Context(..)
    , ContextField(..)
    , bodyField
    , boolField
    , constField
    , defaultContext
    , listField
    , listFieldWith
    , field
    , teaserField
    , getItemUTC
    )
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 (HTMLMathMethod(..), WriterOptions(..))

--
-- 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" (postCtx tags) (pure posts)
                    <> constField "title" "Startseite"
                    <> boolField "active-blog" (const True)
                    <> paginateContext paginate pageNumber
                    <> flevumContext tags
            makeItem ""
                >>= loadAndApplyLayout "blog.html" context
                >>= cleanIndexUrls

localizeMonth :: String -> String
localizeMonth "01" = "Januar"
localizeMonth "02" = "Februar"
localizeMonth "03" = "März"
localizeMonth "04" = "April"
localizeMonth "05" = "Mai"
localizeMonth "06" = "Juni"
localizeMonth "07" = "Juli"
localizeMonth "08" = "August"
localizeMonth "09" = "September"
localizeMonth "10" = "Oktober"
localizeMonth "11" = "November"
localizeMonth "12" = "Dezember"
localizeMonth _ = error "Invalid month number"

formatDate :: FormatTime t => t -> String
formatDate time
    = formatDefaultLocale "%e. "
    ++ localizeMonth (formatDefaultLocale "%m")
    ++ formatDefaultLocale " %Y"
  where
    formatDefaultLocale :: String -> String
    formatDefaultLocale = flip (formatTime defaultTimeLocale) time

postCtx :: Tags -> Context String
postCtx tags
    = field "published" dateField'
    <> teaserField "teaser" "content"
    <> bodyField "description"
    <> flevumContext tags
  where
    dateField' :: Item String -> Compiler String
    dateField' = fmap formatDate
        . getItemUTC defaultTimeLocale
        . itemIdentifier

flevumContext :: Tags -> Context String
flevumContext = (<> defaultContext) . tagsCloud

tagsCloud :: Tags -> Context String
tagsCloud tags
    = listFieldWith "categories" (Context categoryContextF)
    $ forM (tagsMap tags) . go
  where
    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 :: Item String -> (String, [Identifier]) -> Compiler (Item FilePath)
    go 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 = do 
    bib <- load "assets/bibliography/references.bib"
    csl <- load "assets/bibliography/theologie-und-philosophie.csl"

    let pandocBiblio = readPandocBiblio defaultHakyllReaderOptions csl bib
        writerOptions = defaultHakyllWriterOptions
            { writerHTMLMathMethod = MathML
            }

    fmap demoteHeaders . writePandocWith writerOptions
        <$> (getResourceBody >>= pandocBiblio)

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" (postCtx tags) (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

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

    -- Home page.
    createIndex tags

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

    -- Categories.
    tagsRules tags $ createTagPage tags

    -- Blog posts.
    match "posts/**.tex" $ do
        route withoutRootRoute
        compile $ bibtexCompiler
            >>= saveSnapshot "content"
            >>= loadAndApplyLayout "post.html" (postCtx tags)

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

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

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

    match "assets/css/*.css"
        $ route idRoute
        >> compile compressCssCompiler

main :: IO ()
main = hakyllWith configuration rules