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

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

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 $
+otherURL al@(ArticlesList {full}) = absoluteLink $
-  (if full then id else (</> "all.html")) . maybe "" id $ tag collection
+  (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

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 Network.URL (URL)
-import GHC.Generics (Generic)
 import Prelude hiding (head)
 import System.Directory (doesFileExist)
 import System.FilePath ((</>), (<.>))
 
 data Skin = Skin {
       banner :: Maybe String
-    , cardImage :: Maybe FilePath
+    , cardImage :: Maybe URL
-    , favicon :: Maybe FilePath
+    , 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 :: String -> Maybe FilePath -> IO (Maybe URL)
-findImage _ (Just path) = return . Just $ absoluteLink path
+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"]

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 Control.Monad.IO.Class (MonadIO(..))
-import GHC.Generics (Generic)
+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"
+  cards <- getURL (Just argOGCards) siteURL "Open Graph cards"
-  rss <- getSiteURL argRSS "RSS feeds"
+  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
+pathRelative :: String -> URL
-    checksUsed False (Just _) =
+pathRelative url_path = URL {url_type = PathRelative, url_path, url_params = []}
-      hPutStrLn stderr "Site url is set but not used, did you forget --open-graph-cards or --rss ?"
+
-    checksUsed _ _ = return ()
+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

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

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)
+    maybeImage = maybe (return ()) (og "image" . (siteURL //))
-    sitePrefix = pack . (siteURL </>)
 
-mDImage :: (Renderer m, MarkdownContent a ) => a -> m (Maybe String)
+mDImage :: (Renderer m, MarkdownContent a) => a -> m (Maybe URL)
-mDImage = return . Map.lookup "featuredImage" . metadata . getMarkdown
+mDImage = mapM checkURL . Map.lookup "featuredImage" . metadata . getMarkdown
 
 mDTitle :: (Renderer m, MarkdownContent a) => a -> m String
 mDTitle = return . Markdown.title . getMarkdown

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