Commits

Luke Plant committed 3558136

Switched to Data.Text for templates, and HStringTemplate 0.6

Also switched method of doing escaping and escaping exceptions.

Comments (0)

Files changed (8)

         MissingH >= 1.0.2,
         pandoc >= 1.1,
         SHA >= 1.0.2,
-        HStringTemplate >= 0.5.1.3,
+        HStringTemplate >= 0.6,
+        text >= 0.3,
         ella >= 0.1.2
   Main-is: BlogCgi.hs
   hs-source-dirs: src

src/Blog/Templates.hs

 
 import Blog.Forms (emailWidget, nameWidget, messageWidget, formatWidget, usernameWidget, passwordWidget, CommentStage(..))
 import Blog.Links
-import Blog.Utils (escapeHtmlString)
+import Blog.Utils (escapeHtmlStringT)
 import Data.Maybe (fromJust)
 import Ella.Forms.Base
 import Ella.Forms.Widgets (makeLabel)
 import qualified Data.ByteString.Lazy.UTF8 as UTF8
 import qualified Data.ByteString.Lazy as LB
 import qualified Data.Map as Map
+import qualified Data.Text.Lazy as LT
 
 -- Templates
 
-get_templates :: IO (STGroup LB.ByteString)
+get_templates :: IO (STGroup LT.Text)
 get_templates = do
-  templates' <- directoryGroup Settings.template_path
-  return $ setEncoderGroup escapeHtmlString templates'
+  g1 <- directoryGroup Settings.template_path
+  let g2 = setEncoderGroup escapeHtmlStringT g1
+      g3 = groupStringTemplates [("noescape", newSTMP "$it$" :: StringTemplate LT.Text)]
+      g4 = mergeSTGroups g2 g3
+  return g4
 
-get_template :: String -> IO (StringTemplate LB.ByteString)
+get_template :: String -> IO (StringTemplate LT.Text)
 get_template name = do
   templates <- get_templates
   return $ fromJust $ getStringTemplate name templates
 
 -- Allow Html to be inserted
 instance ToSElem Html where
-    toSElem x = BS (utf8 $ showHtmlFragment x)
-
-encT = utf8 . escapeHtmlString -- use for text which might contain unicode or HTML chars
-encH = utf8                    -- use for HTML
-
+    toSElem x = STR $ showHtmlFragment x
 
 -- Convert to form needed for templates
 postTemplateInfo :: P.Post -> Map.Map String ToSElemD
