yesod-comments-0.7: Yesod/Comments/Management.hs
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------
-- |
-- Module : Yesod.Comments.Management
-- Copyright : Patrick Brisbin
-- License : as-is
--
-- Maintainer : Patrick Brisbin <me@pbrisbin.com>
-- Stability : unstable
-- Portability : unportable
--
-- This module allows for self-management of comments by any
-- authenticating commenter on your site.
--
-- The use, add a route like so:
--
-- > /comments CommentsAdminR CommentsAdmin getCommentsAdmin
--
-- Then place a link somewhere to @CommentsAdminR OverviewR@.
--
-- The overview page will show all of the comments (grouped by thread)
-- that the currently logged in user has left on the site along with
-- links to view more details, edit the comment content, or delete the
-- comment entirely.
--
-------------------------------------------------------------------------------
module Yesod.Comments.Management
( CommentsAdmin
, getCommentsAdmin
, Route(..)
) where
import Yesod
import Yesod.Auth
import Yesod.Comments.Core
import Yesod.Markdown
import Control.Applicative ((<$>), (<*>), pure)
import Control.Monad (forM, unless)
import Data.List (sortBy, nub)
import Data.Time (UTCTime, formatTime)
import Language.Haskell.TH.Syntax hiding (lift)
import System.Locale (defaultTimeLocale, rfc822DateFormat)
data CommentsAdmin = CommentsAdmin
getCommentsAdmin :: a -> CommentsAdmin
getCommentsAdmin = const CommentsAdmin
mkYesodSub "CommentsAdmin"
[ ClassP ''YesodAuth [ VarT $ mkName "master" ]
, ClassP ''YesodComments [ VarT $ mkName "master" ] ]
[parseRoutes|
/ OverviewR GET
/view/#ThreadId/#CommentId ViewR GET
/edit/#ThreadId/#CommentId EditR GET POST
/delete/#ThreadId/#CommentId DeleteR GET
|]
getOverviewR :: (YesodAuth m, YesodComments m) => GHandler CommentsAdmin m RepHtml
getOverviewR = do
_ <- requireAuthId
threads <- getThreadedComments
defaultLayout $ do
setTitle "Comments administration"
[whamlet|
<h1>Comments overview
<div .yesod_comments .overview>
$if null threads
<p>No comments found.
$else
$forall thread <- threads
^{showThreadedComments thread}
|]
getViewR :: (YesodAuth m, YesodComments m) => ThreadId -> CommentId -> GHandler CommentsAdmin m RepHtml
getViewR tid cid = withUserComment tid cid $ \comment ->
defaultLayout $ do
setTitle "View comment"
[whamlet|
<h1>View comment
<div .yesod_comments .view>
<table>
<tr>
<th>Thread:
<td>#{tid}
<tr>
<th>Comment Id:
<td>#{cid}
<tr>
<th>Source IP:
<td>#{ipAddress comment}
<tr>
<th>Time stamp:
<td>#{formatTimeStamp $ timeStamp comment}
<p>
<strong>Comment:
<blockquote>
#{markdownToHtml $ content comment}
^{updateLinks comment}
|]
where
formatTimeStamp :: UTCTime -> String -- todo: make my own format
formatTimeStamp = formatTime defaultTimeLocale rfc822DateFormat
getEditR :: (YesodAuth m, YesodComments m) => ThreadId -> CommentId -> GHandler CommentsAdmin m RepHtml
getEditR tid cid = withUserComment tid cid $ \comment -> do
tm <- getRouteToMaster
((res, form), enctype) <- runFormPost $ commentFormEdit comment
defaultLayout $ do
setTitle "Edit comment"
handleFormEdit (tm OverviewR) res comment
[whamlet|
<h1>Edit comment
<div .yesod_comments .edit>
<h3>Update comment
<div .input>
<form enctype="#{enctype}" method="post" .form-stacked>
^{form}
<div .actions>
<button .btn .primary type="submit">Add comment
|]
postEditR :: (YesodAuth m, YesodComments m) => ThreadId -> CommentId -> GHandler CommentsAdmin m RepHtml
postEditR = getEditR
getDeleteR :: (YesodAuth m, YesodComments m) => ThreadId -> CommentId -> GHandler CommentsAdmin m RepHtml
getDeleteR tid cid = withUserComment tid cid $ \comment -> do
tm <- getRouteToMaster
deleteComment comment
setMessage "comment deleted."
redirect $ tm OverviewR
getThreadedComments :: (YesodAuth m, YesodComments m) => GHandler s m [(ThreadId, [Comment])]
getThreadedComments = do
allComments <- loadComments Nothing
allThreads <- forM allComments $ \comment -> do
mine <- isCommentingUser comment
return $ if mine then [threadId comment] else []
unsorted <- forM (nub $ concat allThreads) $ \tid ->
return (tid, filter ((== tid) . threadId) allComments)
return . sortBy latest $ unsorted
latest :: (ThreadId, [Comment]) -> (ThreadId, [Comment]) -> Ordering
latest (t1, cs1) (t2,cs2) =
-- note the comparason is reversed so that the more recent threads
-- will sort first
case compare (latest' cs1) (latest' cs2) of
EQ -> compare t1 t2
GT -> LT
LT -> GT
where
latest' :: [Comment] -> UTCTime
latest' = maximum . map timeStamp
showThreadedComments :: (YesodAuth m, YesodComments m) => (ThreadId, [Comment]) -> GWidget CommentsAdmin m ()
showThreadedComments (tid, comments) = [whamlet|
<div .yesod_comments .thread>
<h3>#{tid}
$forall comment <- comments
^{showThreadComment comment}
|]
where
showThreadComment :: (YesodAuth m, YesodComments m) => Comment -> GWidget CommentsAdmin m ()
showThreadComment comment = do
mine <- lift $ isCommentingUser comment
[whamlet|
$if mine
<div .yours>
^{showCommentAuth comment}
^{updateLinks comment}
$else
<div>
^{showCommentAuth comment}
|]
updateLinks :: (YesodAuth m, YesodComments m) => Comment -> GWidget CommentsAdmin m ()
updateLinks (Comment tid cid _ _ _ _ _ _ )= do
tm <- lift $ getRouteToMaster
[whamlet|
<div .update_links>
<p>
<a href=@{tm $ ViewR tid cid}>View
\ |
<a href=@{tm $ EditR tid cid}>Edit
\ |
<a href=@{tm $ DeleteR tid cid}>Delete
|]
-- | Find a comment by thread/id, ensure it's the logged in user's
-- comment and execute an action on it. Gives notFound or
-- permissionDenied in failing cases.
withUserComment :: (YesodAuth m, YesodComments m)
=> ThreadId
-> CommentId
-> (Comment-> GHandler s m a)
-> GHandler s m a
withUserComment tid cid f = do
mcomment <- getComment tid cid
case mcomment of
Just comment -> do
_ <- requireAuthId
mine <- isCommentingUser comment
unless mine $ permissionDenied "you can only manage your own comments"
f comment
Nothing -> notFound
commentFormEdit :: RenderMessage m FormMessage => Comment -> Form s m CommentForm
commentFormEdit comment = renderBootstrap $ CommentForm
<$> pure "" <*> pure ""
<*> areq markdownField commentLabel (Just $ content comment)
<*> pure True
handleFormEdit :: YesodComments m => Route m -> FormResult CommentForm -> Comment -> GWidget s m ()
handleFormEdit r (FormSuccess cf) comment = lift $ do
updateComment comment $ comment { content = formComment cf }
setMessage "comment updated."
redirect r
handleFormEdit _ _ _ = return ()