Implement safe templating for «local» variables used during hablo rendering of the blog — not in client code

This commit is contained in:
Tissevert 2020-05-06 10:17:33 +02:00
parent 107a9767ab
commit 2a7d721a35
9 changed files with 120 additions and 65 deletions

View file

@ -34,6 +34,7 @@ executable hablo
, ArticlesList , ArticlesList
, Blog , Blog
, Blog.Path , Blog.Path
, Blog.Template
, Blog.Skin , Blog.Skin
, Blog.URL , Blog.URL
, Blog.Wording , Blog.Wording

View file

@ -9,5 +9,5 @@ latestPage = Latest articles
latestTaggedPage = Latest articles tagged ${tag} latestTaggedPage = Latest articles tagged ${tag}
metadata = {?by ${author} ?}on ${date}{? tagged ${tags}?} metadata = {?by ${author} ?}on ${date}{? tagged ${tags}?}
rssLink = Subscribe rssLink = Subscribe
rssTitle = Follow articles{? tagged ${tag}?} rssTitle = Follow all articles{? tagged ${tag}?}
tagsList = Tags tagsList = Tags

View file

@ -10,8 +10,7 @@ module ArticlesList (
) where ) where
import Article (Article) import Article (Article)
import Blog (Blog(..), Skin(..)) import Blog (Blog(..), Renderer, Skin(..), template)
import Blog.Wording (render)
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)
@ -33,20 +32,20 @@ otherURL :: ArticlesList -> String
otherURL (ArticlesList {full, collection}) = absoluteLink $ otherURL (ArticlesList {full, collection}) = absoluteLink $
(if full then id else (</> "all.html")) . maybe "" id $ tag collection (if full then id else (</> "all.html")) . maybe "" id $ tag collection
description :: MonadReader Blog m => ArticlesList -> m Text description :: Renderer m => ArticlesList -> m Text
description (ArticlesList {full, collection}) = description (ArticlesList {full, collection}) =
getDescription (full, tag collection) <$> asks wording getDescription (full, tag collection)
where where
getDescription (True, Nothing) = render "allPage" [] getDescription (True, Nothing) = template "allPage" []
getDescription (True, Just tag) = render "allTaggedPage" [("tag", pack tag)] getDescription (True, Just tag) = template "allTaggedPage" [("tag", pack tag)]
getDescription (False, Nothing) = render "latestPage" [] getDescription (False, Nothing) = template "latestPage" []
getDescription (False, Just tag) = getDescription (False, Just tag) =
render "latestTaggedPage" [("tag", pack tag)] template "latestTaggedPage" [("tag", pack tag)]
rssLinkTexts :: MonadReader Blog m => ArticlesList -> m (Text, Text) rssLinkTexts :: Renderer m => ArticlesList -> m (Text, Text)
rssLinkTexts (ArticlesList {collection}) = do rssLinkTexts (ArticlesList {collection}) = do
text <- asks $wording.$(render "rssLink" []) text <- template "rssLink" []
title <- asks $wording.$(render "rssTitle" environment) title <- template "rssTitle" environment
return (text, title) return (text, title)
where where
environment = maybe [] (\v -> [("tag", pack v)]) $ tag collection environment = maybe [] (\v -> [("tag", pack v)]) $ tag collection

View file

