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

Replace naive String implementation of URL by a proper type from an existing library; thus validating URLs handled by hablo

Browse source
This commit is contained in:
Tissevert 2021-03-28 23:37:42 +02:00
parent 0989b4cab3
commit 6a79533634
7 changed files with 89 additions and 41 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
hablo.cabal
View file

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

8
src/ArticlesList.hs
View file

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

23
src/Blog/Skin.hs
View file

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

62
src/Blog/URL.hs
View file

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

6
src/DOM.hs
View file

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

15
src/DOM/Card.hs
View file

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

14
src/RSS.hs
View file

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