yesod-comments 0.8.3 → 0.9.0
raw patch · 9 files changed
+139/−87 lines, 9 filesdep ~persistentdep ~yesoddep ~yesod-auth
Dependency ranges changed: persistent, yesod, yesod-auth, yesod-form, yesod-markdown
Files
- Yesod/Comments.hs +3/−3
- Yesod/Comments/Core.hs +9/−7
- Yesod/Comments/Form.hs +13/−15
- Yesod/Comments/Management.hs +67/−44
- Yesod/Comments/Management/Routes.hs +28/−0
- Yesod/Comments/Storage.hs +2/−2
- Yesod/Comments/Utils.hs +4/−4
- Yesod/Comments/View.hs +6/−6
- yesod-comments.cabal +7/−6
Yesod/Comments.hs view
@@ -24,10 +24,10 @@ import Yesod.Comments.Form import Yesod.Comments.View -addComments :: (RenderMessage m FormMessage, YesodComments m) => ThreadId -> GWidget s m ()+addComments :: (RenderMessage m FormMessage, YesodComments m) => ThreadId -> WidgetT m IO () addComments thread = do- comments <- lift $ csLoad commentStorage (Just thread)- mudetails <- lift $ currentUserDetails+ comments <- handlerToWidget $ csLoad commentStorage (Just thread)+ mudetails <- handlerToWidget $ currentUserDetails [whamlet| <div .yesod_comments>
Yesod/Comments/Core.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------- -- | -- Module : Yesod.Comments.Core@@ -60,23 +62,23 @@ -- necessary 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 ()+ { csGet :: ThreadId -> CommentId -> HandlerT m IO (Maybe Comment)+ , csStore :: Comment -> HandlerT m IO ()+ , csUpdate :: Comment -> Comment -> HandlerT m IO ()+ , csDelete :: Comment -> HandlerT m IO () -- | Pass @Nothing@ to get all comments site-wide.- , csLoad :: Maybe ThreadId -> GHandler s m [Comment]+ , csLoad :: Maybe ThreadId -> HandlerT m IO [Comment] } -class YesodAuth m => YesodComments m where+class YesodAuthPersist m => YesodComments m where -- | How to store and load comments from persistent storage. commentStorage :: CommentStorage s m -- | 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)+ userDetails :: AuthId m -> HandlerT m IO (Maybe UserDetails) -- | A thread's route. Currently, only used for linking back from the -- admin subsite.
Yesod/Comments/Form.hs view
@@ -31,7 +31,7 @@ import qualified Data.Text as T -type Form s m x = Html -> MForm s m (FormResult x, GWidget s m ())+type Form m x = Html -> MForm (HandlerT m IO) (FormResult x, WidgetT m IO ()) data CommentForm = CommentForm { formUser :: UserDetails@@ -39,7 +39,7 @@ , formComment :: Markdown } -commentFromForm :: YesodComments m => CommentForm -> GHandler s m Comment+commentFromForm :: YesodComments m => CommentForm -> HandlerT m IO Comment commentFromForm cf = do now <- liftIO getCurrentTime ip <- fmap (show . remoteHost) waiRequest@@ -57,14 +57,14 @@ } where- getNextCommentId :: YesodComments m => ThreadId -> GHandler s m CommentId+ getNextCommentId :: YesodComments m => ThreadId -> HandlerT m IO CommentId getNextCommentId tid = go =<< csLoad commentStorage (Just tid) - go :: YesodComments m => [Comment] -> GHandler s m CommentId+ go :: YesodComments m => [Comment] -> HandlerT m IO 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 :: RenderMessage m FormMessage => ThreadId -> UserDetails -> Maybe Comment -> Form m CommentForm commentForm thread udetails mcomment = renderBootstrap $ CommentForm <$> pure udetails <*> pure thread <*> areq markdownField commentLabel (fmap cContent mcomment)@@ -74,30 +74,28 @@ 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 :: YesodComments m => ThreadId -> Maybe UserDetails -> WidgetT m IO () runForm = runFormWith Nothing $ \cf -> do- tm <- getRouteToMaster- csStore commentStorage =<< commentFromForm cf setMessage "comment added." -- redirect to current route- maybe notFound (redirect . tm) =<< getCurrentRoute+ maybe notFound redirect =<< 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 ())+ -> (CommentForm -> HandlerT m IO ()) -> ThreadId -> Maybe UserDetails- -> GWidget s m ()+ -> WidgetT m IO () 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)+ ((res, form), enctype) <- handlerToWidget $ runFormPost (commentForm thread ud mcomment) case res of- FormSuccess cf -> lift $ f cf+ FormSuccess cf -> handlerToWidget $ f cf _ -> return () [whamlet|@@ -118,9 +116,9 @@ <button .btn .primary type="submit">Add comment |] -login :: Yesod m => GWidget s m ()+login :: Yesod m => WidgetT m IO () login = do- mroute <- lift $ do+ mroute <- handlerToWidget $ do setUltDestCurrent fmap authRoute getYesod
Yesod/Comments/Management.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -20,9 +21,8 @@ -- ------------------------------------------------------------------------------- module Yesod.Comments.Management- ( CommentsAdmin- , getCommentsAdmin- , Route(..)+ ( getCommentsAdmin+ , module Yesod.Comments.Management.Routes ) where import Yesod@@ -32,28 +32,24 @@ import Yesod.Comments.Utils import Yesod.Comments.Form import Yesod.Comments.View+import Yesod.Comments.Management.Routes import Control.Monad (forM, unless) import Data.List (sortBy, nub) import Data.Text (Text) import Data.Time (UTCTime)-import Language.Haskell.TH.Syntax hiding (lift) -data CommentsAdmin = CommentsAdmin- getCommentsAdmin :: a -> CommentsAdmin getCommentsAdmin = const CommentsAdmin -mkYesodSub "CommentsAdmin"- [ ClassP ''YesodComments [ VarT $ mkName "master" ] ]- [parseRoutes|- / CommentsR GET- /edit/#ThreadId/#CommentId EditCommentR GET POST- /delete/#ThreadId/#CommentId DeleteCommentR GET POST- |]+instance YesodComments master => YesodSubDispatch CommentsAdmin (HandlerT master IO)+ where yesodSubDispatch = $(mkYesodSubDispatch resourcesCommentsAdmin) -getCommentsR :: YesodComments m => GHandler CommentsAdmin m RepHtml-getCommentsR = do+type Handler a = forall master. YesodComments master+ => HandlerT CommentsAdmin (HandlerT master IO) a++getCommentsR :: Handler RepHtml+getCommentsR = lift $ do comments <- getThreadedComments layout "Your comments" [whamlet|@@ -66,35 +62,72 @@ ^{showComments cs} |] -getEditCommentR :: YesodComments m => ThreadId -> CommentId -> GHandler CommentsAdmin m RepHtml-getEditCommentR thread cid = withUserComment thread cid $ \c -> do- ud <- requireUserDetails+getEditCommentR :: ThreadId -> CommentId -> Handler RepHtml+getEditCommentR thread cid = do+ ud@(UserDetails _ name email) <- lift $ requireUserDetails - layout "Edit comment" [whamlet|- ^{runFormEdit c thread (Just ud)}- |]+ -- TODO: Duplication with withUserComment+ comment <- lift $ do+ mcomment <- csGet commentStorage thread cid+ case mcomment of+ Just comment -> do+ _ <- requireAuthId+ mine <- isCommentingUser comment+ unless mine $ permissionDenied "you can only manage your own comments"+ return comment -postEditCommentR :: YesodComments m => ThreadId -> CommentId -> GHandler CommentsAdmin m RepHtml+ Nothing -> notFound++ ((res, form), enctype) <- lift $ runFormPost (commentForm thread ud (Just comment))++ case res of+ FormSuccess cf -> do+ lift $ csUpdate commentStorage comment $ comment { cContent = formComment cf }+ setMessage "comment updated."+ redirect CommentsR+ _ -> return ()++ -- TODO: Duplication with runFormWith+ lift $ layout "Edit comment" [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+ |]++postEditCommentR :: ThreadId -> CommentId -> Handler RepHtml postEditCommentR = getEditCommentR -getDeleteCommentR :: YesodComments m => ThreadId -> CommentId -> GHandler CommentsAdmin m RepHtml-getDeleteCommentR _ _ = layout "Delete comment" [whamlet|+getDeleteCommentR :: ThreadId -> CommentId -> Handler RepHtml+getDeleteCommentR _ _ = lift $ 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- csDelete commentStorage c- setMessage "comment deleted."- redirect $ tm CommentsR+postDeleteCommentR :: ThreadId -> CommentId -> Handler RepHtml+postDeleteCommentR thread cid = do+ lift $ withUserComment thread cid $ \c -> do+ csDelete commentStorage c+ setMessage "comment deleted." + redirect CommentsR+ -- | Return tuples of thread id and associated comments sorted by most -- recently commented on thread.-getThreadedComments :: YesodComments m => GHandler s m [(ThreadId, [Comment])]+getThreadedComments :: YesodComments m => HandlerT m IO [(ThreadId, [Comment])] getThreadedComments = do allComments <- csLoad commentStorage Nothing allThreads <- forM allComments $ \comment -> do@@ -109,7 +142,7 @@ where latest :: (ThreadId, [Comment]) -> (ThreadId, [Comment]) -> Ordering latest (t1, cs1) (t2, cs2) =- -- reversed comparason so more recent threads sort first+ -- reversed comparison so more recent threads sort first case compare (latest' cs1) (latest' cs2) of EQ -> compare t1 t2 GT -> LT@@ -120,7 +153,7 @@ -- | If the comment belongs to the currently logged in user, runs the -- action on it. Otherwise, halts with @permissionDenied@.-withUserComment :: YesodComments m => ThreadId -> CommentId -> (Comment -> GHandler s m RepHtml) -> GHandler s m RepHtml+withUserComment :: YesodComments m => ThreadId -> CommentId -> (Comment -> HandlerT m IO a) -> HandlerT m IO a withUserComment thread cid f = do mcomment <- csGet commentStorage thread cid case mcomment of@@ -132,17 +165,7 @@ Nothing -> notFound --- | 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 $ tm CommentsR--layout :: Yesod m => Text -> GWidget s m () -> GHandler s m RepHtml+layout :: Yesod m => Text -> WidgetT m IO () -> HandlerT m IO RepHtml layout title inner = defaultLayout $ do setTitle $ toHtml title
+ Yesod/Comments/Management/Routes.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+-------------------------------------------------------------------------------+-- |+-- Module : Yesod.Comments.Management.Routes+-- Copyright : Patrick Brisbin+-- License : as-is+--+-- Maintainer : Patrick Brisbin <me@pbrisbin.com>+-- Stability : unstable+-- Portability : unportable+--+-------------------------------------------------------------------------------+module Yesod.Comments.Management.Routes where++import Yesod+import Yesod.Comments.Core++data CommentsAdmin = CommentsAdmin++mkYesodSubData "CommentsAdmin" [parseRoutes|+ / CommentsR GET+ /edit/#ThreadId/#CommentId EditCommentR GET POST+ /delete/#ThreadId/#CommentId DeleteCommentR GET POST+ |]
Yesod/Comments/Storage.hs view
@@ -27,9 +27,9 @@ import Data.Text (Text) import Data.Time (UTCTime)-import Database.Persist.GenericSql (SqlPersist)+import Database.Persist.Sql (SqlPersist) -share [mkPersist sqlSettings, mkMigrate "migrateComments"] [persist|+share [mkPersist sqlSettings, mkMigrate "migrateComments"] [persistUpperCase| SqlComment threadId Text Eq noreference commentId Int Eq Asc noreference
Yesod/Comments/Utils.hs view
@@ -32,7 +32,7 @@ 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 :: YesodComments m => Comment -> HandlerT m IO UserDetails commentUserDetails c = return . fromMaybe (defaultUserDetails c) =<< case (cIsAuth c, fromPathPiece (cUserName c)) of@@ -40,7 +40,7 @@ _ -> return Nothing -- | Returns @Nothing@ if user is not authenticated-currentUserDetails :: YesodComments m => GHandler s m (Maybe UserDetails)+currentUserDetails :: YesodComments m => HandlerT m IO (Maybe UserDetails) currentUserDetails = do muid <- maybeAuthId case muid of@@ -48,7 +48,7 @@ _ -> return Nothing -- | Halts with @permissionDenied@ if user is not authenticated-requireUserDetails :: YesodComments m => GHandler s m (UserDetails)+requireUserDetails :: YesodComments m => HandlerT m IO (UserDetails) requireUserDetails = do mudetails <- currentUserDetails case mudetails of@@ -64,7 +64,7 @@ gravatar :: Int -> Text -> String gravatar s = G.gravatar defaultConfig { gDefault = Just MM, gSize = Just $ Size s } -isCommentingUser :: YesodComments m => Comment -> GHandler s m Bool+isCommentingUser :: YesodComments m => Comment -> HandlerT m IO Bool isCommentingUser comment = do mudetails <- currentUserDetails cudetails <- commentUserDetails comment
Yesod/Comments/View.hs view
@@ -25,7 +25,7 @@ import Data.Time.Format.Human import Data.Monoid (mempty) -showComments :: YesodComments m => [Comment] -> GWidget s m ()+showComments :: YesodComments m => [Comment] -> WidgetT m IO () showComments comments = [whamlet| <div .list> $if not $ null comments@@ -42,11 +42,11 @@ helper 1 = "1 comment" helper n = show n ++ " comments" -showComment :: YesodComments m => Comment -> GWidget s m ()+showComment :: YesodComments m => Comment -> WidgetT m IO () showComment comment = do- mine <- lift $ isCommentingUser comment- commentTimestamp <- lift . liftIO . humanReadableTime $ cTimeStamp comment- UserDetails _ name email <- lift $ commentUserDetails comment+ mine <- handlerToWidget $ isCommentingUser comment+ commentTimestamp <- handlerToWidget . liftIO . humanReadableTime $ cTimeStamp comment+ UserDetails _ name email <- handlerToWidget $ commentUserDetails comment let anchor = "comment_" ++ show (commentId comment) @@ -72,7 +72,7 @@ -- | 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 ()+ -> ThreadId -> CommentId -> WidgetT m IO () commentControls e@(Just _) d@(Just _) thread cid = [whamlet| ^{commentControls e Nothing thread cid} \ |
yesod-comments.cabal view
@@ -1,5 +1,5 @@ name: yesod-comments-version: 0.8.3+version: 0.9.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@@ -19,6 +19,7 @@ , Yesod.Comments.Utils , Yesod.Comments.Form , Yesod.Comments.View+ , Yesod.Comments.Management.Routes , Yesod.Comments.Management -- Packages needed in order to build this package.@@ -27,12 +28,12 @@ , bytestring >= 0.9.1 && < 0.11 , friendly-time >= 0.2 && < 0.3 , gravatar >= 0.5 && < 0.6- , persistent >= 1.0 && < 1.2+ , persistent >= 1.2 && < 1.3 , wai >= 1.3 && < 1.5- , yesod >= 1.1 && < 1.2- , yesod-auth >= 1.1 && < 1.2- , yesod-form >= 1.1 && < 1.3- , yesod-markdown >= 0.4 && < 0.8+ , yesod >= 1.2 && < 1.3+ , yesod-auth >= 1.2 && < 1.3+ , yesod-form >= 1.3 && < 1.4+ , yesod-markdown >= 0.8 && < 0.9 , template-haskell , directory