diff --git a/Yesod/Comments.hs b/Yesod/Comments.hs --- a/Yesod/Comments.hs +++ b/Yesod/Comments.hs @@ -22,7 +22,6 @@ import Yesod import Yesod.Comments.Core -import Yesod.Comments.Filters (applyFilters) import Yesod.Helpers.Auth -- | Comments that anyone can enter anonymously @@ -31,10 +30,9 @@ -> GWidget s m () addComments tid = do comments <- lift $ loadComments (Just tid) - cid <- lift $ getNextCommentId comments ((res, form), enctype) <- lift $ runFormMonadPost commentForm - handleForm res tid cid + handleForm res tid addStyling [hamlet|
@@ -66,10 +64,9 @@ return (True, toSinglePiece uid, uname, email) comments <- lift $ loadComments (Just tid) - cid <- lift $ getNextCommentId comments ((res, form), enctype) <- lift $ runFormMonadPost $ commentFormAuth uid username email - handleForm res tid cid + handleForm res tid addStyling [hamlet|
@@ -87,53 +84,6 @@ $forall comment <- comments
^{showCommentAuth comment} |] - - --- | Add styling common to the auth and non-auth forms -addStyling :: Yesod m => GWidget s m () -addStyling = addCassius [cassius| - .yesod_comment_input th - text-align: left - vertical-align: top - .yesod_comment_input textarea - height: 10ex - width: 50ex - .yesod_comment_avatar_input, .yesod_comment_avatar_list - float: left - .yesod_comment_avatar_input - margin-right: 5px - .yesod_comment_avatar_list - margin-right: 3px - |] - --- | Handle the posted form and actually insert the comment -handleForm :: YesodComments m - => FormResult CommentForm - -> ThreadId - -> CommentId - -> GWidget s m () -handleForm res tid cid = case res of - FormMissing -> return () - FormFailure _ -> return () - FormSuccess cf -> lift $ do - comment <- commentFromForm tid cid cf - matches <- applyFilters commentFilters comment - if matches - then setMessage "comment dropped. matched filters." - else do - storeComment comment - setMessage "comment added." - redirectCurrentRoute - - where - -- | Redirect back to the current route after a POST request - redirectCurrentRoute :: Yesod m => GHandler s m () - redirectCurrentRoute = do - tm <- getRouteToMaster - mr <- getCurrentRoute - case mr of - Just r -> redirect RedirectTemporary $ tm r - Nothing -> notFound helper :: Int -> String helper 0 = "no comments" diff --git a/Yesod/Comments/Core.hs b/Yesod/Comments/Core.hs --- a/Yesod/Comments/Core.hs +++ b/Yesod/Comments/Core.hs @@ -20,8 +20,14 @@ , commentFromForm , commentForm , commentFormAuth + , commentFormEdit + , handleForm + , handleFormEdit + , addStyling , showComment , showCommentAuth + , getNextCommentId + , isCommentingUser ) where import Yesod @@ -40,31 +46,29 @@ type CommentId = Int class Yesod m => YesodComments m where - -- Data base actions - getComment :: ThreadId -> CommentId -> GHandler s m (Maybe Comment) - storeComment :: Comment -> GHandler s m () - deleteComment :: Comment -> GHandler s m () + -- | Find a specific comment + getComment :: ThreadId -> CommentId -> GHandler s m (Maybe Comment) - -- | Loading all comments, possibly filtered to a single thread. - loadComments :: Maybe ThreadId -> GHandler s m [Comment] + -- | Store a new comment + storeComment :: Comment -> GHandler s m () - -- | Get the next available Id given the passed list of comments. In - -- Handler in case there is a database call involved. - getNextCommentId :: [Comment] -> GHandler s m CommentId - getNextCommentId [] = return 1 - getNextCommentId cs = return $ maximum (map commentId cs) + 1 + -- | Update a comment + updateComment :: Comment -> Comment -> GHandler s m () - -- | See "Yesod.Comments.Filters" - commentFilters :: [(Comment -> GHandler s m Bool)] - commentFilters = [] + -- | Remove a comment + deleteComment :: Comment -> GHandler s m () - -- | if using Auth, provide the function to get from a user id to + -- | Load all comments, possibly filtered to a single thread. + loadComments :: Maybe ThreadId -> GHandler s m [Comment] + + -- | If using Auth, provide the function to get from a user id to -- the string to use as the commenter's username. This should - -- return something friendlier than just a conversion to 'String' + -- return something friendly probably pulled from the user's + -- profile on your site. displayUser :: AuthId m -> GHandler s m T.Text - displayUser _ = return "" + displayUser _ = return "" -- fixme: use toSinglePiece in new auth pkg - -- | if using Auth, provide the function to get form a user id to + -- | If using Auth, provide the function to get from a user id to -- the string to use as the commenter's email. displayEmail :: AuthId m -> GHandler s m T.Text displayEmail _ = return "" @@ -80,6 +84,9 @@ , isAuth :: Bool } +instance Eq Comment where + a == b = (threadId a == threadId b) && (commentId a == commentId b) + data CommentForm = CommentForm { formUser :: T.Text , formEmail :: T.Text @@ -88,10 +95,11 @@ } -- | Cleanse form input and create a 'Comment' to be stored -commentFromForm :: ThreadId -> CommentId -> CommentForm -> GHandler s m Comment -commentFromForm tid cid cf = do +commentFromForm :: YesodComments m => ThreadId -> CommentForm -> GHandler s m Comment +commentFromForm tid cf = do now <- liftIO getCurrentTime ip <- return . show . remoteHost =<< waiRequest + cid <- getNextCommentId tid return Comment { threadId = tid , commentId = cid @@ -129,8 +137,8 @@ commentFormAuth user username email = do let img = gravatarImg email defaultOptions { gDefault = Just MM } - (comment, fiComment) <- markdownField "comment:" Nothing - return (CommentForm <$> FormSuccess user <*> FormSuccess email <*> comment <*> FormSuccess True, [hamlet| + (fComment, fiComment) <- markdownField "comment:" Nothing + return (CommentForm <$> FormSuccess user <*> FormSuccess email <*> fComment <*> FormSuccess True, [hamlet|
@@ -147,6 +155,18 @@ |]) +-- | The comment form used in the management edit page. +commentFormEdit :: Comment -> GFormMonad s m (FormResult CommentForm, GWidget s m ()) +commentFormEdit comment = do + (fComment, fiComment) <- markdownField "comment:" (Just $ content comment) + return (CommentForm <$> FormSuccess "" <*> FormSuccess "" <*> fComment <*> FormSuccess True, [hamlet| + + ^{fieldRow fiComment} + +
  + + + |]) fieldRow :: FieldInfo s m -> GWidget s m () fieldRow fi = [hamlet| @@ -166,6 +186,59 @@ clazz :: FieldInfo s m -> String clazz fi = if fiRequired fi then "required" else "optional" +-- | Add some cassius that is common to all the yesod-comments pages +addStyling :: Yesod m => GWidget s m () +addStyling = addCassius [cassius| + .yesod_comment_input th + text-align: left + vertical-align: top + .yesod_comment_input textarea + height: 10ex + width: 50ex + .yesod_comment_avatar_input, .yesod_comment_avatar_list + float: left + .yesod_comment_avatar_input + margin-right: 5px + .yesod_comment_avatar_list + margin-right: 3px + |] + +-- | POST the form and insert the new comment +handleForm :: YesodComments m + => FormResult CommentForm + -> ThreadId + -> GWidget s m () +handleForm res tid = case res of + FormMissing -> return () + FormFailure _ -> return () + FormSuccess cf -> lift $ do + storeComment =<< commentFromForm tid cf + setMessage "comment added." + redirectCurrentRoute + +-- | POST the form and update an existing comment +handleFormEdit :: YesodComments m + => Route m + -> FormResult CommentForm + -> Comment + -> GWidget s m () +handleFormEdit r res comment = case res of + FormMissing -> return () + FormFailure _ -> return () + FormSuccess cf -> lift $ do + updateComment comment $ comment { content = formComment cf } + setMessage "comment updateded." + redirect RedirectTemporary r + +-- | Redirect back to the current route after a POST request +redirectCurrentRoute :: Yesod m => GHandler s m () +redirectCurrentRoute = do + tm <- getRouteToMaster + mr <- getCurrentRoute + case mr of + Just r -> redirect RedirectTemporary $ tm r + Nothing -> notFound + -- | Show a single comment showComment :: Yesod m => Comment -> GWidget s m () showComment comment = showHelper comment (userName comment, userEmail comment) @@ -191,16 +264,38 @@ showHelper :: Yesod m => Comment -> (T.Text,T.Text) -> GWidget s m () showHelper comment (username, email) = do commentTimestamp <- lift . humanReadableTime $ timeStamp comment - let anchor = "#comment_" ++ show (commentId comment) + let anchor = "comment_" ++ show (commentId comment) let img = gravatarImg email defaultOptions { gDefault = Just MM, gSize = Just $ Size 20 } addHamlet [hamlet|

- #{commentTimestamp} + #{commentTimestamp} , #{username} wrote:

#{markdownToHtml $ content comment} |] + +-- | As the final step before insert, this is called to get the next +-- comment id for the thread. super-high concurrency is probably not +-- well-supported here... +getNextCommentId :: YesodComments m => ThreadId -> GHandler s m CommentId +getNextCommentId tid = go =<< loadComments (Just tid) + + where + go :: YesodComments m => [Comment] -> GHandler s m CommentId + go [] = return 1 + go cs = return $ maximum (map commentId cs) + 1 + +-- | Note: this function does not requireAuthId so a non-logged in user +-- just returns false. +isCommentingUser :: (YesodAuth m, YesodComments m) + => Comment + -> GHandler s m Bool +isCommentingUser comment = do + muid <- maybeAuthId + case muid of + Just uid -> return $ isAuth comment && toSinglePiece uid == userName comment + _ -> return False diff --git a/Yesod/Comments/Filters.hs b/Yesod/Comments/Filters.hs deleted file mode 100644 --- a/Yesod/Comments/Filters.hs +++ /dev/null @@ -1,32 +0,0 @@ -------------------------------------------------------------------------------- --- | --- Module : Yesod.Comments.Filters --- Copyright : (c) Patrick Brisbin 2010 --- License : as-is --- Maintainer : pbrisbin@gmail.com --- Stability : unstable --- Portability : unportable --- -------------------------------------------------------------------------------- -module Yesod.Comments.Filters - ( applyFilters - -- * Example filters - , blacklistFile - ) where - -import Yesod -import Yesod.Comments.Core (Comment(..)) -import qualified Data.Text as T - --- | Apply each filter a given list, return True if the Comment matches --- any one filter -applyFilters :: (Yesod m) => [(Comment -> GHandler s m Bool)] -> Comment -> GHandler s m Bool -applyFilters [] _ = return False -applyFilters (p:ps) c = p c >>= \b -> if b then return True else applyFilters ps c - --- | Read IPs from a file, one per line, return True if the comment's IP --- matches one in the file -blacklistFile :: (Yesod m) => FilePath -> Comment -> GHandler s m Bool -blacklistFile f c = do - contents <- liftIO $ readFile f - return $ (T.unpack $ ipAddress c) `elem` (lines contents) diff --git a/Yesod/Comments/Management.hs b/Yesod/Comments/Management.hs new file mode 100644 --- /dev/null +++ b/Yesod/Comments/Management.hs @@ -0,0 +1,196 @@ +{-# 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 +-- 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 + , CommentsAdminRoute(..) + , getCommentsAdmin + ) where + +import Yesod +import Yesod.Helpers.Auth +import Yesod.Comments.Core +import Yesod.Goodies.Markdown +import Control.Monad (forM, unless) +import Data.List (nub, sort) +import Data.Time (UTCTime, formatTime) +import System.Locale (defaultTimeLocale, rfc822DateFormat) +import Language.Haskell.TH.Syntax hiding (lift) + +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" + addStyling + [hamlet| +

Comments overview +
+ $if null threads +

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" + addStyling + [hamlet| +

View comment +
+ + + + + +
Thread: + #{tid} +
Comment Id: + #{cid} +
Source IP: + #{ipAddress comment} +
Time stamp: + #{formatTimeStamp $ timeStamp comment} + +

+ Comment: + +

+ #{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) <- runFormMonadPost $ commentFormEdit comment + defaultLayout $ do + setTitle "Edit comment" + handleFormEdit (tm OverviewR) res comment + addStyling + [hamlet| +

Edit comment +
+

Update comment +
+
^{form} +

Comments are parsed as pandoc-style markdown + |] + +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 RedirectTemporary $ tm OverviewR + +getThreadedComments :: (YesodAuth m, YesodComments m) => GHandler s m [(ThreadId, [Comment])] +getThreadedComments = do + allComments <- loadComments Nothing + comments' <- forM allComments $ \comment -> do + check <- isCommentingUser comment + return $ if check then [comment] else [] + + let comments = concat comments' + + forM (sort . nub $ map threadId comments) $ \tid -> + return $ (tid, filter ((== tid) . threadId) comments) + +showThreadedComments :: (YesodAuth m, YesodComments m) => (ThreadId, [Comment]) -> GWidget CommentsAdmin m () +showThreadedComments (tid, comments) = [hamlet| +

+

#{tid} + $forall comment <- comments +
+ ^{showCommentAuth comment} + ^{updateLinks comment} + |] + +updateLinks :: (YesodAuth m, YesodComments m) => Comment -> GWidget CommentsAdmin m () +updateLinks (Comment tid cid _ _ _ _ _ _ )= do + tm <- lift $ getRouteToMaster + [hamlet| +
+

+ View + \ | + Edit + \ | + Delete + |] + +-- | Find a comment by thread/id, ensure it's the logged in user's +-- comment and execute and 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 + check <- isCommentingUser comment + unless check $ permissionDenied "you can only manage your own comments" + f comment + + Nothing -> notFound diff --git a/Yesod/Comments/Storage.hs b/Yesod/Comments/Storage.hs --- a/Yesod/Comments/Storage.hs +++ b/Yesod/Comments/Storage.hs @@ -22,11 +22,12 @@ -- $persist getCommentPersist , storeCommentPersist + , updateCommentPersist , deleteCommentPersist , loadCommentsPersist , migrateComments -- * TODO - -- Add more + -- $todo ) where import Yesod @@ -37,7 +38,7 @@ -- $persist -- --- Use these functions to store your comments in an instance of +-- Use these functions to store your comments in an instance of -- YesodPersist -- @@ -51,7 +52,7 @@ ipAddress T.Text userName T.Text userEmail T.Text - content Markdown + content Markdown Update isAuth Bool UniqueSqlComment threadId commentId |] @@ -88,6 +89,14 @@ storeCommentPersist :: (YesodPersist m, PersistBackend (YesodDB m (GGHandler s m IO))) => Comment -> GHandler s m () storeCommentPersist c = return . const () =<< runDB (insert $ toSqlComment c) +-- | Note, only updates the content record +updateCommentPersist :: (YesodPersist m, PersistBackend (YesodDB m (GGHandler s m IO))) => Comment -> Comment -> GHandler s m () +updateCommentPersist (Comment tid cid _ _ _ _ _ _) (Comment _ _ _ _ _ _ newContent _) = do + mres <- runDB (getBy $ UniqueSqlComment tid cid) + case mres of + Just (k,_) -> runDB $ update k [SqlCommentContent newContent] + _ -> return () + deleteCommentPersist :: (YesodPersist m, PersistBackend (YesodDB m (GGHandler s m IO))) => Comment -> GHandler s m () deleteCommentPersist c = return . const () =<< runDB (deleteBy $ UniqueSqlComment (threadId c) (commentId c)) @@ -95,3 +104,8 @@ loadCommentsPersist :: (YesodPersist m, PersistBackend (YesodDB m (GGHandler s m IO))) => Maybe ThreadId -> GHandler s m [Comment] loadCommentsPersist (Just tid) = return . fmap (fromSqlComment . snd) =<< runDB (selectList [SqlCommentThreadIdEq tid] [SqlCommentCommentIdAsc] 0 0) loadCommentsPersist Nothing = return . fmap (fromSqlComment . snd) =<< runDB (selectList [] [SqlCommentCommentIdAsc] 0 0) + +-- $todo +-- +-- Add more storage options... +-- diff --git a/yesod-comments.cabal b/yesod-comments.cabal --- a/yesod-comments.cabal +++ b/yesod-comments.cabal @@ -1,5 +1,5 @@ name: yesod-comments -version: 0.3.4 +version: 0.4.0 synopsis: A generic comments interface for a Yesod application description: A generic comments interface for a Yesod application homepage: http://github.com/pbrisbin/yesod-comments @@ -16,7 +16,7 @@ exposed-modules: Yesod.Comments , Yesod.Comments.Core , Yesod.Comments.Storage - , Yesod.Comments.Filters + , Yesod.Comments.Management -- Packages needed in order to build this package. build-depends: base >= 4 && < 5 @@ -28,10 +28,10 @@ , yesod-auth >= 0.4 && < 0.5 , yesod-goodies >= 0.0.3 && < 0.1 , persistent >= 0.5 && < 0.6 + , template-haskell , directory , time - - + , old-locale ghc-options: -Wall