Commits

Luke Plant  committed fbbb971

Added CSRF protection

  • Participants
  • Parent commits f7a909a

Comments (0)

Files changed (4)

File src/Blog/Views.hs

 
 import Blog.DB (connect)
 import Blog.Forms (CommentStage(..), validateComment, emptyComment, emptyLoginData, validateLogin)
+import Blog.Globals (mkCsrfField)
 import Blog.Links
 import Blog.Model
 import Blog.Templates
                               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
+-- | Standard response, taking a Request and StringTemplate Text as input
+standardResponseTT :: Request -> StringTemplate LT.Text -> Response
+standardResponseTT req template =
+    let csrffield = mkCsrfField req
+        t2 = setAttribute "csrffield" csrffield template
+        rendered = (LT.encodeUtf8 $ render t2)
+    in buildResponse [ addContent rendered
+                     ] utf8HtmlResponse
 
 return404 :: View
 return404 req = do
 custom404handler :: Request -> IO Response
 custom404handler req = do
   t <- get_template "notfound"
-  return $ with (standardResponseTT t) [
+  return $ with (standardResponseTT req t) [
                         setStatus 404
                        ]
 
   (posts,more) <- getRecentPosts cn curpage
   cats <- getCategoriesBulk cn posts
   t <- get_template "index"
-  return $ Just $ standardResponseTT $
+  return $ Just $ standardResponseTT req $
              (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 $ standardResponseTT $
+  return $ Just $ standardResponseTT req $
              (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 $ standardResponseTT $
+              return $ Just $ standardResponseTT req $
                          (renderf t
                           ("category", cat)
                           ("posts", map postTemplateInfo posts)
             comments <- getCommentsForPost cn post
             related <- getRelatedPosts cn post cats
             t <- get_template "post"
-            return $ Just $ standardResponseTT $
+            return $ Just $ standardResponseTT req $
                        (renderf t
                         ("post", postTemplateInfo post)
                         ("commentPreview", commentStage == CommentPreview)
   cn <- connect
   Just post <- getPostBySlug cn slug
   t <- get_template "info"
-  return $ Just $ standardResponseTT $ renderf t ("post", postTemplateInfo post)
+  return $ Just $ standardResponseTT req $ 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 $ standardResponseTT $ loginPage t loginData loginErrors
+           return $ Just $ standardResponseTT req $ loginPage t loginData loginErrors
     _ -> do
       t <- loginTemplate
-      return $ Just $ standardResponseTT $ loginPage t emptyLoginData (Map.empty :: Map.Map String String)
+      return $ Just $ standardResponseTT req $ loginPage t emptyLoginData (Map.empty :: Map.Map String String)
 
   where loginPage t loginData loginErrors =
             (renderf t

File src/BlogCgi.hs

 import Blog.Routes (views)
 import Blog.Views (custom404handler)
+import Blog.Globals (csrfProtectionProcessor)
 import Database.HDBC
 import Ella.Framework
 import Ella.Processors.Security (signedCookiesProcessor)
 import qualified Blog.Settings as Settings
 
 options = defaultDispatchOptions { notFoundHandler = custom404handler
-                                 , viewProcessors = [signedCookiesProcessor Settings.secret]
+                                 , viewProcessors = [ signedCookiesProcessor Settings.secret
+                                                    , csrfProtectionProcessor
+                                                    ]
                                  }
 
 sqlDebug action = catchSql (do { action; return ()}) (\e -> sendResponseCGI $ default500 $ show e)

File src/templates/login.st

 $endif$
 
 <form method="post" action="">
+  $csrffield:noescape()$
   <table>
     <tr>
       <td>$usernameLabel:noescape()$</td>

File src/templates/post.st

     $endif$
 
     <form method="post" action="#addcomment">
+    $csrffield:noescape()$
       <table>
         <tr>
           <td>$nameLabel:noescape()$</td>