shakebook-0.3.0.0: test/Spec.hs

{-# LANGUAGE TemplateHaskell #-}

import           Control.Comonad.Cofree
import           Control.Comonad.Store
import           Control.Comonad.Store.Zipper
import           Control.Comonad.Zipper.Extra
import           Data.Aeson
import           Data.Aeson.With
import           Data.List.Split
import           Data.Text.Time
import           Development.Shake.Plus
import           Path
import           RIO
import           RIO.Partial
import qualified RIO.HashMap                  as HM
import           RIO.List
import           RIO.List.Partial
import qualified RIO.Text                     as T
import           Shakebook.Data
import           Shakebook.Defaults
import           Shakebook.Mustache
import           Shakebook.Conventions
import           Test.Tasty
import           Test.Tasty.Golden
import           Text.Pandoc.Highlighting
import           Within

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")]
sbc :: SbConfig
sbc = SbConfig {
  sbSrcDir      = sourceFolder
, sbOutDir      = outputFolder
, sbBaseUrl     = baseUrl
, sbMdRead      = defaultMarkdownReaderOptions
, sbHTWrite     = defaultHtml5WriterOptions
, sbPPP         = postsPerPage
, sbGlobalApply = withSiteTitle siteTitle . withHighlighting pygments . withSocialLinks mySocial
}

pagePaths :: MonadThrow m => (Path Rel Dir -> Path Rel File) -> Zipper [] [a] -> m [Path Rel File]
pagePaths f xs = forM [1..size xs] $ parseRelDir . show >=> return . f

rules :: ShakePlus ShakebookEnv ()
rules = view sbConfigL >>= \SbConfig {..} -> do

  readMDC <- newCache loadMarkdownAsJSON 

  postsC  <- newCache $ \w -> do
    xs <- batchLoadWithin' w readMDC
    return $ defaultEnrichPost <$> xs

  sortedPosts <- newCache $ \fp -> do
    allPosts <- postsC fp
    return $  sortOn (Down . viewPostTime . snd) $ HM.toList allPosts

  getRecentPosts <- newCache $ \fp -> do
    xs <- sortedPosts fp
    return $ take numRecentPosts (snd <$> xs)

  getBlogNavbar <- newCache $ \fp -> do
    allPosts <- postsC fp
    return $ genBlogNavbarData "Blog" "/posts/"
                  (T.pack . defaultPrettyMonthFormat)
                  (defaultMonthUrlFragment) (HM.elems allPosts)

  let myPosts = ["posts/*.md"] `within` sbSrcDir

  ("index.html" `within` sbOutDir) %^> \out -> do
    src <- blinkAndMapM sbSrcDir withMarkdownExtension $ out
    v   <- readMDC src
    r   <- getRecentPosts myPosts
    let v' = withRecentPosts r v
    buildPageActionWithin ($(mkRelFile "templates/index.html") `within` sbSrcDir) v' out

  ("posts/*.html" `within` sbOutDir) %^> \out -> do
    src <- blinkAndMapM sbSrcDir withMarkdownExtension $ out
    xs <- sortedPosts myPosts
    let k = elemIndex src (fst <$> xs)
    let z = fromJust $ liftA2 seek k $ zipper (snd <$> xs)
    r   <- getRecentPosts myPosts
    n   <- getBlogNavbar myPosts
    let v' = withRecentPosts r . withJSON n $ (extract z) 
    buildPageActionWithin ($(mkRelFile "templates/post.html") `within` sbSrcDir) v' out

  toc' <- mapM (mapM withHtmlExtension) $ fmap (`within` sbOutDir) tableOfContents
  void . sequence . flip extend toc' $ \xs -> (fmap toFilePath $ extract xs) %^> \out -> do
    let getDoc = readMDC <=< blinkAndMapM sbSrcDir withMarkdownExtension 
    ys <- mapM getDoc toc'
    zs <- mapM getDoc $ (immediateShoots xs)
    v  <- getDoc $ out
    let v' = withJSON (genTocNavbarData ys) . withSubsections zs $ v
    buildPageActionWithin ($(mkRelFile "templates/docs.html") `within` sbSrcDir) v' out

  ("posts/index.html" `within` sbOutDir) %^>
    copyFileChangedWithin ($(mkRelFile "posts/pages/1/index.html") `within` sbOutDir)

  ("posts/pages/*/index.html" `within` sbOutDir) %^> \out -> do
    xs <- sortedPosts myPosts
    let n = (+ (-1)) . read . (!! 2) . splitOn "/" . toFilePath . extract $ out
    p <- seek n <$> genIndexPageData (snd <$> xs) "Posts" ("/posts/pages" <>) sbPPP
    k <- getBlogNavbar myPosts
    let v = withJSON k $ extract p
    buildPageActionWithin ($(mkRelFile "templates/post-list.html") `within` sbSrcDir) v out
 
  ("posts/tags/*/index.html" `within` sbOutDir) %^> \out -> do
    let t = (!! 2) . splitOn "/" . toFilePath . extract $ out
    i <- parseRelFile $ "posts/tags/" <> t <> "/pages/1/index.html"
    copyFileChangedWithin (i `within` sbOutDir) out

  ("posts/tags/*/pages/*/index.html" `within` sbOutDir) %^> \out -> do
    let t = T.pack          . (!! 2) . splitOn "/" . toFilePath . extract $ out
    xs <- filter (elem t . viewTags . snd) <$> sortedPosts myPosts
    let n = (+ (-1)) . read . (!! 4) . splitOn "/" . toFilePath . extract $ out
    p  <- seek n <$> genIndexPageData (snd <$> xs) ("Posts tagged " <> t) (("/posts/tags/"  <> t <> "/posts") <>) sbPPP
    k <- getBlogNavbar myPosts
    let v = withJSON k $ extract p
    buildPageActionWithin ($(mkRelFile "templates/post-list.html") `within` sbSrcDir) v out

  ("posts/months/*/index.html" `within` sbOutDir) %^> \out -> do
    let t = (!! 2) . splitOn "/" . toFilePath . extract $ out
    i <- parseRelFile $ "posts/months/" <> t <> "/pages/1/index.html"
    copyFileChangedWithin (i `within` sbOutDir) out

  ("posts/months/*/pages/*/index.html" `within` sbOutDir) %^> \out -> do
    let t = parseISODateTime . T.pack . (!! 2) . splitOn "/" . toFilePath . extract $ out
    xs <- filter (sameMonth t . viewPostTime . snd) <$> sortedPosts myPosts
    let n = (+ (-1)) . read  . (!! 4) . splitOn "/" . toFilePath . extract $ out
    p  <- seek n <$> genIndexPageData (snd <$> xs)
                       (("Posts from " <>) . T.pack . defaultPrettyMonthFormat $ t)
                       (("/posts/months/"  <> T.pack (defaultMonthUrlFormat t) <> "/posts") <>) sbPPP
    k <- getBlogNavbar myPosts
    let v = withJSON k $ extract p
    buildPageActionWithin ($(mkRelFile "templates/post-list.html") `within` sbSrcDir) v out

  phony "index" $
    needIn sbOutDir [$(mkRelFile "index.html")]

  phony "post-index" $ do
    xs <- sortedPosts myPosts
    needIn sbOutDir [$(mkRelFile "posts/index.html")]
    paginate' sbPPP xs
      >>= pagePaths (\p -> $(mkRelDir "posts/pages") </> p </> $(mkRelFile "index.html"))
        >>= needIn sbOutDir

  phony "by-tag-index" $ do
    xs <- sortedPosts myPosts
    forM_ (viewAllPostTags (snd <$> xs)) $ \t -> do
      u <- parseRelDir $ T.unpack t
      needIn sbOutDir [$(mkRelDir "posts/tags") </> u </> $(mkRelFile "index.html")]
      paginate' sbPPP xs
        >>= pagePaths (\p -> $(mkRelDir "posts/tags") </> u </> $(mkRelDir "pages") </> p </> $(mkRelFile "index.html"))
          >>= needIn sbOutDir

  phony "by-month-index" $ do
    xs <- sortedPosts myPosts
    forM_ (viewAllPostTimes (snd <$> xs)) $ \t -> do
      u <- parseRelDir $ defaultMonthUrlFormat t
      needIn sbOutDir [$(mkRelDir "posts/months") </> u </> $(mkRelFile "index.html")]
      paginate' sbPPP xs
        >>= pagePaths (\p -> $(mkRelDir "posts/months") </> u </> $(mkRelDir "pages") </> p </> $(mkRelFile "index.html"))
          >>= needIn sbOutDir

  phony "docs" $
    mapM withHtmlExtension tableOfContents >>= needIn sbOutDir
    
  phony "posts" $
    getDirectoryFilesWithin' (["posts/*.md"] `within` sbSrcDir) >>= 
      mapM (blinkAndMapM sbOutDir withHtmlExtension) >>=
        needWithin'

  phony "clean" $ do
    logInfo $ "Cleaning files in " <> display (PathDisplay sbOutDir)
    removeFilesAfter sbOutDir ["//*"]

tests :: [FilePath] -> TestTree
tests xs = testGroup "Rendering Tests" $
  map ( \x -> goldenVsFile x x
     (replace "golden" "public" x)
     (return ())) xs
  where replace from to' = intercalate to' . splitOn from

main :: IO ()
main = do
   xs <- findByExtension [".html"] "test/golden"
   logOptions' <- logOptionsHandle stdout True
   lf <- newLogFunc (setLogMinLevel LevelInfo logOptions')
   let f = ShakebookEnv (fst lf) sbc
   shake shakeOptions $ want ["clean"] >> runShakePlus f rules
   shake shakeOptions $ want ["index", "docs", "posts", "post-index", "by-tag-index", "by-month-index"] >> runShakePlus f rules--, "docs", "month-index", "posts-index", "tag-index", "posts"]  >> runShakePlus f rules
   defaultMain $ tests xs
   snd lf