From c06af19d11d1487c09f3272173e46512985058d6 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sun, 4 Apr 2021 17:33:31 +0200 Subject: [PATCH] Fix OG cards images URLs issue --- src/Blog/URL.hs | 76 +++++++++++++++++++++++++++++-------------- src/DOM.hs | 5 ++- src/DOM/Card.hs | 6 ++-- src/RSS.hs | 9 +++-- test/Mock/Blog/URL.hs | 20 ++++++------ 5 files changed, 70 insertions(+), 46 deletions(-) diff --git a/src/Blog/URL.hs b/src/Blog/URL.hs index 172ff42..abfc3e6 100644 --- a/src/Blog/URL.hs +++ b/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 - , comments :: Maybe URL - , rss :: Maybe URL + cards :: Maybe AbsoluteURL + , comments :: Maybe AbsoluteURL + , 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 Nothing (Just url) _ = Just <$> checkURL url -getURL (Just True) Nothing reason = die reason -getURL (Just True) (Just url) reason = Just <$> checkURL url +getURL :: Maybe Bool -> Maybe String -> IO (Maybe AbsoluteURL) -> IO (Maybe AbsoluteURL) +getURL Nothing (Just url) _ = Just <$> (checkAbsolute =<< checkURL url) +getURL (Just True) Nothing failure = failure +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" - rss <- getURL (Just argRSS) siteURL "RSS feeds" - comments <- getURL Nothing commentsURL "Comments" + cards <- getURL (Just argOGCards) siteURL (failBecauseOf "Open Graph cards") + rss <- getURL (Just argRSS) siteURL (failBecauseOf "RSS feeds") + 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 - errorMsg = printf "Enabling %s requires setting the site url with --site-url" + failBecauseOf :: String -> IO a + 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 -toText = pack . exportURL +addParams :: AbsoluteURL -> [(String, String)] -> AbsoluteURL +addParams url newParams = url { + urlParams = unionBy ((==) `on` fst) newParams (urlParams url) + } -(./) :: URL -> FilePath -> Text -(./) url subPath = toText $ url {url_path = url_path url subPath} +(./) :: AbsoluteURL -> FilePath -> Text +(./) url = toText . setPath + where setPath ('/':urlPath) = url {urlPath} + setPath subPath = url {urlPath = urlPath url subPath} -(//) :: URL -> URL -> Text -(//) _ url@(URL {url_type = Absolute _}) = pack $ exportURL url -(//) url (URL {url_type = HostRelative, url_path}) = url ./ ('/':url_path) -(//) url (URL {url_path}) = url ./ url_path +(/?) :: AbsoluteURL -> URL -> Text +(/?) _ (URL {url_type = Absolute host, url_path, url_params}) = + toText $ AbsoluteURL host url_path url_params +(/?) 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 diff --git a/src/DOM.hs b/src/DOM.hs index c312e05..ab45475 100644 --- a/src/DOM.hs +++ b/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 () diff --git a/src/DOM/Card.hs b/src/DOM/Card.hs index 52e7742..dfef431 100644 --- a/src/DOM/Card.hs +++ b/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 diff --git a/src/RSS.hs b/src/RSS.hs index ae83b3f..63da43d 100644 --- a/src/RSS.hs +++ b/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") diff --git a/test/Mock/Blog/URL.hs b/test/Mock/Blog/URL.hs index c945a81..b091757 100644 --- a/test/Mock/Blog/URL.hs +++ b/test/Mock/Blog/URL.hs @@ -4,15 +4,15 @@ module Mock.Blog.URL ( , subPath ) where -import Blog.URL (URLs(..)) -import Network.URL (Host(..), Protocol(..), URL(..), URLType(..)) +import Blog.URL (AbsoluteURL(..), URLs(..)) +import Network.URL (Host(..), Protocol(..)) simple :: URLs simple = URLs { - cards = Just (URL { - url_type = Absolute (Host (HTTP True) "test.net" Nothing) - , url_path = "" - , url_params = [] + cards = Just (AbsoluteURL { + Blog.URL.host = Host (HTTP True) "test.net" Nothing + , urlPath = "" + , urlParams = [] }) , comments = Nothing , rss = Nothing @@ -20,10 +20,10 @@ simple = URLs { subPath :: URLs subPath = URLs { - cards = Just (URL { - url_type = Absolute (Host (HTTP True) "test.net" Nothing) - , url_path = "subPath" - , url_params = [] + cards = Just (AbsoluteURL { + Blog.URL.host = Host (HTTP True) "test.net" Nothing + , urlPath = "subPath" + , urlParams = [] }) , comments = Nothing , rss = Nothing