diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Yesod/Comments.hs b/Yesod/Comments.hs new file mode 100644 --- /dev/null +++ b/Yesod/Comments.hs @@ -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| +
+

Add a comment: +
+
^{form} +

Comments are parsed as pandoc-style markdown + + $if not $ null comments +

Showing #{toHtml $ helper $ length comments}: + + $forall comment <- comments +
^{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| +
+ $if isAuthenticated +

Add a comment: +
+ ^{form} +

Comments are parsed as pandoc-style markdown + $else +

Please ^{login} to post a comment. + + $if not $ null comments +

Showing #{toHtml $ helper $ length comments}: + + $forall comment <- comments +
^{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|log in|] + Nothing -> [hamlet|log in|] diff --git a/Yesod/Comments/Core.hs b/Yesod/Comments/Core.hs new file mode 100644 --- /dev/null +++ b/Yesod/Comments/Core.hs @@ -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| + + ^{fieldRow fiUser} + ^{fieldRow fiEmail} + ^{fieldRow fiComment} + +
  + + + |]) + +-- | 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| +
+ + + + + + + + + + +
+ + ^{fiInput fiUser} + +
+ + ^{fiInput fiEmail} + +
name: + #{username} + +
email: + #{email} + + ^{fieldRow fiComment} +
  + + + |]) + +fieldRow :: FieldInfo s m -> GWidget s m () +fieldRow fi = [hamlet| +
+ + ^{fiInput fi} + + $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| +
+ + +

+ #{commentTimestamp} + , #{username} wrote: + +

+ #{markdownToHtml $ content comment} + |] diff --git a/Yesod/Comments/Filters.hs b/Yesod/Comments/Filters.hs new file mode 100644 --- /dev/null +++ b/Yesod/Comments/Filters.hs @@ -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) diff --git a/Yesod/Comments/Storage.hs b/Yesod/Comments/Storage.hs new file mode 100644 --- /dev/null +++ b/Yesod/Comments/Storage.hs @@ -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) diff --git a/yesod-comments.cabal b/yesod-comments.cabal new file mode 100644 --- /dev/null +++ b/yesod-comments.cabal @@ -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