{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module Shakebook.Defaults where
import Control.Comonad
import Control.Comonad.Cofree
import Control.Comonad.Store.Class
import Control.Comonad.Zipper.Extra
import Control.Monad.Extra
import Data.Aeson as A
import Data.List.Split
import Data.Text.Time
import Development.Shake.Plus
import qualified Development.Shake.FilePath as S
import RIO
import qualified RIO.ByteString.Lazy as LBS
import RIO.List
import RIO.List.Partial
import qualified RIO.Map as M
import RIO.Partial
import qualified RIO.Text as T
import RIO.Time
import Path as P
import Shakebook.Aeson
import Shakebook.Conventions
import Shakebook.Data
import Shakebook.Mustache
import Text.DocTemplates
import Text.Pandoc.Class
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Text.Pandoc.PDF
import Text.Pandoc.Readers
import Text.Pandoc.Templates
import Text.Pandoc.Walk
import Text.Pandoc.Writers
import Within
defaultMonthUrlFormat :: UTCTime -> String
defaultMonthUrlFormat = formatTime defaultTimeLocale "%Y-%m"
defaultPrettyMonthFormat :: UTCTime -> String
defaultPrettyMonthFormat = formatTime defaultTimeLocale "%B, %Y"
defaultPrettyTimeFormat :: UTCTime -> String
defaultPrettyTimeFormat = formatTime defaultTimeLocale "%A, %B %d, %Y"
defaultIndexFileFragment :: Path Rel File
defaultIndexFileFragment = $(mkRelFile "index.html")
defaultMonthDirFragment :: MonadThrow m => UTCTime -> m (Path Rel Dir)
defaultMonthDirFragment t = do
k <- parseRelDir $ defaultMonthUrlFormat t
return $ $(mkRelDir "posts/months") </> k
defaultMonthUrlFragment :: UTCTime -> Text
defaultMonthUrlFragment t = T.pack $ "/posts/months/" <> defaultMonthUrlFormat t
defaultEnrichPost :: Value -> Value
defaultEnrichPost = enrichTeaser "<!--more-->"
. enrichTagLinks ("/posts/tags/" <>)
. enrichPrettyDate defaultPrettyTimeFormat
defaultMarkdownReaderOptions :: ReaderOptions
defaultMarkdownReaderOptions = def { readerExtensions = pandocExtensions }
defaultHtml5WriterOptions :: WriterOptions
defaultHtml5WriterOptions = def { writerHTMLMathMethod = MathJax ""}
defaultLatexWriterOptions :: WriterOptions
defaultLatexWriterOptions = def { writerTableOfContents = True
, writerVariables = Context $ M.fromList [
("geometry", SimpleVal "margin=3cm")
, ("fontsize", SimpleVal "10")
, ("linkcolor",SimpleVal "blue")]
}
defaultSbSrcDir :: Path Rel Dir
defaultSbSrcDir = $(mkRelDir "site")
defaultSbOutDir :: Path Rel Dir
defaultSbOutDir = $(mkRelDir "public")
defaultPostsPerPage :: Int
defaultPostsPerPage = 5
defaultSbConfig :: Text
-> SbConfig
defaultSbConfig x = SbConfig defaultSbSrcDir defaultSbOutDir x defaultMarkdownReaderOptions defaultHtml5WriterOptions defaultPostsPerPage
affixBlogNavbar :: MonadShakebookAction r m
=> [FilePattern]
-> Text
-> Text
-> (UTCTime -> Text)
-> (UTCTime -> Text)
-> (Value -> Value)
-> Value -> m Value
affixBlogNavbar patterns a b c d e x = do
xs <- loadSortEnrich patterns (Down . viewPostTime) e
return $ withJSON (genBlogNavbarData a b c d (snd <$> xs)) $ x
affixRecentPosts :: MonadShakebookAction r m
=> [FilePattern]
-> Int
-> (Value -> Value)
-> Value -> m Value
affixRecentPosts patterns n e x = do
xs <- loadSortEnrich patterns (Down . viewPostTime) e
return $ withRecentPosts (take n (snd <$> xs)) $ x
defaultDocsPatterns :: (MonadShakebookRules r m)
=> Cofree [] FilePath
-> FilePath
-> (Value -> Value)
-> m ()
defaultDocsPatterns toc tmpl withData = view sbConfigL >>= \SbConfig{..} -> do
tmpl' <- parseRelFile tmpl
o <- view localOutL
toc' <- mapM (parseRelFile >=> pure . (`within` o) >=> mapWithinT withHtmlExtension) toc
let e = blinkAndMapT sbSrcDir withMarkdownExtension >=> readMarkdownFile' >=> enrichSupposedUrl
void . sequence . flip extend toc' $ \xs -> (toFilePath . whatLiesWithin $ extract xs) %-> \out -> do
ys <- mapM e toc'
zs <- mapM e xs
v <- e out
let v' = withData . withJSON (genTocNavbarData ys) . withSubsections (lower (zs)) $ v
buildPageActionWithin (tmpl' `within` sbSrcDir) v' out
defaultPostIndexData :: MonadShakebookAction r m
=> [FilePattern]
-> (a -> Value -> Bool)
-> (a -> Text)
-> (a -> Text -> Text)
-> a
-> m (Zipper [] Value)
defaultPostIndexData pat f t l a = view sbConfigL >>= \SbConfig {..} -> do
xs <- loadSortFilterEnrich pat (Down . viewPostTime) (f a) defaultEnrichPost
ys <- genIndexPageData (snd <$> xs) (t a) (l a) sbPPP
return ys
defaultPagerPattern :: (MonadShakebookRules r m)
=> FilePattern
-> FilePath
-> (FilePattern -> Int)
-> (FilePattern -> a)
-> (a -> RAction r (Zipper [] Value))
-> (Zipper [] Value -> RAction r (Zipper [] Value))
-> m ()
defaultPagerPattern fp tmpl f g h w = view sbConfigL >>= \SbConfig{..} -> do
tmpl' <- parseRelFile tmpl
fp %-> \x -> do
let x' = toFilePath $ whatLiesWithin x
xs <- (w <=< h) $ g (x')
let b = extract (seek (f x') xs)
buildPageActionWithin (tmpl' `within` sbSrcDir) b x
defaultPostIndexPatterns :: MonadShakebookRules r m
=> [FilePattern]
-> FilePath
-> (Zipper [] Value -> RAction r (Zipper [] Value))
-> m ()
defaultPostIndexPatterns pat tmpl extData = do
defaultPagerPattern "posts/index.html" tmpl
(const 0)
(const ())
(defaultPostIndexData pat (const $ (const True))
(const "Posts")
(const ("/posts/pages/" <>)))
extData
defaultPagerPattern ("posts/pages/*/index.html") tmpl
((+ (-1)) . read . (!! 2) . splitOn "/")
(const ())
(defaultPostIndexData pat (const $ (const True))
(const "Posts")
(const ("/posts/pages/" <>)))
extData
defaultTagIndexPatterns :: MonadShakebookRules r m
=> [FilePattern]
-> FilePath
-> (Zipper [] Value -> RAction r (Zipper [] Value))
-> m ()
defaultTagIndexPatterns pat tmpl extData = do
defaultPagerPattern ("posts/tags/*/index.html") tmpl
(const 0)
(T.pack . (!! 2) . splitOn "/")
(defaultPostIndexData pat (\x y -> elem x (viewTags y) )
("Posts tagged " <>)
(\x y -> ("/posts/tags/" <> x <> "/pages/" <> y)))
extData
defaultPagerPattern ("posts/tags/*/pages/*/index.html") tmpl
((+ (-1)) . read . (!! 4) . splitOn "/")
(T.pack . (!! 2) . splitOn "/")
(defaultPostIndexData pat (\x y -> elem x (viewTags y))
("Posts tagged " <>)
(\x y -> ("/posts/tags/" <> x <> "/pages/" <> y)))
extData
defaultMonthIndexPatterns :: MonadShakebookRules r m
=> [FilePattern]
-> FilePath
-> (Zipper [] Value -> RAction r (Zipper [] Value))
-> m ()
defaultMonthIndexPatterns pat tmpl extData = do
defaultPagerPattern "posts/months/*/index.html" tmpl
(const 0)
(parseISODateTime . T.pack . (!! 2) . splitOn "/")
(defaultPostIndexData pat
(\x y -> sameMonth x (viewPostTime y))
(("Posts from " <>) . T.pack . defaultPrettyMonthFormat)
(\x y -> ("/posts/months/" <> T.pack (defaultMonthUrlFormat x) <> "/pages" <> y)))
extData
defaultPagerPattern "posts/months/*/pages/*/index.html" tmpl
((+ (-1)) . read . (!! 4) . splitOn "/")
(parseISODateTime . T.pack . (!! 2) . splitOn "/")
(defaultPostIndexData pat
(\x y -> sameMonth x (viewPostTime y))
(("Posts from " <>) . T.pack . defaultPrettyMonthFormat)
(\x y -> ("/posts/months/" <> T.pack (defaultMonthUrlFormat x) <> "/pages" <> y)))
extData
defaultPostsPatterns :: MonadShakebookRules r m
=> FilePattern
-> FilePath
-> (Value -> RAction r Value)
-> (Zipper [] Value -> RAction r (Zipper [] Value))
-> m ()
defaultPostsPatterns pat tmpl e extData = view sbConfigL >>= \SbConfig {..} ->
pat %-> \out -> do
logInfo $ display $ "Caught pattern: " <> display (WithinDisplay out)
tmpl' <- parseRelFile tmpl
logInfo $ display $ "Using template " <> display (PathDisplay tmpl')
let pat' = pat S.-<.> ".md"
xs <- loadSortEnrich [pat'] (Down . viewPostTime) defaultEnrichPost
xs' <- mapM (\(s,x) -> e x >>= \e' -> return (s, e')) xs
i <- blinkAndMapT sbSrcDir withMarkdownExtension out
logInfo $ display $ WithinDisplay i
logInfo $ display $ WithinDisplay . fst <$> xs'
let k = fromJust $ elemIndex i (fst <$> xs')
let z = fromJust $ seek k <$> zipper (snd <$> xs')
z' <- extData z
buildPageActionWithin (tmpl' `within` sbSrcDir) (extract z') out
makePDFLaTeX :: Pandoc -> PandocIO (Either LBS.ByteString LBS.ByteString)
makePDFLaTeX p = do
t <- compileDefaultTemplate "latex"
makePDF "pdflatex" [] writeLaTeX defaultLatexWriterOptions { writerTemplate = Just t } p
handleImages :: Text -> (Text -> Text) -> Inline -> Inline
handleImages prefix f (Image attr ins (src,txt)) =
if T.takeEnd 4 src == ".mp4" then Str (f src)
else Image attr ins (prefix <> "/" <> src, txt)
handleImages _ _ x = x
handleHeaders :: Int -> Block -> Block
handleHeaders i (Header a as xs) = Header (max 1 (a + i)) as xs
handleHeaders _ x = x
pushHeaders :: Int -> Cofree [] Pandoc -> Cofree [] Pandoc
pushHeaders i (x :< xs) = walk (handleHeaders i) x :< map (pushHeaders (i+1)) xs
buildPDF :: (MonadShakebookAction r m, MonadFail m) => Cofree [] String -> Path Rel File -> FilePath -> m ()
buildPDF toc meta out = view sbConfigL >>= \SbConfig {..} -> do
y <- mapM (readFileIn' sbSrcDir <=< parseRelFile) toc
m <- readFileIn' sbSrcDir meta
Right f <- liftIO . runIOorExplode $ do
k <- mapM (readMarkdown sbMdRead ) y
a <- readMarkdown sbMdRead $ m
let z = walk (handleImages (T.pack $ toFilePath sbOutDir) (\x -> "[Video available at " <> sbBaseUrl <> x <> "]")) $ foldr (<>) a $ pushHeaders (-1) k
makePDFLaTeX z
LBS.writeFile out f
defaultSinglePagePattern :: (MonadRules m, MonadReader r m, HasSbConfig r, HasLocalOut r)
=> FilePath
-> FilePath
-> (Value -> RAction r Value)
-> m ()
defaultSinglePagePattern out tmpl withDataM = view sbConfigL >>= \SbConfig {..} -> do
out %-> \x -> do
tmpl' <- parseRelFile tmpl
x' <- blinkAndMapT sbSrcDir withMarkdownExtension $ x
v <- withDataM =<< readMarkdownFile' x'
buildPageActionWithin (tmpl' `within` sbSrcDir) v x
defaultStaticsPatterns :: MonadShakebookRules r m => [FilePattern] -> m ()
defaultStaticsPatterns xs = view sbConfigL >>= \SbConfig {..} -> do
foldr (>>) (return ()) $ flip map xs $ flip (%->) $ \y -> do
let y' = blinkWithin sbSrcDir y
copyFileChanged (fromWithin y') (fromWithin y)
defaultCleanPhony :: MonadShakebookRules r m => m ()
defaultCleanPhony = view sbConfigL >>= \SbConfig {..} ->
phony "clean" $ do
logInfo $ "Cleaning files in " <> display (PathDisplay sbOutDir)
removeFilesAfter sbOutDir ["//*"]
defaultSinglePagePhony :: MonadShakebookRules r m => String -> FilePath -> m ()
defaultSinglePagePhony x y = phony x $ parseRelFile y >>= needLocalOut . pure
defaultStaticsPhony :: MonadShakebookRules r m => [FilePattern] -> m ()
defaultStaticsPhony pattern = view sbConfigL >>= \SbConfig{..} ->
phony "statics" $
getDirectoryFiles sbSrcDir pattern >>= needIn sbOutDir
defaultPostsPhony :: MonadShakebookRules r m => [FilePattern] -> m ()
defaultPostsPhony pattern = view sbConfigL >>= \SbConfig{..} ->
phony "posts" $
getDirectoryFilesWithin sbSrcDir pattern >>= mapM (blinkAndMapT sbOutDir withHtmlExtension) >>= needWithin
defaultPostIndexPhony :: MonadShakebookRules r m => [FilePattern] -> m ()
defaultPostIndexPhony pattern = view sbConfigL >>= \SbConfig{..} ->
phony "posts-index" $ do
fp <- getDirectoryFilesWithin sbSrcDir pattern >>= mapM readMarkdownFile'
needIn sbOutDir [dirPosts </> fileIndexHTML]
paginate' sbPPP fp >>= defaultPagePaths dirPosts >>= needIn sbOutDir
defaultTagIndexPhony :: MonadShakebookRules r m => [FilePattern] -> m ()
defaultTagIndexPhony pattern = view sbConfigL >>= \SbConfig{..} ->
phony "tag-index" $ do
fp <- getDirectoryFilesWithin sbSrcDir pattern >>= mapM readMarkdownFile'
forM_ (viewAllPostTags fp) $ \t -> do
u <- parseRelDir $ T.unpack t
needIn sbOutDir [dirPosts </> dirTags </> u </> fileIndexHTML]
paginate' sbPPP (tagFilterPosts t fp)
>>= defaultPagePaths (dirPosts </> dirTags </> u)
>>= needIn sbOutDir
defaultPagePaths :: MonadThrow m => Path Rel Dir -> Zipper [] [a] -> m [Path Rel File]
defaultPagePaths a xs = forM [1..size xs] $ parseRelDir . show >=> \p -> return $ a </> dirPages </> p </> fileIndexHTML
fileIndexHTML :: Path Rel File
fileIndexHTML = $(mkRelFile "index.html")
dirPosts :: Path Rel Dir
dirPosts = $(mkRelDir "posts")
dirMonths :: Path Rel Dir
dirMonths = $(mkRelDir "months")
dirPages :: Path Rel Dir
dirPages = $(mkRelDir "pages")
dirTags :: Path Rel Dir
dirTags = $(mkRelDir "tags")
defaultMonthIndexPhony :: (MonadRules m, MonadReader r m, HasSbConfig r, HasLocalOut r) => [FilePattern] -> m ()
defaultMonthIndexPhony pattern = phony "month-index" $ do
SbConfig{..} <- view sbConfigL
fp <- getDirectoryFilesWithin sbSrcDir pattern >>= mapM readMarkdownFile'
forM_ (viewAllPostTimes fp) $ \t -> do
u <- parseRelDir $ defaultMonthUrlFormat t
needLocalOut [dirPosts </> dirMonths </> u </> fileIndexHTML]
paginate' sbPPP (monthFilterPosts t fp)
>>= defaultPagePaths (dirPosts </> dirMonths </> u)
>>= needLocalOut
defaultDocsPhony :: MonadShakebookRules r m
=> Cofree [] String
-> m ()
defaultDocsPhony toc = view sbConfigL >>= \SbConfig{..} ->
phony "docs" $ do
let xs = foldr ((<>) . pure) [] $ toc
pure xs >>= mapM (parseRelFile >=> withHtmlExtension) >>= needIn sbOutDir