-- start snippet imports
{-# LANGUAGE DeriveGeneric, ScopedTypeVariables, LambdaCase, Strict, ApplicativeDo #-}
module Main where
import Control.Monad (void)
import Data.Aeson.Types (FromJSON (..), Result (..), ToJSON (..))
import Data.List (nub, sortOn)
import Data.Time (UTCTime, defaultTimeLocale, formatTime, parseTimeM)
import Development.Shake ((%>), Action, Rules, (|%>), (~>))
import Development.Shake.FilePath ((<.>), (</>))
import GHC.Generics (Generic)
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.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
import qualified Data.Ord as Ord
-- end snippet imports
-- start snippet main
main :: IO ()
main = do
Shake.shakeArgs Shake.shakeOptions $ do
Shake.withTargetDocs "Build the site" $
"build" ~> buildTargets
Shake.withTargetDocs "Clean the built site" $
"clean" ~> Shake.removeFilesAfter outputDir ["//*"]
Shake.withoutTargets buildRules
-- end snippet main
-- start snippet build-rules
outputDir :: String
outputDir = "_site"
buildTargets :: Action ()
buildTargets = void $ do
needOutput [ "about/index.html"
, "contact/index.html"
, "archive/index.html"
, "index.html"
]
postPaths <- Shake.getDirectoryFiles "" ["posts/*.md"]
assetPaths <- Shake.getDirectoryFiles "" ["css/*.css", "images/*.png"]
Shake.need . map indexHtmlOutputPath $ postPaths
needOutput assetPaths
posts <- Shake.forP postPaths readPost
needOutput
. map (\tag -> "tags" </> tag </> "index.html")
. nub
. concatMap postTags
$ posts
where
needOutput = Shake.need . map (outputDir </>)
buildRules :: Rules ()
buildRules = do
assets
pages
posts
archive
tagArchives
index
-- end snippet build-rules
-- start snippet assets
assets :: Rules ()
assets =
map (outputDir </>) ["css/*.css", "images/*.png"] |%> \out -> do
let src = Shake.dropDirectory1 out
Shake.copyFile' src out
Shake.putInfo $ "Copied " <> out <> " from " <> src
-- end snippet assets
-- start snippet pages
data Page = Page { pageTitle :: T.Text, pageContent :: T.Text }
deriving (Show, Generic)
instance ToJSON Page where
toJSON = A.genericToJSON $
A.defaultOptions { A.fieldLabelModifier = A.camelTo2 '_' . drop 4 }
instance FromJSON Page where
parseJSON = A.genericParseJSON $
A.defaultOptions { A.fieldLabelModifier = A.camelTo2 '_' . drop 4 }
pages :: Rules ()
pages =
map indexHtmlOutputPath ["about.md", "contact.md"] |%> \out -> do
let src = indexHtmlSourcePath out
(meta, html) <- markdownToHtml src
let page = Page (meta HM.! "title") html
applyTemplateAndWrite "default.html" page out
Shake.putInfo $ "Built " <> out <> " from " <> src
-- end snippet pages
-- start snippet posts-1
data Post = Posts {
postTitle :: T.Text
, postAuthor :: Maybe String
, postTags :: [String]
, postDate :: Maybe String
, postContent :: Maybe T.Text
, postUrl :: Maybe String
} deriving (Show, Generic)
instance ToJSON Post where
toJSON = A.genericToJSON $
A.defaultOptions { A.fieldLabelModifier = A.camelTo2 '_' . drop 4 }
instance FromJSON Post where
parseJSON = A.genericParseJSON $
A.defaultOptions { A.fieldLabelModifier = A.camelTo2 '_' . drop 4 }
-- end snippet posts-1
-- start snippet posts-2
posts :: Rules ()
posts =
outputDir </> "posts/*/index.html" %> \out -> do
let src = indexHtmlSourcePath out
post <- readPost src
postHtml <- applyTemplate "post.html" post
let page = Page (postTitle post) postHtml
applyTemplateAndWrite "default.html" page out
Shake.putInfo $ "Built " <> out <> " from " <> src
readPost :: FilePath -> Action Post
readPost postPath = do
date :: UTCTime <- parseTimeM False defaultTimeLocale "%Y-%-m-%-d"
. take 10
. Shake.takeBaseName
$ postPath
let dateFmtd = formatTime defaultTimeLocale "%b %e, %Y" date
(post, html) <- markdownToHtml postPath
Shake.putInfo $ "Read " <> postPath
return $ post { postDate = Just dateFmtd
, postContent = Just html
, postUrl = Just $ "/" <> Shake.dropExtension postPath <> "/" }
-- end snippet posts-2
-- start snippet archive
archive :: Rules ()
archive =
outputDir </> "archive/index.html" %> \out -> do
postPaths <- Shake.getDirectoryFiles "" ["posts/*.md"]
posts <- sortOn (Ord.Down . postDate) <$> Shake.forP postPaths readPost
writeArchive "Archive" posts out
writeArchive :: String -> [Post] -> FilePath -> Action ()
writeArchive title posts out = do
archiveHtml <- applyTemplate "archive.html"
$ HM.singleton "posts" posts
let page = Page (T.pack title) archiveHtml
applyTemplateAndWrite "default.html" page out
Shake.putInfo $ "Built " <> out
-- end snippet archive
-- start snippet tag-archive
tagArchives :: Rules ()
tagArchives =
outputDir </> "tags/*/index.html" %> \out -> do
let tag = Shake.splitDirectories out !! 2
postPaths <- Shake.getDirectoryFiles "" ["posts/*.md"]
posts <- sortOn (Ord.Down . postDate)
. filter ((tag `elem`) . postTags)
<$> Shake.forP postPaths readPost
writeArchive ("Posts tagged " <> tag) posts out
-- end snippet tag-archive
-- start snippet index
index :: Rules ()
index =
outputDir </> "index.html" %> \out -> do
postPaths <- Shake.getDirectoryFiles "" ["posts/*.md"]
posts <- take 3
. sortOn (Ord.Down . postDate)
<$> Shake.forP postPaths readPost
indexHtml <- applyTemplate "index.html"
$ HM.singleton "posts" posts
let page = Page (T.pack "Home") indexHtml
applyTemplateAndWrite "default.html" page out
Shake.putInfo $ "Built " <> out
-- end snippet index
-- start snippet shake
indexHtmlOutputPath :: FilePath -> FilePath
indexHtmlOutputPath srcPath =
outputDir </> Shake.dropExtension srcPath </> "index.html"
indexHtmlSourcePath :: FilePath -> FilePath
indexHtmlSourcePath =
Shake.dropDirectory1
. (<.> "md")
. Shake.dropTrailingPathSeparator
. Shake.dropFileName
-- end snippet shake
-- start snippet pandoc
markdownToHtml :: FromJSON a => FilePath -> Action (a, T.Text)
markdownToHtml fp = do
content <- Shake.readFile' fp
Shake.quietly . Shake.traced "Markdown to HTML" $ do
pandoc@(Pandoc meta _) <- runPandoc . Pandoc.readMarkdown readerOptions . T.pack $ content
meta' <- metaToValue meta >>= convert
html <- runPandoc . Pandoc.writeHtml5String writerOptions $ pandoc
return (meta', html)
where
readerOptions = Pandoc.def { Pandoc.readerExtensions = Pandoc.pandocExtensions }
writerOptions = Pandoc.def { Pandoc.writerExtensions = Pandoc.pandocExtensions }
metaToValue (Meta meta) = toJSON <$> traverse go meta
go (MetaMap m) = toJSON <$> traverse go m
go (MetaList m) = toJSONList <$> traverse go m
go (MetaBool m) = pure $ toJSON m
go (MetaString m) = pure $ toJSON $ T.strip m
go (MetaInlines m) =
toJSON . T.strip <$> (runPandoc . Pandoc.writePlain Pandoc.def . Pandoc mempty . (:[]) . Plain $ m)
go (MetaBlocks m) =
toJSON . T.strip <$> (runPandoc . Pandoc.writePlain Pandoc.def . Pandoc mempty $ m)
convert a = case A.fromJSON (toJSON a) of
Success res -> pure res
Error err -> fail $ "json conversion error:" ++ err
runPandoc p = Pandoc.runIO p >>= either (fail . show) return
-- end snippet pandoc
-- start snippet mustache
applyTemplate :: ToJSON a => FilePath -> a -> Action T.Text
applyTemplate template context = do
tmpl <- readTemplate $ "templates" </> template
case Mus.checkedSubstitute tmpl (toJSON context) of
([], text) -> return text
(errs, _) -> fail $
"Error while substituting template " <> template <> ": " <> unlines (map show errs)
applyTemplateAndWrite :: (ToJSON a) => FilePath -> a -> FilePath -> Action ()
applyTemplateAndWrite template context out =
applyTemplate template context >>= Shake.writeFile' out . T.unpack
readTemplate :: FilePath -> Action Mus.Template
readTemplate tmplPath = do
Shake.need [tmplPath]
Shake.liftIO (Mus.localAutomaticCompile tmplPath) >>= \case
Right template -> do
Shake.need (Mus.getPartials . Mus.ast $ template)
return template
Left err -> fail $ show err
-- end snippet mustache