From 6a795336342bf0ebb597476580b3f17b227078a3 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sun, 28 Mar 2021 23:37:42 +0200 Subject: [PATCH] Replace naive String implementation of URL by a proper type from an existing library; thus validating URLs handled by hablo --- hablo.cabal | 2 ++ src/ArticlesList.hs | 8 ++++-- src/Blog/Skin.hs | 23 +++++++++-------- src/Blog/URL.hs | 62 +++++++++++++++++++++++++++++++++++---------- src/DOM.hs | 6 +++-- src/DOM/Card.hs | 15 ++++++----- src/RSS.hs | 14 +++++----- 7 files changed, 89 insertions(+), 41 deletions(-) diff --git a/hablo.cabal b/hablo.cabal index 190cf2c..4c4d663 100644 --- a/hablo.cabal +++ b/hablo.cabal @@ -65,6 +65,7 @@ library , time >= 1.8.0 && < 1.12 , SJW >= 0.1.2 && < 0.2 , unix >= 2.7.2 && < 2.8 + , url >= 2.1.3 && < 2.2 ghc-options: -Wall hs-source-dirs: src default-language: Haskell2010 @@ -107,6 +108,7 @@ test-suite tests , lucid , mtl , text + , url hs-source-dirs: test ghc-options: -Wall default-language: Haskell2010 diff --git a/src/ArticlesList.hs b/src/ArticlesList.hs index c111be0..df4a052 100644 --- a/src/ArticlesList.hs +++ b/src/ArticlesList.hs @@ -6,6 +6,7 @@ module ArticlesList ( , description , getArticles , otherURL + , ArticlesList.path , rssLinkTexts ) where @@ -29,8 +30,8 @@ getArticles (ArticlesList {full, collection = Collection {featured}}) = do return $ if full then featured else limit featured otherURL :: ArticlesList -> String -otherURL (ArticlesList {full, collection}) = absoluteLink $ - (if full then id else ( "all.html")) . maybe "" id $ tag collection +otherURL al@(ArticlesList {full}) = absoluteLink $ + (if full then id else ( "all.html")) $ ArticlesList.path al description :: Renderer m => ArticlesList -> m Text description (ArticlesList {full, collection}) = @@ -46,3 +47,6 @@ rssLinkTexts (ArticlesList {collection}) = do return (text, title) where environment = maybe [] (\v -> [("tag", pack v)]) $ tag collection + +path :: ArticlesList -> FilePath +path = maybe "" id . tag . collection diff --git a/src/Blog/Skin.hs b/src/Blog/Skin.hs index 35370c8..ad25f3b 100644 --- a/src/Blog/Skin.hs +++ b/src/Blog/Skin.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} @@ -9,37 +8,41 @@ module Blog.Skin ( import Arguments (Arguments) import qualified Arguments (bannerPath, favicon, cardImage, headPath, previewArticlesCount, previewLinesCount) +import Blog.URL (checkURL, pathRelative) import Control.Monad (filterM) -import Data.Aeson (ToJSON(..), (.=), pairs) +import Data.Aeson (ToJSON(..), (.=), object, pairs) import Data.Maybe (listToMaybe) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif -import Files (absoluteLink) -import GHC.Generics (Generic) +import Network.URL (URL) import Prelude hiding (head) import System.Directory (doesFileExist) import System.FilePath ((), (<.>)) data Skin = Skin { banner :: Maybe String - , cardImage :: Maybe FilePath - , favicon :: Maybe FilePath + , cardImage :: Maybe URL + , favicon :: Maybe URL , head :: Maybe String , previewArticlesCount :: Int , previewLinesCount :: Int - } deriving Generic + } instance ToJSON Skin where + toJSON (Skin {previewArticlesCount, previewLinesCount}) = object [ + ("previewArticlesCount", toJSON previewArticlesCount) + , ("previewLinesCount", toJSON previewLinesCount) + ] toEncoding (Skin {previewArticlesCount, previewLinesCount}) = pairs ( "previewArticlesCount" .= previewArticlesCount <> "previewLinesCount" .= previewLinesCount ) -findImage :: String -> Maybe FilePath -> IO (Maybe FilePath) -findImage _ (Just path) = return . Just $ absoluteLink path +findImage :: String -> Maybe FilePath -> IO (Maybe URL) +findImage _ (Just path) = Just <$> checkURL path findImage name Nothing = - listToMaybe <$> filterM doesFileExist pathsToCheck + fmap pathRelative . listToMaybe <$> filterM doesFileExist pathsToCheck where directories = [".", "image", "images", "pictures", "skin", "static"] extensions = ["ico", "gif", "jpeg", "jpg", "png", "svg"] diff --git a/src/Blog/URL.hs b/src/Blog/URL.hs index 14d1520..172ff42 100644 --- a/src/Blog/URL.hs +++ b/src/Blog/URL.hs @@ -1,46 +1,80 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Blog.URL ( URLs(..) + , (./) + , (//) , build + , checkURL + , pathRelative + , toText ) where import Arguments (Arguments) import qualified Arguments as Arguments (Arguments(..)) -import Data.Aeson (ToJSON(..), (.=), pairs) -import GHC.Generics (Generic) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Aeson (ToJSON(..), (.=), object, pairs) +import Data.Text (Text, pack) +import Network.URL (URL(..), URLType(..), exportURL, importURL) import System.Exit (die) import System.IO (hPutStrLn, stderr) +import System.FilePath (()) import Text.Printf (printf) -type URL = String data URLs = URLs { cards :: Maybe URL , comments :: Maybe URL , rss :: Maybe URL - } deriving Generic + } instance ToJSON URLs where + toJSON (URLs {comments}) = object [ + ("comments", toJSON (exportURL <$> comments)) + ] toEncoding (URLs {comments}) = pairs ( - "comments" .= comments + "comments" .= (exportURL <$> comments) ) +checkURL :: MonadIO m => String -> m URL +checkURL url = + maybe (liftIO . die $ printf "Invalid URL %s" url) pure $ importURL 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 _ _ _ = pure Nothing + build :: Arguments -> IO URLs build arguments = do - cards <- getSiteURL argOGCards "Open Graph cards" - rss <- getSiteURL argRSS "RSS feeds" + cards <- getURL (Just argOGCards) siteURL "Open Graph cards" + rss <- getURL (Just argRSS) siteURL "RSS feeds" + comments <- getURL Nothing commentsURL "Comments" checksUsed (argOGCards || argRSS) siteURL return $ URLs {cards, comments, rss} where - comments = Arguments.commentsURL arguments + commentsURL = Arguments.commentsURL arguments 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" - getSiteURL False _ = return Nothing - getSiteURL True name = maybe (die $ errorMsg name) (return . Just) siteURL - checksUsed False (Just _) = - hPutStrLn stderr "Site url is set but not used, did you forget --open-graph-cards or --rss ?" - checksUsed _ _ = return () + +pathRelative :: String -> URL +pathRelative url_path = URL {url_type = PathRelative, url_path, url_params = []} + +toText :: URL -> Text +toText = pack . exportURL + +(./) :: URL -> FilePath -> Text +(./) url subPath = toText $ url {url_path = url_path 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 diff --git a/src/DOM.hs b/src/DOM.hs index f53ead8..c312e05 100644 --- a/src/DOM.hs +++ b/src/DOM.hs @@ -11,6 +11,7 @@ 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) @@ -23,6 +24,7 @@ import Lucid ( , title_, toHtml, toHtmlRaw, type_, ul_ ) import Markdown (Markdown(..), MarkdownContent(..)) +import Network.URL (URL) import Page (Page) import Prelude hiding (head, lookup) import Pretty ((.$)) @@ -83,9 +85,9 @@ defaultBanner = ) ) -faviconLink :: FilePath -> HtmlGenerator () +faviconLink :: URL -> HtmlGenerator () faviconLink url = link_ [ - rel_ "shortcut icon", href_ . pack $ absoluteLink url, type_ "image/x-icon" + rel_ "shortcut icon", href_ $ toText url, type_ "image/x-icon" ] optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator () diff --git a/src/DOM/Card.hs b/src/DOM/Card.hs index be7ccbe..52e7742 100644 --- a/src/DOM/Card.hs +++ b/src/DOM/Card.hs @@ -10,6 +10,7 @@ import Article (Article(..)) import ArticlesList (ArticlesList(..)) import qualified ArticlesList (description) import Blog (Blog(..), Renderer, Skin(..), template) +import Blog.URL ((./), (//), checkURL) import Collection (Collection(..)) import qualified Collection (title) import Control.Applicative ((<|>)) @@ -19,6 +20,7 @@ import Data.Text (Text, pack) import Lucid (HtmlT, content_, meta_) import Lucid.Base (makeAttribute) import Markdown (MarkdownContent(..), metadata) +import Network.URL (URL) import qualified Markdown (Markdown(..)) import Page (Page(..)) import Pretty ((.$)) @@ -27,7 +29,7 @@ import System.FilePath.Posix ((), (<.>)) class HasCard a where cardType :: Renderer m => a -> m Text description :: Renderer m => a -> m Text - image :: Renderer m => a -> m (Maybe String) + image :: Renderer m => a -> m (Maybe URL) title :: Renderer m => a -> m String urlPath :: Renderer m => a -> m String @@ -38,20 +40,19 @@ og attribute value = , content_ value ] -make :: (HasCard a, Renderer m) => a -> String -> HtmlT m () +make :: (HasCard a, Renderer m) => a -> URL -> HtmlT m () make element siteURL = do - og "url" . sitePrefix =<< urlPath element + og "url" . (siteURL ./) =<< urlPath element og "type" =<< cardType element og "title" . pack =<< title element og "description" =<< description element maybeImage =<< ((<|>) <$> image element <*> (asks $skin.$cardImage)) og "site_name" =<< (asks $name.$pack) where - maybeImage = maybe (return ()) (og "image" . sitePrefix) - sitePrefix = pack . (siteURL ) + maybeImage = maybe (return ()) (og "image" . (siteURL //)) -mDImage :: (Renderer m, MarkdownContent a ) => a -> m (Maybe String) -mDImage = return . Map.lookup "featuredImage" . metadata . getMarkdown +mDImage :: (Renderer m, MarkdownContent a) => a -> m (Maybe URL) +mDImage = mapM checkURL . Map.lookup "featuredImage" . metadata . getMarkdown mDTitle :: (Renderer m, MarkdownContent a) => a -> m String mDTitle = return . Markdown.title . getMarkdown diff --git a/src/RSS.hs b/src/RSS.hs index fd0a9d3..ae83b3f 100644 --- a/src/RSS.hs +++ b/src/RSS.hs @@ -7,8 +7,9 @@ module RSS ( import Article (Article(..)) import ArticlesList (ArticlesList(..), getArticles) -import qualified ArticlesList (description) +import qualified ArticlesList (description, path) import Blog (Blog(urls), Renderer, URLs(..)) +import Blog.URL ((./)) import Collection (Collection(..), getAll) import qualified Collection (title) import Control.Monad.IO.Class (MonadIO(..)) @@ -21,6 +22,7 @@ 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 ((), (<.>)) @@ -57,24 +59,24 @@ item_ = term "item" pubDate_ :: Term arg result => arg -> result pubDate_ = term "pubDate" -articleItem :: Monad m => String -> Article -> HtmlT m () +articleItem :: Monad m => URL -> Article -> HtmlT m () articleItem siteURL (Article (Markdown {path, metadata, title})) = item_ $ do title_ $ toHtml title - link_ $ toHtml (siteURL path <.> "html") + link_ . toHtml $ siteURL ./ (path <.> "html") pubDate_ . toHtml . rfc822Date $ metadata ! "date" where rfc822Date = formatTime defaultTimeLocale rfc822DateFormat . posixSecondsToUTCTime . fromIntegral . (read :: String -> Int) -feed :: Renderer m => String -> ArticlesList -> HtmlT m () +feed :: Renderer m => URL -> ArticlesList -> HtmlT m () feed siteURL al@(ArticlesList {collection}) = do prolog rss_ [version, content, atom] $ do channel_ $ do title_ . toHtml =<< Collection.title collection - link_ . toHtml $ siteURL maybe "" (++ "/") (tag collection) + link_ . toHtml $ siteURL ./ ArticlesList.path al description_ . toHtml =<< ArticlesList.description al mapM_ (articleItem siteURL) =<< getArticles al where @@ -82,7 +84,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 :: String -> Collection -> ReaderT Blog IO () +generateCollection :: URL -> Collection -> ReaderT Blog IO () generateCollection siteURL collection = renderTextT (feed siteURL $ ArticlesList {full = False, collection}) >>= liftIO . TextIO.writeFile (basePath collection "rss" <.> "xml")