@@ -12,6 +12,7 @@ import Data.Either
1212import GHC.Generics
1313import Data.Binary
1414import qualified Data.Text as T
15+import qualified Data.Text.Lazy as TL
1516import Data.Time.Clock
1617import Data.Time.Calendar
1718import Control.DeepSeq
@@ -83,6 +84,7 @@ main = do
8384 scotty 3000 $ do
8485 S.get "/" (listBlogs sessionId conn)
8586 S.get "/blog/:blogid" (showBlogEntry sessionId conn)
87+ S.post "/comment" (addComment sessionId conn)
8688
8789--define the schema with the new Category atom (data) type, blog relvar, a comment relvar, and a foreign key relationship between them
8890createSchema :: SessionId -> Connection -> IO ()
@@ -191,4 +193,27 @@ showBlogEntry sessionId conn = do
191193 H.p (H.toHtml ("Commented at " <> formatStamp (commentTime comment)))
192194 H.p (H.toHtml (contents comment))) commentsSorted
193195 when (length comments == 0) (H.p "No comments.")
196+ --add a comment form
197+ H.h3 "Add a Comment"
198+ H.form H.! A.method "POST" H.! A.action "/comment" $ do
199+ H.input H.! A.type_ "hidden" H.! A.name "blogid" H.! A.value (H.toValue blogid)
200+ H.textarea H.! A.name "contents" $ ""
201+ H.input H.! A.type_ "submit"
202+
203+addComment :: SessionId -> Connection -> ActionM ()
204+addComment sessionId conn = do
205+ blogid <- param "blogid"
206+ commentText <- param "contents"
207+ now <- liftIO getCurrentTime
208+ let commentAttrs = toAttributes (Proxy :: Proxy Comment)
209+ case mkRelationFromList commentAttrs [[TextAtom blogid,
210+ DateTimeAtom now,
211+ TextAtom commentText]] of
212+ Left err -> handleWebError (Left err)
213+ Right newCommentRel -> do
214+ eRet <- liftIO (withTransaction sessionId conn (executeDatabaseContextExpr sessionId conn (Insert "comment" (ExistingRelation newCommentRel))) (commit sessionId conn))
215+ case eRet of
216+ Left err -> handleWebError (Left err)
217+ Right _ ->
218+ redirect (TL.fromStrict ("/blog/" <> blogid))
194219