hablo/test/XML/Card/Output.hs

module XML.Card.Output (
    test
  ) where

import Blog (Blog(..), URLs(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (asks, runReaderT)
import qualified Data.Text.Lazy.IO as Lazy (readFile)
import Distribution.TestSuite
import DOM.Card (HasCard(..), make)
import Lucid (renderTextT)
import Mock.Blog as Blog (noCards, simple, subPath)
import Mock.Article as Article (
    hostRelativeImage, noDescription, noImage, remoteImage, simple
  )
import Mock.ArticlesList as ArticlesList (
    longMain, longTesting, shortMain, shortTesting
  )
import Pretty ((.$))
import System.FilePath ((</>))
import Utils (assertAll, assertEqual, simpleTest, tag, testDataPath)

check :: HasCard a => IO Blog -> a -> FilePath -> IO Progress
check getBlog input expectedFile =
  getBlog >>= runReaderT (do
      actual <- renderTextT $ maybe (return ()) (DOM.Card.make input) =<< (asks $urls.$cards)
      expected <- liftIO . Lazy.readFile $ testDataPath "XML/Card/Output" </> expectedFile
      liftIO $ assertAll [
          assertEqual "card HTML output" expected actual
        ]
    )

articleCard :: Test 
articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
      ("simple article output", check Blog.simple Article.simple "simple.html")
    , ("simple article output with subPath", check Blog.subPath Article.simple "subPath.html")
    , ("article output without description"
      , check Blog.simple Article.noDescription "noDescription.html")
    , ("article output without image"
      , check Blog.simple Article.noImage "noImage.html")
    , ("article output with an image on a remote server"
      , check Blog.simple Article.remoteImage "remoteImage.html")
    , ("article output with an image in a host-relative folder"
      , check Blog.simple Article.hostRelativeImage "hostRelativeImage.html")
    , ("no card article output", check Blog.noCards Article.simple "/dev/null")
  ]

articlesListCard :: Test 
articlesListCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
      ("short untagged page output", ArticlesList.shortMain >>= flip (check Blog.simple) "shortMain.html")
    , ("long untagged page output", ArticlesList.longMain >>= flip (check Blog.simple) "longMain.html")
    , ("short tagged page output", ArticlesList.shortTesting >>= flip (check Blog.simple) "shortTesting.html")
    , ("long tagged page output", ArticlesList.longTesting >>= flip (check Blog.simple) "longTesting.html")
    , ("no card articlesList output", ArticlesList.shortMain >>= flip (check Blog.noCards) "/dev/null")
  ]

test :: Test
test = tag "output" $ testGroup "Cards outputs" [articleCard, articlesListCard]