shakebook-0.7.3.0: test/Spec.hs
{-# LANGUAGE TemplateHaskell #-}
import Data.Aeson.With
import qualified Data.IxSet.Typed as Ix
import Data.List.Split
import Path.Extensions
import RIO
import qualified RIO.HashMap as HM
import RIO.List
import RIO.List.Partial
import RIO.Partial
import qualified RIO.Text as T
import RIO.Time
import Shakebook
import Test.Tasty
import Test.Tasty.Golden
sourceFolder :: Path Rel Dir
sourceFolder = $(mkRelDir "test/site")
outputFolder :: Path Rel Dir
outputFolder = $(mkRelDir "test/public")
baseUrl :: Text
baseUrl = "http://blanky.test"
siteTitle :: Text
siteTitle = "Blanky Site"
tableOfContents :: Cofree [] (Path Rel File)
tableOfContents = $(mkRelFile "docs/index.md") :< [
$(mkRelFile "docs/1/index.md") :< []
, $(mkRelFile "docs/2/index.md") :< [
$(mkRelFile "docs/2/champ.md") :< []
]
]
numRecentPosts :: Int
numRecentPosts = 3
numPageNeighbours :: Int
numPageNeighbours = 1
postsPerPage :: Int
postsPerPage = 5
mySocial :: [Value]
mySocial = uncurry genLinkData <$> [("twitter", "http://twitter.com/blanky-site-nowhere")
,("youtube", "http://youtube.com/blanky-site-nowhere")
,("gitlab", "http://gitlab.com/blanky-site-nowhere")]
rules :: HasLogFunc r => ShakePlus r ()
rules = do
readMDC <- newCache $ loadMarkdownAsJSON defaultMarkdownReaderOptions defaultHtml5WriterOptions
postsIx <- newCache $ postIndex $ fmap defaultEnrichPost . readMDC
blogNav <- newCache $ \fp -> do
xs <- postsIx fp
return $ genBlogNavbarData "Blog" "/posts/" defaultPrettyMonthFormat defaultMonthUrlFragment xs
postsZ <- newCache $ postsIx >=> postZipper
blogIndexPageData <- newCache $ \fp -> do
xs <- postsIx fp
genIndexPageData (Ix.toList xs) "Posts" ("/posts/pages/" <>) postsPerPage
blogTagIndexPageData <- newCache $ \fp -> do
xs <- postsIx fp
k <- forM (Ix.groupDescBy xs) $ \(Tag t, ys) -> do
z <- genIndexPageData ys ("Posts tagged " <> t) (("/posts/tags/" <> t <> "/pages/") <>) postsPerPage
return (t, z)
return $ HM.fromList k
blogMonthIndexPageData <- newCache $ \fp -> do
xs <- postsIx fp
k <- forM (Ix.groupDescBy xs) $ \(YearMonth (y,m), ys) -> do
let t' = UTCTime (fromGregorian y m 1) 0
z <- genIndexPageData ys
(("Posts from " <>) . defaultPrettyMonthFormat $ t')
(("/posts/months/" <> defaultMonthUrlFormat t' <> "/pages/") <>)
postsPerPage
return (defaultMonthUrlFormat t', z)
return $ HM.fromList k
let myPosts = ["posts/*.md"] `within` sourceFolder
o' = (`within` outputFolder)
s' = (`within` sourceFolder)
myBuildPage tmpl v out = do
rs <- postsZ myPosts
let v' = withHighlighting pygments
. withSocialLinks mySocial
. withSiteTitle siteTitle
. withRecentPosts (take numRecentPosts (unzipper rs)) $ v
buildPageActionWithin (s' tmpl) v' out
myBuildBlogPage tmpl v out = do
k <- blogNav myPosts
myBuildPage tmpl (withJSON k v) out
myBuildPostListPage z out = do
let v = extract . extendPageNeighbours numPageNeighbours $ z
myBuildBlogPage $(mkRelFile "templates/post-list.html") v out
o' "index.html" %^> \out -> do
src <- blinkAndMapM sourceFolder withMdExtension out
v <- readMDC src
myBuildPage $(mkRelFile "templates/index.html") v out
o' "posts/*.html" %^> \out -> do
src <- blinkAndMapM sourceFolder withMdExtension out
xs <- postsZ myPosts
xs' <- seekOnThrow viewSrcPath (T.pack . toFilePath . extract $ src) xs
myBuildBlogPage $(mkRelFile "templates/post.html") (toJSON $ extract xs') out
toc' <- mapM (mapM withHtmlExtension) $ fmap o' tableOfContents
void . sequence . flip extend toc' $ \xs -> (toFilePath <$> extract xs) %^> \out -> do
let getDoc = readMDC <=< blinkAndMapM sourceFolder withMdExtension
ys <- mapM getDoc toc'
zs <- mapM getDoc (fmap extract . unwrap $ xs)
v <- getDoc out
let v' = withJSON (genTocNavbarData ys) . withSubsections zs $ v
myBuildPage $(mkRelFile "templates/docs.html") v' out
o' "posts/index.html" %^>
copyFileChangedWithin (o' $(mkRelFile "posts/pages/1/index.html"))
o' "posts/pages/*/index.html" %^> \out -> do
let n = (+ (-1)) . read . (!! 2) . splitOn "/" . toFilePath . extract $ out
xs <- blogIndexPageData myPosts
myBuildPostListPage (seek n xs) out
o' "posts/tags/*/index.html" %^> \out -> do
let t = (!! 2) . splitOn "/" . toFilePath . extract $ out
i <- parseRelFile $ "posts/tags/" <> t <> "/pages/1/index.html"
copyFileChangedWithin (o' i) out
o' "posts/tags/*/pages/*/index.html" %^> \out -> do
let t = T.pack . (!! 2) . splitOn "/" . toFilePath . extract $ out
let n = (+ (-1)) . read . (!! 4) . splitOn "/" . toFilePath . extract $ out
xs <- blogTagIndexPageData myPosts
case HM.lookup t xs of
Nothing -> logError $ "Attempting to lookup non-existant tag " <> display t
Just x -> myBuildPostListPage (seek n x) out
o' "posts/months/*/index.html" %^> \out -> do
let t = (!! 2) . splitOn "/" . toFilePath . extract $ out
i <- parseRelFile $ "posts/months/" <> t <> "/pages/1/index.html"
copyFileChangedWithin (o' i) out
o' "posts/months/*/pages/*/index.html" %^> \out -> do
let t = T.pack . (!! 2) . splitOn "/" . toFilePath . extract $ out
let n = (+ (-1)) . read . (!! 4) . splitOn "/" . toFilePath . extract $ out
xs <- blogMonthIndexPageData myPosts
case HM.lookup t xs of
Nothing -> logError $ "Attempting to lookup non-existant month " <> displayShow t
Just x -> myBuildPostListPage (seek n x) out
o' ["css//*", "js//*", "webfonts//*", "images//*"] |%^> \out ->
copyFileChangedWithin (blinkLocalDir sourceFolder out) out
o' "sitemap.xml" %^> \out -> do
xs <- postsZ myPosts
buildSitemap baseUrl (unzipper $ unPost <$> xs) (fromWithin out)
let simplePipeline f = getDirectoryFiles sourceFolder >=> mapM f >=> needIn outputFolder
verbatimPipeline = simplePipeline return
phony "statics" $ verbatimPipeline ["css//*", "js//*", "webfonts//*", "images//*"]
phony "index" $ needIn outputFolder [$(mkRelFile "index.html")]
phony "post-index" $ do
ps <- blogIndexPageData myPosts
fs <- defaultPagePaths [1..size ps]
needIn (outputFolder </> $(mkRelDir "posts")) ($(mkRelFile "index.html") : fs)
phony "by-tag-index" $ do
ps <- blogTagIndexPageData myPosts
void $ flip HM.traverseWithKey ps $ \t z -> do
u <- parseRelDir $ T.unpack t
fs <- defaultPagePaths [1..size z]
let tagFolder = outputFolder </> $(mkRelDir "posts/tags") </> u
needIn tagFolder ($(mkRelFile "index.html") : fs)
phony "by-month-index" $ do
ps <- blogMonthIndexPageData myPosts
void $ flip HM.traverseWithKey ps $ \t z -> do
u <- parseRelDir $ T.unpack t
fs <- defaultPagePaths [1..size z]
let monthFolder = outputFolder </> $(mkRelDir "posts/months") </> u
needIn monthFolder ($(mkRelFile "index.html") : fs)
phony "docs" $
mapM withHtmlExtension tableOfContents >>= needIn outputFolder
phony "posts" $ simplePipeline withHtmlExtension ["posts/*.md"]
phony "clean" $ do
logInfo $ "Cleaning files in " <> displayShow outputFolder
removeFilesAfter outputFolder ["//*"]
phony "sitemap" $ needIn outputFolder [$(mkRelFile "sitemap.xml")]
tests :: [FilePath] -> TestTree
tests xs = testGroup "Rendering Tests" $
map ( \x -> goldenVsFile x x
(replace "golden" "public" x)
(return ())) xs
where replace fr to' = intercalate to' . splitOn fr
main :: IO ()
main = do
xs <- findByExtension [".html", ".xml"] "test/golden"
logOptions' <- logOptionsHandle stdout True
(lf, dlf) <- newLogFunc (setLogMinLevel LevelInfo logOptions')
shake shakeOptions $ want ["clean"] >> runShakePlus lf rules
shake shakeOptions $ want ["index", "docs", "posts", "post-index", "by-tag-index", "by-month-index", "sitemap"] >> runShakePlus lf rules
defaultMain $ tests xs
dlf