offtopia.org/site.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}

import Control.DeepSeq (rnf)
import Control.Concurrent
import Control.Exception
import Control.Monad

import qualified Data.ByteString.Lazy.Char8 as BS
import Data.ByteString.Lazy.Char8 (pack, unpack)
import qualified Data.Text.Encoding as T
import qualified Data.HashMap.Strict as HMap
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import Data.Functor
import Data.Monoid
import Data.Aeson
import Data.Maybe
import Data.List
import Data.Char

import Debug.Trace

import Hakyll.Core.Compiler.Internal
import Hakyll.Core.Compiler
import Hakyll.Web.Sass
import Hakyll

import qualified Network.URI.Encode as URI (encode)

import qualified Skylighting as Sky

import System.Environment
import System.Process
import System.Exit
import System.IO

import Text.Pandoc.Walk (query, walkM)
import Text.Pandoc.Highlighting
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Text.Sass.Functions

readerOpts :: ReaderOptions
readerOpts = def { readerExtensions = pandocExtensions
                 , readerIndentedCodeClasses = ["amulet"] }

writerOptions :: Compiler WriterOptions
writerOptions = do
  syntaxMap <- loadAllSnapshots "syntax/*.xml" "syntax"
           <&> foldr (Sky.addSyntaxDefinition . itemBody) Sky.defaultSyntaxMap

  pure $ defaultHakyllWriterOptions
    { writerExtensions = extensionsFromList
                         [ Ext_tex_math_dollars
                         , Ext_tex_math_double_backslash
                         , Ext_latex_macros
                         ] <> writerExtensions defaultHakyllWriterOptions
    , writerSyntaxMap = syntaxMap
    , writerHighlightStyle = Just kate
    }

rssfeed :: FeedConfiguration
rssfeed
  = FeedConfiguration { feedTitle = "Abigail's Blag: Latest articles"
                      , feedDescription = ""
                      , feedAuthorName = "Abigail Magalhães"
                      , feedAuthorEmail = "magalhaes.alcantara@pucpr.edu.br"
                      , feedRoot = "https://abby.how"
                      }

conf :: Configuration
conf = def { destinationDirectory = ".site"
           , storeDirectory       = ".store"
           , tmpDirectory         = ".store/tmp"
           , deployCommand        = "./sync" }

main :: IO ()
main = hakyllWith conf $ do
  let compiler = do
        wops <- writerOptions
        pandocCompilerWithTransformM readerOpts wops pure

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

  match "css/*.scss" $ do
    route $ setExtension "css"
    compile $ sassCompilerWith def { sassOutputStyle = SassStyleCompressed
                                   , sassImporters = Nothing
                                   }

  match "pages/**/*" $ do
    route $ setExtension "html"

    compile $ do
      id   <- getUnderlying
      meta <- getMetadata id
      let category = takeWhile (/= '/') $ tail $ dropWhile (/= '/') (toFilePath id)
      compiler
        >>= loadAndApplyTemplate (fromFilePath ("templates/" ++ category ++ ".html")) (metaToContext meta)
        >>= saveSnapshot "content"

  match "pages/*.html" $ do
    route $ gsubRoute "pages/" (const "")
    compile $ do
      ppl <- loadAll "pages/people/*"
      let (ppl_a, ppl_b) = explode ppl

      projects <- loadAll "pages/projects/*"

      let indexCtx =
            listField "people-1" postCtx (return ppl_a)    <>
            listField "people-2" postCtx (return ppl_b)    <>
            listField "projects" postCtx (return projects) <>
            constField "title" "Home"                      <>
            defaultContext
      getResourceBody
        >>= applyAsTemplate indexCtx
        >>= loadAndApplyTemplate "templates/default.html" indexCtx
        >>= relativizeUrls

  match "pages/*.md" $ do
    route $ gsubRoute "pages/" (const "") <> setExtension "html"
    compile $ compiler
      >>= loadAndApplyTemplate "templates/default.html" defaultContext
      >>= relativizeUrls

  match "templates/*" $ compile templateBodyCompiler

postCtx :: Context String
postCtx = dateField "date" "%B %e, %Y"
       <> defaultContext

pathFromTitle :: Metadata -> Routes
pathFromTitle meta =
  let
    declaredCategory =
      case lookupString "category" meta of
        Just s -> ((s ++ "/") ++)
        Nothing -> ("posts/" <>)

    !titleString =
      case lookupString "title" meta of
        Just s -> s
        Nothing -> error "post has no title?"

    title = filter (/= "") . map (filter isAlphaNum . map toLower) . words $ titleString

    (category, title') =
      if | "or" `elem` title                   -> (declaredCategory, takeWhile (/= "or") title)
         | ["a", "quickie"] `isPrefixOf` title -> (("quick/" ++), drop 2 title)
         | otherwise                           -> (declaredCategory, title)
  in
    case lookupString "path" meta of
      Just p -> constRoute (category (p <> ".html"))
      Nothing -> constRoute (category (intercalate "-" title' <> ".html"))

foldMapM :: (Monad w, Monoid m, Foldable f) => (a -> w m) -> f a -> w m
foldMapM k = foldr (\x y -> do { m <- k x; (m <>) <$> y }) (pure mempty)

explode :: [a] -> ([a], [a])
explode = go True where
  go True (x:xs) =
    let (as, bs) = go False xs
     in (x:as, bs)
  go False (x:xs) =
    let (as, bs) = go True xs
     in (as, x:bs)
  go _ [] = ([], [])

metaToContext :: Object -> Context String
metaToContext obj = HMap.foldrWithKey go mempty obj <> defaultContext where
  go :: T.Text -> Value -> Context String -> Context String
  go key (String x) ctx = constField (T.unpack key) (T.unpack x) <> ctx
  go key (Array xs) ctx = listField (T.unpack key) (Context jsonContext) (traverse makeItem (foldr (:) [] xs))

  jsonContext key idk item = do
    let x = itemBody item
    objToField key x

  objToField key x =
    case x of
      String x -> pure $ StringField (T.unpack x)
      Object m -> objToField (tail (dropWhile (/= '.') key)) (fromJust (HMap.lookup (T.pack (takeWhile (/= '.') key)) m))
      Array xs -> do
        is <- traverse makeItem (foldr (:) [] xs)
        pure $ ListField (Context jsonContext) is