@ -1,13 +1,16 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
module Blog ( module Blog (
Blog(..) Blog(..)
, Path(..) , Path(..)
, Renderer
, Skin(..) , Skin(..)
, URL(..) , URL(..)
, Wording , Wording
, build , build
, get , get
, template
) where ) where
import Arguments (Arguments) import Arguments (Arguments)
@ -16,6 +19,8 @@ import Article (Article)
import qualified Article (at, getKey) import qualified Article (at, getKey)
import Blog.Path (Path(..)) import Blog.Path (Path(..))
import qualified Blog.Path as Path (build) import qualified Blog.Path as Path (build)
import Blog.Template (Environment, Templates, render)
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 (URL(..))
@ -23,11 +28,13 @@ 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)
import Control.Monad ((>=>), filterM, foldM, forM) import Control.Monad ((>=>), filterM, foldM, forM)
import Control.Monad.Reader (MonadReader, ask) import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (MonadReader, asks)
import Data.Map (Map, insert, lookup) import Data.Map (Map, insert, lookup)
import qualified Data.Map as Map (empty, fromList) import qualified Data.Map as Map (empty, fromList)
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set (empty, null, singleton, union) import qualified Data.Set as Set (empty, null, singleton, union)
import Data.Text (Text)
import Files (File(..), absolute) import Files (File(..), absolute)
import qualified Files (find) import qualified Files (find)
import Prelude hiding (lookup) import Prelude hiding (lookup)
@ -44,12 +51,18 @@ data Blog = Blog {
, path :: Path , path :: Path
, skin :: Skin , skin :: Skin
, tags :: Map String (Set String) , tags :: Map String (Set String)
, templates :: Templates
, urls :: URL , urls :: URL
, wording :: Wording , wording :: Wording
} }
type Renderer m = (MonadIO m, MonadReader Blog m)
template :: Renderer m => String -> Environment -> m Text
template key environment = asks templates >>= render key environment
get :: MonadReader Blog m => (Blog -> a) -> m a get :: MonadReader Blog m => (Blog -> a) -> m a
get = (<$> ask) get = asks
keepOrWarn :: Map String Article -> Either ParseError (String, Article) -> IO (Map String Article) keepOrWarn :: Map String Article -> Either ParseError (String, Article) -> IO (Map String Article)
keepOrWarn accumulator (Left parseErrors) = keepOrWarn accumulator (Left parseErrors) =
@ -90,13 +103,16 @@ discover path = do
build :: Arguments -> IO Blog build :: Arguments -> IO Blog
build arguments = do build arguments = do
urls <- URL.build arguments urls <- URL.build arguments
let hasRSS = maybe False (\_-> True) $ rss urls
wording <- Wording.build arguments wording <- Wording.build arguments
templates <- Template.build wording
root <- Files.absolute . Dir $ Arguments.sourceDir arguments root <- Files.absolute . Dir $ Arguments.sourceDir arguments
withCurrentDirectory root $ do withCurrentDirectory root $ do
let hasRSS = maybe False (\_-> True) $ rss urls
path <- Path.build root arguments path <- Path.build root arguments
let name = maybe (takeFileName $ dropTrailingPathSeparator root) id let name = maybe (takeFileName $ dropTrailingPathSeparator root) id
$ Arguments.name arguments $ Arguments.name arguments
skin <- Skin.build name arguments skin <- Skin.build name arguments
(articles, tags) <- discover path (articles, tags) <- discover path
return $ Blog {articles, hasRSS, name, path, skin, tags, urls, wording} return $ Blog {
articles, hasRSS, name, path, skin, tags, templates, urls, wording
}

69
src/Blog/Template.hs Normal file
View file

