diff --git a/hablo.cabal b/hablo.cabal index 189a17a..d2dadba 100644 --- a/hablo.cabal +++ b/hablo.cabal @@ -96,6 +96,7 @@ test-suite tests , Mock.Markdown , Mock.URL , Structure + , URLs , Utils , XML.Card , XML.Card.Component diff --git a/src/ArticlesList.hs b/src/ArticlesList.hs index df4a052..bada0ae 100644 --- a/src/ArticlesList.hs +++ b/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 al@(ArticlesList {full}) = absoluteLink $ - (if full then id else ( "all.html")) $ ArticlesList.path al +otherURL :: ArticlesList -> FilePath +otherURL (ArticlesList {full}) = if full then "." else "all.html" description :: Renderer m => ArticlesList -> m Text description (ArticlesList {full, collection}) = diff --git a/src/Blog/URL.hs b/src/Blog/URL.hs index abfc3e6..6836b40 100644 --- a/src/Blog/URL.hs +++ b/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 -(./) url = toText . setPath +pathOn :: AbsoluteURL -> FilePath -> Text +pathOn url = toText . setPath where setPath ('/':urlPath) = url {urlPath} setPath subPath = url {urlPath = urlPath url subPath} -(/?) :: AbsoluteURL -> URL -> Text -(/?) _ (URL {url_type = Absolute host, url_path, url_params}) = +defaultOn :: AbsoluteURL -> URL -> Text +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 diff --git a/src/DOM.hs b/src/DOM.hs index ab45475..d650fa8 100644 --- a/src/DOM.hs +++ b/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_ - , head_, header_, href_, li_, link_, id_, meta_, pre_, rel_, script_, src_ - , title_, toHtml, toHtmlRaw, type_, ul_ + Attribute, HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_ + , h1_, h2_, head_, header_, href_, li_, link_, id_, meta_, pre_, rel_ + , 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 - content = mDContent True . getMarkdown +instance PageType Article where + content = mDContent True ".." . getMarkdown + pathToRoot _ = ".." -instance HasContent Page where - content = mDContent True . getMarkdown +instance PageType Page where + 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 () -mDContent raw markdown@(Markdown {key, body}) = + pathToRoot = maybe "." (\_ -> "..") . Collection.tag . collection + +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 raw (Markdown {Markdown.path, title}) = - a_ [href_ $ pack url] $ toHtml title +mDLink :: Bool -> FilePath -> Markdown -> HtmlGenerator () +mDLink raw base (Markdown {Markdown.path, title}) = link $ 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 () -tag name = - a_ [href_ . pack $ absoluteLink name ++ "/", class_ "tag"] $ toHtml name +href :: FilePath -> FilePath -> Attribute +href base = href_ . pack . (base ) -defaultBanner :: HtmlGenerator () -defaultBanner = +tag :: FilePath -> String -> HtmlGenerator () +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 url = link_ [ - rel_ "shortcut icon", href_ . pack $ exportURL url, type_ "image/x-icon" +faviconLink :: FilePath -> URL -> HtmlGenerator () +faviconLink base url = link_ [ + 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 ) ) diff --git a/src/DOM/Card.hs b/src/DOM/Card.hs index dfef431..fa0739d 100644 --- a/src/DOM/Card.hs +++ b/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 diff --git a/src/Files.hs b/src/Files.hs index b6bec82..edfcceb 100644 --- a/src/Files.hs +++ b/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 diff --git a/src/HTML.hs b/src/HTML.hs index 8b684ca..0f2e9a7 100644 --- a/src/HTML.hs +++ b/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) diff --git a/src/RSS.hs b/src/RSS.hs index 63da43d..0f5b5fa 100644 --- a/src/RSS.hs +++ b/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 diff --git a/test/Mock/Blog/URL.hs b/test/Mock/Blog/URL.hs index 3fce356..1783ac3 100644 --- a/test/Mock/Blog/URL.hs +++ b/test/Mock/Blog/URL.hs @@ -4,27 +4,19 @@ module Mock.Blog.URL ( , subPath ) where -import Blog.URL (AbsoluteURL(..), URLs(..)) -import Mock.URL (testHost) +import Blog.URL (URLs(..)) +import Mock.URL (prefixedTestSite, testSite) simple :: URLs simple = URLs { - cards = Just (AbsoluteURL { - Blog.URL.host = testHost - , urlPath = "" - , urlParams = [] - }) + cards = Just testSite , comments = Nothing , rss = Nothing } subPath :: URLs subPath = URLs { - cards = Just (AbsoluteURL { - Blog.URL.host = testHost - , urlPath = "subPath" - , urlParams = [] - }) + cards = Just prefixedTestSite , comments = Nothing , rss = Nothing } diff --git a/test/Mock/URL.hs b/test/Mock/URL.hs index 4c761db..ae3668b 100644 --- a/test/Mock/URL.hs +++ b/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 = [] } diff --git a/test/Tests.hs b/test/Tests.hs index 20d28bd..5445ae7 100644 --- a/test/Tests.hs +++ b/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 ] diff --git a/test/URLs.hs b/test/URLs.hs index 60bd3be..8fe8b84 100644 --- a/test/URLs.hs +++ b/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 -test = tag "URLs" . testGroup "URLs handling" $ simpleTest <$> [ - ("nothing", return $ Finished Pass) +check :: Text -> Text -> IO Progress +check actual expected = + 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 ] diff --git a/test/XML/Favicon.hs b/test/XML/Favicon.hs index 4d1f4d8..bfcbbd7 100644 --- a/test/XML/Favicon.hs +++ b/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 - actual <- getter - assertAll $ [ - assertEqual "URLs" actual expected - ] +check getter expected = + withCurrentDirectory (testDataPath "XML/Favicon/Input") $ do + actual <- getter + 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)) ]