Remove dreadful absoluteLink, fix image URL + at-root-only blogs, test URL generation

hablo.cabal

@@ -96,6 +96,7 @@ test-suite tests
                      , Mock.Markdown
                      , Mock.URL
                      , Structure
+                     , URLs
                      , Utils
                      , XML.Card
                      , XML.Card.Component

src/ArticlesList.hs

@@ -15,9 +15,7 @@ import Blog (Blog(..), Renderer, Skin(..), template)
 import Collection (Collection(..))
 import Control.Monad.Reader (MonadReader, asks)
 import Data.Text (Text, pack)
-import Files (absoluteLink)
 import Pretty ((.$))
-import System.FilePath.Posix ((</>))
 
 data ArticlesList = ArticlesList {
       full :: Bool
@@ -29,9 +27,8 @@ getArticles (ArticlesList {full, collection = Collection {featured}}) = do
   limit <- take <$> (asks $skin.$previewArticlesCount)
   return $ if full then featured else limit featured
 
-otherURL :: ArticlesList -> String
+otherURL :: ArticlesList -> FilePath
-otherURL al@(ArticlesList {full}) = absoluteLink $
+otherURL (ArticlesList {full}) = if full then "." else "all.html"
-  (if full then id else (</> "all.html")) $ ArticlesList.path al
 
 description :: Renderer m => ArticlesList -> m Text
 description (ArticlesList {full, collection}) =

src/Blog/URL.hs

@@ -3,10 +3,11 @@
 module Blog.URL (
       AbsoluteURL(..)
     , URLs(..)
-    , (./)
-    , (/?)
     , build
     , checkURL
+    , defaultOn
+    , localPrefix
+    , pathOn
     , pathRelative
     , toText
   ) where
@@ -93,14 +94,20 @@ addParams url newParams = url {
     urlParams = unionBy ((==) `on` fst) newParams (urlParams url)
   }
 
-(./) :: AbsoluteURL -> FilePath -> Text
+pathOn :: AbsoluteURL -> FilePath -> Text
-(./) url = toText . setPath
+pathOn url = toText . setPath
   where setPath ('/':urlPath) = url {urlPath}
         setPath subPath = url {urlPath = urlPath url </> subPath}
 
-(/?) :: AbsoluteURL -> URL -> Text
+defaultOn :: AbsoluteURL -> URL -> Text
-(/?) _ (URL {url_type = Absolute host, url_path, url_params}) =
+defaultOn _ (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}) =
+defaultOn 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
+defaultOn url (URL {url_path, url_params}) =
+  pathOn (addParams url url_params) url_path
+
+localPrefix :: FilePath -> URL -> Text
+localPrefix base url = pack . prefix (url_type url) $ exportURL url
+  where prefix PathRelative = (base </>)
+        prefix _ = id

src/DOM.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 module DOM (
-      HasContent(..)
+      PageType(..)
     , htmlDocument
   ) where
 
@@ -11,44 +11,48 @@ import ArticlesList (
     ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
   )
 import Blog (Blog(..), Skin(..), URLs(..), template)
+import Blog.URL (localPrefix)
+import qualified Collection (tag)
 import Control.Monad.Reader (ReaderT, asks)
 import Data.Map as Map (Map, toList)
 import Data.Text (Text, pack, empty)
 import DOM.Card (HasCard)
 import qualified DOM.Card as Card (make)
-import Files (absoluteLink)
 import Lucid (
-      HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_, h1_, h2_
+      Attribute, HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_
-    , head_, header_, href_, li_, link_, id_, meta_, pre_, rel_, script_, src_
+    , h1_, h2_, head_, header_, href_, li_, link_, id_, meta_, pre_, rel_
-    , title_, toHtml, toHtmlRaw, type_, ul_
+    , script_, src_, title_, toHtml, toHtmlRaw, type_, ul_
   )
 import Markdown (Markdown(..), MarkdownContent(..))
-import Network.URL (URL, exportURL)
+import Network.URL (URL)
 import Page (Page)
 import Prelude hiding (head, lookup)
 import Pretty ((.$))
-import System.FilePath.Posix ((<.>))
+import System.FilePath.Posix ((</>), (<.>))
 
 type HtmlGenerator = HtmlT (ReaderT Blog IO)
 
