Compare commits

...

12 commits

24 changed files with 407 additions and 119 deletions

View file

@ -51,7 +51,7 @@ library
, RSS , RSS
-- other-extensions: -- other-extensions:
build-depends: aeson >= 1.2.0 && < 1.6 build-depends: aeson >= 1.2.0 && < 1.6
, base >= 4.9.1 && < 4.15 , base >= 4.9.1 && < 4.16
, bytestring >= 0.10.8 && < 0.12 , bytestring >= 0.10.8 && < 0.12
, containers >= 0.5.11 && < 0.7 , containers >= 0.5.11 && < 0.7
, directory >= 1.3.1 && < 1.4 , directory >= 1.3.1 && < 1.4
@ -65,6 +65,7 @@ library
, time >= 1.8.0 && < 1.12 , time >= 1.8.0 && < 1.12
, SJW >= 0.1.2 && < 0.2 , SJW >= 0.1.2 && < 0.2
, unix >= 2.7.2 && < 2.8 , unix >= 2.7.2 && < 2.8
, url >= 2.1.3 && < 2.2
ghc-options: -Wall ghc-options: -Wall
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
@ -73,9 +74,9 @@ executable hablo
main-is: src/Main.hs main-is: src/Main.hs
other-modules: Paths_hablo other-modules: Paths_hablo
-- other-extensions: -- other-extensions:
build-depends: base >= 4.9.1 && < 4.15 build-depends: base
, hablo , hablo
, mtl >= 2.2.2 && < 2.3 , mtl
ghc-options: -Wall ghc-options: -Wall
default-language: Haskell2010 default-language: Haskell2010
@ -93,11 +94,14 @@ test-suite tests
, Mock.Blog.Wording , Mock.Blog.Wording
, Mock.Collection , Mock.Collection
, Mock.Markdown , Mock.Markdown
, Mock.URL
, Structure , Structure
, URLs
, Utils , Utils
, XML.Card , XML.Card
, XML.Card.Component , XML.Card.Component
, XML.Card.Output , XML.Card.Output
, XML.Favicon
build-depends: base build-depends: base
, Cabal , Cabal
, containers , containers
@ -107,6 +111,7 @@ test-suite tests
, lucid , lucid
, mtl , mtl
, text , text
, url
hs-source-dirs: test hs-source-dirs: test
ghc-options: -Wall ghc-options: -Wall
default-language: Haskell2010 default-language: Haskell2010

View file

