yesod-comments 0.7.1 → 0.8.0
raw patch · 8 files changed
+498/−513 lines, 8 filesdep ~persistentdep ~waidep ~yesod
Dependency ranges changed: persistent, wai, yesod, yesod-auth, yesod-form
Files
- Yesod/Comments.hs +10/−79
- Yesod/Comments/Core.hs +54/−187
- Yesod/Comments/Form.hs +130/−0
- Yesod/Comments/Management.hs +86/−170
- Yesod/Comments/Storage.hs +52/−71
- Yesod/Comments/Utils.hs +73/−0
- Yesod/Comments/View.hs +84/−0
- yesod-comments.cabal +9/−6
Yesod/Comments.hs view
@@ -10,97 +10,28 @@ -- Stability : unstable -- Portability : unportable ----- A generic Comments interface for a Yesod application. This module is--- in the early stages of development. Beware bugs, patches welcome.+-- A generic Comments interface for a Yesod application. -- ------------------------------------------------------------------------------- module Yesod.Comments ( addComments- , addCommentsAuth , module Yesod.Comments.Core ) where import Yesod-import Yesod.Auth import Yesod.Comments.Core-import Network.Gravatar-import Data.Text (Text)---- | Comments that anyone can enter anonymously-addComments :: (RenderMessage m FormMessage, YesodComments m)- => ThreadId -- ^ the thread you're adding comments to- -> GWidget s m ()-addComments tid = do- comments <- lift $ loadComments (Just tid)- ((res, form), enctype) <- lift $ runFormPost commentForm-- handleForm res tid-- [whamlet|- <div .yesod_comments>- ^{showComments comments showComment}-- <div .input>- <form enctype="#{enctype}" method="post" .form-stacked>- ^{form}- <div .actions>- <button .btn .primary type="submit">Add comment- |]---- | Comments that require authentication-addCommentsAuth :: (RenderMessage m FormMessage, YesodAuth m, YesodComments m)- => ThreadId -- ^ the thread you're adding comments to- -> GWidget s m ()-addCommentsAuth tid = do- (isAuthenticated, uid, username, email) <- lift $ do- muid <- maybeAuthId- case muid of- Nothing -> return (False, "", "", "")- Just uid -> do- uname <- displayUser uid- email <- displayEmail uid- return (True, toPathPiece uid, uname, email)-- comments <- lift $ loadComments (Just tid)- ((res, form), enctype) <- lift $ runFormPost (commentFormAuth uid email)+import Yesod.Comments.Utils+import Yesod.Comments.Form+import Yesod.Comments.View - handleForm res tid+addComments :: (RenderMessage m FormMessage, YesodComments m) => ThreadId -> GWidget s m ()+addComments thread = do+ comments <- lift $ csLoad commentStorage (Just thread)+ mudetails <- lift $ currentUserDetails [whamlet| <div .yesod_comments>- ^{showComments comments showCommentAuth}-- $if isAuthenticated- <div .avatar>- <a target="_blank" title="change your profile picture at gravatar" href="http://gravatar.com/emails/">- <img src="#{img email}">-- <div .input>- <form enctype="#{enctype}" method="post" .form-stacked>- <div .clearfix .optional>- <label for="username">Username- <div .input>- <p #username>#{username}-- ^{form}-- <div .actions>- <button .btn .primary type="submit">Add comment+ ^{showComments comments} - $else- <h4>Please ^{login} to post a comment.+ ^{runForm thread mudetails} |]-- where- img :: Text -> String- img = gravatar defaultConfig { gDefault = Just MM, gSize = Just $ Size 48 }-- login :: Yesod m => GWidget s m ()- login = do- mroute <- lift $ do- setUltDestCurrent- fmap authRoute getYesod-- case mroute of- Just r -> [whamlet|<a href="@{r}">log in|]- Nothing -> [whamlet|log in|]
Yesod/Comments/Core.hs view
@@ -13,212 +13,79 @@ -- ------------------------------------------------------------------------------- module Yesod.Comments.Core- ( Comment(..)- , CommentForm(..)+ ( YesodComments(..) , CommentId , ThreadId- , YesodComments (..)- , Form- , commentFromForm- , commentForm- , commentFormAuth- , commentLabel- , handleForm- , showComments- , showComment- , showCommentAuth- , getNextCommentId- , isCommentingUser+ , Comment(..)+ , UserDetails(..)+ , CommentStorage(..) ) where import Yesod import Yesod.Auth import Yesod.Markdown-import Control.Applicative ((<$>), (<*>), pure)-import Data.Text (Text)-import Data.Time (UTCTime, getCurrentTime)-import Data.Time.Format.Human-import Network.Gravatar-import Network.Wai (remoteHost)-import qualified Data.Text as T +import Data.Text (Text)+import Data.Time (UTCTime)+ type ThreadId = Text type CommentId = Int -class Yesod m => YesodComments m where- getComment :: ThreadId -> CommentId -> GHandler s m (Maybe Comment)- storeComment :: Comment -> GHandler s m ()- updateComment :: Comment -> Comment -> GHandler s m ()- deleteComment :: Comment -> GHandler s m ()- 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 friendly probably pulled from the user's- -- profile on your site.- displayUser :: AuthId m -> GHandler s m Text- displayUser _ = return ""-- -- | 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 Text- displayEmail _ = return ""-+-- | The core data type a Comment data Comment = Comment- { threadId :: ThreadId- , commentId :: CommentId- , timeStamp :: UTCTime- , ipAddress :: Text- , userName :: Text- , userEmail :: Text- , content :: Markdown- , isAuth :: Bool+ { commentId :: CommentId+ , cThreadId :: ThreadId+ , cTimeStamp :: UTCTime+ , cIpAddress :: Text+ , cUserName :: Text+ , cUserEmail :: Text+ , cContent :: Markdown+ , cIsAuth :: Bool -- ^ compatability field, always true } instance Eq Comment where- a == b = (threadId a == threadId b) && (commentId a == commentId b)--data CommentForm = CommentForm- { formUser :: Text- , formEmail :: Text- , formComment :: Markdown- , formIsAuth :: Bool- }--type Form s m x = Html -> MForm s m (FormResult x, GWidget s m ())--commentFromForm :: YesodComments m => ThreadId -> CommentForm -> GHandler s m Comment-commentFromForm tid cf = do- now <- liftIO getCurrentTime- ip <- fmap (show . remoteHost) waiRequest- cid <- getNextCommentId tid-- return Comment - { threadId = tid - , commentId = cid - , timeStamp = now- , ipAddress = T.pack ip- , userName = formUser cf- , userEmail = formEmail cf- , content = formComment cf- , isAuth = formIsAuth cf- }--commentForm :: RenderMessage m FormMessage => Form s m CommentForm-commentForm = renderBootstrap $ CommentForm- <$> areq textField "Name" Nothing- <*> areq emailField "Email" Nothing- <*> areq markdownField commentLabel Nothing- <*> pure False--commentFormAuth :: RenderMessage m FormMessage- => Text -- ^ Text version of uid- -> Text -- ^ user's email- -> Form s m CommentForm-commentFormAuth user email = renderBootstrap $ CommentForm- <$> pure user <*> pure email- <*> areq markdownField commentLabel Nothing- <*> pure True---handleForm :: YesodComments m => FormResult CommentForm -> ThreadId -> GWidget s m ()-handleForm (FormSuccess cf) tid = lift $ do- storeComment =<< commentFromForm tid cf- setMessage "comment added."- redirectCurrentRoute--handleForm _ _ = return ()---showComment :: Comment -> GWidget s m ()-showComment comment = showHelper comment (userName comment, userEmail comment)--showCommentAuth :: (YesodAuth m, YesodComments m) => Comment -> GWidget s m ()-showCommentAuth comment = do- let cusername = userName comment-- (cuname, cemail) <-- if isAuth comment- then case fromPathPiece $ cusername of- Just uid -> do- uname <- lift $ displayUser uid- email <- lift $ displayEmail uid- return (uname, email)- _ -> return (cusername, userEmail comment)- else return (cusername, userEmail comment)-- showHelper comment (cuname, cemail)--showComments :: [Comment] -> (Comment -> GWidget s m ()) -> GWidget s m ()-showComments comments f = [whamlet|- <div .list>- $if not $ null comments- <h4>Showing #{toHtml $ helper $ length comments}:-- $forall comment <- comments- ^{f comment}- |]-- where- -- pluralize comments- helper :: Int -> String- helper 0 = "no comments"- helper 1 = "1 comment"- helper n = show n ++ " comments"--showHelper :: Comment -> (Text,Text) -> GWidget s m ()-showHelper comment (username, email) = do- commentTimestamp <- lift . liftIO . humanReadableTime $ timeStamp comment-- let anchor = "comment_" ++ show (commentId comment)-- [whamlet|- <div .comment>- <div .attribution>- <p>- <span .avatar>- <img src="#{img email}">-- <a href="##{anchor}" id="#{anchor}">#{commentTimestamp}- , #{username} wrote:+ a == b = (cThreadId a == cThreadId b) && (commentId a == commentId b) - <div .content>- <blockquote>- #{markdownToHtml $ content comment}- |]+-- | Information about the User that's needed to store comments.+data UserDetails = UserDetails+ { textUserName :: Text -- ^ Text version of user id, @toPathPiece+ -- userId@ is recommended. comments are stored+ -- using this value so users can freely change+ -- names without losing comments.+ , friendlyName :: Text -- ^ The name that's actually displayed+ , emailAddress :: Text -- ^ Not shown but stored+ } deriving Eq - where- img :: Text -> String- img = gravatar defaultConfig { gDefault = Just MM, gSize = Just $ Size 20 }+-- | How to save and restore comments from persisten storage. All necesary+-- actions are accomplished through these 5 functions. Currently, only+-- @persistStorage@ is available.+data CommentStorage s m = CommentStorage+ { csGet :: ThreadId -> CommentId -> GHandler s m (Maybe Comment)+ , csStore :: Comment -> GHandler s m ()+ , csUpdate :: Comment -> Comment -> GHandler s m ()+ , csDelete :: Comment -> GHandler s m ()+ , csLoad :: Maybe ThreadId -> GHandler s m [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)+class YesodAuth m => YesodComments m where+ -- | How to store and load comments from persistent storage.+ commentStorage :: CommentStorage s m - where- go :: YesodComments m => [Comment] -> GHandler s m CommentId- go [] = return 1- go cs = return $ maximum (map commentId cs) + 1+ -- | If @Nothing@ is returned, the user cannot add a comment. This can+ -- be used to blacklist users. Note that comments left by them will+ -- still appear until manually deleted.+ userDetails :: AuthId m -> GHandler s m (Maybe UserDetails) --- | Returns False when not logged in.-isCommentingUser :: YesodAuth m => Comment -> GHandler s m Bool-isCommentingUser comment = do- muid <- maybeAuthId- return $ case muid of- Just uid -> isAuth comment && toPathPiece uid == userName comment- _ -> False+ -- | A thread's route. Currently, only used for linking back from the+ -- admin subsite.+ threadRoute :: ThreadId -> Route m --- | Redirect back to the current route after a POST request. Calls not--- found if the current route is unknown.-redirectCurrentRoute :: Yesod m => GHandler s m ()-redirectCurrentRoute = do- tm <- getRouteToMaster- mr <- getCurrentRoute- case mr of- Just r -> redirect $ tm r- Nothing -> notFound+ -- | A route to the admin subsite's EditCommentR action. If @Nothing@,+ -- the Edit link will not be shown.+ editRoute :: Maybe (ThreadId -> CommentId -> Route m)+ editRoute = Nothing -commentLabel :: FieldSettings master-commentLabel = "Comment" { fsTooltip = Just "Comments are parsed as pandoc-style markdown." }+ -- | A route to the admin subsite's DeleteCommentR action. If+ -- @Nothing@, the Delete link will not be shown.+ deleteRoute :: Maybe (ThreadId -> CommentId -> Route m)+ deleteRoute = Nothing
+ Yesod/Comments/Form.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+-------------------------------------------------------------------------------+-- |+-- Module : Yesod.Comments.Form+-- Copyright : (c) Patrick Brisbin 2010+-- License : as-is+--+-- Maintainer : pbrisbin@gmail.com+-- Stability : unstable+-- Portability : unportable+--+-------------------------------------------------------------------------------+module Yesod.Comments.Form+ ( CommentForm(..)+ , commentForm+ , commentFromForm+ , runForm+ , runFormWith+ ) where++import Yesod+import Yesod.Markdown+import Yesod.Comments.Core+import Yesod.Comments.Utils++import Control.Applicative ((<$>), (<*>), pure)+import Data.Time (getCurrentTime)+import Network.Wai (remoteHost)++import qualified Data.Text as T++type Form s m x = Html -> MForm s m (FormResult x, GWidget s m ())++data CommentForm = CommentForm+ { formUser :: UserDetails+ , formThread :: ThreadId+ , formComment :: Markdown+ }++commentFromForm :: YesodComments m => CommentForm -> GHandler s m Comment+commentFromForm cf = do+ now <- liftIO getCurrentTime+ ip <- fmap (show . remoteHost) waiRequest+ cid <- getNextCommentId $ formThread cf++ return Comment+ { commentId = cid+ , cThreadId = formThread cf+ , cTimeStamp = now+ , cIpAddress = T.pack ip+ , cUserName = textUserName $ formUser cf+ , cUserEmail = emailAddress $ formUser cf+ , cContent = formComment cf+ , cIsAuth = True+ }++ where+ getNextCommentId :: YesodComments m => ThreadId -> GHandler s m CommentId+ getNextCommentId tid = go =<< csLoad commentStorage (Just tid)++ go :: YesodComments m => [Comment] -> GHandler s m CommentId+ go [] = return 1+ go cs = return $ maximum (map commentId cs) + 1++commentForm :: RenderMessage m FormMessage => ThreadId -> UserDetails -> Maybe Comment -> Form s m CommentForm+commentForm thread udetails mcomment = renderBootstrap $ CommentForm+ <$> pure udetails+ <*> pure thread+ <*> areq markdownField commentLabel (fmap cContent mcomment)++ where+ commentLabel :: FieldSettings master+ commentLabel = "Comment" { fsTooltip = Just "Comments are parsed as pandoc-style markdown." }++-- | Run the form and stores the comment on successful submission+runForm :: YesodComments m => ThreadId -> Maybe UserDetails -> GWidget s m ()+runForm = runFormWith Nothing $ \cf -> do+ tm <- getRouteToMaster++ csStore commentStorage =<< commentFromForm cf+ setMessage "comment added."++ -- redirect to current route+ maybe notFound (redirect . tm) =<< getCurrentRoute++-- | Both handle form submission and present form HTML. On FormSuccess, run+-- the given function on the submitted value.+runFormWith :: YesodComments m+ => Maybe Comment+ -> (CommentForm -> GHandler s m ())+ -> ThreadId+ -> Maybe UserDetails+ -> GWidget s m ()+runFormWith _ _ _ Nothing = [whamlet|<h4>Please ^{login} to post a comment.|]+runFormWith mcomment f thread (Just ud@(UserDetails _ name email)) = do+ ((res, form), enctype) <- lift $ runFormPost (commentForm thread ud mcomment)++ case res of+ FormSuccess cf -> lift $ f cf+ _ -> return ()++ [whamlet|+ <div .avatar>+ <a target="_blank" title="change your profile picture at gravatar" href="http://gravatar.com/emails/">+ <img src="#{gravatar 48 email}">++ <div .input>+ <form enctype="#{enctype}" method="post" .form-stacked>+ <div .clearfix .optional>+ <label for="username">Username+ <div .input>+ <p #username>#{name}++ ^{form}++ <div .actions>+ <button .btn .primary type="submit">Add comment+ |]++login :: Yesod m => GWidget s m ()+login = do+ mroute <- lift $ do+ setUltDestCurrent+ fmap authRoute getYesod++ case mroute of+ Just r -> [whamlet|<a href="@{r}">log in|]+ Nothing -> [whamlet|log in|]
Yesod/Comments/Management.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------- -- | -- Module : Yesod.Comments.Management@@ -15,20 +16,8 @@ -- 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@@ -38,14 +27,17 @@ import Yesod import Yesod.Auth+ import Yesod.Comments.Core-import Yesod.Markdown-import Control.Applicative ((<$>), (<*>), pure)+import Yesod.Comments.Utils+import Yesod.Comments.Form+import Yesod.Comments.View+ import Control.Monad (forM, unless) import Data.List (sortBy, nub)-import Data.Time (UTCTime, formatTime)+import Data.Text (Text)+import Data.Time (UTCTime) import Language.Haskell.TH.Syntax hiding (lift)-import System.Locale (defaultTimeLocale, rfc822DateFormat) data CommentsAdmin = CommentsAdmin @@ -53,166 +45,84 @@ getCommentsAdmin = const CommentsAdmin mkYesodSub "CommentsAdmin"- [ ClassP ''YesodAuth [ VarT $ mkName "master" ]- , ClassP ''YesodComments [ 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+ / CommentsR GET+ /edit/#ThreadId/#CommentId EditCommentR GET POST+ /delete/#ThreadId/#CommentId DeleteCommentR GET POST |] -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}+getCommentsR :: YesodComments m => GHandler CommentsAdmin m RepHtml+getCommentsR = do+ comments <- getThreadedComments - ^{updateLinks comment}- |]+ layout "Your comments" [whamlet|+ $forall (t, cs) <- comments+ <div .thread>+ <h3>+ <a href="@{threadRoute t}">#{t} - where- formatTimeStamp :: UTCTime -> String -- todo: make my own format- formatTimeStamp = formatTime defaultTimeLocale rfc822DateFormat+ <div .comments>+ ^{showComments cs}+ |] -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}+getEditCommentR :: YesodComments m => ThreadId -> CommentId -> GHandler CommentsAdmin m RepHtml+getEditCommentR thread cid = withUserComment thread cid $ \c -> do+ ud <- requireUserDetails - <div .actions>- <button .btn .primary type="submit">Add comment+ layout "Edit comment" [whamlet|+ ^{runFormEdit c thread (Just ud)} |] -postEditR :: (YesodAuth m, YesodComments m) => ThreadId -> CommentId -> GHandler CommentsAdmin m RepHtml-postEditR = getEditR+postEditCommentR :: YesodComments m => ThreadId -> CommentId -> GHandler CommentsAdmin m RepHtml+postEditCommentR = getEditCommentR -getDeleteR :: (YesodAuth m, YesodComments m) => ThreadId -> CommentId -> GHandler CommentsAdmin m RepHtml-getDeleteR tid cid = withUserComment tid cid $ \comment -> do+getDeleteCommentR :: YesodComments m => ThreadId -> CommentId -> GHandler CommentsAdmin m RepHtml+getDeleteCommentR _ _ = layout "Delete comment" [whamlet|+ <p>Are you sure?+ <form method="post" .form-stacked>+ <div .actions>+ <button .btn .btn-danger type="submit">Delete comment+ |]++postDeleteCommentR :: YesodComments m => ThreadId -> CommentId -> GHandler CommentsAdmin m RepHtml+postDeleteCommentR thread cid = withUserComment thread cid $ \c -> do tm <- getRouteToMaster- deleteComment comment+ csDelete commentStorage c setMessage "comment deleted."- redirect $ tm OverviewR+ redirect $ tm CommentsR -getThreadedComments :: (YesodAuth m, YesodComments m) => GHandler s m [(ThreadId, [Comment])]+-- | Return tuples of thread id and associated comments sorted by most+-- recently commented on thread.+getThreadedComments :: YesodComments m => GHandler s m [(ThreadId, [Comment])] getThreadedComments = do- allComments <- loadComments Nothing+ allComments <- csLoad commentStorage Nothing allThreads <- forM allComments $ \comment -> do mine <- isCommentingUser comment- return $ if mine then [threadId comment] else []+ return $ if mine then [cThreadId comment] else [] unsorted <- forM (nub $ concat allThreads) $ \tid ->- return (tid, filter ((== tid) . threadId) allComments)+ return (tid, filter ((== tid) . cThreadId) 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}- |]+ latest :: (ThreadId, [Comment]) -> (ThreadId, [Comment]) -> Ordering+ latest (t1, cs1) (t2, cs2) =+ -- reversed comparason so more recent threads sort first+ case compare (latest' cs1) (latest' cs2) of+ EQ -> compare t1 t2+ GT -> LT+ LT -> GT -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- |]+ latest' :: [Comment] -> UTCTime+ latest' = maximum . map cTimeStamp --- | 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+-- | Halts with @permissionDenied@ or runs the action if the comment+-- belongs to the currently logged in user+withUserComment :: YesodComments m => ThreadId -> CommentId -> (Comment -> GHandler s m RepHtml) -> GHandler s m RepHtml+withUserComment thread cid f = do+ mcomment <- csGet commentStorage thread cid case mcomment of Just comment -> do _ <- requireAuthId@@ -222,16 +132,22 @@ 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 }+-- | Runs the form and updates the comment on success+runFormEdit :: YesodComments m => Comment -> ThreadId -> Maybe UserDetails -> GWidget CommentsAdmin m ()+runFormEdit comment = runFormWith (Just comment) $ \cf -> do+ tm <- getRouteToMaster+ csUpdate commentStorage comment $ comment { cContent = formComment cf } setMessage "comment updated."- redirect r+ redirect $ tm CommentsR -handleFormEdit _ _ _ = return ()+layout :: Yesod m => Text -> GWidget s m () -> GHandler s m RepHtml+layout title inner = defaultLayout $ do+ setTitle $ toHtml title++ [whamlet|+ <div .page_header>+ <h1>#{title}++ <div .yesod_comments>+ ^{inner}+ |]
Yesod/Comments/Storage.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}@@ -14,104 +15,84 @@ -- Stability : unstable -- Portability : unportable ----- Some pre-built function definitions for storing and loading comments.--- ------------------------------------------------------------------------------- module Yesod.Comments.Storage- (- -- * Persist- -- $persist- getCommentPersist- , storeCommentPersist- , updateCommentPersist- , deleteCommentPersist- , loadCommentsPersist+ ( persistStorage , migrateComments- -- * TODO- -- $todo ) where import Yesod-import Database.Persist.GenericSql (SqlPersist)-import Yesod.Comments.Core (Comment(..))-import Yesod.Markdown (Markdown(..))-import Data.Time.Clock (UTCTime)-import qualified Data.Text as T+import Yesod.Comments.Core+import Yesod.Markdown (Markdown(..)) --- $persist------ Use these functions to store your comments in an instance of--- YesodPersist---+import Data.Text (Text)+import Data.Time (UTCTime)+import Database.Persist.GenericSql (SqlPersist) --- | Create the required types and migration function for use in a--- general yesod app------ todo: find out how to do the ThreadId/CommentId types with the new--- persistent module--- share [mkPersist sqlSettings, mkMigrate "migrateComments"] [persist| SqlComment- threadId T.Text Eq noreference+ threadId Text Eq noreference commentId Int Eq Asc noreference timeStamp UTCTime- ipAddress T.Text- userName T.Text- userEmail T.Text+ ipAddress Text+ userName Text+ userEmail Text content Markdown Update isAuth Bool UniqueSqlComment threadId commentId |] --- | Make a 'SqlComment' out of a 'Comment' for passing off to insert toSqlComment :: Comment -> SqlComment toSqlComment comment = SqlComment- { sqlCommentThreadId = threadId comment- , sqlCommentCommentId = commentId comment- , sqlCommentTimeStamp = timeStamp comment- , sqlCommentIpAddress = ipAddress comment- , sqlCommentUserName = userName comment- , sqlCommentUserEmail = userEmail comment- , sqlCommentContent = content comment- , sqlCommentIsAuth = isAuth comment+ { sqlCommentCommentId = commentId comment+ , sqlCommentThreadId = cThreadId comment+ , sqlCommentTimeStamp = cTimeStamp comment+ , sqlCommentIpAddress = cIpAddress comment+ , sqlCommentUserName = cUserName comment+ , sqlCommentUserEmail = cUserEmail comment+ , sqlCommentContent = cContent comment+ , sqlCommentIsAuth = cIsAuth comment } --- | Read a 'Comment' back from a selected 'SqlComment' fromSqlComment :: SqlComment -> Comment fromSqlComment sqlComment = Comment- { threadId = sqlCommentThreadId sqlComment- , commentId = sqlCommentCommentId sqlComment- , timeStamp = sqlCommentTimeStamp sqlComment- , ipAddress = sqlCommentIpAddress sqlComment- , userName = sqlCommentUserName sqlComment- , userEmail = sqlCommentUserEmail sqlComment- , content = sqlCommentContent sqlComment- , isAuth = sqlCommentIsAuth sqlComment+ { commentId = sqlCommentCommentId sqlComment+ , cThreadId = sqlCommentThreadId sqlComment+ , cTimeStamp = sqlCommentTimeStamp sqlComment+ , cIpAddress = sqlCommentIpAddress sqlComment+ , cUserName = sqlCommentUserName sqlComment+ , cUserEmail = sqlCommentUserEmail sqlComment+ , cContent = sqlCommentContent sqlComment+ , cIsAuth = sqlCommentIsAuth sqlComment } -getCommentPersist :: (YesodPersistBackend m ~ SqlPersist, YesodPersist m) => T.Text -> Int -> GHandler s m (Maybe Comment)-getCommentPersist tid cid = return . fmap (fromSqlComment . entityVal) =<< runDB (getBy $ UniqueSqlComment tid cid)+-- | Store comments in an instance of YesodPersit with a SQL backend+persistStorage :: ( YesodPersist m+ , YesodPersistBackend m ~ SqlPersist+ ) => CommentStorage s m+persistStorage = CommentStorage+ { csGet = \tid cid -> do+ mentity <- runDB (getBy $ UniqueSqlComment tid cid)+ return $ fmap (fromSqlComment . entityVal) mentity -storeCommentPersist :: (YesodPersist m, PersistStore (YesodPersistBackend m) (GHandler s m)) => Comment -> GHandler s m ()-storeCommentPersist c = return . const () =<< runDB (insert $ toSqlComment c)+ , csStore = \c -> do+ _ <- runDB (insert $ toSqlComment c)+ return () --- | Note, only updates the content record-updateCommentPersist :: (YesodPersist m, PersistUnique (YesodPersistBackend m) (GHandler s m), PersistQuery (YesodPersistBackend m) (GHandler s m)) => Comment -> Comment -> GHandler s m ()-updateCommentPersist (Comment tid cid _ _ _ _ _ _) (Comment _ _ _ _ _ _ newContent _) = do- mres <- runDB (getBy $ UniqueSqlComment tid cid)- case mres of- Just (Entity k _) -> runDB $ update k [SqlCommentContent =. newContent]- _ -> return ()+ , csUpdate = \(Comment cid tid _ _ _ _ _ _) (Comment _ _ _ _ _ _ newContent _) -> do+ mres <- runDB (getBy $ UniqueSqlComment tid cid)+ case mres of+ Just (Entity k _) -> runDB $ update k [SqlCommentContent =. newContent]+ _ -> return () -deleteCommentPersist :: (YesodPersist m, PersistUnique (YesodPersistBackend m) (GHandler s m)) => Comment -> GHandler s m ()-deleteCommentPersist c = return . const () =<< runDB (deleteBy $ UniqueSqlComment (threadId c) (commentId c))+ , csDelete = \c -> do+ _ <- runDB (deleteBy $ UniqueSqlComment (cThreadId c) (commentId c))+ return () --- | Use @'Nothing'@ to retrieve all comments site-wide-loadCommentsPersist :: (YesodPersistBackend m ~ SqlPersist, YesodPersist m) => Maybe T.Text -> GHandler s m [Comment]-loadCommentsPersist (Just tid) = return . fmap (fromSqlComment . entityVal) =<< runDB (selectList [SqlCommentThreadId ==. tid] [Asc SqlCommentCommentId])-loadCommentsPersist Nothing = return . fmap (fromSqlComment . entityVal) =<< runDB (selectList [] [Asc SqlCommentCommentId])+ , csLoad = \mthread -> do+ entities <- case mthread of+ (Just tid) -> runDB (selectList [SqlCommentThreadId ==. tid] [Asc SqlCommentCommentId])+ Nothing -> runDB (selectList [] [Asc SqlCommentCommentId]) --- $todo------ Add more storage options...---+ return $ map (fromSqlComment . entityVal) entities+ }
+ Yesod/Comments/Utils.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+-------------------------------------------------------------------------------+-- |+-- Module : Yesod.Comments.Utils+-- Copyright : (c) Patrick Brisbin 2010+-- License : as-is+--+-- Maintainer : pbrisbin@gmail.com+-- Stability : unstable+-- Portability : unportable+--+-------------------------------------------------------------------------------+module Yesod.Comments.Utils+ ( commentUserDetails+ , currentUserDetails+ , requireUserDetails+ , defaultUserDetails+ , isCommentingUser+ , gravatar+ ) where++import Yesod+import Yesod.Auth+import Yesod.Comments.Core++import Data.Text (Text)+import Data.Maybe (fromMaybe)++import Network.Gravatar hiding (gravatar)+import qualified Network.Gravatar as G++-- | Map the commenter's id to user details or return defaults.+commentUserDetails :: YesodComments m => Comment -> GHandler s m UserDetails+commentUserDetails c =+ return . fromMaybe (defaultUserDetails c) =<<+ case (cIsAuth c, fromPathPiece (cUserName c)) of+ (True, Just uid) -> userDetails uid+ _ -> return Nothing++-- | Returns @Nothing@ if user is not authenticated+currentUserDetails :: YesodComments m => GHandler s m (Maybe UserDetails)+currentUserDetails = do+ muid <- maybeAuthId+ case muid of+ Just uid -> userDetails uid+ _ -> return Nothing++-- | Halts with @permissionDenied@ if user is not authorized+requireUserDetails :: YesodComments m => GHandler s m (UserDetails)+requireUserDetails = do+ mudetails <- currentUserDetails+ case mudetails of+ Just udetails -> return udetails+ _ -> permissionDenied "you must be logged in"++-- | For a comment that was not authenticated or cannot be mapped, the+-- default details are the id and email stored directly on the comment.+defaultUserDetails :: Comment -> UserDetails+defaultUserDetails c = UserDetails (cUserName c) (cUserName c) (cUserEmail c)++gravatar :: Int -- ^ size+ -> Text -- ^ email+ -> String+gravatar s = G.gravatar defaultConfig { gDefault = Just MM, gSize = Just $ Size s }++isCommentingUser :: YesodComments m => Comment -> GHandler s m Bool+isCommentingUser comment = do+ mudetails <- currentUserDetails+ cudetails <- commentUserDetails comment++ return $ maybe False (== cudetails) mudetails
+ Yesod/Comments/View.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+-------------------------------------------------------------------------------+-- |+-- Module : Yesod.Comments.View+-- Copyright : (c) Patrick Brisbin 2010+-- License : as-is+--+-- Maintainer : pbrisbin@gmail.com+-- Stability : unstable+-- Portability : unportable+--+-------------------------------------------------------------------------------+module Yesod.Comments.View+ ( showComments+ , showComment+ ) where++import Yesod+import Yesod.Comments.Core+import Yesod.Comments.Utils+import Yesod.Markdown++import Data.Time.Format.Human+import Data.Monoid (mempty)++showComments :: YesodComments m => [Comment] -> GWidget s m ()+showComments comments = [whamlet|+ <div .list>+ $if not $ null comments+ <h4>#{helper $ length comments}:++ $forall comment <- comments+ ^{showComment comment}+ |]++ where+ -- pluralize comments+ helper :: Int -> String+ helper 0 = "no comments"+ helper 1 = "1 comment"+ helper n = show n ++ " comments"++showComment :: YesodComments m => Comment -> GWidget s m ()+showComment comment = do+ mine <- lift $ isCommentingUser comment+ commentTimestamp <- lift . liftIO . humanReadableTime $ cTimeStamp comment+ UserDetails _ name email <- lift $ commentUserDetails comment++ let anchor = "comment_" ++ show (commentId comment)++ [whamlet|+ <div .comment :mine:.mine:>+ <div .attribution>+ <p>+ <span .avatar>+ <img src="#{gravatar 20 email}">++ <a href="##{anchor}" id="#{anchor}">#{commentTimestamp}+ , #{name} wrote:++ <div .content>+ <blockquote>+ #{markdownToHtml $ cContent comment}++ $if mine+ <div .controls>+ ^{commentControls editRoute deleteRoute (cThreadId comment) (commentId comment)}+ |]++-- | Edit and Delete links if configured+commentControls :: Maybe (ThreadId -> CommentId -> Route m) -- ^ Edit route+ -> Maybe (ThreadId -> CommentId -> Route m) -- ^ Delete route+ -> ThreadId -> CommentId -> GWidget s m ()+commentControls e@(Just _) d@(Just _) thread cid = [whamlet|+ ^{commentControls e Nothing thread cid}+ \ | + ^{commentControls Nothing d thread cid}+ |]++commentControls (Just editR) Nothing thread cid = [whamlet|<a href="@{editR thread cid}">Edit|]+commentControls Nothing (Just deleteR) thread cid = [whamlet|<a href="@{deleteR thread cid}">Delete|]+commentControls _ _ _ _ = mempty
yesod-comments.cabal view
@@ -1,5 +1,5 @@ name: yesod-comments-version: 0.7.1+version: 0.8.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,6 +16,9 @@ exposed-modules: Yesod.Comments , Yesod.Comments.Core , Yesod.Comments.Storage+ , Yesod.Comments.Utils+ , Yesod.Comments.Form+ , Yesod.Comments.View , Yesod.Comments.Management -- Packages needed in order to build this package.@@ -24,11 +27,11 @@ , bytestring >= 0.9.1 && < 0.10 , friendly-time >= 0.2 && < 0.3 , gravatar >= 0.5 && < 0.6- , persistent >= 0.9 && < 0.10- , wai >= 1.2 && < 1.3- , yesod >= 1.0 && < 1.1- , yesod-auth >= 1.0 && < 1.1- , yesod-form >= 1.0 && < 1.1+ , persistent >= 1.0 && < 1.1+ , wai >= 1.3 && < 1.4+ , yesod >= 1.1 && < 1.2+ , yesod-auth >= 1.1 && < 1.2+ , yesod-form >= 1.1 && < 1.2 , yesod-markdown >= 0.4 && < 0.5 , template-haskell