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 (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
    , takeDirectory
    )
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 = const False
    , deployCommand = "rsync"
    , deploySite = deploySite'
    , inMemoryCache = True
    , previewHost = "127.0.0.1"
    , previewPort = 8000
    , checkHtmlFile = const False
    , previewSettings = Static.defaultFileServerSettings
    }
  where
    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 = do
    paginate <- buildPaginateWith grouper "posts/**" makeId
    paginateRules paginate $ indexRules paginate
  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
    makeId 1 = "index.html"
    makeId pageNumber = fromFilePath $ shows pageNumber ".html"

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 $ fst tag
        tagsMetadata <- getMetadataField currentPage "tags"
        let isActiveClass
                = directoryNames currentPage == directoryNames tagId
                || Just (fst 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 = takeDirectory 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

grouper :: [Identifier] -> Rules [[Identifier]]
grouper = fmap (paginateEvery 25) . sortRecentFirst

createTagPage :: Tags -> String -> Pattern -> Rules ()
createTagPage tags tagName tagPattern = do
    paginate <- buildPaginateWith grouper tagPattern makeId
    paginateRules paginate $ paginateTag paginate
  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
    tagBase = fromFilePath . (("tags/" ++ tagName) ++)
    makeId 1 = tagBase "/index.html"
    makeId pageNumber = tagBase ('/' : shows pageNumber ".html")

--
-- 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
            >>= cleanIndexUrls

    -- Categories.
    tagsRules tags $ createTagPage tags

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

    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