diff --git a/hablo.cabal b/hablo.cabal index a712ee0..88e3628 100644 --- a/hablo.cabal +++ b/hablo.cabal @@ -83,10 +83,20 @@ test-suite tests type: detailed-0.9 test-module: Tests other-modules: Mock.Article + , Mock.ArticlesList , Mock.Blog + , Mock.Blog.Path + , Mock.Blog.Skin + , Mock.Blog.Template + , Mock.Blog.URL + , Mock.Blog.Wording + , Mock.Collection + , Mock.Markdown + , Utils , XML.Card build-depends: base , containers + , filepath , Cabal , hablo-internals , mtl diff --git a/test/Mock/Article.hs b/test/Mock/Article.hs index 6a4d1fb..12f1cb1 100644 --- a/test/Mock/Article.hs +++ b/test/Mock/Article.hs @@ -8,46 +8,16 @@ module Mock.Article ( import Article (Article(..)) import qualified Data.Map as Map (fromList) import Markdown (Markdown(..)) +import Mock.Markdown (article) simple :: Article -simple = Article (Markdown { - key = "test" - , path = "article/test" - , Markdown.title = "Some test" - , metadata = Map.fromList [ - ("summary", "It's a test") - , ("featuredImage", "test.png") - ] - , bodyOffset = 3 - , body = [] - }) +simple = Article article noImage :: Article -noImage = Article (Markdown { - key = "test" - , path = "article/test" - , Markdown.title = "Some test" - , metadata = Map.fromList [("summary", "It's a test")] - , bodyOffset = 3 - , body = [] - }) +noImage = Article $ article {metadata = Map.fromList [("summary", "It's a test")]} noDescription :: Article -noDescription = Article (Markdown { - key = "test" - , path = "article/test" - , Markdown.title = "Some test" - , metadata = Map.fromList [("featuredImage", "test.png")] - , bodyOffset = 3 - , body = [] - }) +noDescription = Article $ article {metadata = Map.fromList [("featuredImage", "test.png")]} noMeta :: Article -noMeta = Article (Markdown { - key = "test" - , path = "article/test" - , Markdown.title = "Some test" - , metadata = Map.fromList [] - , bodyOffset = 3 - , body = [] - }) +noMeta = Article $ article {metadata = Map.fromList []} diff --git a/test/Mock/ArticlesList.hs b/test/Mock/ArticlesList.hs new file mode 100644 index 0000000..a1a5d5c --- /dev/null +++ b/test/Mock/ArticlesList.hs @@ -0,0 +1,22 @@ +module Mock.ArticlesList ( + longMain + , longTesting + , shortMain + , shortTesting + ) where + +import ArticlesList (ArticlesList(..)) +import Mock.Collection (main, testing) +import Prelude hiding (all) + +shortMain :: IO ArticlesList +shortMain = ArticlesList False <$> main + +shortTesting :: IO ArticlesList +shortTesting = ArticlesList False <$> testing + +longMain :: IO ArticlesList +longMain = ArticlesList True <$> main + +longTesting :: IO ArticlesList +longTesting = ArticlesList True <$> testing diff --git a/test/Mock/Blog.hs b/test/Mock/Blog.hs index 4d471d2..92bd3d0 100644 --- a/test/Mock/Blog.hs +++ b/test/Mock/Blog.hs @@ -1,8 +1,35 @@ +{-# LANGUAGE NamedFieldPuns #-} module Mock.Blog ( - simple + simple + , noRSS ) where -import Blog (Blog) +import Blog (Blog(..)) +import qualified Data.Map as Map (fromList) +import qualified Data.Set as Set (fromList) +import qualified Mock.Article (simple) +import qualified Mock.Blog.Path (simple) +import qualified Mock.Blog.Skin (simple) +import qualified Mock.Blog.Template (simple) +import qualified Mock.Blog.URL (simple) +import qualified Mock.Blog.Wording (defaultWording) -simple :: Blog -simple = undefined +simple :: IO Blog +simple = + let wording = Mock.Blog.Wording.defaultWording in do + templates <- Mock.Blog.Template.simple + return $ Blog { + articles = Map.fromList [("test", Mock.Article.simple)] + , hasRSS = True + , name = "The Test Blog" + , pages = Map.fromList [] + , path = Mock.Blog.Path.simple + , skin = Mock.Blog.Skin.simple + , tags = Map.fromList [("testing", Set.fromList ["test"])] + , templates + , urls = Mock.Blog.URL.simple + , wording + } + +noRSS :: IO Blog +noRSS = (\b -> b {hasRSS = False}) <$> simple diff --git a/test/Mock/Blog/Path.hs b/test/Mock/Blog/Path.hs new file mode 100644 index 0000000..ce025e9 --- /dev/null +++ b/test/Mock/Blog/Path.hs @@ -0,0 +1,13 @@ +module Mock.Blog.Path ( + simple + ) where + +import Blog.Path (Path(..)) + +simple :: Path +simple = Path { + articlesPath = "articles" + , pagesPath = Nothing + , remarkableConfig = Nothing + , root = "/home/test/blog" + } diff --git a/test/Mock/Blog/Skin.hs b/test/Mock/Blog/Skin.hs new file mode 100644 index 0000000..3259a5a --- /dev/null +++ b/test/Mock/Blog/Skin.hs @@ -0,0 +1,16 @@ +module Mock.Blog.Skin ( + simple + ) where + +import Blog.Skin (Skin(..)) +import Prelude hiding (head) + +simple :: Skin +simple = Skin { + banner = Nothing + , cardImage = Nothing + , favicon = Nothing + , head = Nothing + , previewArticlesCount = 3 + , previewLinesCount = 10 + } diff --git a/test/Mock/Blog/Template.hs b/test/Mock/Blog/Template.hs new file mode 100644 index 0000000..bba3d39 --- /dev/null +++ b/test/Mock/Blog/Template.hs @@ -0,0 +1,9 @@ +module Mock.Blog.Template ( + simple + ) where + +import Blog.Template (Templates, build) +import Mock.Blog.Wording (defaultWording) + +simple :: IO Templates +simple = build Mock.Blog.Wording.defaultWording diff --git a/test/Mock/Blog/URL.hs b/test/Mock/Blog/URL.hs new file mode 100644 index 0000000..6954787 --- /dev/null +++ b/test/Mock/Blog/URL.hs @@ -0,0 +1,12 @@ +module Mock.Blog.URL ( + simple + ) where + +import Blog.URL (URL(..)) + +simple :: URL +simple = URL { + cards = Nothing + , comments = Nothing + , rss = Nothing + } diff --git a/test/Mock/Blog/Wording.hs b/test/Mock/Blog/Wording.hs new file mode 100644 index 0000000..175763a --- /dev/null +++ b/test/Mock/Blog/Wording.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} +module Mock.Blog.Wording ( + defaultWording + ) where + +import Blog.Wording (Wording(..)) +import qualified Data.Map as Map (fromList) + +defaultWording :: Wording +defaultWording = Wording $ Map.fromList [ + ("allLink", "See all") + , ("allPage", "All articles{? tagged ${tag}?}") + , ("commentsLink", "Comment on the fediverse") + , ("commentsSection", "Comments") + , ("dateFormat", "en-US") + , ("latestLink", "See only latest") + , ("latestPage", "Latest articles{? tagged ${tag}?}") + , ("metadata", "{?by ${author} ?}on ${date}{? tagged ${tags}?}") + , ("rssLink", "Subscribe") + , ("rssTitle", "Follow all articles{? tagged ${tag}?}") + , ("tagsList", "Tags") + ] diff --git a/test/Mock/Collection.hs b/test/Mock/Collection.hs new file mode 100644 index 0000000..68c1dfd --- /dev/null +++ b/test/Mock/Collection.hs @@ -0,0 +1,28 @@ +module Mock.Collection ( + main + , testing + ) where + +import Blog (Blog(..), Path(..)) +import Collection (Collection(..)) +import Data.Map as Map (elems) +import qualified Mock.Blog (simple) +import System.FilePath (()) + +main :: IO Collection +main = do + blog <- Mock.Blog.simple + return $ Collection { + featured = Map.elems $ articles blog + , basePath = root $ path blog + , tag = Nothing + } + +testing :: IO Collection +testing = do + blog <- Mock.Blog.simple + return $ Collection { + featured = Map.elems $ articles blog + , basePath = root (path blog) "testing" + , tag = Just "testing" + } diff --git a/test/Mock/Markdown.hs b/test/Mock/Markdown.hs new file mode 100644 index 0000000..b745a66 --- /dev/null +++ b/test/Mock/Markdown.hs @@ -0,0 +1,33 @@ +module Mock.Markdown ( + article + , page + ) where + +import qualified Data.Map as Map (fromList) +import Markdown (Markdown(..)) + +article :: Markdown +article = Markdown { + key = "test" + , path = "articles/test" + , Markdown.title = "Some test" + , metadata = Map.fromList [ + ("summary", "It's a test") + , ("featuredImage", "test.png") + ] + , bodyOffset = 3 + , body = [] + } + +page :: Markdown +page = Markdown { + key = "test" + , path = "pages/test" + , Markdown.title = "A test page" + , metadata = Map.fromList [ + ("summary", "Tests are useful") + , ("featuredImage", "test.png") + ] + , bodyOffset = 3 + , body = [] + } diff --git a/test/Tests.hs b/test/Tests.hs index 8963e28..a1117e3 100644 --- a/test/Tests.hs +++ b/test/Tests.hs @@ -3,9 +3,10 @@ module Tests ( ) where import Distribution.TestSuite +import Utils (tag) import qualified XML.Card (test) tests :: IO [Test] -tests = return [ +tests = return $ tag "xml" <$> [ XML.Card.test ] diff --git a/test/Utils.hs b/test/Utils.hs new file mode 100644 index 0000000..7c537d8 --- /dev/null +++ b/test/Utils.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Utils ( + assertAll + , assertEqual + , simpleTest + , tag + ) where + +import Distribution.TestSuite +import Text.Printf (printf) + +tagInstance :: String -> TestInstance -> TestInstance +tagInstance tagName testInstance = testInstance { + tags = tagName : (tags testInstance) + } + +tag :: String -> Test -> Test +tag tagName (Test testInstance) = Test (tagInstance tagName testInstance) +tag tagName group = group {groupTests = tag tagName <$> groupTests group} + +simpleTest :: (String, IO Progress) -> Test +simpleTest (name, run) = Test testInstance + where + testInstance = TestInstance { + run + , name + , tags = [] + , options = [] + , setOption = \_ _ -> Right testInstance + } + +wrong :: Show a => String -> a -> a -> IO Progress +wrong message expected actual = return . Finished . Fail $ + printf "%s: %s vs. %s" message (show expected) (show actual) + +assertAll :: [(Bool, IO Progress, String)] -> IO Progress +assertAll = foldr assert (return $ Finished Pass) + where + assert (bool, badIssue, checkMessage) next = + if bool then return $ Progress checkMessage next else badIssue + +assertEqual :: (Show a, Eq a) => String -> a -> a -> (Bool, IO Progress, String) +assertEqual what a b = + (a == b, wrong (what ++ " do not match !") a b, what ++ " ok") + diff --git a/test/XML/Card.hs b/test/XML/Card.hs index 12673d0..58fb402 100644 --- a/test/XML/Card.hs +++ b/test/XML/Card.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module XML.Card ( test ) where -import Article (Article(..)) import Blog (Blog) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (runReaderT) @@ -12,57 +10,87 @@ import Data.Text (Text) import Distribution.TestSuite import DOM.Card (HasCard(..)) import Mock.Blog as Blog (simple) -import Mock.Article as Article (noDescription, noImage, noMeta, simple) -import Text.Printf (printf) +import Mock.Article as Article (noDescription, noImage, simple) +import Mock.ArticlesList as ArticlesList ( + longMain, longTesting, shortMain, shortTesting + ) +import Utils (assertAll, assertEqual, simpleTest, tag) -simpleTest :: [String] -> (String, IO Progress) -> Test -simpleTest tags (name, run) = Test testInstance - where - testInstance = TestInstance { - run - , name - , tags - , options = [] - , setOption = \_ _ -> Right testInstance - } - -wrong :: Show a => String -> a -> a -> IO Progress -wrong message expected actual = return . Finished . Fail $ - printf "%s: %s vs. %s" message (show expected) (show actual) - -assertAll :: [(Bool, IO Progress, String)] -> IO Progress -assertAll = foldr assert (return $ Finished Pass) - where - assert (bool, badIssue, checkMessage) next = - if bool then return $ Progress checkMessage next else badIssue - -assertEqual :: (Show a, Eq a) => String -> a -> a -> (Bool, IO Progress, String) -assertEqual what a b = - (a == b, wrong (what ++ " do not match !") a b, what ++ " ok") - -checkCard :: Blog -> Article -> (Text, Text, Maybe String, String, String) -> IO Progress -checkCard blog article (expectedCT, expectedD, expectedI, expectedT, expectedU) = - flip runReaderT blog $ - sequence [ - assertEqual "card types" expectedCT <$> cardType article - , assertEqual "descriptions" expectedD <$> description article - , assertEqual "images" expectedI <$> image article - , assertEqual "titles" expectedT <$> title article - , assertEqual "urls" expectedU <$> urlPath article - ] >>= liftIO . assertAll +checkCard :: HasCard a => IO Blog -> a -> (Text, Text, Maybe String, String, String) -> IO Progress +checkCard getBlog input (expectedCT, expectedD, expectedI, expectedT, expectedU) = + getBlog >>= runReaderT ( + sequence [ + assertEqual "card types" expectedCT <$> cardType input + , assertEqual "descriptions" expectedD <$> description input + , assertEqual "images" expectedI <$> image input + , assertEqual "titles" expectedT <$> title input + , assertEqual "urls" expectedU <$> urlPath input + ] >>= liftIO . assertAll + ) articleCard :: Test -articleCard = - testGroup "Article cards" $ simpleTest ["xml", "card", "article"] <$> [ +articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [ ("simple article", checkCard Blog.simple Article.simple ( "article" , "It's a test" , Just "test.png" , "Some test" - , "https://test.net/articles/test.html" + , "articles/test.html" ) ) - ] + , ("article without description", checkCard Blog.simple Article.noDescription ( + "article" + , "A new article on The Test Blog" + , Just "test.png" + , "Some test" + , "articles/test.html" + ) + ) + , ("article without image", checkCard Blog.simple Article.noImage ( + "article" + , "It's a test" + , Nothing + , "Some test" + , "articles/test.html" + ) + ) + ] + +articlesListCard :: Test +articlesListCard = tag "articlesList" . testGroup "Articles list cards" $ simpleTest <$> [ + ("short untagged page", ArticlesList.shortMain >>= (flip (checkCard Blog.simple) ( + "website" + , "Latest articles" + , Nothing + , "The Test Blog" + , "index.html" + ) + )) + , ("long untagged page", ArticlesList.longMain >>= (flip (checkCard Blog.simple) ( + "website" + , "All articles" + , Nothing + , "The Test Blog" + , "all.html" + ) + )) + , ("short tagged page", ArticlesList.shortTesting >>= (flip (checkCard Blog.simple) ( + "website" + , "Latest articles tagged testing" + , Nothing + , "The Test Blog - testing" + , "testing/index.html" + ) + )) + , ("long tagged page", ArticlesList.longTesting >>= (flip (checkCard Blog.simple) ( + "website" + , "All articles tagged testing" + , Nothing + , "The Test Blog - testing" + , "testing/all.html" + ) + )) + ] test :: Test -test = testGroup "Cards" [articleCard] +test = tag "card" $ testGroup "Cards" [articleCard, articlesListCard]