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

hablo.cabal

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

share/defaultWording.conf

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

src/ArticlesList.hs

@@ -10,8 +10,7 @@ module ArticlesList (
   ) where
 
 import Article (Article)
-import Blog (Blog(..), Skin(..))
+import Blog (Blog(..), Renderer, Skin(..), template)
-import Blog.Wording (render)
 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, 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) =
-      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" [])
+  text <- template "rssLink" []
-  title <- asks $wording.$(render "rssTitle" environment)
+  title <- template "rssTitle" environment
   return (text, title)
   where
     environment = maybe [] (\v -> [("tag", pack v)]) $ tag collection

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

src/Blog/Template.hs

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

src/Blog/Wording.hs

@@ -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 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 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 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)
+  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 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 addWording Map.empty wordingFiles
-  Wording <$> foldM (
-      \templated key -> flip (Map.insert key) templated <$> makeTemplate key wordindMap
-    ) Map.empty (Map.keys variables)

src/DOM.hs

@@ -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 =
-      otherLink = Blog.get $wording.$link.$toHtml
+        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

src/DOM/Card.hs

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

src/RSS.hs

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