RSS

Yesod でアプリを作る 7

次にコメント機能を追加する。template/post.hamletを編集。

<h2>Comments
$if null comments 
  <p> There are no comments in this post.
$else
  $forall Entity commentId comment <- comments
    <div>
      Commenter: #{commentCommenter comment} 
      (#{show $ commentCreatedAt comment})
      <p>
        #{commentBody comment}
    <hr>

<form method=post action=@{CommentNewR postId} enctype=#{enctype}>
    ^{commentWidget}
    <div>
        <input type=submit value="Post New Comment">

次に config/route にコメントを作成する部分を追加

/blog/#PostId/comment/new       CommentNewR     POST

config/model にコメントのモデルを作成

Comment
  commenter Text
  body Textarea 
  createdAt UTCTime default=CURRENT_TIMESTAMP
  postId PostId
  deriving

Handler/Blog.hs

getPostDeleteR :: PostId -> Handler RepHtml
getPostDeleteR postId = do
  runDB $ do
    _post <- get404 postId
    delete postId
    deleteWhere [ CommentPostId ==. postId ]
  redirect $ BlogR

deleteWhere ... の部分で元記事が削除されたら関係するコメントも削除するような処理をしている。

commentForm :: PostId -> Form Comment
commentForm postId = renderDivs $ Comment
  <$> areq textField     "Commenter" Nothing
  <*> areq textareaField "Body"      Nothing
  <*> aformM (liftIO getCurrentTime)
  <*> pure postId

フォームの部分で理解できない部分があってpure PostIdがはたしてこれでいいのかわかっていない。モデルをそのまま流用するフォームにしないほうがいいのかもしれない。

postCommentNewR :: PostId -> Handler RepHtml
postCommentNewR postId = do
  _post <- runDB $ get404 postId
  ((res, commentWidget), enctype) <- runFormPost $ commentForm postId
  case res of
    FormSuccess comment -> do
      commentId <- runDB $ insert comment
      setMessage $ toHtml $ (commentCommenter comment)
      redirect $ PostViewR postId
    _ -> do
      setMessage "add correct comment"
      redirect $ PostViewR postId

ここは普通にコメントを追加する。

getPostviewRに投稿フォームとコメントの一覧を表示させる部分を追加。

getPostViewR :: PostId -> Handler RepHtml
getPostViewR postId = do
  post <- runDB $ get404 postId
  comments <- runDB $ selectList [CommentPostId ==. postId] [Asc CommentId]
  (commentWidget, enctype) <- generateFormPost $ commentForm postId
  defaultLayout $ do
    setTitle $ toHtml $ postTitle post
    $(widgetFile "post")

このような具合で一通りできた。