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

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

This commit is contained in:
Tissevert 2021-05-02 16:49:05 +02:00
parent 75252dc236
commit f229a17bbb
13 changed files with 179 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
hablo.cabal
View File

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

7
src/ArticlesList.hs
View File

@ -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}) =

23
src/Blog/URL.hs
View File

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

81
src/DOM.hs
View File

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

6
src/DOM/Card.hs
View File

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

5
src/Files.hs
View File

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

4
src/HTML.hs
View File

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

6
src/RSS.hs
View File

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

16
test/Mock/Blog/URL.hs
View File

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

29
test/Mock/URL.hs
View File

@ -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 = []
}

2
test/Tests.hs
View File

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

69
test/URLs.hs
View File

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

18
test/XML/Favicon.hs
View File

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