@ -6,6 +6,7 @@ module ArticlesList (
, description , description
, getArticles , getArticles
, otherURL , otherURL
, ArticlesList.path
, rssLinkTexts , rssLinkTexts
) where ) where
@ -14,9 +15,7 @@ import Blog (Blog(..), Renderer, Skin(..), template)
import Collection (Collection(..)) import Collection (Collection(..))
import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Reader (MonadReader, asks)
import Data.Text (Text, pack) import Data.Text (Text, pack)
import Files (absoluteLink)
import Pretty ((.$)) import Pretty ((.$))
import System.FilePath.Posix ((</>))
data ArticlesList = ArticlesList { data ArticlesList = ArticlesList {
full :: Bool full :: Bool
@ -28,9 +27,8 @@ getArticles (ArticlesList {full, collection = Collection {featured}}) = do
limit <- take <$> (asks $skin.$previewArticlesCount) limit <- take <$> (asks $skin.$previewArticlesCount)
return $ if full then featured else limit featured return $ if full then featured else limit featured
otherURL :: ArticlesList -> String otherURL :: ArticlesList -> FilePath
otherURL (ArticlesList {full, collection}) = absoluteLink $ otherURL (ArticlesList {full}) = if full then "." else "all.html"
(if full then id else (</> "all.html")) . maybe "" id $ tag collection
description :: Renderer m => ArticlesList -> m Text description :: Renderer m => ArticlesList -> m Text
description (ArticlesList {full, collection}) = description (ArticlesList {full, collection}) =
@ -46,3 +44,6 @@ rssLinkTexts (ArticlesList {collection}) = do
return (text, title) return (text, title)
where where
environment = maybe [] (\v -> [("tag", pack v)]) $ tag collection environment = maybe [] (\v -> [("tag", pack v)]) $ tag collection
path :: ArticlesList -> FilePath
path = maybe "" id . tag . collection

View file

@ -6,7 +6,7 @@ module Blog (
, Path(..) , Path(..)
, Renderer , Renderer
, Skin(..) , Skin(..)
, URL(..) , URLs(..)
, Wording , Wording
, build , build
, template , template
@ -22,7 +22,7 @@ import Blog.Template (Environment, Templates, render)
import qualified Blog.Template as Template (build) import qualified Blog.Template as Template (build)
import Blog.Skin (Skin(..)) import Blog.Skin (Skin(..))
import qualified Blog.Skin as Skin (build) import qualified Blog.Skin as Skin (build)
import Blog.URL (URL(..)) import Blog.URL (URLs(..))
import qualified Blog.URL as URL (build) import qualified Blog.URL as URL (build)
import Blog.Wording (Wording) import Blog.Wording (Wording)
import qualified Blog.Wording as Wording (build) import qualified Blog.Wording as Wording (build)
@ -57,7 +57,7 @@ data Blog = Blog {
, skin :: Skin , skin :: Skin
, tags :: Collection (Set String) , tags :: Collection (Set String)
, templates :: Templates , templates :: Templates
, urls :: URL , urls :: URLs
, wording :: Wording , wording :: Wording
} }

View file

@ -1,45 +1,49 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Blog.Skin ( module Blog.Skin (
Skin(..) Skin(..)
, build , build
, findImage
) where ) where
import Arguments (Arguments) import Arguments (Arguments)
import qualified Arguments (bannerPath, favicon, cardImage, headPath, previewArticlesCount, previewLinesCount) import qualified Arguments (bannerPath, favicon, cardImage, headPath, previewArticlesCount, previewLinesCount)
import Blog.URL (checkURL, pathRelative)
import Control.Monad (filterM) import Control.Monad (filterM)
import Data.Aeson (ToJSON(..), (.=), pairs) import Data.Aeson (ToJSON(..), (.=), object, pairs)
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
#if !MIN_VERSION_base(4,11,0) #if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
#endif #endif
import Files (absoluteLink) import Network.URL (URL)
import GHC.Generics (Generic)
import Prelude hiding (head) import Prelude hiding (head)
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import System.FilePath ((</>), (<.>)) import System.FilePath ((</>), (<.>))
data Skin = Skin { data Skin = Skin {
banner :: Maybe String banner :: Maybe String
, cardImage :: Maybe FilePath , cardImage :: Maybe URL
, favicon :: Maybe FilePath , favicon :: Maybe URL
, head :: Maybe String , head :: Maybe String
, previewArticlesCount :: Int , previewArticlesCount :: Int
, previewLinesCount :: Int , previewLinesCount :: Int
} deriving Generic }
instance ToJSON Skin where instance ToJSON Skin where
toJSON (Skin {previewArticlesCount, previewLinesCount}) = object [
("previewArticlesCount", toJSON previewArticlesCount)
, ("previewLinesCount", toJSON previewLinesCount)
]
toEncoding (Skin {previewArticlesCount, previewLinesCount}) = pairs ( toEncoding (Skin {previewArticlesCount, previewLinesCount}) = pairs (
"previewArticlesCount" .= previewArticlesCount "previewArticlesCount" .= previewArticlesCount
<> "previewLinesCount" .= previewLinesCount <> "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 = findImage name Nothing =
listToMaybe <$> filterM doesFileExist pathsToCheck fmap pathRelative . listToMaybe <$> filterM doesFileExist pathsToCheck
where where
directories = [".", "image", "images", "pictures", "skin", "static"] directories = [".", "image", "images", "pictures", "skin", "static"]
extensions = ["ico", "gif", "jpeg", "jpg", "png", "svg"] extensions = ["ico", "gif", "jpeg", "jpg", "png", "svg"]

View file

@ -1,45 +1,113 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Blog.URL ( module Blog.URL (
URL(..) AbsoluteURL(..)
, URLs(..)
, build , build
, checkURL
, defaultOn
, localPrefix
, pathOn
, pathRelative
, toText
) where ) where
import Arguments (Arguments) import Arguments (Arguments)
import qualified Arguments as 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.Function (on)
import Data.List (unionBy)
import Data.Text (Text, pack)
import Network.URL (Host, URL(..), URLType(..), exportURL, importURL)
import System.Exit (die) import System.Exit (die)
import System.IO (hPutStrLn, stderr) import System.IO (hPutStrLn, stderr)
import System.FilePath ((</>))
import Text.Printf (printf) import Text.Printf (printf)
data URL = URL { data AbsoluteURL = AbsoluteURL {
cards :: Maybe String host :: Host
, comments :: Maybe String , urlPath :: FilePath
, rss :: Maybe String , urlParams :: [(String, String)]
} deriving Generic }
instance ToJSON URL where toText :: AbsoluteURL -> Text
toEncoding (URL {comments}) = pairs ( toText (AbsoluteURL {host, urlPath, urlParams}) =
"comments" .= comments pack . exportURL $ URL (Absolute host) urlPath urlParams
data URLs = URLs {
cards :: Maybe AbsoluteURL
, comments :: Maybe AbsoluteURL
, rss :: Maybe AbsoluteURL
}
instance ToJSON URLs where
toJSON (URLs {comments}) = object [
("comments", toJSON (toText <$> comments))
]
toEncoding (URLs {comments}) = pairs (
"comments" .= (toText <$> comments)
) )
build :: Arguments -> IO URL checkURL :: MonadIO m => String -> m URL
checkURL url =
maybe (liftIO . die $ printf "Invalid URL %s" url) pure $ importURL url
checkAbsolute :: MonadIO m => URL -> m AbsoluteURL
checkAbsolute (URL {url_type = Absolute host, url_path, url_params}) =
pure $ AbsoluteURL host url_path url_params
checkAbsolute url =
liftIO . die . printf "%s is not an absolute URL" $ exportURL 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 -> IO (Maybe AbsoluteURL) -> IO (Maybe AbsoluteURL)
getURL Nothing (Just url) _ = Just <$> (checkAbsolute =<< checkURL url)
getURL (Just True) Nothing failure = failure
getURL (Just True) (Just url) _ = Just <$> (checkAbsolute =<< checkURL url)
getURL _ _ _ = pure Nothing
build :: Arguments -> IO URLs
build arguments = do build arguments = do
cards <- getSiteURL argOGCards "Open Graph cards" cards <- getURL (Just argOGCards) siteURL (failBecauseOf "Open Graph cards")
rss <- getSiteURL argRSS "RSS feeds" rss <- getURL (Just argRSS) siteURL (failBecauseOf "RSS feeds")
comments <- getURL Nothing commentsURL (pure Nothing)
checksUsed (argOGCards || argRSS) siteURL checksUsed (argOGCards || argRSS) siteURL
return $ URL {cards, comments, rss} return $ URLs {cards, comments, rss}
where where
comments = Arguments.commentsURL arguments commentsURL = Arguments.commentsURL arguments
siteURL = Arguments.siteURL arguments siteURL = Arguments.siteURL arguments
argOGCards = Arguments.openGraphCards arguments argOGCards = Arguments.openGraphCards arguments
argRSS = Arguments.rss arguments argRSS = Arguments.rss arguments
errorMsg :: String -> String failBecauseOf :: String -> IO a
errorMsg = printf "Enabling %s requires setting the site url with --site-url" failBecauseOf =
getSiteURL False _ = return Nothing die . printf "Enabling %s requires setting the site url with --site-url"
getSiteURL True name = maybe (die $ errorMsg name) (return . Just) siteURL
checksUsed False (Just _) = pathRelative :: String -> URL
hPutStrLn stderr "Site url is set but not used, did you forget --open-graph-cards or --rss ?" pathRelative url_path = URL {url_type = PathRelative, url_path, url_params = []}
checksUsed _ _ = return ()
addParams :: AbsoluteURL -> [(String, String)] -> AbsoluteURL
addParams url newParams = url {
urlParams = unionBy ((==) `on` fst) newParams (urlParams url)
}
pathOn :: AbsoluteURL -> FilePath -> Text
pathOn url = toText . setPath
where setPath ('/':urlPath) = url {urlPath}
setPath subPath = url {urlPath = urlPath url </> subPath}
defaultOn :: AbsoluteURL -> URL -> Text
defaultOn _ (URL {url_type = Absolute host, url_path, url_params}) =
toText $ AbsoluteURL host url_path url_params
defaultOn url (URL {url_type = HostRelative, url_path, url_params}) =
toText $ addParams (url {urlPath = url_path}) url_params
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

View file

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

View file

@ -10,6 +10,7 @@ import Article (Article(..))
import ArticlesList (ArticlesList(..)) import ArticlesList (ArticlesList(..))
import qualified ArticlesList (description) import qualified ArticlesList (description)
import Blog (Blog(..), Renderer, Skin(..), template) import Blog (Blog(..), Renderer, Skin(..), template)
import Blog.URL (AbsoluteURL, checkURL, defaultOn, pathOn)
import Collection (Collection(..)) import Collection (Collection(..))
import qualified Collection (title) import qualified Collection (title)
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
@ -19,6 +20,7 @@ import Data.Text (Text, pack)
import Lucid (HtmlT, content_, meta_) import Lucid (HtmlT, content_, meta_)
import Lucid.Base (makeAttribute) import Lucid.Base (makeAttribute)
import Markdown (MarkdownContent(..), metadata) import Markdown (MarkdownContent(..), metadata)
import Network.URL (URL)
import qualified Markdown (Markdown(..)) import qualified Markdown (Markdown(..))
import Page (Page(..)) import Page (Page(..))
import Pretty ((.$)) import Pretty ((.$))
@ -27,7 +29,7 @@ import System.FilePath.Posix ((</>), (<.>))
class HasCard a where class HasCard a where
cardType :: Renderer m => a -> m Text cardType :: Renderer m => a -> m Text
description :: 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 title :: Renderer m => a -> m String
urlPath :: Renderer m => a -> m String urlPath :: Renderer m => a -> m String
@ -38,20 +40,19 @@ og attribute value =
, content_ value , content_ value
] ]
make :: (HasCard a, Renderer m) => a -> String -> HtmlT m () make :: (HasCard a, Renderer m) => a -> AbsoluteURL -> HtmlT m ()
make element siteURL = do make element siteURL = do
og "url" . sitePrefix =<< urlPath element og "url" . (pathOn siteURL) =<< urlPath element
og "type" =<< cardType element og "type" =<< cardType element
og "title" . pack =<< title element og "title" . pack =<< title element
og "description" =<< description element og "description" =<< description element
maybeImage =<< ((<|>) <$> image element <*> (asks $skin.$cardImage)) maybeImage =<< ((<|>) <$> image element <*> (asks $skin.$cardImage))
og "site_name" =<< (asks $name.$pack) og "site_name" =<< (asks $name.$pack)
where where
maybeImage = maybe (return ()) (og "image" . sitePrefix) maybeImage = maybe (return ()) (og "image" . defaultOn 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 :: (Renderer m, MarkdownContent a) => a -> m String
mDTitle = return . Markdown.title . getMarkdown mDTitle = return . Markdown.title . getMarkdown

View file

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

View file

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

View file

@ -4,7 +4,7 @@ module JSON (
exportBlog exportBlog
) where ) where
import Blog (Blog, Path, Skin, URL, Wording) import Blog (Blog, Path, Skin, URLs, Wording)
import qualified Blog (Blog(..)) import qualified Blog (Blog(..))
import Data.Aeson (Options(..), ToJSON(..), genericToEncoding, defaultOptions) import Data.Aeson (Options(..), ToJSON(..), genericToEncoding, defaultOptions)
import Data.Map (Map, mapWithKey) import Data.Map (Map, mapWithKey)
@ -39,7 +39,7 @@ data BlogExport = BlogExport {
, pages :: Map String MarkdownExport , pages :: Map String MarkdownExport
, skin :: Skin , skin :: Skin
, tags :: Map String [String] , tags :: Map String [String]
, urls :: URL , urls :: URLs
, wording :: Wording , wording :: Wording
} deriving (Generic) } deriving (Generic)

View file

@ -7,12 +7,13 @@ module RSS (
import Article (Article(..)) import Article (Article(..))
import ArticlesList (ArticlesList(..), getArticles) import ArticlesList (ArticlesList(..), getArticles)
import qualified ArticlesList (description) import qualified ArticlesList (description, path)
import Blog (Blog(urls), Renderer, URL(..)) import Blog (Blog(urls), Renderer, URLs(..))
import Blog.URL (AbsoluteURL, pathOn)
import Collection (Collection(..), getAll) import Collection (Collection(..), getAll)
import qualified Collection (title) import qualified Collection (title)
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (MonadReader, ReaderT, asks) import Control.Monad.Reader (ReaderT, asks)
import Data.Text (Text) import Data.Text (Text)
import Data.Map ((!)) import Data.Map ((!))
import qualified Data.Text.Lazy.IO as TextIO (writeFile) import qualified Data.Text.Lazy.IO as TextIO (writeFile)
@ -57,24 +58,24 @@ item_ = term "item"
pubDate_ :: Term arg result => arg -> result pubDate_ :: Term arg result => arg -> result
pubDate_ = term "pubDate" pubDate_ = term "pubDate"
articleItem :: MonadReader Blog m => String -> Article -> HtmlT m () articleItem :: Monad m => AbsoluteURL -> Article -> HtmlT m ()
articleItem siteURL (Article (Markdown {path, metadata, title})) = articleItem siteURL (Article (Markdown {path, metadata, title})) =
item_ $ do item_ $ do
title_ $ toHtml title title_ $ toHtml title
link_ $ toHtml (siteURL </> path <.> "html") link_ . toHtml $ pathOn siteURL (path <.> "html")
pubDate_ . toHtml . rfc822Date $ metadata ! "date" pubDate_ . toHtml . rfc822Date $ metadata ! "date"
where where
rfc822Date = rfc822Date =
formatTime defaultTimeLocale rfc822DateFormat formatTime defaultTimeLocale rfc822DateFormat
. posixSecondsToUTCTime . fromIntegral . (read :: String -> Int) . posixSecondsToUTCTime . fromIntegral . (read :: String -> Int)
feed :: Renderer m => String -> ArticlesList -> HtmlT m () feed :: Renderer m => AbsoluteURL -> ArticlesList -> HtmlT m ()
feed siteURL al@(ArticlesList {collection}) = do feed siteURL al@(ArticlesList {collection}) = do
prolog prolog
rss_ [version, content, atom] $ do rss_ [version, content, atom] $ do
channel_ $ do channel_ $ do
title_ . toHtml =<< Collection.title collection title_ . toHtml =<< Collection.title collection
link_ . toHtml $ siteURL </> maybe "" (++ "/") (tag collection) link_ . toHtml . pathOn siteURL $ ArticlesList.path al
description_ . toHtml =<< ArticlesList.description al description_ . toHtml =<< ArticlesList.description al
mapM_ (articleItem siteURL) =<< getArticles al mapM_ (articleItem siteURL) =<< getArticles al
where where
@ -82,7 +83,7 @@ feed siteURL al@(ArticlesList {collection}) = do
content = xmlns_content_ "http://purl.org/rss/1.0/modules/content/" content = xmlns_content_ "http://purl.org/rss/1.0/modules/content/"
atom = xmlns_atom_ "http://www.w3.org/2005/Atom" atom = xmlns_atom_ "http://www.w3.org/2005/Atom"
generateCollection :: String -> Collection -> ReaderT Blog IO () generateCollection :: AbsoluteURL -> Collection -> ReaderT Blog IO ()
generateCollection siteURL collection = generateCollection siteURL collection =
renderTextT (feed siteURL $ ArticlesList {full = False, collection}) renderTextT (feed siteURL $ ArticlesList {full = False, collection})
>>= liftIO . TextIO.writeFile (basePath collection </> "rss" <.> "xml") >>= liftIO . TextIO.writeFile (basePath collection </> "rss" <.> "xml")

View file

@ -1,12 +1,14 @@
module Mock.Article ( module Mock.Article (
noDescription hostRelativeImage
, noDescription
, noImage , noImage
, noMeta , noMeta
, remoteImage
, simple , simple
) where ) where
import Article (Article(..)) import Article (Article(..))
import qualified Data.Map as Map (fromList) import qualified Data.Map as Map (fromList, insert)
import Markdown (Markdown(..)) import Markdown (Markdown(..))
import Mock.Markdown (article) import Mock.Markdown (article)
@ -16,6 +18,16 @@ simple = Article article
noImage :: Article noImage :: Article
noImage = Article $ article {metadata = Map.fromList [("summary", "It's a test")]} noImage = Article $ article {metadata = Map.fromList [("summary", "It's a test")]}
remoteImage :: Article
remoteImage = Article $ article {metadata = setImage $ metadata article}
where
setImage = Map.insert "featuredImage" "https://somewhere.el.se/test.png"
hostRelativeImage :: Article
hostRelativeImage = Article $ article {metadata = setImage $ metadata article}
where
setImage = Map.insert "featuredImage" "/media/test.png"
noDescription :: Article noDescription :: Article
noDescription = Article $ article {metadata = Map.fromList [("featuredImage", "test.png")]} noDescription = Article $ article {metadata = Map.fromList [("featuredImage", "test.png")]}

View file

@ -3,6 +3,7 @@ module Mock.Blog (
noCards noCards
, noRSS , noRSS
, simple , simple
, subPath
) where ) where
import Blog (Blog(..)) import Blog (Blog(..))
@ -12,7 +13,7 @@ import qualified Mock.Article (simple)
import qualified Mock.Blog.Path (defaultArticles) import qualified Mock.Blog.Path (defaultArticles)
import qualified Mock.Blog.Skin (simple) import qualified Mock.Blog.Skin (simple)
import qualified Mock.Blog.Template (simple) import qualified Mock.Blog.Template (simple)
import qualified Mock.Blog.URL (simple, noCards) import qualified Mock.Blog.URL (simple, subPath, noCards)
import qualified Mock.Blog.Wording (defaultWording) import qualified Mock.Blog.Wording (defaultWording)
simple :: IO Blog simple :: IO Blog
@ -32,6 +33,9 @@ simple =
, wording , wording
} }
subPath :: IO Blog
subPath = (\b -> b {urls = Mock.Blog.URL.subPath}) <$> simple
noCards :: IO Blog noCards :: IO Blog
noCards = (\b -> b {urls = Mock.Blog.URL.noCards}) <$> simple noCards = (\b -> b {urls = Mock.Blog.URL.noCards}) <$> simple

