spokeproof.hs

{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}

import           BasePrelude
import           Data.List.Split (splitOn)
import qualified Data.Map as M
import           Hakyll hiding (defaultContext)
import qualified Hakyll as H
import           System.FilePath (replaceExtension, takeFileName)
import qualified Text.Pandoc as P

formatPostFilePath :: String -> String
formatPostFilePath s =
  case splitOn "-" s of
    (_:_:_:rest) ->
      intercalate "/" [intercalate "-" rest]

toHtmlExtension :: String -> String
toHtmlExtension = (`replaceExtension` "html")

readerOptions :: P.ReaderOptions
readerOptions = defaultHakyllReaderOptions { P.readerExtensions = P.phpMarkdownExtraExtensions }

postRoute :: Rules ()
postRoute =
  do (route . customRoute) (toHtmlExtension . formatPostFilePath . takeFileName . toFilePath)
     compile (pandocCompilerWith readerOptions defaultHakyllWriterOptions >>=
              saveSnapshot "_post" >>=
              loadAndApplyTemplate "templates/post-single.html" postCtx >>=
              saveSnapshot "_single" >>=
              loadAndApplyTemplate "templates/post.html" postCtx >>=
              loadAndApplyTemplate "templates/default.html" postCtx >>=
              relativizeUrls)

snapshots :: String -> Compiler [Item String]
snapshots key =
  loadAllSnapshots "_db/posts/*" key >>= recentFirst

archiveRoute :: Rules ()
archiveRoute =
  do route idRoute
     compile (do singles <- snapshots "_single"
                 let archiveCtx =
                       listField "posts" postCtx (return singles) <>
                       constField "title" "Archive" <>
                       H.defaultContext
                 (makeItem "" >>=
                  loadAndApplyTemplate "templates/archive.html" archiveCtx >>=
                  loadAndApplyTemplate "templates/default.html" archiveCtx >>=
                  relativizeUrls))

indexRoute :: Rules ()
indexRoute =
  do route idRoute
     compile (do singles <- snapshots "_single"
                 let indexCtx =
                       listField "posts" postCtx (return (drop 1 singles)) <>
                       listField "featuredPosts" postCtx (return [head singles]) <>
                       H.defaultContext
                 let defaultContext =
                       constField "hideSubtitle" "" <>
                       H.defaultContext
                 (makeItem "" >>=
                  loadAndApplyTemplate "templates/index.html" indexCtx >>=
                  loadAndApplyTemplate "templates/default.html" defaultContext >>=
                  relativizeUrls))

atomRoute :: Rules ()
atomRoute =
  do
    route idRoute
    compile (do
                posts <- snapshots "_post"
                renderAtom config atomCtx posts
             )
  where
    config =
      FeedConfiguration {
          feedTitle = "Spoke Proof"
        , feedDescription = "Computers"
        , feedAuthorName = "Hao Lian"
        , feedAuthorEmail = "spokeproof@haolian.org"
        , feedRoot = "http://hao.codes"
        }

main :: IO ()
main = hakyll $ do
    match "images/*" $ do
        route   idRoute
        compile copyFileCompiler

    match "css/*" $ do
        route   idRoute
        compile compressCssCompiler

    match "js/*" $ do
      route idRoute
      compile copyFileCompiler

    match "_db/posts/*" postRoute
    match "templates/*" (compile templateCompiler)

    create ["archive.html"] archiveRoute
    create ["archive.atom"] atomRoute
    create ["index.html"] indexRoute

previousItem :: Item a -> Item a
previousItem = id

nextItem :: Item a -> Item a
nextItem = id

itemUrl :: Item a -> Compiler String
itemUrl = fmap (toUrl . fromJust) . getRoute . itemIdentifier

metadataLookup :: String -> Item a -> Compiler String
metadataLookup key item = (fromJust . M.lookup key) <$> (getMetadata $ itemIdentifier item)

postCtx :: Context String
postCtx =
  mconcat [
      dateField "date" "%B %e, %Y"
    , field "wordCount" (return . show . length . words . itemBody)
    , field "previousURL" (itemUrl . previousItem)
    , field "nextURL" (itemUrl . nextItem)
    , field "previousTitle" (metadataLookup "title" . previousItem)
    , field "nextTitle" (metadataLookup "title" . nextItem)
    , H.defaultContext
    ]

atomCtx :: Context String
atomCtx =
  mconcat [
      bodyField "description"
    , H.defaultContext
    ]