Fix OG cards images URLs issue

src/Blog/URL.hs

@@ -1,9 +1,10 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Blog.URL (
-      URLs(..)
+      AbsoluteURL(..)
+    , URLs(..)
     , (./)
-    , (//)
+    , (/?)
     , build
     , checkURL
     , pathRelative
@@ -14,47 +15,65 @@ import Arguments (Arguments)
 import qualified Arguments as Arguments (Arguments(..))
 import Control.Monad.IO.Class (MonadIO(..))
 import Data.Aeson (ToJSON(..), (.=), object, pairs)
+import Data.Function (on)
+import Data.List (unionBy)
 import Data.Text (Text, pack)
-import Network.URL (URL(..), URLType(..), exportURL, importURL)
+import Network.URL (Host, URL(..), URLType(..), exportURL, importURL)
 import System.Exit (die)
 import System.IO (hPutStrLn, stderr)
 import System.FilePath ((</>))
 import Text.Printf (printf)
 
+data AbsoluteURL = AbsoluteURL {
+      host :: Host
+    , urlPath :: FilePath
+    , urlParams :: [(String, String)]
+  }
+
+toText :: AbsoluteURL -> Text
+toText (AbsoluteURL {host, urlPath, urlParams}) =
+  pack . exportURL $ URL (Absolute host) urlPath urlParams
+
 data URLs = URLs {
-      cards :: Maybe URL
+      cards :: Maybe AbsoluteURL
-    , comments :: Maybe URL
+    , comments :: Maybe AbsoluteURL
-    , rss :: Maybe URL
+    , rss :: Maybe AbsoluteURL
   }
 
 instance ToJSON URLs where
   toJSON (URLs {comments}) = object [
-      ("comments", toJSON (exportURL <$> comments))
+      ("comments", toJSON (toText <$> comments))
     ]
   toEncoding (URLs {comments}) = pairs (
-      "comments" .= (exportURL <$> comments)
+      "comments" .= (toText <$> comments)
     )
 
 checkURL :: MonadIO m => String -> m URL
 checkURL url =
   maybe (liftIO . die $ printf "Invalid URL %s" url) pure $ importURL url
 
+checkAbsolute :: MonadIO m => URL -> m AbsoluteURL
+checkAbsolute (URL {url_type = Absolute host, url_path, url_params}) =
+  pure $ AbsoluteURL host url_path url_params
+checkAbsolute url =
+  liftIO . die . printf "%s is not an absolute URL" $ exportURL url
+
 checksUsed :: Bool -> Maybe a -> IO ()
 checksUsed False (Just _) =
   hPutStrLn stderr "Site url is set but not used, did you forget --open-graph-cards or --rss ?"
 checksUsed _ _ = return ()
 
-getURL :: Maybe Bool -> Maybe String -> String -> IO (Maybe URL)
+getURL :: Maybe Bool -> Maybe String -> IO (Maybe AbsoluteURL) -> IO (Maybe AbsoluteURL)
-getURL Nothing (Just url) _ = Just <$> checkURL url
+getURL Nothing (Just url) _ = Just <$> (checkAbsolute =<< checkURL url)
-getURL (Just True) Nothing reason = die reason
+getURL (Just True) Nothing failure = failure
-getURL (Just True) (Just url) reason = Just <$> checkURL url
+getURL (Just True) (Just url) _ = Just <$> (checkAbsolute =<< checkURL url)
 getURL _ _ _ = pure Nothing
 
 build :: Arguments -> IO URLs
 build arguments = do
-  cards <- getURL (Just argOGCards) siteURL "Open Graph cards"
+  cards <- getURL (Just argOGCards) siteURL (failBecauseOf "Open Graph cards")
-  rss <- getURL (Just argRSS) siteURL "RSS feeds"
+  rss <- getURL (Just argRSS) siteURL (failBecauseOf "RSS feeds")
-  comments <- getURL Nothing commentsURL "Comments"
+  comments <- getURL Nothing commentsURL (pure Nothing)
   checksUsed (argOGCards || argRSS) siteURL
   return $ URLs {cards, comments, rss}
   where
@@ -62,19 +81,26 @@ build arguments = do
     siteURL = Arguments.siteURL arguments
     argOGCards = Arguments.openGraphCards arguments
     argRSS = Arguments.rss arguments
-    errorMsg :: String -> String
+    failBecauseOf :: String -> IO a
-    errorMsg = printf "Enabling %s requires setting the site url with --site-url"
+    failBecauseOf =
+      die . printf "Enabling %s requires setting the site url with --site-url"
 
 pathRelative :: String -> URL
 pathRelative url_path = URL {url_type = PathRelative, url_path, url_params = []}
 
-toText :: URL -> Text
+addParams :: AbsoluteURL -> [(String, String)] -> AbsoluteURL
-toText = pack . exportURL
+addParams url newParams = url {
+    urlParams = unionBy ((==) `on` fst) newParams (urlParams url)
+  }
 
-(./) :: URL -> FilePath -> Text
+(./) :: AbsoluteURL -> FilePath -> Text
-(./) url subPath = toText $ url {url_path = url_path url </> subPath}
+(./) url = toText . setPath
+  where setPath ('/':urlPath) = url {urlPath}
+        setPath subPath = url {urlPath = urlPath url </> subPath}
 
-(//) :: URL -> URL -> Text
+(/?) :: AbsoluteURL -> URL -> Text
-(//) _ url@(URL {url_type = Absolute _}) = pack $ exportURL url
+(/?) _ (URL {url_type = Absolute host, url_path, url_params}) =
-(//) url (URL {url_type = HostRelative, url_path}) = url ./ ('/':url_path)
+  toText $ AbsoluteURL host url_path url_params
-(//) url (URL {url_path}) = url ./ url_path
+(/?) url (URL {url_type = HostRelative, url_path, url_params}) =
+  toText $ addParams (url {urlPath = url_path}) url_params
+(/?) url (URL {url_path, url_params}) = (addParams url url_params) ./ url_path

src/DOM.hs

@@ -11,7 +11,6 @@ import ArticlesList (
     ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
   )
 import Blog (Blog(..), Skin(..), URLs(..), template)
-import Blog.URL (toText)
 import Control.Monad.Reader (ReaderT, asks)
 import Data.Map as Map (Map, toList)
 import Data.Text (Text, pack, empty)
@@ -24,7 +23,7 @@ import Lucid (
     , title_, toHtml, toHtmlRaw, type_, ul_
   )
 import Markdown (Markdown(..), MarkdownContent(..))
-import Network.URL (URL)
+import Network.URL (URL, exportURL)
 import Page (Page)
 import Prelude hiding (head, lookup)
 import Pretty ((.$))
@@ -87,7 +86,7 @@ defaultBanner =
 
 faviconLink :: URL -> HtmlGenerator ()
 faviconLink url = link_ [
-    rel_ "shortcut icon", href_ $ toText url, type_ "image/x-icon"
+    rel_ "shortcut icon", href_ . pack $ exportURL url, type_ "image/x-icon"
   ]
 
 optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator ()

src/DOM/Card.hs

@@ -10,7 +10,7 @@ import Article (Article(..))
 import ArticlesList (ArticlesList(..))
 import qualified ArticlesList (description)
 import Blog (Blog(..), Renderer, Skin(..), template)
-import Blog.URL ((./), (//), checkURL)
+import Blog.URL ((./), (/?), AbsoluteURL, checkURL)
 import Collection (Collection(..))
 import qualified Collection (title)
 import Control.Applicative ((<|>))
@@ -40,7 +40,7 @@ og attribute value =
       , content_ value
     ]
 
-make :: (HasCard a, Renderer m) => a -> URL -> HtmlT m ()
+make :: (HasCard a, Renderer m) => a -> AbsoluteURL -> HtmlT m ()
 make element siteURL = do
   og "url" . (siteURL ./) =<< urlPath element
   og "type" =<< cardType element
@@ -49,7 +49,7 @@ make element siteURL = do
   maybeImage =<< ((<|>) <$> image element <*> (asks $skin.$cardImage))
   og "site_name" =<< (asks $name.$pack)
   where
-    maybeImage = maybe (return ()) (og "image" . (siteURL //))
+    maybeImage = maybe (return ()) (og "image" . (siteURL /?))
 
 mDImage :: (Renderer m, MarkdownContent a) => a -> m (Maybe URL)
 mDImage = mapM checkURL . Map.lookup "featuredImage" . metadata . getMarkdown

src/RSS.hs

@@ -9,7 +9,7 @@ import Article (Article(..))
 import ArticlesList (ArticlesList(..), getArticles)
 import qualified ArticlesList (description, path)
 import Blog (Blog(urls), Renderer, URLs(..))
-import Blog.URL ((./))
+import Blog.URL ((./), AbsoluteURL)
 import Collection (Collection(..), getAll)
 import qualified Collection (title)
 import Control.Monad.IO.Class (MonadIO(..))
@@ -22,7 +22,6 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import Lucid (Attribute, HtmlT, Term, ToHtml(..), term, renderTextT)
 import Lucid.Base (makeAttribute)
 import Markdown (Markdown(..))
-import Network.URL (URL)
 import Pretty ((.$))
 import System.FilePath.Posix ((</>), (<.>))
 
@@ -59,7 +58,7 @@ item_ = term "item"
 pubDate_ :: Term arg result => arg -> result
 pubDate_ = term "pubDate"
 
-articleItem :: Monad m => URL -> Article -> HtmlT m ()
+articleItem :: Monad m => AbsoluteURL -> Article -> HtmlT m ()
 articleItem siteURL (Article (Markdown {path, metadata, title})) =
   item_ $ do
     title_ $ toHtml title
@@ -70,7 +69,7 @@ articleItem siteURL (Article (Markdown {path, metadata, title})) =
         formatTime defaultTimeLocale rfc822DateFormat
       . posixSecondsToUTCTime . fromIntegral . (read :: String -> Int)
 
-feed :: Renderer m => URL -> ArticlesList -> HtmlT m ()
+feed :: Renderer m => AbsoluteURL -> ArticlesList -> HtmlT m ()
 feed siteURL al@(ArticlesList {collection}) = do
   prolog
   rss_ [version, content, atom] $ do
@@ -84,7 +83,7 @@ feed siteURL al@(ArticlesList {collection}) = do
     content = xmlns_content_ "http://purl.org/rss/1.0/modules/content/"
     atom = xmlns_atom_ "http://www.w3.org/2005/Atom"
 
-generateCollection :: URL -> Collection -> ReaderT Blog IO ()
+generateCollection :: AbsoluteURL -> Collection -> ReaderT Blog IO ()
 generateCollection siteURL collection =
   renderTextT (feed siteURL $ ArticlesList {full = False, collection})
   >>= liftIO . TextIO.writeFile (basePath collection </> "rss" <.> "xml")

test/Mock/Blog/URL.hs

@@ -4,15 +4,15 @@ module Mock.Blog.URL (
     , subPath
   ) where
 
-import Blog.URL (URLs(..))
+import Blog.URL (AbsoluteURL(..), URLs(..))
-import Network.URL (Host(..), Protocol(..), URL(..), URLType(..))
+import Network.URL (Host(..), Protocol(..))
 
 simple :: URLs
 simple = URLs {
-      cards = Just (URL {
+      cards = Just (AbsoluteURL {
-            url_type = Absolute (Host (HTTP True) "test.net" Nothing)
+            Blog.URL.host = Host (HTTP True) "test.net" Nothing
-          , url_path = ""
+          , urlPath = ""
-          , url_params = []
+          , urlParams = []
         })
     , comments = Nothing
     , rss = Nothing
@@ -20,10 +20,10 @@ simple = URLs {
 
 subPath :: URLs
 subPath = URLs {
-      cards = Just (URL {
+      cards = Just (AbsoluteURL {
-            url_type = Absolute (Host (HTTP True) "test.net" Nothing)
+            Blog.URL.host = Host (HTTP True) "test.net" Nothing
-          , url_path = "subPath"
+          , urlPath = "subPath"
-          , url_params = []
+          , urlParams = []
         })
     , comments = Nothing
     , rss = Nothing