From 2a7d721a351af3384303909128495021301cec02 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Wed, 6 May 2020 10:17:33 +0200 Subject: [PATCH] =?UTF-8?q?Implement=20safe=20templating=20for=20=C2=ABloc?= =?UTF-8?q?al=C2=BB=20variables=20used=20during=20hablo=20rendering=20of?= =?UTF-8?q?=20the=20blog=20=E2=80=94=20not=20in=20client=20code?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- hablo.cabal | 1 + share/defaultWording.conf | 2 +- src/ArticlesList.hs | 21 ++++++------ src/Blog.hs | 24 +++++++++++--- src/Blog/Template.hs | 69 +++++++++++++++++++++++++++++++++++++++ src/Blog/Wording.hs | 48 ++++++--------------------- src/DOM.hs | 9 +++-- src/DOM/Card.hs | 7 ++-- src/RSS.hs | 4 +-- 9 files changed, 120 insertions(+), 65 deletions(-) create mode 100644 src/Blog/Template.hs diff --git a/hablo.cabal b/hablo.cabal index 9e23312..01c480c 100644 --- a/hablo.cabal +++ b/hablo.cabal @@ -34,6 +34,7 @@ executable hablo , ArticlesList , Blog , Blog.Path + , Blog.Template , Blog.Skin , Blog.URL , Blog.Wording diff --git a/share/defaultWording.conf b/share/defaultWording.conf index 6aa51f1..3c21d86 100644 --- a/share/defaultWording.conf +++ b/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 diff --git a/src/ArticlesList.hs b/src/ArticlesList.hs index d076ddb..489aa35 100644 --- a/src/ArticlesList.hs +++ b/src/ArticlesList.hs @@ -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 diff --git a/src/Blog.hs b/src/Blog.hs index eb1545a..1fa5789 100644 --- a/src/Blog.hs +++ b/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 + } diff --git a/src/Blog/Template.hs b/src/Blog/Template.hs new file mode 100644 index 0000000..e9ee71a --- /dev/null +++ b/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 diff --git a/src/Blog/Wording.hs b/src/Blog/Wording.hs index b696f4d..9caec83 100644 --- a/src/Blog/Wording.hs +++ b/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 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 diff --git a/src/DOM.hs b/src/DOM.hs index f52a40e..015c2a7 100644 --- a/src/DOM.hs +++ b/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 = 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 diff --git a/src/DOM/Card.hs b/src/DOM/Card.hs index 2860edd..9b69131 100644 --- a/src/DOM/Card.hs +++ b/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 diff --git a/src/RSS.hs b/src/RSS.hs index 52a9d49..73f8b79 100644 --- a/src/RSS.hs +++ b/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