Fix OG cards images URLs issue
This commit is contained in:
parent
55d8262883
commit
c06af19d11
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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,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")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue