#! /usr/bin/env nix-shell
#! nix-shell -p "haskellPackages.ghcWithPackages (p: [p.mustache p.pandoc p.shake p.deriving-aeson])"
#! nix-shell -i runhaskell
{-# LANGUAGE ApplicativeDo, DataKinds, DeriveGeneric #-}
{-# LANGUAGE DerivingVia, LambdaCase, TypeApplications #-}
module Main where
import Control.Monad (forM, void)
import Data.Aeson.Types (Result (..))
import Data.List (nub, sortOn)
import Data.Text (Text)
import Data.Time (UTCTime, defaultTimeLocale, formatTime, parseTimeM)
import Deriving.Aeson
import Deriving.Aeson.Stock (PrefixedSnake)
import Development.Shake (Action, Rules, (%>), (|%>), (~>))
import Development.Shake.FilePath ((<.>), (</>))
import Text.Pandoc (Block (Plain), Meta (..), MetaValue (..), Pandoc (..))
import qualified Data.Aeson.Types as A
import qualified Data.HashMap.Strict as HM
import qualified Data.Ord as Ord
import qualified Data.Text as T
import qualified Development.Shake as Shake
import qualified Development.Shake.FilePath as Shake
import qualified Text.Mustache as Mus
import qualified Text.Mustache.Compile as Mus
import qualified Text.Pandoc as Pandoc
main :: IO ()
main = do
templateCache <- newTemplateCache
postCache <- newPostCache
Shake.shakeArgs Shake.shakeOptions $ do
Shake.withTargetDocs "Build the site" $
"build" ~> buildTargets postCache
Shake.withTargetDocs "Clean the built site" $
"clean" ~> Shake.removeFilesAfter outputDir ["//*"]
Shake.withoutTargets $ buildRules templateCache postCache
outputDir :: String
outputDir = "_site"
buildTargets :: PostCache -> Action ()
buildTargets postCache = do
assetPaths <- Shake.getDirectoryFiles "" assetGlobs
Shake.need $ map (outputDir </>) assetPaths
Shake.need $ map indexHtmlOutputPath pagePaths
postPaths <- Shake.getDirectoryFiles "" postGlobs
Shake.need $ map indexHtmlOutputPath postPaths
Shake.need $ map (outputDir </>) ["archive/index.html", "index.html"]
posts <- forM postPaths postCache
Shake.need
[ outputDir </> "tags" </> T.unpack tag </> "index.html"
| post <- posts, tag <- postTags post ]
assetGlobs :: [String]
assetGlobs = ["css/*.css", "images/*.png"]
pagePaths :: [String]
pagePaths = ["about.md", "contact.md"]
postGlobs :: [String]
postGlobs = ["posts/*.md"]
indexHtmlOutputPath :: FilePath -> FilePath
indexHtmlOutputPath srcPath =
outputDir </> Shake.dropExtension srcPath </> "index.html"
buildRules :: TemplateCache -> PostCache -> Rules ()
buildRules templateCache postCache = do
assets
pages templateCache
posts templateCache postCache
archive templateCache postCache
tags templateCache postCache
home templateCache postCache
assets :: Rules ()
assets = map (outputDir </>) assetGlobs |%> \target -> do
let src = Shake.dropDirectory1 target
Shake.copyFileChanged src target
Shake.putInfo $ "Copied " <> target <> " from " <> src
data Page = Page {pageTitle :: Text, pageContent :: Text}
deriving (Show, Generic)
deriving (ToJSON) via PrefixedSnake "page" Page
pages :: TemplateCache -> Rules ()
pages templateCache =
map indexHtmlOutputPath pagePaths |%> \target -> do
let src = indexHtmlSourcePath target
(meta, html) <- markdownToHtml src
let page = Page (meta HM.! "title") html
applyTemplateAndWrite templateCache "default.html" page target
Shake.putInfo $ "Built " <> target <> " from " <> src
indexHtmlSourcePath :: FilePath -> FilePath
indexHtmlSourcePath =
Shake.dropDirectory1
. (<.> "md")
. Shake.dropTrailingPathSeparator
. Shake.dropFileName
data Post = Post
{ postTitle :: Text,
postAuthor :: Maybe Text,
postTags :: [Text],
postDate :: Maybe Text,
postContent :: Maybe Text,
postLink :: Maybe Text
} deriving (Show, Generic)
deriving (FromJSON, ToJSON) via PrefixedSnake "post" Post
posts :: TemplateCache -> PostCache -> Rules ()
posts templateCache postCache =
map indexHtmlOutputPath postGlobs |%> \target -> do
let src = indexHtmlSourcePath target
post <- postCache src
postHtml <- applyTemplate templateCache "post.html" post
let page = Page (postTitle post) postHtml
applyTemplateAndWrite templateCache "default.html" page target
Shake.putInfo $ "Built " <> target <> " from " <> src
readPost :: FilePath -> Action Post
readPost postPath = do
date <- parseTimeM False defaultTimeLocale "%Y-%-m-%-d"
. take 10
. Shake.takeBaseName
$ postPath
let formattedDate =
T.pack $ formatTime @UTCTime defaultTimeLocale "%b %e, %Y" date
(post, html) <- markdownToHtml postPath
Shake.putInfo $ "Read " <> postPath
return $ post
{ postDate = Just formattedDate,
postContent = Just html,
postLink = Just . T.pack $ "/" <> Shake.dropExtension postPath <> "/"
}
type PostCache = FilePath -> Action Post
newPostCache :: IO PostCache
newPostCache = Shake.newCacheIO readPost
archive :: TemplateCache -> PostCache -> Rules ()
archive templateCache postCache =
outputDir </> "archive/index.html" %> \target -> do
postPaths <- Shake.getDirectoryFiles "" postGlobs
posts <- sortOn (Ord.Down . postDate) <$> forM postPaths postCache
writeArchive templateCache (T.pack "Archive") posts target
writeArchive :: TemplateCache -> Text -> [Post] -> FilePath -> Action ()
writeArchive templateCache title posts target = do
html <- applyTemplate templateCache "archive.html" $ HM.singleton "posts" posts
applyTemplateAndWrite templateCache "default.html" (Page title html) target
Shake.putInfo $ "Built " <> target
tags :: TemplateCache -> PostCache -> Rules ()
tags templateCache postCache =
outputDir </> "tags/*/index.html" %> \target -> do
let tag = T.pack $ Shake.splitDirectories target !! 2
postPaths <- Shake.getDirectoryFiles "" postGlobs
posts <- sortOn (Ord.Down . postDate)
. filter ((tag `elem`) . postTags)
<$> forM postPaths postCache
writeArchive templateCache (T.pack "Posts tagged " <> tag) posts target
home :: TemplateCache -> PostCache -> Rules ()
home templateCache postCache =
outputDir </> "index.html" %> \target -> do
postPaths <- Shake.getDirectoryFiles "" postGlobs
posts <- take 3
. sortOn (Ord.Down . postDate)
<$> forM postPaths postCache
html <- applyTemplate templateCache "home.html" $ HM.singleton "posts" posts
let page = Page (T.pack "Home") html
applyTemplateAndWrite templateCache "default.html" page target
Shake.putInfo $ "Built " <> target
markdownToHtml :: FromJSON a => FilePath -> Action (a, Text)
markdownToHtml filePath = do
content <- Shake.readFile' filePath
Shake.quietly . Shake.traced "Markdown to HTML" $ do
pandoc@(Pandoc meta _) <-
runPandoc . Pandoc.readMarkdown readerOptions . T.pack $ content
meta' <- fromMeta meta
html <- runPandoc . Pandoc.writeHtml5String writerOptions $ pandoc
return (meta', html)
where
readerOptions =
Pandoc.def {Pandoc.readerExtensions = Pandoc.pandocExtensions}
writerOptions =
Pandoc.def {Pandoc.writerExtensions = Pandoc.pandocExtensions}
fromMeta (Meta meta) =
A.fromJSON . A.toJSON <$> traverse metaValueToJSON meta >>= \case
Success res -> pure res
Error err -> fail $ "json conversion error:" <> err
metaValueToJSON = \case
MetaMap m -> A.toJSON <$> traverse metaValueToJSON m
MetaList m -> A.toJSONList <$> traverse metaValueToJSON m
MetaBool m -> pure $ A.toJSON m
MetaString m -> pure $ A.toJSON $ T.strip m
MetaInlines m -> metaValueToJSON $ MetaBlocks [Plain m]
MetaBlocks m ->
fmap (A.toJSON . T.strip)
. runPandoc
. Pandoc.writePlain Pandoc.def
$ Pandoc mempty m
runPandoc action =
Pandoc.runIO (Pandoc.setVerbosity Pandoc.ERROR >> action)
>>= either (fail . show) return
applyTemplate :: ToJSON a => TemplateCache -> String -> a -> Action Text
applyTemplate templateCache templateName context = do
tmpl <- templateCache $ "templates" </> templateName
case Mus.checkedSubstitute tmpl (A.toJSON context) of
([], text) -> return text
(errs, _) -> fail $
"Error while substituting template " <> templateName
<> ": " <> unlines (map show errs)
applyTemplateAndWrite ::
ToJSON a => TemplateCache -> String -> a -> FilePath -> Action ()
applyTemplateAndWrite templateCache templateName context outputPath =
applyTemplate templateCache templateName context
>>= Shake.writeFile' outputPath . T.unpack
readTemplate :: FilePath -> Action Mus.Template
readTemplate templatePath = do
Shake.need [templatePath]
eTemplate <- Shake.quietly
. Shake.traced "Compile template"
$ Mus.localAutomaticCompile templatePath
case eTemplate of
Right template -> do
Shake.need . Mus.getPartials . Mus.ast $ template
Shake.putInfo $ "Read " <> templatePath
return template
Left err -> fail $ show err
type TemplateCache = FilePath -> Action Mus.Template
newTemplateCache :: IO TemplateCache
newTemplateCache = Shake.newCacheIO readTemplate