{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} ------------------------------------------------------------------------------- -- | -- Module : Yesod.Comments.Core -- Copyright : (c) Patrick Brisbin 2010 -- License : as-is -- -- Maintainer : pbrisbin@gmail.com -- Stability : unstable -- Portability : unportable -- ------------------------------------------------------------------------------- module Yesod.Comments.Core ( Comment(..) , CommentForm(..) , CommentId , ThreadId , YesodComments (..) , Form , commentFromForm , commentForm , commentFormAuth , commentLabel , handleForm , showComments , showComment , showCommentAuth , getNextCommentId , isCommentingUser ) 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 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 "" data Comment = Comment { threadId :: ThreadId , commentId :: CommentId , timeStamp :: UTCTime , ipAddress :: Text , userName :: Text , userEmail :: Text , content :: Markdown , isAuth :: Bool } 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|