yesod-comments 0.3.4 → 0.4.0
raw patch · 6 files changed
+338/−115 lines, 6 filesdep +old-localedep +template-haskell
Dependencies added: old-locale, template-haskell
Files
- Yesod/Comments.hs +2/−52
- Yesod/Comments/Core.hs +119/−24
- Yesod/Comments/Filters.hs +0/−32
- Yesod/Comments/Management.hs +196/−0
- Yesod/Comments/Storage.hs +17/−3
- yesod-comments.cabal +4/−4
Yesod/Comments.hs view
@@ -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| <div .yesod_comments>@@ -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| <div .yesod_comments>@@ -87,53 +84,6 @@ $forall comment <- comments <div .yesod_comment>^{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"
Yesod/Comments/Core.hs view
@@ -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| <div .yesod_comment_avatar_input> <a title="change your profile picture at gravatar" href="http://gravatar.com/emails/"> <img src="#{img}">@@ -147,6 +155,18 @@ <input type="submit" value="Add comment"> |]) +-- | 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|+ <table>+ ^{fieldRow fiComment}+ <tr>+ <td> + <td colspan="2">+ <input type="submit" value="Update comment">+ |]) 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| <div .yesod_comment_avatar_list> <img src="#{img}"> <p>- <a href="#{anchor}" id="#{anchor}">#{commentTimestamp}+ <a href="##{anchor}" id="#{anchor}">#{commentTimestamp} , #{username} wrote: <blockquote> #{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
− Yesod/Comments/Filters.hs
@@ -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)
+ Yesod/Comments/Management.hs view
@@ -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 <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+ , 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|+ <h1>Comments overview+ <article .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"+ addStyling+ [hamlet|+ <h1>View comment+ <article .yesod_comments_view_comment>+ <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) <- runFormMonadPost $ commentFormEdit comment+ defaultLayout $ do+ setTitle "Edit comment"+ handleFormEdit (tm OverviewR) res comment+ addStyling+ [hamlet|+ <h1>Edit comment+ <article .yesod_comments_edit_comment>+ <h3>Update comment+ <div .yesod_comment_input>+ <form enctype="#{enctype}" method="post">^{form}+ <p .helptext>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|+ <div .yesod_comments_overview_thread>+ <h3>#{tid}+ $forall comment <- comments+ <div .yesod_comments_overview_comment>+ ^{showCommentAuth comment}+ ^{updateLinks comment}+ |]++updateLinks :: (YesodAuth m, YesodComments m) => Comment -> GWidget CommentsAdmin m ()+updateLinks (Comment tid cid _ _ _ _ _ _ )= do+ tm <- lift $ getRouteToMaster+ [hamlet|+ <div .yesod_comments_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 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
Yesod/Comments/Storage.hs view
@@ -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...+--
yesod-comments.cabal view
@@ -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