Open the blog

1 files changed, 287 insertions, 0 deletions

diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..fac40ac
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,287 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Main where
+
+import Control.Monad (forM)
+import Data.List (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.
+--
+configuration :: Configuration
+configuration = Configuration
+    { destinationDirectory = "./var/web"
+    , storeDirectory = "./var/cache"
+    , tmpDirectory = "./var/cache/tmp"
+    , providerDirectory = "./themes"
+    , watchIgnore = const False
+    , ignoreFile = const False
+    , deployCommand = "rsync"
+    , deploySite = deploySite'
+    , inMemoryCache = True
+    , previewHost = "127.0.0.1"
+    , previewPort = 8000
+    , checkHtmlFile = const False
+    , previewSettings = Static.defaultFileServerSettings
+    }
+  where
+    deploySite'  deploymentConfiguration
+        = readFile "deployment.txt"
+        >>= executeDeployment deploymentConfiguration
+    executeDeployment Configuration{..} deploymentTarget = rawSystem deployCommand
+        [ "-ave"
+        , "ssh"
+        , "--delete"
+        , addTrailingPathSeparator destinationDirectory
+        , deploymentTarget
+        ]
+
+--
+-- Helpers.
+--
+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 ""
+                >>= loadAndApplyTemplate "templates/blog.html" context
+                >>= loadAndApplyTemplate "templates/default.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 ""
+                >>= loadAndApplyTemplate "templates/tag.html" context
+                >>= loadAndApplyTemplate "templates/default.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
+            >>= loadAndApplyTemplate "templates/page.html" contextWithTags
+            >>= loadAndApplyTemplate "templates/default.html" contextWithTags
+            >>= cleanIndexUrls
+
+    -- Categories.
+    tagsRules tags $ createTagPage tags
+
+    -- Blog posts.
+    match "posts/**.tex" $ do
+        route withoutRootRoute
+        compile $ bibtexCompiler
+            >>= saveSnapshot "content"
+            >>= loadAndApplyTemplate "templates/post.html" (postCtx tags)
+            >>= loadAndApplyTemplate "templates/default.html" (postCtx tags)
+            >>= cleanIndexUrls
+
+    match "assets/bibliography/*.bib" $ compile biblioCompiler
+    match "assets/bibliography/*.csl" $ compile cslCompiler
+
+    -- Templates.
+    match (fromGlob "templates/*") $ compile templateBodyCompiler
+    match "_includes/**" $ compile templateBodyCompiler
+
+    -- Copy files.
+    copyMatchedFiles "assets/fonts/*"
+    copyMatchedFiles "assets/images/**"
+
+    match "assets/css/*.css"
+        $ route idRoute
+        >> compile compressCssCompiler
+
+main :: IO ()
+main = hakyllWith configuration rules