yesod-comments (empty) → 0.3.1
raw patch · 7 files changed
+557/−0 lines, 7 filesdep +basedep +bytestringdep +directorysetup-changed
Dependencies added: base, bytestring, directory, persistent, text, time, wai, yesod, yesod-auth, yesod-form, yesod-goodies
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Yesod/Comments.hs +150/−0
- Yesod/Comments/Core.hs +209/−0
- Yesod/Comments/Filters.hs +32/−0
- Yesod/Comments/Storage.hs +94/−0
- yesod-comments.cabal +40/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Patrick Brisbin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Patrick Brisbin nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Yesod/Comments.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+-------------------------------------------------------------------------------+-- |+-- Module : Yesod.Comments+-- Copyright : (c) Patrick Brisbin 2010 +-- License : as-is+-- Maintainer : pbrisbin@gmail.com +-- 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.+--+-------------------------------------------------------------------------------+module Yesod.Comments+ ( addComments+ , addCommentsAuth+ , module Yesod.Comments.Core+ ) where++import Yesod+import Yesod.Comments.Core+import Yesod.Comments.Filters (applyFilters)+import Yesod.Helpers.Auth++-- | Comments that anyone can enter anonymously+addComments :: YesodComments m + => ThreadId -- ^ the thread you're adding comments to+ -> GWidget s m ()+addComments tid = do+ comments <- lift $ loadComments (Just tid)+ cid <- lift $ getNextCommentId comments+ ((res, form), enctype) <- lift $ runFormMonadPost commentForm++ handleForm res tid cid+ addStyling+ [hamlet|+ <div .yesod_comments>+ <h4>Add a comment:+ <div .yesod_comment_input>+ <form enctype="#{enctype}" method="post">^{form}+ <p .helptext>Comments are parsed as pandoc-style markdown++ $if not $ null comments+ <h4>Showing #{toHtml $ helper $ length comments}:++ $forall comment <- comments+ <div .yesod_comment>^{showComment comment}++ |]++-- | Comments that require authentication+addCommentsAuth :: (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, toSinglePiece uid, uname, email)++ comments <- lift $ loadComments (Just tid)+ cid <- lift $ getNextCommentId comments+ ((res, form), enctype) <- lift $ runFormMonadPost $ commentFormAuth uid username email++ handleForm res tid cid+ addStyling+ [hamlet|+ <div .yesod_comments>+ $if isAuthenticated+ <h4>Add a comment:+ <div .yesod_comment_input>+ <form enctype="#{enctype}" method="post">^{form}+ <p .helptext>Comments are parsed as pandoc-style markdown+ $else+ <h4>Please ^{login} to post a comment.++ $if not $ null comments+ <h4>Showing #{toHtml $ helper $ length comments}:++ $forall comment <- comments+ <div .yesod_comment>^{showCommentAuth comment}+ |]+++-- | Add styling common to the auth and non-auth forms+addStyling :: Yesod m => GWidget s m ()+addStyling = addCassius [cassius|+ .yesod_comment_input th+ text-align: left+ vertical-align: top+ .yesod_comment_input textarea+ height: 10ex+ width: 50ex+ .yesod_comment_avatar_input, .yesod_comment_avatar_list+ float: left+ .yesod_comment_avatar_input+ margin-right: 5px+ .yesod_comment_avatar_list+ margin-right: 3px+ |]++-- | Handle the posted form and actually insert the comment+handleForm :: YesodComments m + => FormResult CommentForm + -> ThreadId + -> CommentId + -> GWidget s m ()+handleForm res tid cid = case res of+ FormMissing -> return ()+ FormFailure _ -> return ()+ FormSuccess cf -> lift $ do+ comment <- commentFromForm tid cid cf+ matches <- applyFilters commentFilters comment+ if matches+ then setMessage "comment dropped. matched filters."+ else do+ storeComment comment+ setMessage "comment added."+ redirectCurrentRoute++ where+ -- | Redirect back to the current route after a POST request+ redirectCurrentRoute :: Yesod m => GHandler s m ()+ redirectCurrentRoute = do+ tm <- getRouteToMaster+ mr <- getCurrentRoute+ case mr of+ Just r -> redirect RedirectTemporary $ tm r+ Nothing -> notFound++helper :: Int -> String+helper 0 = "no comments"+helper 1 = "1 comment"+helper n = show n ++ " comments"++-- | Show the authroute as a link if set up+login :: Yesod m => GWidget s m ()+login = do+ lift $ setUltDest' -- so we come back here after login+ mroute <- lift $ fmap authRoute getYesod+ case mroute of+ Just r -> [hamlet|<a href="@{r}">log in|]+ Nothing -> [hamlet|log in|]
+ Yesod/Comments/Core.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+-------------------------------------------------------------------------------+-- |+-- 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 (..)+ , commentFromForm+ , commentForm+ , commentFormAuth+ , showComment+ , showCommentAuth+ ) where++import Yesod+import Yesod.Form.Core+import Yesod.Helpers.Auth+import Yesod.Goodies.Gravatar+import Yesod.Goodies.Markdown+import Yesod.Goodies.Time+import Control.Applicative ((<$>), (<*>))+import Data.Time (UTCTime, getCurrentTime)+import Network.Wai (remoteHost)++import qualified Data.Text as T++type ThreadId = T.Text+type CommentId = Int++class Yesod m => YesodComments m where+ -- Data base actions+ getComment :: ThreadId -> CommentId -> GHandler s m (Maybe Comment)+ storeComment :: Comment -> GHandler s m ()+ deleteComment :: Comment -> GHandler s m ()++ -- | Loading all comments, possibly filtered to a single thread.+ loadComments :: Maybe ThreadId -> GHandler s m [Comment]++ -- | Get the next available Id given the passed list of comments. In + -- Handler in case there is a database call involved.+ getNextCommentId :: [Comment] -> GHandler s m CommentId+ getNextCommentId [] = return 1+ getNextCommentId cs = return $ maximum (map commentId cs) + 1++ -- | See "Yesod.Comments.Filters"+ commentFilters :: [(Comment -> GHandler s m Bool)]+ commentFilters = []++ -- | 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 friendlier than just a conversion to 'String'+ displayUser :: AuthId m -> GHandler s m T.Text+ displayUser _ = return ""++ -- | if using Auth, provide the function to get form a user id to + -- the string to use as the commenter's email.+ displayEmail :: AuthId m -> GHandler s m T.Text+ displayEmail _ = return ""++data Comment = Comment+ { threadId :: ThreadId+ , commentId :: CommentId+ , timeStamp :: UTCTime+ , ipAddress :: T.Text+ , userName :: T.Text+ , userEmail :: T.Text+ , content :: Markdown+ }++data CommentForm = CommentForm+ { formUser :: T.Text+ , formEmail :: T.Text+ , formComment :: Markdown+ }++-- | Cleanse form input and create a 'Comment' to be stored+commentFromForm :: ThreadId -> CommentId -> CommentForm -> GHandler s m Comment+commentFromForm tid cid cf = do+ now <- liftIO getCurrentTime+ ip <- return . show . remoteHost =<< waiRequest+ return Comment + { threadId = tid + , commentId = cid + , timeStamp = now+ , ipAddress = T.pack ip+ , userName = formUser cf+ , userEmail = formEmail cf+ , content = formComment cf+ }++-- | 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, [hamlet|+ <table>+ ^{fieldRow fiUser}+ ^{fieldRow fiEmail}+ ^{fieldRow fiComment}+ <tr>+ <td> + <td colspan="2">+ <input type="submit" value="Add comment">+ |])++-- | The comment form if using authentication (uid is hidden and display+-- name is shown)+commentFormAuth :: T.Text -> T.Text -> T.Text -> GFormMonad s m (FormResult CommentForm, GWidget s m ())+commentFormAuth uid username email = do+ (user , fiUser ) <- hiddenField "name:" (Just uid)+ (email' , fiEmail ) <- hiddenField "email:" (Just email)+ (comment, fiComment) <- markdownField "comment:" Nothing++ let img = gravatarImg email defaultOptions++ return (CommentForm <$> user <*> email' <*> comment, [hamlet|+ <div .yesod_comment_avatar_input>+ <a title="change your profile picture at gravatar" href="http://gravatar.com/emails/">+ <img src="#{img}">++ <table>+ <tr style="display: none;">+ <th>+ <label for="#{fiIdent fiUser}"> + <td colspan="2">+ ^{fiInput fiUser}++ <tr style="display: none;">+ <th>+ <label for="#{fiIdent fiEmail}"> + <td colspan="2">+ ^{fiInput fiEmail}++ <tr>+ <th>name:+ <td colspan="2">#{username}++ <tr>+ <th>email:+ <td colspan="2">#{email}++ ^{fieldRow fiComment}+ <tr>+ <td> + <td colspan="2">+ <input type="submit" value="Add comment">+ |])++fieldRow :: FieldInfo s m -> GWidget s m ()+fieldRow fi = [hamlet|+ <tr .#{clazz fi}>+ <th>+ <label for="#{fiIdent fi}">#{fiLabel fi}+ <div .tooltip>#{fiTooltip fi}+ <td>+ ^{fiInput fi}+ <td>+ $maybe error <- fiErrors fi+ #{error}+ $nothing+ + |]++clazz :: FieldInfo s m -> String+clazz fi = if fiRequired fi then "required" else "optional"++-- | Show a single comment+showComment :: Yesod m => Comment -> GWidget s m ()+showComment comment = showHelper comment $ userName comment++-- | Show a single comment, auth version+showCommentAuth :: (Yesod m, YesodAuth m, YesodComments m) => Comment -> GWidget s m ()+showCommentAuth comment = do+ let cusername = userName comment+ case fromSinglePiece $ cusername of+ Nothing -> showHelper comment cusername+ Just uid -> showHelper comment =<< lift (displayUser uid)++-- | Factor out common code+showHelper :: Yesod m => Comment -> T.Text -> GWidget s m ()+showHelper comment username = do+ commentTimestamp <- lift . humanReadableTime $ timeStamp comment+ let anchor = "#comment_" ++ show (commentId comment)+ let img = gravatarImg (userEmail comment) defaultOptions { gSize = Just $ Size 20 }+ addHamlet [hamlet|+ <div .yesod_comment_avatar_list>+ <img src="#{img}">++ <p>+ <a href="#{anchor}" id="#{anchor}">#{commentTimestamp}+ , #{username} wrote:++ <blockquote>+ #{markdownToHtml $ content comment}+ |]
+ Yesod/Comments/Filters.hs view
@@ -0,0 +1,32 @@+-------------------------------------------------------------------------------+-- |+-- Module : Yesod.Comments.Filters+-- Copyright : (c) Patrick Brisbin 2010 +-- License : as-is+-- Maintainer : pbrisbin@gmail.com +-- Stability : unstable+-- Portability : unportable+--+-------------------------------------------------------------------------------+module Yesod.Comments.Filters+ ( applyFilters+ -- * Example filters+ , blacklistFile+ ) where++import Yesod+import Yesod.Comments.Core (Comment(..))+import qualified Data.Text as T++-- | Apply each filter a given list, return True if the Comment matches +-- any one filter+applyFilters :: (Yesod m) => [(Comment -> GHandler s m Bool)] -> Comment -> GHandler s m Bool+applyFilters [] _ = return False+applyFilters (p:ps) c = p c >>= \b -> if b then return True else applyFilters ps c++-- | Read IPs from a file, one per line, return True if the comment's IP +-- matches one in the file+blacklistFile :: (Yesod m) => FilePath -> Comment -> GHandler s m Bool+blacklistFile f c = do+ contents <- liftIO $ readFile f+ return $ (T.unpack $ ipAddress c) `elem` (lines contents)
+ Yesod/Comments/Storage.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-------------------------------------------------------------------------------+-- |+-- Module : Yesod.Comments.Storage+-- Copyright : (c) Patrick Brisbin 2010 +-- License : as-is+--+-- Maintainer : pbrisbin@gmail.com+-- Stability : unstable+-- Portability : unportable+--+-- Some pre-built function definitions for storing and loading comments.+--+-------------------------------------------------------------------------------+module Yesod.Comments.Storage+ ( + -- * Persist+ -- $persist+ getCommentPersist+ , storeCommentPersist+ , deleteCommentPersist+ , loadCommentsPersist+ , migrateComments+ -- * TODO+ -- Add more+ ) where++import Yesod+import Yesod.Comments.Core (Comment(..), ThreadId, CommentId)+import Yesod.Goodies.Markdown (Markdown(..))+import Data.Time.Clock (UTCTime)+import qualified Data.Text as T++-- $persist+--+-- Use these functions to store your comments in an instance of +-- YesodPersist+--++-- | Create the required types and migration function for use in a+-- general yesod app+share2 mkPersist (mkMigrate "migrateComments") [persist|+SqlComment+ threadId ThreadId Eq+ commentId CommentId Eq Asc+ timeStamp UTCTime+ ipAddress T.Text+ userName T.Text+ userEmail T.Text+ content Markdown+ 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+ }++-- | 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+ }++getCommentPersist :: (YesodPersist m, PersistBackend (YesodDB 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 c = return . const () =<< runDB (insert $ toSqlComment c)++deleteCommentPersist :: (YesodPersist m, PersistBackend (YesodDB 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)
+ yesod-comments.cabal view
@@ -0,0 +1,40 @@+name: yesod-comments+version: 0.3.1+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+license: BSD3+license-file: LICENSE+author: Patrick Brisbin+maintainer: me@pbrisbin.com+category: Web, Yesod+build-type: Simple+cabal-version: >=1.6++library+ -- Modules exported by the library.+ exposed-modules: Yesod.Comments+ , Yesod.Comments.Core+ , Yesod.Comments.Storage+ , Yesod.Comments.Filters+ + -- Packages needed in order to build this package.+ build-depends: base >= 4 && < 5+ , text >= 0.11 && < 0.12+ , bytestring >= 0.9.1 && < 10.0+ , wai >= 0.4 && < 0.5+ , yesod >= 0.8 && < 0.9+ , yesod-form >= 0.1 && < 0.2+ , yesod-auth >= 0.4 && < 0.5+ , yesod-goodies >= 0.0.3 && < 0.1+ , persistent >= 0.5 && < 0.6+ , directory+ , time++++ ghc-options: -Wall+ +source-repository head+ type: git+ location: git://github.com/pbrisbin/yesod-comments.git