View file

@ -1,16 +1,25 @@
module Mock.Blog.URL ( module Mock.Blog.URL (
noCards noCards
, simple , simple
, subPath
) where ) where
import Blog.URL (URL(..)) import Blog.URL (URLs(..))
import Mock.URL (prefixedTestSite, testSite)
simple :: URL simple :: URLs
simple = URL { simple = URLs {
cards = Just "https://test.net" cards = Just testSite
, comments = Nothing , comments = Nothing
, rss = Nothing , rss = Nothing
} }
noCards :: URL subPath :: URLs
subPath = URLs {
cards = Just prefixedTestSite
, comments = Nothing
, rss = Nothing
}
noCards :: URLs
noCards = simple {cards = Nothing} noCards = simple {cards = Nothing}

60
test/Mock/URL.hs Normal file
View file

@ -0,0 +1,60 @@
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
cdnFavicon :: URL
cdnFavicon = URL {
url_type = Absolute cdn
, url_path = "favicon.png"
, url_params = []
}
hostFavicon :: URL
hostFavicon = URL {
url_type = HostRelative
, url_path = "favicon.png"
, url_params = []
}
localFavicon :: URL
localFavicon = URL {
url_type = PathRelative
, url_path = "favicon.png"
, url_params = []
}
localDiscovered :: URL
localDiscovered = URL {
url_type = PathRelative
, url_path = "skin/favicon.png"
, url_params = []
}

