Commits

Luke Plant  committed 98b4fd8

Beginnings of 'validateComment' functionality. Totally broken at the moment.

This produces a compiler crash with GHC 6.8.3, no idea why

  • Participants
  • Parent commits 82fded5

Comments (0)

Files changed (4)

         HDBC-sqlite3 >= 1.1.4,
         HDBC >= 1.1.5,
         containers,
+        unix >= 2.3.0.0,
         utf8-string,
         regex-pcre,
         regex-base,

File src/Blog/Forms.hs

 
 import Ella.Forms.Widgets.TextInput (TextInput(..))
 import Ella.Forms.Widgets.Textarea  (Textarea(..))
+import qualified Ella.Forms.Widgets.TextInput as TI
+import qualified Ella.Forms.Widgets.Textarea as TA
+import qualified Blog.Comment as Cm
+import qualified Blog.Post as P
+import Blog.Formats (plaintext)
+
+import Data.Maybe (fromJust)
+import System.Posix.Time (epochTime)
+
 
 nameWidget = TextInput { value = ""
                        , size = Just 20
                   | CommentInvalid
                   | CommentAccepted
                     deriving (Eq, Ord, Enum, Read, Show)
+
+
+-- | extract the posted data from a POST request and build
+-- a Comment from it, returning a Comment and a list of validaion errors
+validateComment postedData blogpost =
+    do
+    -- TODO - protect name -- some names are reversed for logged in users.
+    -- TODO - posts that are closed for comments
+    -- TODO - actual validation on fields
+    -- TODO - addCommentToPost utility
+      ts <- epochTime
+      let text = fromJust $ postedData "message"
+      let errors = []
+      return (Cm.Comment {
+                      Cm.uid = undefined
+                    , Cm.post_id = P.uid blogpost
+                    , Cm.timestamp = ts
+                    , Cm.name = fromJust $ Map.lookup "name" postedData
+                    , Cm.email = fromJust $ Map.lookup "name" postedData
+                    , Cm.text_raw = text
+                    , Cm.text_formatted = text -- TODO fix, security
+                    , Cm.format_id = plaintext
+                    }, errors)
+

File src/Blog/Templates.hs

 
 
 postPage :: P.Post        -- ^ The Post to display
-         -> ()            -- ^ Data for the comment form (TODO)
          -> CommentStage  -- ^ What stage comment submission is at
+         -> Cm.Comment    -- ^ Data for the comment form
+         -> [String]      -- ^ Validation errors for comment
          -> [C.Category]  -- ^ Categories the post is in
          -> [Cm.Comment]  -- ^ Comments belonging to the poast
          -> [P.Post]      -- ^ Related posts
          -> Html
-postPage post commentData commentStage categories comments related =
+postPage post commentStage commentData commentErrors categories comments related =
     page $ defaultPageVars
              { pcontent = formatPost post categories comments related
              , ptitle = P.title post

File src/Blog/Views.hs

 import Blog.Links
 import Blog.DB (connect)
 import Blog.Model
-import Maybe (fromMaybe)
+import Blog.Forms (CommentStage(..), validateComment)
+import Maybe (fromMaybe, isJust)
 
 ---- Utilities
 
   case mp of
     Nothing -> return $ Just $ custom404 -- preferred to 'Nothing'
     Just post -> do
-            (commentData, commentStage) <- handleUserComment cn post req
+            (commentStage, commentData, commentErrors) <- handleUserComment cn post req
             cats <- getCategoriesForPost cn post
             comments <- getCommentsForPost cn post
             related <- getRelatedPosts cn post cats
-            return $ Just $ standardResponse $ postPage post commentData commentStage cats comments related
+            return $ Just $ standardResponse $ postPage post commentStage commentData commentErrors cats comments related
   where
-    handleUserComment cn post req = return (undefined, undefined)
+    handleUserComment cn post req =
+        case requestMethod req of
+          "POST" -> do
+            (commentData, commentErrors) <- validateComment (getPOST req) post
+            commentStage <-
+                do
+                  if isJust (getPOST req "submit")
+                     then if null commentErrors
+                          then
+                              do
+                                addComment cn commentData
+                                return CommentAccepted
+                          else
+                              return CommentInvalid
+                     -- Just assume 'preview' if not 'submit'
+                     else return CommentPreview
+            return (commentStage, commentData, commentErrors)
+
+          _ -> return (NoComment, undefined, undefined)
+
 
 -- | View that shows a post as a static information page -- no comments etc.
 infoPageView slug req = do