@ -0,0 +1,69 @@
{-# LANGUAGE OverloadedStrings #-}
module Blog.Template (
Environment
, Templates(..)
, build
, render
) where
import Blog.Wording (Wording(..), variables)
import Control.Monad (foldM)
import Control.Monad.IO.Class (MonadIO(..))
import Data.List (intercalate)
import Data.Map (Map, (!))
import qualified Data.Map as Map (empty, insert, keys)
import Data.Text (Text, breakOn)
import qualified Data.Text as Text (concat, drop, null, unpack)
import Data.Text.Lazy (toStrict)
import Data.Text.Template (Template, renderA, showTemplate, templateSafe)
import System.Exit (die)
data TemplateChunk = Top Template | Sub Template
newtype HabloTemplate = HabloTemplate [TemplateChunk]
newtype Templates = Templates (Map String HabloTemplate)
type Environment = [(Text, Text)]
render :: MonadIO m => String -> Environment -> Templates -> m Text
render key environment (Templates templates) =
(Text.concat . fmap toStrict) <$> mapM renderChunk templateChunks
where
HabloTemplate templateChunks = templates ! key
renderer template = renderA template (flip lookup environment)
renderChunk (Top template) =
let err = "Could not template " ++ Text.unpack (showTemplate template) in
maybe (liftIO $ die err) return $ renderer template
renderChunk (Sub template) = return . maybe "" id $ renderer template
makeTemplate :: String -> Text -> IO Template
makeTemplate key templateText =
let testEnvironment = flip lookup [(s, "") | s <- availableVariables] in
case templateSafe templateText of
Left (row, col) -> die $ syntaxError (show row) (show col)
Right template ->
maybe (die badTemplate) (return . const template) (renderA template testEnvironment)
where
availableVariables = variables ! key
variablesMessage =
" (available variables: " ++ intercalate ", " (Text.unpack <$> availableVariables) ++ ")"
syntaxError row col =
"Syntax error in template for variable " ++ key ++ "at l." ++ row ++ ", c." ++ col
badTemplate = "Invalid template for variable " ++ key ++ variablesMessage
makeHabloTemplate :: String -> Map String Text -> IO HabloTemplate
makeHabloTemplate key wording = HabloTemplate <$> toHablo True (wording ! key)
where
toHablo _ "" = return []
toHablo atTop template = do
let (start, rest) = (Text.drop 2) <$> breakOn (delimiter atTop) template
push atTop start <*> toHablo (not atTop) rest
delimiter atTop = if atTop then "{?" else "?}"
push atTop t
| Text.null t = return id
| otherwise = (:) . (if atTop then Top else Sub) <$> makeTemplate key t
build :: Wording -> IO Templates
build (Wording wordingMap) =
Templates <$> foldM templateWording Map.empty (Map.keys variables)
where
templateWording templated key =
flip (Map.insert key) templated <$> makeHabloTemplate key wordingMap

View file

@ -1,22 +1,17 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Blog.Wording ( module Blog.Wording (
Wording(..) Wording(..)
, build , build
, render , variables
) where ) where
import Arguments (Arguments(..)) import Arguments (Arguments(..))
import Control.Monad (foldM) import Control.Monad (foldM)
import Data.Aeson (ToJSON(..)) import Data.Aeson (ToJSON(..))
import Data.List (intercalate) import Data.Map (Map)
import Data.Map (Map, (!)) import qualified Data.Map as Map (empty, fromList, keys, map, union)
import qualified Data.Map as Map (empty, fromList, insert, keys, map, union)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text (pack, unpack) import qualified Data.Text as Text (pack)
import Data.Text.Lazy (toStrict)
import Data.Text.Template (Template, renderA, showTemplate, templateSafe)
import qualified Data.Text.Template as Template (render)
import Paths_hablo (getDataFileName) import Paths_hablo (getDataFileName)
import Text.ParserCombinators.Parsec ( import Text.ParserCombinators.Parsec (
Parser Parser
@ -25,7 +20,7 @@ import Text.ParserCombinators.Parsec (
) )
import System.Exit (die) import System.Exit (die)
newtype Wording = Wording (Map String Template) newtype Wording = Wording (Map String Text)
variables :: Map String [Text] variables :: Map String [Text]
variables = Map.fromList [ variables = Map.fromList [
@ -44,14 +39,9 @@ variables = Map.fromList [
, ("tagsList", []) , ("tagsList", [])
] ]
instance ToJSON Wording where instance ToJSON Wording where
toJSON (Wording m) = toJSON (showTemplate <$> m) toJSON (Wording m) = toJSON m
toEncoding (Wording m) = toEncoding (showTemplate <$> m) toEncoding (Wording m) = toEncoding m
render :: String -> [(Text, Text)] -> Wording -> Text
render key env (Wording wMap) =
toStrict $ Template.render (wMap ! key) (Map.fromList env !)
addWording :: Map String Text -> FilePath -> IO (Map String Text) addWording :: Map String Text -> FilePath -> IO (Map String Text)
addWording currentWording wordingFile = do addWording currentWording wordingFile = do
@ -67,30 +57,12 @@ wordingP = Map.map Text.pack . Map.fromList <$>
restOfLine = many $ noneOf "\r\n" restOfLine = many $ noneOf "\r\n"
eol = try (string "\r\n") <|> string "\r" <|> string "\n" eol = try (string "\r\n") <|> string "\r" <|> string "\n"
skip = optional (char '#' *> restOfLine) *> eol skip = optional (char '#' *> restOfLine) *> eol
line = (,) <$> (choice (try . string <$> Map.keys variables) <* equal) <*> restOfLine varEqual = choice (try . string <$> Map.keys variables) <* equal
line = (,) <$> varEqual <*> restOfLine
equal = many (char ' ') *> char '=' *> many (char ' ') equal = many (char ' ') *> char '=' *> many (char ' ')
makeTemplate :: String -> Map String Text -> IO Template
makeTemplate key wording =
let templateText = wording ! key in
let testEnvironment = flip lookup [(s, "") | s <- availableVariables] in
case templateSafe templateText of
Left (row, col) -> die $ syntaxError (show row) (show col)
Right template ->
maybe (die badTemplate) (return . const template) (renderA template testEnvironment)
where
availableVariables = variables ! key
variablesMessage =
" (available variables: " ++ intercalate ", " (Text.unpack <$> availableVariables) ++ ")"
syntaxError row col =
"Syntax error in template for variable " ++ key ++ "at l." ++ row ++ ", c." ++ col
badTemplate = "Invalid template for variable " ++ key ++ variablesMessage
build :: Arguments -> IO Wording build :: Arguments -> IO Wording
build arguments = do build arguments = do
defaultWording <- getDataFileName "defaultWording.conf" defaultWording <- getDataFileName "defaultWording.conf"
let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording] let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording]
wordindMap <- foldM addWording Map.empty wordingFiles Wording <$> foldM addWording Map.empty wordingFiles
Wording <$> foldM (
\templated key -> flip (Map.insert key) templated <$> makeTemplate key wordindMap
) Map.empty (Map.keys variables)

View file

@ -9,9 +9,8 @@ import qualified Article (preview)
import ArticlesList ( import ArticlesList (
ArticlesList(..), description, getArticles, otherURL, rssLinkTexts ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
) )
import Blog (Blog(..), Path(..), Skin(..), URL(..)) import Blog (Blog(..), Path(..), Skin(..), URL(..), template)
import qualified Blog (get) import qualified Blog (get)
import Blog.Wording (render)
import Control.Monad.Reader (ReaderT, asks) import Control.Monad.Reader (ReaderT, asks)
import qualified Data.Map as Map (keys) import qualified Data.Map as Map (keys)
import Data.Text (pack, empty) import Data.Text (pack, empty)
@ -46,8 +45,8 @@ instance Page ArticlesList where
mapM_ (article False . preview) =<< getArticles al mapM_ (article False . preview) =<< getArticles al
) )
where where
link = render (if full then "latestLink" else "allLink") [] otherLink =
otherLink = Blog.get $wording.$link.$toHtml toHtml <$> template (if full then "latestLink" else "allLink") []
rssLink :: Bool -> HtmlGenerator () rssLink :: Bool -> HtmlGenerator ()
rssLink True = do rssLink True = do
(text, title) <- rssLinkTexts al (text, title) <- rssLinkTexts al
@ -100,7 +99,7 @@ page aPage =
body_ (do body_ (do
maybe defaultBanner toHtmlRaw =<< (Blog.get $skin.$banner) maybe defaultBanner toHtmlRaw =<< (Blog.get $skin.$banner)
div_ [id_ "navigator"] (do div_ [id_ "navigator"] (do
h2_ =<< (Blog.get $wording.$(render "tagsList" []).$toHtml) h2_ . toHtml =<< template "tagsList" []
ul_ . mapM_ tag . Map.keys =<< Blog.get tags ul_ . mapM_ tag . Map.keys =<< Blog.get tags
) )
div_ [id_ "contents"] $ content aPage div_ [id_ "contents"] $ content aPage

View file

@ -10,12 +10,11 @@ module DOM.Card (
import qualified Article (Article(..)) import qualified Article (Article(..))
import ArticlesList (ArticlesList(..)) import ArticlesList (ArticlesList(..))
import qualified ArticlesList (description) import qualified ArticlesList (description)
import Blog (Blog(..), Skin(..)) import Blog (Blog(..), Renderer, Skin(..))
import qualified Blog (get) import qualified Blog (get)
import Collection (Collection(..)) import Collection (Collection(..))
import qualified Collection (title) import qualified Collection (title)
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Monad.Reader (MonadReader)
import qualified Data.Map as Map (lookup) import qualified Data.Map as Map (lookup)
import Data.Text (Text, pack) import Data.Text (Text, pack)
import Lucid (HtmlT, content_, meta_) import Lucid (HtmlT, content_, meta_)
@ -31,7 +30,7 @@ data Card = Card {
} }
class HasCard a where class HasCard a where
getCard :: MonadReader Blog m => a -> m Card getCard :: Renderer m => a -> m Card
og :: Applicative m => Text -> Text -> HtmlT m () og :: Applicative m => Text -> Text -> HtmlT m ()
og attribute value = og attribute value =
@ -40,7 +39,7 @@ og attribute value =
, content_ value , content_ value
] ]
make :: (HasCard a, MonadReader Blog m) => a -> String -> HtmlT m () make :: (HasCard a, Renderer m) => a -> String -> HtmlT m ()
make element siteURL = do make element siteURL = do
Card {cardType, description, image, title, urlPath} <- getCard element Card {cardType, description, image, title, urlPath} <- getCard element
og "url" . pack $ siteURL ++ urlPath og "url" . pack $ siteURL ++ urlPath

View file

@ -8,7 +8,7 @@ module RSS (
import Article (Article(..)) import Article (Article(..))
import ArticlesList (ArticlesList(..), getArticles) import ArticlesList (ArticlesList(..), getArticles)
import qualified ArticlesList (description) import qualified ArticlesList (description)
import Blog (Blog(..), Path(..), URL(..)) import Blog (Blog(..), Path(..), Renderer, URL(..))
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(..))
@ -68,7 +68,7 @@ articleItem siteURL (Article {key, metadata, title}) =
formatTime defaultTimeLocale rfc822DateFormat formatTime defaultTimeLocale rfc822DateFormat
. posixSecondsToUTCTime . fromIntegral . (read :: String -> Int) . posixSecondsToUTCTime . fromIntegral . (read :: String -> Int)
feed :: MonadReader Blog m => String -> ArticlesList -> HtmlT m () feed :: Renderer m => String -> 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