diff --git a/hablo.cabal b/hablo.cabal index 1782baa..189a17a 100644 --- a/hablo.cabal +++ b/hablo.cabal @@ -94,11 +94,13 @@ test-suite tests , Mock.Blog.Wording , Mock.Collection , Mock.Markdown + , Mock.URL , Structure , Utils , XML.Card , XML.Card.Component , XML.Card.Output + , XML.Favicon build-depends: base , Cabal , containers diff --git a/src/Blog/Skin.hs b/src/Blog/Skin.hs index ad25f3b..7d2d032 100644 --- a/src/Blog/Skin.hs +++ b/src/Blog/Skin.hs @@ -4,6 +4,7 @@ module Blog.Skin ( Skin(..) , build + , findImage ) where import Arguments (Arguments) diff --git a/test/Mock/Blog/URL.hs b/test/Mock/Blog/URL.hs index b091757..3fce356 100644 --- a/test/Mock/Blog/URL.hs +++ b/test/Mock/Blog/URL.hs @@ -5,12 +5,12 @@ module Mock.Blog.URL ( ) where import Blog.URL (AbsoluteURL(..), URLs(..)) -import Network.URL (Host(..), Protocol(..)) +import Mock.URL (testHost) simple :: URLs simple = URLs { cards = Just (AbsoluteURL { - Blog.URL.host = Host (HTTP True) "test.net" Nothing + Blog.URL.host = testHost , urlPath = "" , urlParams = [] }) @@ -21,7 +21,7 @@ simple = URLs { subPath :: URLs subPath = URLs { cards = Just (AbsoluteURL { - Blog.URL.host = Host (HTTP True) "test.net" Nothing + Blog.URL.host = testHost , urlPath = "subPath" , urlParams = [] }) diff --git a/test/Mock/URL.hs b/test/Mock/URL.hs new file mode 100644 index 0000000..4c761db --- /dev/null +++ b/test/Mock/URL.hs @@ -0,0 +1,35 @@ +module Mock.URL ( + cdnFavicon + , localDiscovered + , localFavicon + , testHost + ) where + +import Network.URL (Host(..), Protocol(..), URL(..), URLType(..)) + +testHost :: Host +testHost = Host (HTTP True) "test.net" Nothing + +cdn :: Host +cdn = Host (HTTP True) "cdn.net" Nothing + +cdnFavicon :: URL +cdnFavicon = URL { + url_type = Absolute cdn + , url_path = "favicon.png" + , url_params = [] + } + +localFavicon :: URL +localFavicon = URL { + url_type = HostRelative + , url_path = "favicon.png" + , url_params = [] + } + +localDiscovered :: URL +localDiscovered = URL { + url_type = HostRelative + , url_path = "skin/favicon.png" + , url_params = [] + } diff --git a/test/Tests.hs b/test/Tests.hs index 1be31f5..20d28bd 100644 --- a/test/Tests.hs +++ b/test/Tests.hs @@ -6,9 +6,11 @@ import Distribution.TestSuite import qualified Structure (test) import Utils (tag) import qualified XML.Card (test) +import qualified XML.Favicon (test) tests :: IO [Test] tests = return $ tag "xml" <$> [ XML.Card.test + , XML.Favicon.test , Structure.test ] diff --git a/test/XML/Favicon.hs b/test/XML/Favicon.hs new file mode 100644 index 0000000..5575d3e --- /dev/null +++ b/test/XML/Favicon.hs @@ -0,0 +1,25 @@ +module XML.Favicon ( + test + ) where + +import Blog.Skin (findImage) +import Distribution.TestSuite +import Mock.URL (cdnFavicon, localDiscovered, localFavicon) +import Network.URL (URL) +import Utils (assertAll, assertEqual, simpleTest, tag) + +check :: IO (Maybe URL) -> Maybe URL -> IO Progress +check getter expected = do + actual <- getter + assertAll $ [ + assertEqual "URLs" actual expected + ] + +test :: Test +test = tag "favicon" . testGroup "Favicons" $ simpleTest <$> [ + ("auto-discover", check (findImage "favicon" Nothing) (Just localDiscovered)) + , ("none", check (findImage "blerp" Nothing) Nothing) + , ("manual absolute", check (findImage "" (Just "https://cdn.net/favicon.png")) (Just cdnFavicon)) + , ("manual relative", check (findImage "" (Just "favicon.ico")) (Just localFavicon)) + , ("manual host-relative", check (findImage "" (Just "/favicon.ico")) (Just localFavicon)) + ] diff --git a/test/XML/Favicon/Input/skin/favicon.png b/test/XML/Favicon/Input/skin/favicon.png new file mode 100644 index 0000000..e69de29