Tissevert/hablo
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Fix OG cards images URLs issue

Browse source
This commit is contained in:
Tissevert 2021-04-04 17:33:31 +02:00
parent 55d8262883
commit c06af19d11
5 changed files with 70 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

76
src/Blog/URL.hs
View file

@ -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

5
src/DOM.hs
View file

@ -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 ()

6
src/DOM/Card.hs
View file

@ -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

9
src/RSS.hs
View file

@ -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")

20
test/Mock/Blog/URL.hs
View file

@ -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