diff --git a/Yesod/Comments.hs b/Yesod/Comments.hs --- a/Yesod/Comments.hs +++ b/Yesod/Comments.hs @@ -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|
diff --git a/Yesod/Comments/Core.hs b/Yesod/Comments/Core.hs --- a/Yesod/Comments/Core.hs +++ b/Yesod/Comments/Core.hs @@ -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. diff --git a/Yesod/Comments/Form.hs b/Yesod/Comments/Form.hs --- a/Yesod/Comments/Form.hs +++ b/Yesod/Comments/Form.hs @@ -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|

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 @@