-class HasCard a => HasContent a where
+class HasCard a => PageType a where
   content :: a -> HtmlGenerator ()
+  pathToRoot :: a -> FilePath
 
-instance HasContent Article where
+instance PageType Article where
-  content = mDContent True . getMarkdown
+  content = mDContent True ".." . getMarkdown
+  pathToRoot _ = ".."
 
-instance HasContent Page where
+instance PageType Page where
-  content = mDContent True . getMarkdown
+  content = mDContent True ".." . getMarkdown
+  pathToRoot _ = ".."
 
-instance HasContent ArticlesList where
+instance PageType ArticlesList where
   content al@(ArticlesList {full}) = do
     preview <- Article.preview <$> (asks $skin.$previewLinesCount)
     h2_ . toHtml =<< description al
     ul_ $ do
       asks hasRSS >>= rssLink
-      li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink
+      li_ . a_ [href "" $ otherURL al, class_ "other"] =<< otherLink
     div_ [class_ "articles"] (
-        mapM_ (mDContent False . preview) =<< getArticles al
+        mapM_ (mDContent False (pathToRoot al) . preview) =<< getArticles al
       )
     where
       otherLink =
@@ -59,34 +63,38 @@ instance HasContent ArticlesList where
         li_ . a_ [href_ "rss.xml", class_ "RSS", title_ title] $ toHtml text
       rssLink False = return ()
 
-mDContent :: Bool -> Markdown -> HtmlGenerator ()
+  pathToRoot = maybe "." (\_ -> "..") . Collection.tag . collection
-mDContent raw markdown@(Markdown {key, body}) =
+
+mDContent :: Bool -> FilePath -> Markdown -> HtmlGenerator ()
+mDContent raw base markdown@(Markdown {key, body}) =
   article_ [id_ $ pack key] (do
-      header_ . h1_ $ mDLink raw markdown
+      header_ . h1_ $ mDLink raw base markdown
       pre_ . toHtml $ unlines body
     )
 
-mDLink :: Bool -> Markdown -> HtmlGenerator ()
+mDLink :: Bool -> FilePath -> Markdown -> HtmlGenerator ()
-mDLink raw (Markdown {Markdown.path, title}) =
+mDLink raw base (Markdown {Markdown.path, title}) = link $ toHtml title
-  a_ [href_ $ pack url] $ toHtml title
   where
-    url = absoluteLink $ path <.> (if raw then "md" else "html")
+    link = a_ [href base $ path <.> (if raw then "md" else "html")]
 
-tag :: String -> HtmlGenerator ()
+href :: FilePath -> FilePath -> Attribute
-tag name =
+href base = href_ . pack . (base </>)
-  a_ [href_ . pack $ absoluteLink name ++ "/", class_ "tag"] $ toHtml name
 