-postTemplateInfo p = Map.fromList [ ("title", ToSElemD $ encT $ P.title p)
+postTemplateInfo p = Map.fromList [ ("title", ToSElemD $ P.title p)
                                   , ("date", ToSElemD $ showDate $ P.timestamp p)
-                                  , ("summary", ToSElemD $ encH $ P.summary_formatted p)
-                                  , ("full", ToSElemD $ encH $ P.post_formatted p)
-                                  , ("url", ToSElemD $ encT $ postUrl p)
+                                  , ("summary", ToSElemD $ P.summary_formatted p)
+                                  , ("full", ToSElemD $ P.post_formatted p)
+                                  , ("url", ToSElemD $ postUrl p)
                                   , ("commentsOpen", ToSElemD $ P.comments_open p)
                                   ]
 
 categoryTemplateInfo :: C.Category -> Map.Map String ToSElemD
-categoryTemplateInfo c = Map.fromList [ ("name", ToSElemD $ encT $ C.name c)
-                                      , ("url", ToSElemD $ encT $ categoryUrl c)
+categoryTemplateInfo c = Map.fromList [ ("name", ToSElemD $ C.name c)
+                                      , ("url", ToSElemD $ categoryUrl c)
                                       ]
 
 commentTemplateInfo :: Cm.Comment -> Map.Map String ToSElemD
-commentTemplateInfo cm = Map.fromList [ ("name", ToSElemD $ encT $ Cm.name cm)
-                                      , ("formattedName", ToSElemD $ encT $ formatName $ Cm.name cm)
+commentTemplateInfo cm = Map.fromList [ ("name", ToSElemD $ Cm.name cm)
+                                      , ("formattedName", ToSElemD $ formatName $ Cm.name cm)
                                       , ("isAuthor", ToSElemD $ Cm.name cm == Settings.blog_author_name)
                                       , ("date", ToSElemD $ showDate $ Cm.timestamp cm)
-                                      , ("textFormatted", ToSElemD $ encH $ Cm.text_formatted cm)
-                                      , ("email", ToSElemD $ encT $ Cm.email cm)
+                                      , ("textFormatted", ToSElemD $ Cm.text_formatted cm)
+                                      , ("email", ToSElemD $ Cm.email cm)
                                       ]

src/Blog/Utils.hs

 import Text.Regex.Base
 import Text.Regex.PCRE
 import qualified Data.ByteString.Lazy.Char8 as LB
-
+import qualified Data.Text.Lazy as LT
 
 -- | Replace using a regular expression. ByteString version
 regexReplace ::
         else [head s] ++ (replace find repl (tail s))
 
 escapeHtmlString s = replace "<" "&lt;" $ replace ">" "&gt;" $ replace "\"" "&quot;" $ replace "&" "&amp;" s
+
+-- | Replace a string of Text in a Text with another Text
+replaceLT find repl src
+    | LT.null src = src
+    | otherwise = let l = LT.length find
+                  in if LT.take (fromIntegral l) src == find
+                     then LT.append repl (replaceLT find repl (LT.drop (fromIntegral l) src))
+                     else LT.cons (LT.head src) (replaceLT find repl (LT.tail src))
+
+escapeHtmlStringT = repl "<" "&lt;" .
+                    repl ">" "&gt;" .
+                    repl "\"" "&quot;" .
+                    repl "\'" "&#39;" .
+                    repl "&" "&amp;"
+    where repl x y = replaceLT (LT.pack x) (LT.pack y)

src/Blog/Views.hs

 import Text.StringTemplate.GenericStandard
 import qualified Blog.Settings as Settings
 import qualified Data.Map as Map
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LT
 import qualified Text.XHtml as X
 
 ---- Utilities
                          addHtml html
                         ] utf8HtmlResponse
 
-standardResponseBS :: ByteString -> Response
+standardResponseBS :: LB.ByteString -> Response
 standardResponseBS content = buildResponse [
                               addContent content
                              ] utf8HtmlResponse
 
+-- | Standard response, taking a StringTemplate Text as input
+standardResponseTT :: StringTemplate LT.Text -> Response
+standardResponseTT template = buildResponse [
+                               addContent (LT.encodeUtf8 $ render template)
+                              ] utf8HtmlResponse
+
 return404 :: View
 return404 req = do
   resp <- custom404handler req
 custom404handler :: Request -> IO Response
 custom404handler req = do
   t <- get_template "notfound"
-  return $ with (standardResponseBS $ render t) [
+  return $ with (standardResponseTT t) [
                         setStatus 404
                        ]
 
   (posts,more) <- getRecentPosts cn curpage
   cats <- getCategoriesBulk cn posts
   t <- get_template "index"
-  return $ Just $ standardResponseBS $
+  return $ Just $ standardResponseTT $
              (renderf t
               ("posts", map postTemplateInfo posts)
               ("categories", map (map categoryTemplateInfo) cats)
   cats <- getCategories cn
   t <- get_template "categories"
   let categories = [ (c, categoryUrl c) | c <- cats ]
-  return $ Just $ standardResponseBS $
+  return $ Just $ standardResponseTT $
              (renderf t
               ("categories", categories)
               ("hasCategories", not $ null cats)
               (posts,more) <- getPostsForCategory cn cat (getPage req)
               cats <- getCategoriesBulk cn posts
               t <- get_template "category"
-              return $ Just $ standardResponseBS $
+              return $ Just $ standardResponseTT $
                          (renderf t
                           ("category", cat)
                           ("posts", map postTemplateInfo posts)
             comments <- getCommentsForPost cn post
             related <- getRelatedPosts cn post cats
             t <- get_template "post"
-            return $ Just $ standardResponseBS $
+            return $ Just $ standardResponseTT $
                        (renderf t
                         ("post", postTemplateInfo post)
                         ("commentPreview", commentStage == CommentPreview)
   cn <- connect
   Just post <- getPostBySlug cn slug
   t <- get_template "info"
-  return $ Just $ standardResponseBS $ renderf t ("post", postTemplateInfo post)
+  return $ Just $ standardResponseTT $ renderf t ("post", postTemplateInfo post)
 
 -- | View that displays a login form and handles logging in
 loginView :: View
            return $ Just $ (redirectResponse adminMenuUrl) `with` (map addCookie loginCookies)
          else do
            t <- loginTemplate
-           return $ Just $ standardResponseBS $ loginPage t loginData loginErrors
+           return $ Just $ standardResponseTT $ loginPage t loginData loginErrors
     _ -> do
       t <- loginTemplate
-      return $ Just $ standardResponseBS $ loginPage t emptyLoginData (Map.empty :: Map.Map String String)
+      return $ Just $ standardResponseTT $ loginPage t emptyLoginData (Map.empty :: Map.Map String String)
 
   where loginPage t loginData loginErrors =
             (renderf t

src/templates/category.st

 $posts,categories:{ p,cs |
 <div class="summarylink"><a href="$p.url$">$p.title$</a></div>
 $metainfoline(divclass="metainfoindex";post=p;categories=cs)$
-<div class="summary">$p.summary$</div>
+<div class="summary">$p.summary:noescape()$</div>
 }$
-$paginglinks$
+$paginglinks:noescape()$
 $pageend()$

src/templates/comment.st

         <span>On <span class="timestamp">$comment.date$</span>, <span class="commentBy">$comment.formattedName$</span> wrote:</span>
       </div>
       <div class="commenttext">
-         $comment.textFormatted$
+         $comment.textFormatted:noescape()$
       </div>
     </div>
     <hr/>

src/templates/index.st

 $posts,categories:{ p,cs |
 <div class="summarylink"><a href="$p.url$">$p.title$</a></div>
 $metainfoline(divclass="metainfoindex";post=p;categories=cs)$
-<div class="summary">$p.summary$</div>
+<div class="summary">$p.summary:noescape()$</div>
 }$
-$paginglinks$
+$paginglinks:noescape()$
 $pageend()$

src/templates/post.st

 $metainfoline(divclass="metainfo";post=post;categories=categories)$
 <h1 class="posttitle">$post.title$</h1>
 <div class="post">
-  $post.full$
+  $post.full:noescape()$
 </div>
 
 <div class="comments">
     <form method="post" action="#addcomment">
       <table>
         <tr>
-          <td>$nameLabel$</td>
-          <td>$nameWidget$</td>
+          <td>$nameLabel:noescape()$</td>
+          <td>$nameWidget:noescape()$</td>
         </tr>
         <tr>
-          <td>$emailLabel$</td>
-          <td>$emailWidget$</td>
+          <td>$emailLabel:noescape()$</td>
+          <td>$mailWidget:noescape()$</td>
         </tr>
         <tr>
-          <td>$formatLabel$</td>
-          <td>$formatWidget$</td>
+          <td>$formatLabel:noescape()$</td>
+          <td>$formatWidget:noescape()$</td>
         </tr>
       </table>
-      <div>$messageWidget$</div>
+      <div>$messageWidget:noescape()$</div>
       <div>
         <input type="submit" name="submit" value="Submit" />
         <input type="submit" name="preview" value="Preview" />