View file

@ -4,11 +4,15 @@ module Tests (
import Distribution.TestSuite import Distribution.TestSuite
import qualified Structure (test) import qualified Structure (test)
import qualified URLs (test)
import Utils (tag) import Utils (tag)
import qualified XML.Card (test) import qualified XML.Card (test)
import qualified XML.Favicon (test)
tests :: IO [Test] tests :: IO [Test]
tests = return $ tag "xml" <$> [ tests = return $ tag "xml" <$> [
XML.Card.test XML.Card.test
, XML.Favicon.test
, Structure.test , Structure.test
, URLs.test
] ]

73
test/URLs.hs Normal file
View file

@ -0,0 +1,73 @@
{-# LANGUAGE OverloadedStrings #-}
module URLs (
test
) where
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)
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
]

View file

@ -4,6 +4,7 @@ module XML.Card.Component (
) where ) where
import Blog (Blog) import Blog (Blog)
import Blog.URL (pathRelative)
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (runReaderT) import Control.Monad.Reader (runReaderT)
import Data.Text (Text) import Data.Text (Text)
@ -14,9 +15,10 @@ import Mock.Article as Article (noDescription, noImage, simple)
import Mock.ArticlesList as ArticlesList ( import Mock.ArticlesList as ArticlesList (
longMain, longTesting, shortMain, shortTesting longMain, longTesting, shortMain, shortTesting
) )
import Network.URL (URL)
import Utils (assertAll, assertEqual, simpleTest, tag) import Utils (assertAll, assertEqual, simpleTest, tag)
check :: HasCard a => IO Blog -> a -> (Text, Text, Maybe String, String, String) -> IO Progress check :: HasCard a => IO Blog -> a -> (Text, Text, Maybe URL, String, String) -> IO Progress
check getBlog input (expectedCT, expectedD, expectedI, expectedT, expectedU) = check getBlog input (expectedCT, expectedD, expectedI, expectedT, expectedU) =
getBlog >>= runReaderT ( getBlog >>= runReaderT (
sequence [ sequence [
@ -33,14 +35,14 @@ articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
("simple article components", check Blog.simple Article.simple ( ("simple article components", check Blog.simple Article.simple (
"article" "article"
, "It's a test" , "It's a test"
, Just "test.png" , Just (pathRelative "test.png")
, "Some test" , "Some test"
, "articles/test.html" , "articles/test.html"
)) ))
, ("article components without description", check Blog.simple Article.noDescription ( , ("article components without description", check Blog.simple Article.noDescription (
"article" "article"
, "A new article on The Test Blog" , "A new article on The Test Blog"
, Just "test.png" , Just (pathRelative "test.png")
, "Some test" , "Some test"
, "articles/test.html" , "articles/test.html"
)) ))

View file

@ -2,15 +2,17 @@ module XML.Card.Output (
test test
) where ) where
import Blog (Blog(..), URL(..)) import Blog (Blog(..), URLs(..))
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (asks, runReaderT) import Control.Monad.Reader (asks, runReaderT)
import qualified Data.Text.Lazy.IO as Lazy (readFile) import qualified Data.Text.Lazy.IO as Lazy (readFile)
import Distribution.TestSuite import Distribution.TestSuite
import DOM.Card (HasCard(..), make) import DOM.Card (HasCard(..), make)
import Lucid (renderTextT) import Lucid (renderTextT)
import Mock.Blog as Blog (noCards, simple) import Mock.Blog as Blog (noCards, simple, subPath)
import Mock.Article as Article (noDescription, noImage, simple) import Mock.Article as Article (
hostRelativeImage, noDescription, noImage, remoteImage, simple
)
import Mock.ArticlesList as ArticlesList ( import Mock.ArticlesList as ArticlesList (
longMain, longTesting, shortMain, shortTesting longMain, longTesting, shortMain, shortTesting
) )
@ -31,8 +33,15 @@ check getBlog input expectedFile =
articleCard :: Test articleCard :: Test
articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [ articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
("simple article output", check Blog.simple Article.simple "simple.html") ("simple article output", check Blog.simple Article.simple "simple.html")
, ("article output without description", check Blog.simple Article.noDescription "noDescription.html") , ("simple article output with subPath", check Blog.subPath Article.simple "subPath.html")
, ("article output without image", check Blog.simple Article.noImage "noImage.html") , ("article output without description"
, check Blog.simple Article.noDescription "noDescription.html")
, ("article output without image"
, check Blog.simple Article.noImage "noImage.html")
, ("article output with an image on a remote server"
, check Blog.simple Article.remoteImage "remoteImage.html")
, ("article output with an image in a host-relative folder"
, check Blog.simple Article.hostRelativeImage "hostRelativeImage.html")
, ("no card article output", check Blog.noCards Article.simple "/dev/null") , ("no card article output", check Blog.noCards Article.simple "/dev/null")
] ]

View file

@ -0,0 +1 @@
<meta property="og:url" content="https://test.net/articles/test.html"><meta property="og:type" content="article"><meta property="og:title" content="Some test"><meta property="og:description" content="It&#39;s a test"><meta property="og:image" content="https://test.net/media/test.png"><meta property="og:site_name" content="The Test Blog">

View file

@ -0,0 +1 @@
<meta property="og:url" content="https://test.net/articles/test.html"><meta property="og:type" content="article"><meta property="og:title" content="Some test"><meta property="og:description" content="It&#39;s a test"><meta property="og:image" content="https://somewhere.el.se/test.png"><meta property="og:site_name" content="The Test Blog">

View file

@ -0,0 +1 @@
<meta property="og:url" content="https://test.net/subPath/articles/test.html"><meta property="og:type" content="article"><meta property="og:title" content="Some test"><meta property="og:description" content="It&#39;s a test"><meta property="og:image" content="https://test.net/subPath/test.png"><meta property="og:site_name" content="The Test Blog">

27
test/XML/Favicon.hs Normal file
View file

@ -0,0 +1,27 @@
module XML.Favicon (
test
) where
import Blog.Skin (findImage)
import Distribution.TestSuite
import Mock.URL (cdnFavicon, hostFavicon, localDiscovered, localFavicon)
import Network.URL (URL)
import System.Directory (withCurrentDirectory)
import Utils (assertAll, assertEqual, simpleTest, tag, testDataPath)
check :: IO (Maybe URL) -> Maybe URL -> IO Progress
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))
]

View file