Fix tests / add new ones to capture the subtle way og:image can fail

test/Mock/Article.hs

@@ -1,12 +1,14 @@
 module Mock.Article (
-      noDescription
+      hostRelativeImage
+    , noDescription
     , noImage
     , noMeta
+    , remoteImage
     , simple
   ) where
 
 import Article (Article(..))
-import qualified Data.Map as Map (fromList)
+import qualified Data.Map as Map (fromList, insert)
 import Markdown (Markdown(..))
 import Mock.Markdown (article)
 
@@ -16,6 +18,16 @@ simple = Article article
 noImage :: Article
 noImage = Article $ article {metadata = Map.fromList [("summary", "It's a test")]}
 
+remoteImage :: Article
+remoteImage = Article $ article {metadata = setImage $ metadata article}
+  where
+    setImage = Map.insert "featuredImage" "https://somewhere.el.se/test.png"
+
+hostRelativeImage :: Article
+hostRelativeImage = Article $ article {metadata = setImage $ metadata article}
+  where
+    setImage = Map.insert "featuredImage" "/media/test.png"
+
 noDescription :: Article
 noDescription = Article $ article {metadata = Map.fromList [("featuredImage", "test.png")]}
 

test/Mock/Blog.hs

@@ -3,6 +3,7 @@ module Mock.Blog (
       noCards
     , noRSS
     , simple
+    , subPath
   ) where
 
 import Blog (Blog(..))
@@ -12,7 +13,7 @@ import qualified Mock.Article (simple)
 import qualified Mock.Blog.Path (defaultArticles)
 import qualified Mock.Blog.Skin (simple)
 import qualified Mock.Blog.Template (simple)
-import qualified Mock.Blog.URL (simple, noCards)
+import qualified Mock.Blog.URL (simple, subPath, noCards)
 import qualified Mock.Blog.Wording (defaultWording)
 
 simple :: IO Blog
@@ -32,6 +33,9 @@ simple =
       , wording
     }
 
+subPath :: IO Blog
+subPath = (\b -> b {urls = Mock.Blog.URL.subPath}) <$> simple
+
 noCards :: IO Blog
 noCards = (\b -> b {urls = Mock.Blog.URL.noCards}) <$> simple
 

test/Mock/Blog/URL.hs

@@ -1,13 +1,30 @@
 module Mock.Blog.URL (
       noCards
     , simple
+    , subPath
   ) where
 
 import Blog.URL (URLs(..))
+import Network.URL (Host(..), Protocol(..), URL(..), URLType(..))
 
 simple :: URLs
 simple = URLs {
-      cards = Just "https://test.net"
+      cards = Just (URL {
+            url_type = Absolute (Host (HTTP True) "test.net" Nothing)
+          , url_path = ""
+          , url_params = []
+        })
+    , comments = Nothing
+    , rss = Nothing
+  }
+
+subPath :: URLs
+subPath = URLs {
+      cards = Just (URL {
+            url_type = Absolute (Host (HTTP True) "test.net" Nothing)
+          , url_path = "subPath"
+          , url_params = []
+        })
     , comments = Nothing
     , rss = Nothing
   }

test/URLs.hs

@@ -0,0 +1,12 @@
+module URLs (
+    test
+  ) where
+
+import Blog.URL (URL(..))
+import Distribution.TestSuite
+import Utils (simpleTest, tag)
+
+test :: Test
+test = tag "URLs" . testGroup "URLs handling" $ simpleTest <$> [
+    ("nothing", return $ Finished Pass)
+  ]

test/XML/Card/Component.hs

@@ -4,6 +4,7 @@ module XML.Card.Component (
   ) where
 
 import Blog (Blog)
+import Blog.URL (pathRelative)
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Reader (runReaderT)
 import Data.Text (Text)
@@ -14,9 +15,10 @@ import Mock.Article as Article (noDescription, noImage, simple)
 import Mock.ArticlesList as ArticlesList (
     longMain, longTesting, shortMain, shortTesting
   )
+import Network.URL (URL)
 import Utils (assertAll, assertEqual, simpleTest, tag)
 
-check :: HasCard a => IO Blog -> a -> (Text, Text, Maybe String, String, String) -> IO Progress
+check :: HasCard a => IO Blog -> a -> (Text, Text, Maybe URL, String, String) -> IO Progress
 check getBlog input (expectedCT, expectedD, expectedI, expectedT, expectedU) =
   getBlog >>= runReaderT (
       sequence [
@@ -33,14 +35,14 @@ articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
       ("simple article components", check Blog.simple Article.simple (
             "article"
           , "It's a test"
-          , Just "test.png"
+          , Just (pathRelative "test.png")
           , "Some test"
           , "articles/test.html"
         ))
     , ("article components without description", check Blog.simple Article.noDescription (
             "article"
           , "A new article on The Test Blog"
-          , Just "test.png"
+          , Just (pathRelative "test.png")
           , "Some test"
           , "articles/test.html"
         ))

test/XML/Card/Output.hs

@@ -9,8 +9,10 @@ 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)
-import Mock.Article as Article (noDescription, noImage, simple)
+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
   )
@@ -31,8 +33,15 @@ check getBlog input expectedFile =
 articleCard :: Test 
 articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
       ("simple article output", check Blog.simple Article.simple "simple.html")
-    , ("article output without description", check Blog.simple Article.noDescription "noDescription.html")
-    , ("article output without image", check Blog.simple Article.noImage "noImage.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")
   ]
 

test/XML/Card/Output/hostRelativeImage.html

@@ -0,0 +1 @@
+<meta property="og:url" content="https://test.net/articles/test.html"><meta property="og:type" content="article"><meta property="og:title" content="Some test"><meta property="og:description" content="It&#39;s a test"><meta property="og:image" content="https://test.net/media/test.png"><meta property="og:site_name" content="The Test Blog">

test/XML/Card/Output/remoteImage.html

@@ -0,0 +1 @@
+<meta property="og:url" content="https://test.net/articles/test.html"><meta property="og:type" content="article"><meta property="og:title" content="Some test"><meta property="og:description" content="It&#39;s a test"><meta property="og:image" content="https://somewhere.el.se/test.png"><meta property="og:site_name" content="The Test Blog">

test/XML/Card/Output/subPath.html

@@ -0,0 +1 @@
+<meta property="og:url" content="https://test.net/subPath/articles/test.html"><meta property="og:type" content="article"><meta property="og:title" content="Some test"><meta property="og:description" content="It&#39;s a test"><meta property="og:image" content="https://test.net/subPath/test.png"><meta property="og:site_name" content="The Test Blog">