diff --git a/Yesod/Comments.hs b/Yesod/Comments.hs --- a/Yesod/Comments.hs +++ b/Yesod/Comments.hs @@ -21,20 +21,20 @@ ) where import Yesod +import Yesod.Auth import Yesod.Comments.Core -import Yesod.Helpers.Auth -- | Comments that anyone can enter anonymously -addComments :: YesodComments m +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 $ runFormMonadPost commentForm + ((res, form), enctype) <- lift $ runFormPost commentForm handleForm res tid addStyling - [hamlet| + [whamlet|

Add a comment:
@@ -50,7 +50,7 @@ |] -- | Comments that require authentication -addCommentsAuth :: (YesodAuth m, YesodComments m) +addCommentsAuth :: (RenderMessage m FormMessage, YesodAuth m, YesodComments m) => ThreadId -- ^ the thread you're adding comments to -> GWidget s m () addCommentsAuth tid = do @@ -64,11 +64,11 @@ return (True, toSinglePiece uid, uname, email) comments <- lift $ loadComments (Just tid) - ((res, form), enctype) <- lift $ runFormMonadPost $ commentFormAuth uid username email + ((res, form), enctype) <- lift $ runFormPost (commentFormAuth uid username email) handleForm res tid addStyling - [hamlet| + [whamlet|
$if isAuthenticated

Add a comment: @@ -96,5 +96,5 @@ lift $ setUltDest' -- so we come back here after login mroute <- lift $ fmap authRoute getYesod case mroute of - Just r -> [hamlet|log in|] - Nothing -> [hamlet|log in|] + Just r -> [whamlet|log in|] + Nothing -> [whamlet|log in|] diff --git a/Yesod/Comments/Core.hs b/Yesod/Comments/Core.hs --- a/Yesod/Comments/Core.hs +++ b/Yesod/Comments/Core.hs @@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} ------------------------------------------------------------------------------- -- | -- Module : Yesod.Comments.Core @@ -31,8 +32,7 @@ ) where import Yesod -import Yesod.Form.Core -import Yesod.Helpers.Auth +import Yesod.Auth import Yesod.Goodies.Gravatar import Yesod.Goodies.Markdown import Yesod.Goodies.Time @@ -112,12 +112,13 @@ } -- | The comment form itself -commentForm :: GFormMonad s m (FormResult CommentForm, GWidget s m ()) -commentForm = do - (user , fiUser ) <- stringField "name:" Nothing - (email , fiEmail ) <- emailField "email:" Nothing - (comment, fiComment) <- markdownField "comment:" Nothing - return (CommentForm <$> user <*> email <*> comment <*> FormSuccess False, [hamlet| +commentForm :: RenderMessage m FormMessage => Html -> Form s m (FormResult CommentForm, GWidget s m ()) +commentForm fragment = do + (user , fiUser ) <- mreq textField "name:" Nothing + (email , fiEmail ) <- mreq emailField "email:" Nothing + (comment, fiComment) <- mreq markdownField "comment:" Nothing + return (CommentForm <$> user <*> email <*> comment <*> FormSuccess False, [whamlet| + #{fragment} ^{fieldRow fiUser} ^{fieldRow fiEmail} @@ -130,15 +131,18 @@ -- | The comment form if using authentication (uid is hidden and display -- name is shown) -commentFormAuth :: T.Text -- ^ text version of uid +commentFormAuth :: RenderMessage m FormMessage + => T.Text -- ^ text version of uid -> T.Text -- ^ friendly name -> T.Text -- ^ email - -> GFormMonad s m (FormResult CommentForm, GWidget s m ()) -commentFormAuth user username email = do + -> Html -- ^ nonce fragment + -> Form s m (FormResult CommentForm, GWidget s m ()) +commentFormAuth user username email fragment = do let img = gravatarImg email defaultOptions { gDefault = Just MM } - (fComment, fiComment) <- markdownField "comment:" Nothing - return (CommentForm <$> FormSuccess user <*> FormSuccess email <*> fComment <*> FormSuccess True, [hamlet| + (fComment, fiComment) <- mreq markdownField "comment:" Nothing + return (CommentForm <$> FormSuccess user <*> FormSuccess email <*> fComment <*> FormSuccess True, [whamlet| + #{fragment}
^{fieldRow fiComment} @@ -168,23 +176,24 @@ |]) -fieldRow :: FieldInfo s m -> GWidget s m () -fieldRow fi = [hamlet| - +fieldRow :: FieldView s m -> GWidget s m () +fieldRow fv = [whamlet| +
- - ^{fiInput fi} + ^{fvInput fv} - $maybe error <- fiErrors fi + $maybe error <- fvErrors fv #{error} $nothing   |] -clazz :: FieldInfo s m -> String -clazz fi = if fiRequired fi then "required" else "optional" +clazz :: FieldView s m -> String +clazz fv = if fvRequired fv then "required" else "optional" -- | Add some cassius that is common to all the yesod-comments pages addStyling :: Yesod m => GWidget s m () diff --git a/Yesod/Comments/Management.hs b/Yesod/Comments/Management.hs --- a/Yesod/Comments/Management.hs +++ b/Yesod/Comments/Management.hs @@ -30,7 +30,6 @@ -- comment entirely. -- ------------------------------------------------------------------------------- - module Yesod.Comments.Management ( CommentsAdmin , CommentsAdminRoute(..) @@ -38,7 +37,7 @@ ) where import Yesod -import Yesod.Helpers.Auth +import Yesod.Auth import Yesod.Comments.Core import Yesod.Goodies.Markdown import Control.Monad (forM, unless) @@ -69,7 +68,7 @@ defaultLayout $ do setTitle "Comments administration" addStyling - [hamlet| + [whamlet|

Comments overview
$if null threads @@ -84,7 +83,7 @@ defaultLayout $ do setTitle "View comment" addStyling - [hamlet| + [whamlet|

View comment
@@ -117,12 +116,12 @@ 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 + ((res, form), enctype) <- runFormPost $ commentFormEdit comment defaultLayout $ do setTitle "Edit comment" handleFormEdit (tm OverviewR) res comment addStyling - [hamlet| + [whamlet|

Edit comment

Update comment @@ -144,29 +143,39 @@ 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' + allThreads <- forM allComments $ \comment -> do + mine <- isCommentingUser comment + return $ if mine then [threadId comment] else [] - forM (sort . nub $ map threadId comments) $ \tid -> - return $ (tid, filter ((== tid) . threadId) comments) + forM (sort . nub $ concat allThreads) $ \tid -> + return (tid, filter ((== tid) . threadId) allComments) showThreadedComments :: (YesodAuth m, YesodComments m) => (ThreadId, [Comment]) -> GWidget CommentsAdmin m () -showThreadedComments (tid, comments) = [hamlet| +showThreadedComments (tid, comments) = [whamlet|

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

View @@ -189,8 +198,8 @@ case mcomment of Just comment -> do _ <- requireAuthId - check <- isCommentingUser comment - unless check $ permissionDenied "you can only manage your own comments" + mine <- isCommentingUser comment + unless mine $ 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -44,10 +45,14 @@ -- | Create the required types and migration function for use in a -- general yesod app -share2 mkPersist (mkMigrate "migrateComments") [persist| +-- +-- todo: find out how to do the ThreadId/CommentId types with the new +-- persistent module +-- +share [mkPersist sqlSettings, mkMigrate "migrateComments"] [persist| SqlComment - threadId ThreadId Eq noreference - commentId CommentId Eq Asc noreference + threadId T.Text Eq noreference + commentId Int Eq Asc noreference timeStamp UTCTime ipAddress T.Text userName T.Text @@ -83,27 +88,27 @@ , isAuth = sqlCommentIsAuth sqlComment } -getCommentPersist :: (YesodPersist m, PersistBackend (YesodDB m (GGHandler s m IO))) => ThreadId -> CommentId -> GHandler s m (Maybe Comment) +getCommentPersist :: (YesodPersist m, PersistBackend (YesodPersistBackend m) (GGHandler s m IO)) => ThreadId -> CommentId -> GHandler s m (Maybe Comment) getCommentPersist tid cid = return . fmap (fromSqlComment . snd) =<< runDB (getBy $ UniqueSqlComment tid cid) -storeCommentPersist :: (YesodPersist m, PersistBackend (YesodDB m (GGHandler s m IO))) => Comment -> GHandler s m () +storeCommentPersist :: (YesodPersist m, PersistBackend (YesodPersistBackend 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 :: (YesodPersist m, PersistBackend (YesodPersistBackend 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] + Just (k,_) -> runDB $ update k [SqlCommentContent =. newContent] _ -> return () -deleteCommentPersist :: (YesodPersist m, PersistBackend (YesodDB m (GGHandler s m IO))) => Comment -> GHandler s m () +deleteCommentPersist :: (YesodPersist m, PersistBackend (YesodPersistBackend m) (GGHandler s m IO)) => Comment -> GHandler s m () deleteCommentPersist c = return . const () =<< runDB (deleteBy $ UniqueSqlComment (threadId c) (commentId c)) -- | Use @'Nothing'@ to retrieve all comments site-wide -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) +loadCommentsPersist :: (YesodPersist m, PersistBackend (YesodPersistBackend m) (GGHandler s m IO)) => Maybe ThreadId -> GHandler s m [Comment] +loadCommentsPersist (Just tid) = return . fmap (fromSqlComment . snd) =<< runDB (selectList [SqlCommentThreadId ==. tid] [Asc SqlCommentCommentId]) +loadCommentsPersist Nothing = return . fmap (fromSqlComment . snd) =<< runDB (selectList [] [Asc SqlCommentCommentId]) -- $todo -- 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.4.0 +version: 0.5.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 @@ -21,13 +21,13 @@ -- Packages needed in order to build this package. build-depends: base >= 4 && < 5 , text >= 0.11 && < 0.12 - , bytestring >= 0.9.1 && < 10.0 + , bytestring >= 0.9.1 && < 0.10 , wai >= 0.4 && < 0.5 - , yesod >= 0.8 && < 0.9 - , yesod-form >= 0.1 && < 0.2 - , yesod-auth >= 0.4 && < 0.5 + , yesod >= 0.9 && < 1.0 + , yesod-form >= 0.3 && < 0.4 + , yesod-auth >= 0.7 && < 0.8 , yesod-goodies >= 0.0.3 && < 0.1 - , persistent >= 0.5 && < 0.6 + , persistent >= 0.6 && < 0.7 , template-haskell , directory , time