blag/site.hs

{-|
Module      : Main
Description : Static HTML generation for my blog
Copyright   : (c) 2019 Chris Hodapp
License     : ??
Stability   : experimental
Portability : POSIX
-}
{-# LANGUAGE OverloadedStrings #-}
import           Data.Monoid (mappend)
import           Hakyll
import           Hakyll.Images
import           System.FilePath
import           Text.Pandoc.Options
import qualified GHC.IO.Encoding as E
import qualified Data.Set as S

-- | Configuration for the RSS and ATOM feeds.
feedConfiguration :: FeedConfiguration
feedConfiguration = FeedConfiguration
    { feedTitle = "hodapple blog"
    , feedDescription = "FIXME!"
    , feedAuthorName = "Chris Hodapp"
    , feedAuthorEmail = "Hodapp87@gmail.com"
    , feedRoot = "http://???"
    }

-- | Alternate pandocCompiler which enables MathJax
pandocMathCompiler :: Compiler (Item String)
pandocMathCompiler =
  -- Lifted straight from:
  -- http://travis.athougies.net/posts/2013-08-13-using-math-on-your-hakyll-blog.html
  let mathExtensions = [ Ext_tex_math_dollars
                       , Ext_tex_math_double_backslash
                       , Ext_latex_macros]
      defaultExtensions = writerExtensions defaultHakyllWriterOptions
      newExtensions = foldr enableExtension defaultExtensions mathExtensions
      writerOptions = defaultHakyllWriterOptions {
        writerExtensions = newExtensions,
          writerHTMLMathMethod = MathJax ""
        }
  in pandocCompilerWith defaultHakyllReaderOptions writerOptions

config :: Configuration
config = defaultConfiguration

options :: Options
options = Options { verbosity = True
                  , optCommand = Watch { host = "0.0.0.0"
                                       , port = 8000
                                       , no_server = False
                                       }
                  }

-- | Main entry point for generating all code via Hakyll
main :: IO ()
main = do
  E.setLocaleEncoding E.utf8
  hakyll $ do
  --hakyllWithArgs config options $ do
    -- Build up tags
    tags <- buildTags "posts/*" (fromCapture "tags/*.html")
    let postCtxTags = postCtxWithTags tags

    -- Pass through all full-size images:
    match ("images/**") $ version "full" $ do
        route   idRoute
        compile copyFileCompiler

    -- But also, make 640x480 reduced versions with /thumbnail
    -- prepended to their path:
    match ("images/**.jpg" .||. "images/**.png") $ version "thumbnail" $ do
        route $ customRoute $ combine "./thumbnail/" . toFilePath
        compile $ loadImage
            >>= scaleImageCompiler 640 480

    -- (I don't fully understand what role "version" plays here except
    -- that it appears to be required for me to have two matches on
    -- the same file paths.)

    match ("assets/**" .||. "assets_external/**" .||. "css/*" .||. "js/**") $ do
        route   idRoute
        compile copyFileCompiler

    match "images/favicons/*" $ do
        route $ customRoute $ takeFileName . toFilePath
        compile copyFileCompiler

    match "pages/*" $ do
        route   $ setExtension "html"
        compile $ pandocMathCompiler
            >>= loadAndApplyTemplate "templates/default.html" defaultContext
            >>= relativizeUrls

    match "slides/**" $ version "raw" $ do
        route idRoute
        compile copyFileCompiler

    -- We want .lhs files to be directly accessible, so copy them
    -- through unmodified.
    match ("posts/*.lhs" .||. "drafts/*.lhs") $ version "raw" $ do
        route idRoute
        compile $ getResourceBody >>= relativizeUrls

    match "posts/*" $ do
        route $ setExtension "html"
        compile $ pandocMathCompiler
            >>= loadAndApplyTemplate "templates/post.html"     postCtxTags
            >>= saveSnapshot "feedContent"
            >>= loadAndApplyTemplate "templates/comments.html" postCtxTags
            >>= loadAndApplyTemplate "templates/default.html"  postCtxTags
            >>= relativizeUrls

    match "drafts/*" $ do
        route $ setExtension "html"
        compile $ pandocMathCompiler
            >>= loadAndApplyTemplate "templates/post.html"     postCtxTags
            >>= loadAndApplyTemplate "templates/default.html"  postCtxTags
            >>= relativizeUrls

    create ["archive.html"] $ do
        route idRoute
        compile $ do
            posts <- recentFirst =<< loadAll ("posts/*" .&&. hasNoVersion)
            let archiveCtx =
                    listField "posts" postCtxTags (return posts) `mappend`
                    constField "title" "Archives"                `mappend`
                    defaultContext

            makeItem ""
                >>= loadAndApplyTemplate "templates/archive.html" archiveCtx
                >>= loadAndApplyTemplate "templates/default.html" archiveCtx
                >>= relativizeUrls

    match "index.html" $ do
        route idRoute
        compile $ do
            posts <- recentFirst =<< loadAll ("posts/*" .&&. hasNoVersion)
            let indexCtx =
                    listField "posts" postCtxTags (return posts) `mappend`
                    constField "title" "Home"                    `mappend`
                    defaultContext
                    -- so... "posts" is a list field which is added
                    -- into indexCtx with contents derived from
                    -- 'posts' above.

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

    match "works/*" $ do
        route $ setExtension "html"
        compile $ pandocMathCompiler
            >>= saveSnapshot "content"
            >>= loadAndApplyTemplate "templates/post.html"     postCtxTags
            >>= loadAndApplyTemplate "templates/default.html"  postCtxTags
            >>= relativizeUrls

    create ["works.html"] $ do
        route idRoute
        compile $ do
            posts <- recentFirst =<< loadAllSnapshots "works/*" "content"
            let archiveCtx = 
                    listField "works" postCtxTags (return posts) `mappend`
                    constField "title" "Something"               `mappend`
                    defaultContext
            makeItem ""
                >>= loadAndApplyTemplate "templates/works.html" archiveCtx
                >>= loadAndApplyTemplate "templates/default.html" archiveCtx
                >>= relativizeUrls

    -- tried to follow
    -- https://jaspervdj.be/hakyll/tutorials/05-snapshots-feeds.html
    -- but I am stuck at this if I clean first & then watch:
    -- [ERROR] Missing field $description$ in context for item works/2019-10-27-test.md
    -- For some reason, bodyField just doesn't seem to add the context.

    match "templates/*" $ compile templateCompiler

    let compileFeed f = compile $ do
          posts <- recentFirst =<< loadAllSnapshots ("posts/*" .&&. complement "posts/*.lhs") "feedContent"
          f feedConfiguration feedCtx posts

    create ["atom.xml"] $ do
        route idRoute
        compileFeed renderAtom

    create ["rss.xml"] $ do
        route idRoute
        compileFeed renderRss

    tagsRules tags $ \tag pattern -> do
        let title = "Posts tagged \"" ++ tag ++ "\""
        route idRoute
        compile $ do
            posts <- recentFirst =<< loadAll pattern
            let ctx = constField "title" title
                      `mappend` listField "posts" postCtx (return posts)
                      `mappend` defaultContext

            makeItem ""
                >>= loadAndApplyTemplate "templates/tag.html" ctx
                >>= loadAndApplyTemplate "templates/default.html" ctx
                >>= relativizeUrls

-- | Post context, no tags present:
postCtx :: Context String
postCtx =
    dateField "date" "%B %e, %Y" `mappend`
    defaultContext

-- | Post context, with tags:
postCtxWithTags :: Tags -> Context String
postCtxWithTags tags = tagsField "tags" tags `mappend` postCtx

-- | Context for feeds.
feedCtx :: Context String
feedCtx = postCtx `mappend` bodyField "description"