Implement safe templating for «local» variables used during hablo rendering of the blog — not in client code
This commit is contained in:
parent
107a9767ab
commit
2a7d721a35
|
|
@ -34,6 +34,7 @@ executable hablo
|
|||
, ArticlesList
|
||||
, Blog
|
||||
, Blog.Path
|
||||
, Blog.Template
|
||||
, Blog.Skin
|
||||
, Blog.URL
|
||||
, Blog.Wording
|
||||
|
|
|
|||
|
|
@ -9,5 +9,5 @@ latestPage = Latest articles
|
|||
latestTaggedPage = Latest articles tagged ${tag}
|
||||
metadata = {?by ${author} ?}on ${date}{? tagged ${tags}?}
|
||||
rssLink = Subscribe
|
||||
rssTitle = Follow articles{? tagged ${tag}?}
|
||||
rssTitle = Follow all articles{? tagged ${tag}?}
|
||||
tagsList = Tags
|
||||
|
|
|
|||
|
|
@ -10,8 +10,7 @@ module ArticlesList (
|
|||
) where
|
||||
|
||||
import Article (Article)
|
||||
import Blog (Blog(..), Skin(..))
|
||||
import Blog.Wording (render)
|
||||
import Blog (Blog(..), Renderer, Skin(..), template)
|
||||
import Collection (Collection(..))
|
||||
import Control.Monad.Reader (MonadReader, asks)
|
||||
import Data.Text (Text, pack)
|
||||
|
|
@ -33,20 +32,20 @@ otherURL :: ArticlesList -> String
|
|||
otherURL (ArticlesList {full, collection}) = absoluteLink $
|
||||
(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}) =
|
||||
getDescription (full, tag collection) <$> asks wording
|
||||
getDescription (full, tag collection)
|
||||
where
|
||||
getDescription (True, Nothing) = render "allPage" []
|
||||
getDescription (True, Just tag) = render "allTaggedPage" [("tag", pack tag)]
|
||||
getDescription (False, Nothing) = render "latestPage" []
|
||||
getDescription (True, Nothing) = template "allPage" []
|
||||
getDescription (True, Just tag) = template "allTaggedPage" [("tag", pack tag)]
|
||||
getDescription (False, Nothing) = template "latestPage" []
|
||||
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
|
||||
text <- asks $wording.$(render "rssLink" [])
|
||||
title <- asks $wording.$(render "rssTitle" environment)
|
||||
text <- template "rssLink" []
|
||||
title <- template "rssTitle" environment
|
||||
return (text, title)
|
||||
where
|
||||
environment = maybe [] (\v -> [("tag", pack v)]) $ tag collection
|
||||
|
|
|
|||
24
src/Blog.hs
24
src/Blog.hs
|
|
@ -1,13 +1,16 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
module Blog (
|
||||
Blog(..)
|
||||
, Path(..)
|
||||
, Renderer
|
||||
, Skin(..)
|
||||
, URL(..)
|
||||
, Wording
|
||||
, build
|
||||
, get
|
||||
, template
|
||||
) where
|
||||
|
||||
import Arguments (Arguments)
|
||||
|
|
@ -16,6 +19,8 @@ import Article (Article)
|
|||
import qualified Article (at, getKey)
|
||||
import Blog.Path (Path(..))
|
||||
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 qualified Blog.Skin as Skin (build)
|
||||
import Blog.URL (URL(..))
|
||||
|
|
@ -23,11 +28,13 @@ import qualified Blog.URL as URL (build)
|
|||
import Blog.Wording (Wording)
|
||||
import qualified Blog.Wording as Wording (build)
|
||||
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 qualified Data.Map as Map (empty, fromList)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set (empty, null, singleton, union)
|
||||
import Data.Text (Text)
|
||||
import Files (File(..), absolute)
|
||||
import qualified Files (find)
|
||||
import Prelude hiding (lookup)
|
||||
|
|
@ -44,12 +51,18 @@ data Blog = Blog {
|
|||
, path :: Path
|
||||
, skin :: Skin
|
||||
, tags :: Map String (Set String)
|
||||
, templates :: Templates
|
||||
, urls :: URL
|
||||
, 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 = (<$> ask)
|
||||
get = asks
|
||||
|
||||
keepOrWarn :: Map String Article -> Either ParseError (String, Article) -> IO (Map String Article)
|
||||
keepOrWarn accumulator (Left parseErrors) =
|
||||
|
|
@ -90,13 +103,16 @@ discover path = do
|
|||
build :: Arguments -> IO Blog
|
||||
build arguments = do
|
||||
urls <- URL.build arguments
|
||||
let hasRSS = maybe False (\_-> True) $ rss urls
|
||||
wording <- Wording.build arguments
|
||||
templates <- Template.build wording
|
||||
root <- Files.absolute . Dir $ Arguments.sourceDir arguments
|
||||
withCurrentDirectory root $ do
|
||||
let hasRSS = maybe False (\_-> True) $ rss urls
|
||||
path <- Path.build root arguments
|
||||
let name = maybe (takeFileName $ dropTrailingPathSeparator root) id
|
||||
$ Arguments.name arguments
|
||||
skin <- Skin.build name arguments
|
||||
(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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -1,22 +1,17 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Blog.Wording (
|
||||
Wording(..)
|
||||
, build
|
||||
, render
|
||||
, variables
|
||||
) where
|
||||
|
||||
import Arguments (Arguments(..))
|
||||
import Control.Monad (foldM)
|
||||
import Data.Aeson (ToJSON(..))
|
||||
import Data.List (intercalate)
|
||||
import Data.Map (Map, (!))
|
||||
import qualified Data.Map as Map (empty, fromList, insert, keys, map, union)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map (empty, fromList, keys, map, union)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text (pack, unpack)
|
||||
import Data.Text.Lazy (toStrict)
|
||||
import Data.Text.Template (Template, renderA, showTemplate, templateSafe)
|
||||
import qualified Data.Text.Template as Template (render)
|
||||
import qualified Data.Text as Text (pack)
|
||||
import Paths_hablo (getDataFileName)
|
||||
import Text.ParserCombinators.Parsec (
|
||||
Parser
|
||||
|
|
@ -25,7 +20,7 @@ import Text.ParserCombinators.Parsec (
|
|||
)
|
||||
import System.Exit (die)
|
||||
|
||||
newtype Wording = Wording (Map String Template)
|
||||
newtype Wording = Wording (Map String Text)
|
||||
|
||||
variables :: Map String [Text]
|
||||
variables = Map.fromList [
|
||||
|
|
@ -44,14 +39,9 @@ variables = Map.fromList [
|
|||
, ("tagsList", [])
|
||||
]
|
||||
|
||||
|
||||
instance ToJSON Wording where
|
||||
toJSON (Wording m) = toJSON (showTemplate <$> m)
|
||||
toEncoding (Wording m) = toEncoding (showTemplate <$> m)
|
||||
|
||||
render :: String -> [(Text, Text)] -> Wording -> Text
|
||||
render key env (Wording wMap) =
|
||||
toStrict $ Template.render (wMap ! key) (Map.fromList env !)
|
||||
toJSON (Wording m) = toJSON m
|
||||
toEncoding (Wording m) = toEncoding m
|
||||
|
||||
addWording :: Map String Text -> FilePath -> IO (Map String Text)
|
||||
addWording currentWording wordingFile = do
|
||||
|
|
@ -67,30 +57,12 @@ wordingP = Map.map Text.pack . Map.fromList <$>
|
|||
restOfLine = many $ noneOf "\r\n"
|
||||
eol = try (string "\r\n") <|> string "\r" <|> string "\n"
|
||||
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 ' ')
|
||||
|
||||
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 = do
|
||||
defaultWording <- getDataFileName "defaultWording.conf"
|
||||
let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording]
|
||||
wordindMap <- foldM addWording Map.empty wordingFiles
|
||||
Wording <$> foldM (
|
||||
\templated key -> flip (Map.insert key) templated <$> makeTemplate key wordindMap
|
||||
) Map.empty (Map.keys variables)
|
||||
Wording <$> foldM addWording Map.empty wordingFiles
|
||||
|
|
|
|||
|
|
@ -9,9 +9,8 @@ import qualified Article (preview)
|
|||
import ArticlesList (
|
||||
ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
|
||||
)
|
||||
import Blog (Blog(..), Path(..), Skin(..), URL(..))
|
||||
import Blog (Blog(..), Path(..), Skin(..), URL(..), template)
|
||||
import qualified Blog (get)
|
||||
import Blog.Wording (render)
|
||||
import Control.Monad.Reader (ReaderT, asks)
|
||||
import qualified Data.Map as Map (keys)
|
||||
import Data.Text (pack, empty)
|
||||
|
|
@ -46,8 +45,8 @@ instance Page ArticlesList where
|
|||
mapM_ (article False . preview) =<< getArticles al
|
||||
)
|
||||
where
|
||||
link = render (if full then "latestLink" else "allLink") []
|
||||
otherLink = Blog.get $wording.$link.$toHtml
|
||||
otherLink =
|
||||
toHtml <$> template (if full then "latestLink" else "allLink") []
|
||||
rssLink :: Bool -> HtmlGenerator ()
|
||||
rssLink True = do
|
||||
(text, title) <- rssLinkTexts al
|
||||
|
|
@ -100,7 +99,7 @@ page aPage =
|
|||
body_ (do
|
||||
maybe defaultBanner toHtmlRaw =<< (Blog.get $skin.$banner)
|
||||
div_ [id_ "navigator"] (do
|
||||
h2_ =<< (Blog.get $wording.$(render "tagsList" []).$toHtml)
|
||||
h2_ . toHtml =<< template "tagsList" []
|
||||
ul_ . mapM_ tag . Map.keys =<< Blog.get tags
|
||||
)
|
||||
div_ [id_ "contents"] $ content aPage
|
||||
|
|
|
|||
|
|
@ -10,12 +10,11 @@ module DOM.Card (
|
|||
import qualified Article (Article(..))
|
||||
import ArticlesList (ArticlesList(..))
|
||||
import qualified ArticlesList (description)
|
||||
import Blog (Blog(..), Skin(..))
|
||||
import Blog (Blog(..), Renderer, Skin(..))
|
||||
import qualified Blog (get)
|
||||
import Collection (Collection(..))
|
||||
import qualified Collection (title)
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad.Reader (MonadReader)
|
||||
import qualified Data.Map as Map (lookup)
|
||||
import Data.Text (Text, pack)
|
||||
import Lucid (HtmlT, content_, meta_)
|
||||
|
|
@ -31,7 +30,7 @@ data Card = Card {
|
|||
}
|
||||
|
||||
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 attribute value =
|
||||
|
|
@ -40,7 +39,7 @@ og attribute 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
|
||||
Card {cardType, description, image, title, urlPath} <- getCard element
|
||||
og "url" . pack $ siteURL ++ urlPath
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ module RSS (
|
|||
import Article (Article(..))
|
||||
import ArticlesList (ArticlesList(..), getArticles)
|
||||
import qualified ArticlesList (description)
|
||||
import Blog (Blog(..), Path(..), URL(..))
|
||||
import Blog (Blog(..), Path(..), Renderer, URL(..))
|
||||
import Collection (Collection(..), getAll)
|
||||
import qualified Collection (title)
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
|
|
@ -68,7 +68,7 @@ articleItem siteURL (Article {key, metadata, title}) =
|
|||
formatTime defaultTimeLocale rfc822DateFormat
|
||||
. 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
|
||||
prolog
|
||||
rss_ [version, content, atom] $ do
|
||||
|
|
|
|||
Loading…
Reference in New Issue