-defaultBanner :: HtmlGenerator ()
+tag :: FilePath -> String -> HtmlGenerator ()
-defaultBanner =
+tag base name =
+  a_ [href base $ name ++ "/", class_ "tag"] $ toHtml name
+
+defaultBanner :: FilePath -> HtmlGenerator ()
+defaultBanner base =
   div_ [id_ "header"] (
-      a_ [href_ "/"] (
+      a_ [href_ $ pack base] (
           h1_ . toHtml =<< asks name
         )
     )
 
-faviconLink :: URL -> HtmlGenerator ()
+faviconLink :: FilePath -> URL -> HtmlGenerator ()
-faviconLink url = link_ [
+faviconLink base url = link_ [
-    rel_ "shortcut icon", href_ . pack $ exportURL url, type_ "image/x-icon"
+    rel_ "shortcut icon", href_ $ localPrefix base url, type_ "image/x-icon"
   ]
 
 optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator ()
@@ -102,24 +110,25 @@ navigationSection sectionId templateKey generator collection
           ul_ . mapM_  (li_ . generator) $ Map.toList collection
         )
 
-htmlDocument :: HasContent a => a -> HtmlGenerator ()
+htmlDocument :: PageType a => a -> HtmlGenerator ()
 htmlDocument someContent =
+  let base = pathToRoot someContent in
   doctypehtml_ (do
       head_ (do
           meta_ [charset_ "utf-8"]
           title_ . toHtml =<< asks name
           script_ [src_ "/js/remarkable.min.js"] empty
           script_ [src_ "/js/hablo.js"] empty
-          optional faviconLink =<< (asks $skin.$favicon)
+          optional (faviconLink base) =<< (asks $skin.$favicon)
           optional (Card.make someContent) =<< (asks $urls.$cards)
           optional toHtmlRaw =<< (asks $skin.$head)
         )
       body_ (do
-          maybe defaultBanner toHtmlRaw =<< (asks $skin.$banner)
+          maybe (defaultBanner base) toHtmlRaw =<< (asks $skin.$banner)
           asks tags >>= navigationSection "tags" "tagsList"
-                          (\(key, _) -> tag key)
+                          (\(key, _) -> tag base key)
           asks pages >>= navigationSection "pages" "pagesList"
-                          (\(_, page) -> mDLink False $ getMarkdown page)
+                          (\(_, page) -> mDLink False base $ getMarkdown page)
           div_ [id_ "contents"] $ content someContent
         )
     )

src/DOM/Card.hs

@@ -10,7 +10,7 @@ import Article (Article(..))
 import ArticlesList (ArticlesList(..))
 import qualified ArticlesList (description)
 import Blog (Blog(..), Renderer, Skin(..), template)
-import Blog.URL ((./), (/?), AbsoluteURL, checkURL)
+import Blog.URL (AbsoluteURL, checkURL, defaultOn, pathOn)
 import Collection (Collection(..))
 import qualified Collection (title)
 import Control.Applicative ((<|>))
@@ -42,14 +42,14 @@ og attribute value =
 
 make :: (HasCard a, Renderer m) => a -> AbsoluteURL -> HtmlT m ()
 make element siteURL = do
-  og "url" . (siteURL ./) =<< urlPath element
+  og "url" . (pathOn 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" . (siteURL /?))
+    maybeImage = maybe (return ()) (og "image" . defaultOn siteURL)
 
 mDImage :: (Renderer m, MarkdownContent a) => a -> m (Maybe URL)
 mDImage = mapM checkURL . Map.lookup "featuredImage" . metadata . getMarkdown

src/Files.hs

@@ -1,6 +1,5 @@
 module Files (
       File(..)
-    , absoluteLink
     , filePath
     , find
   ) where
@@ -10,10 +9,6 @@ import System.FilePath ((</>))
 
 data File = File FilePath | Dir FilePath
 
-absoluteLink :: FilePath -> FilePath
-absoluteLink ('.':path) = path
-absoluteLink path = "/" </> path
-
 filePath :: File -> IO (Either String FilePath)
 filePath = filePathAux
   where

src/HTML.hs

@@ -12,7 +12,7 @@ import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Reader (ReaderT, asks)
 import qualified Data.Map as Map (elems)
 import qualified Data.Text.Lazy.IO as TextIO (writeFile)
-import DOM (HasContent, htmlDocument)
+import DOM (PageType, htmlDocument)
 import Lucid (renderTextT)
 import Markdown (Markdown(..), MarkdownContent(..))
 import Pretty ((.$))
@@ -26,7 +26,7 @@ articlesLists collection@(Collection {basePath}) = [
     file bool = if bool then "all" else "index"
     path bool = basePath </> file bool <.> "html"
 
-generateMarkdown :: (HasContent a, MarkdownContent a) => [a] -> ReaderT Blog IO ()
+generateMarkdown :: (PageType a, MarkdownContent a) => [a] -> ReaderT Blog IO ()
 generateMarkdown = mapM_ $ \content -> do
   let relativePath = Markdown.path (getMarkdown content) <.> "html"
   filePath <- (</> relativePath) <$> (asks $Blog.path.$root)

src/RSS.hs

@@ -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 ((./), AbsoluteURL)
+import Blog.URL (AbsoluteURL, pathOn)
 import Collection (Collection(..), getAll)
 import qualified Collection (title)
 import Control.Monad.IO.Class (MonadIO(..))
@@ -62,7 +62,7 @@ articleItem :: Monad m => AbsoluteURL -> Article -> HtmlT m ()
 articleItem siteURL (Article (Markdown {path, metadata, title})) =
   item_ $ do
     title_ $ toHtml title
-    link_ . toHtml $ siteURL ./ (path <.> "html")
+    link_ . toHtml $ pathOn siteURL (path <.> "html")
     pubDate_ . toHtml . rfc822Date $ metadata ! "date"
   where
     rfc822Date =
@@ -75,7 +75,7 @@ feed siteURL al@(ArticlesList {collection}) = do
   rss_ [version, content, atom] $ do
     channel_ $ do
       title_ . toHtml =<< Collection.title collection
-      link_ . toHtml $ siteURL ./ ArticlesList.path al
+      link_ . toHtml . pathOn siteURL $ ArticlesList.path al
       description_ . toHtml =<< ArticlesList.description al
       mapM_ (articleItem siteURL) =<< getArticles al
   where

test/Mock/Blog/URL.hs

@@ -4,27 +4,19 @@ module Mock.Blog.URL (
     , subPath
   ) where
 
-import Blog.URL (AbsoluteURL(..), URLs(..))
+import Blog.URL (URLs(..))
-import Mock.URL (testHost)
+import Mock.URL (prefixedTestSite, testSite)
 
 simple :: URLs
 simple = URLs {
-      cards = Just (AbsoluteURL {
+      cards = Just testSite
-            Blog.URL.host = testHost
-          , urlPath = ""
-          , urlParams = []
-        })
     , comments = Nothing
     , rss = Nothing
   }
 
 subPath :: URLs
 subPath = URLs {
-      cards = Just (AbsoluteURL {
+      cards = Just prefixedTestSite
-            Blog.URL.host = testHost
-          , urlPath = "subPath"
-          , urlParams = []
-        })
     , comments = Nothing
     , rss = Nothing
   }

test/Mock/URL.hs

@@ -1,15 +1,33 @@
 module Mock.URL (
       cdnFavicon
+    , hostFavicon
     , localDiscovered
     , localFavicon
+    , prefixedTestSite
     , testHost
+    , testSite
   ) where
 
+import Blog.URL (AbsoluteURL(..))
 import Network.URL (Host(..), Protocol(..), URL(..), URLType(..))
 
 testHost :: Host
 testHost = Host (HTTP True) "test.net" Nothing
 
+testSite :: AbsoluteURL
+testSite = AbsoluteURL {
+      Blog.URL.host = testHost
+    , urlPath = ""
+    , urlParams = []
+  }
+
+prefixedTestSite :: AbsoluteURL
+prefixedTestSite = AbsoluteURL {
+        Blog.URL.host = testHost
+      , urlPath = "subPath"
+      , urlParams = []
+  }
+
 cdn :: Host
 cdn = Host (HTTP True) "cdn.net" Nothing
 
@@ -20,16 +38,23 @@ cdnFavicon = URL {
     , url_params = []
   }
 
+hostFavicon :: URL
+hostFavicon = URL {
+      url_type = HostRelative
+    , url_path = "favicon.png"
+    , url_params = []
+  }
+
 localFavicon :: URL
 localFavicon = URL {
-      url_type = HostRelative
+      url_type = PathRelative
     , url_path = "favicon.png"
     , url_params = []
   }
 
 localDiscovered :: URL
 localDiscovered = URL {
-      url_type = HostRelative
+      url_type = PathRelative
     , url_path = "skin/favicon.png"
     , url_params = []
   }

test/Tests.hs

@@ -4,6 +4,7 @@ module Tests (
 
 import Distribution.TestSuite
 import qualified Structure (test)
+import qualified URLs (test)
 import Utils (tag)
 import qualified XML.Card (test)
 import qualified XML.Favicon (test)
@@ -13,4 +14,5 @@ tests = return $ tag "xml" <$> [
       XML.Card.test
     , XML.Favicon.test
     , Structure.test
+    , URLs.test
   ]

test/URLs.hs

@@ -1,12 +1,73 @@
+{-# LANGUAGE OverloadedStrings #-}
 module URLs (
     test
   ) where
 
-import Blog.URL (URL(..))
+import Blog.URL (defaultOn, pathOn, localPrefix)
+import Data.Text (Text)
 import Distribution.TestSuite
+import Mock.URL (
+      cdnFavicon, hostFavicon, localDiscovered, localFavicon, prefixedTestSite
+    , testSite
+  )
 import Utils (simpleTest, tag)
 
-test :: Test
+check :: Text -> Text -> IO Progress
-test = tag "URLs" . testGroup "URLs handling" $ simpleTest <$> [
+check actual expected =
-    ("nothing", return $ Finished Pass)
+  return . Finished $
+    if actual == expected
+    then Pass
+    else Fail $ "Expected " ++ show expected ++ " but got " ++ show actual
+
+testPathOn :: Test
+testPathOn = tag "pathOn" . testGroup "Concat path" $ simpleTest <$> [
+      ("no prefix / relative path",
+        check (pathOn testSite "tag/all.html") "https://test.net/tag/all.html")
+    , ("no prefix / absolute path",
+        check
+          (pathOn testSite "/media/logo.png")
+          "https://test.net/media/logo.png")
+    , ("prefixed / relative path",
+        check
+          (pathOn prefixedTestSite "tag/all.html")
+          "https://test.net/subPath/tag/all.html")
+    , ("prefixed / absolute path ",
+        check
+          (pathOn prefixedTestSite "/media/logo.png")
+          "https://test.net/media/logo.png")
+  ]
+
+testDefaultOn :: Test
+testDefaultOn = tag "defaultOn" . testGroup "Concat path or pick URL" $ simpleTest <$> [
+      ("external resource", -- shouldn't even touch the first argument when the second is an absolute URL
+        check (defaultOn undefined cdnFavicon) "https://cdn.net/favicon.png")
+    , ("host relative",
+        check (defaultOn testSite hostFavicon) "https://test.net/favicon.png")
+    , ("host relative / prefix",
+        check
+          (defaultOn prefixedTestSite hostFavicon)
+          "https://test.net/favicon.png")
+    , ("relative",
+        check
+          (defaultOn testSite localDiscovered)
+          "https://test.net/skin/favicon.png")
+    , ("relative / prefix",
+        check
+          (defaultOn prefixedTestSite localDiscovered)
+          "https://test.net/subPath/skin/favicon.png")
+  ]
+
+testLocalPrefix :: Test
+testLocalPrefix = tag "localPrefix" . testGroup "Prefixed URLs" $ simpleTest <$> [
+      ("absolute URL", check (localPrefix ".." cdnFavicon) "https://cdn.net/favicon.png")
+    , ("host relative", check (localPrefix ".." hostFavicon) "/favicon.png")
+    , ("relative path", check (localPrefix ".." localDiscovered) "../skin/favicon.png")
+    , ("relative path no prefix", check (localPrefix "" localFavicon) "favicon.png")
+  ]
+
+test :: Test
+test = tag "URLs" $ testGroup "URLs handling" [
+      testPathOn
+    , testDefaultOn
+    , testLocalPrefix
   ]

test/XML/Favicon.hs

@@ -4,22 +4,24 @@ module XML.Favicon (
 
 import Blog.Skin (findImage)
 import Distribution.TestSuite
-import Mock.URL (cdnFavicon, localDiscovered, localFavicon)
+import Mock.URL (cdnFavicon, hostFavicon, localDiscovered, localFavicon)
 import Network.URL (URL)
-import Utils (assertAll, assertEqual, simpleTest, tag)
+import System.Directory (withCurrentDirectory)
+import Utils (assertAll, assertEqual, simpleTest, tag, testDataPath)
 
 check :: IO (Maybe URL) -> Maybe URL -> IO Progress
-check getter expected = do
+check getter expected =
-  actual <- getter
+  withCurrentDirectory (testDataPath "XML/Favicon/Input") $ do
-  assertAll $ [
+    actual <- getter
-      assertEqual "URLs" actual expected
+    assertAll $ [
-    ]
+        assertEqual "URLs" actual expected
+      ]
 
 test :: Test
 test = tag "favicon" . testGroup "Favicons" $ simpleTest <$> [
       ("auto-discover", check (findImage "favicon" Nothing) (Just localDiscovered))
     , ("none", check (findImage "blerp" Nothing) Nothing)
     , ("manual absolute", check (findImage "" (Just "https://cdn.net/favicon.png")) (Just cdnFavicon))
+    , ("manual host-relative", check (findImage "" (Just "/favicon.png")) (Just hostFavicon))
     , ("manual relative", check (findImage "" (Just "favicon.png")) (Just localFavicon))
-    , ("manual host-relative", check (findImage "" (Just "/favicon.png")) (Just localFavicon))
   ]