From a56a7575feaafd1ad6edb4af0d33b5bfefeda9e3 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 19 May 2016 22:07:25 +0000 Subject: [PATCH] Implement reply-to-existing-comment --- config/routes | 4 +- src/Vervis/Form/Discussion.hs | 39 ++++++++++ src/Vervis/Foundation.hs | 3 + src/Vervis/Handler/Discussion.hs | 90 +++++++++++++++++++--- src/Vervis/Handler/Ticket.hs | 56 ++++++++++---- src/Vervis/Widget/Discussion.hs | 22 ++++-- templates/discussion/reply.hamlet | 19 +++++ templates/discussion/widget/message.hamlet | 10 ++- templates/ticket/one.hamlet | 2 +- vervis.cabal | 1 + 10 files changed, 207 insertions(+), 39 deletions(-) create mode 100644 src/Vervis/Form/Discussion.hs create mode 100644 templates/discussion/reply.hamlet diff --git a/config/routes b/config/routes index d448a3c..b8a3f28 100644 --- a/config/routes +++ b/config/routes @@ -61,7 +61,9 @@ /u/#Text/p/#Text/t/#Int TicketR GET PUT DELETE POST /u/#Text/p/#Text/t/#Int/edit TicketEditR GET /u/#Text/p/#Text/t/#Int/d TicketDiscussionR GET -/u/#Text/p/#Text/t/#Int/d/#Int TicketCommentR GET +/u/#Text/p/#Text/t/#Int/d/#Int TicketMessageR GET POST +/u/#Text/p/#Text/t/#Int/d/!reply TicketTopReplyR GET +/u/#Text/p/#Text/t/#Int/d/#Int/reply TicketReplyR GET -- /u/#Text/p/#Text/w WikiR GET -- /u/#Text/p/#Text/w/+Texts WikiPageR GET diff --git a/src/Vervis/Form/Discussion.hs b/src/Vervis/Form/Discussion.hs new file mode 100644 index 0000000..648acad --- /dev/null +++ b/src/Vervis/Form/Discussion.hs @@ -0,0 +1,39 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Form.Discussion + ( NewMessage (..) + , newMessageForm + ) +where + +import Prelude + +import Data.Text (Text) +import Yesod.Form + +import Vervis.Foundation (Form, Handler) +import Vervis.Model + +data NewMessage = NewMessage + { nmContent :: Text + } + +newMessageAForm :: AForm Handler NewMessage +newMessageAForm = NewMessage + <$> (unTextarea <$> areq textareaField "" Nothing) + +newMessageForm :: Form NewMessage +newMessageForm = renderDivs newMessageAForm diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 50089c7..4c03d52 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -132,6 +132,9 @@ instance Yesod App where loggedInAs user "Only project members can modify this ticket" isAuthorized (TicketEditR user _ _) _ = loggedInAs user "Only project members can modify this ticket" + isAuthorized (TicketDiscussionR _ _ _) True = loggedIn + isAuthorized (TicketTopReplyR _ _ _) _ = loggedIn + isAuthorized (TicketReplyR _ _ _ _) _ = loggedIn isAuthorized _ _ = return Authorized -- This function creates static content files in the static folder diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index ac53571..ba26664 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/src/Vervis/Handler/Discussion.hs @@ -15,7 +15,9 @@ module Vervis.Handler.Discussion ( getDiscussion - , getComment + , getMessage + , getReply + , postReply ) where @@ -23,24 +25,94 @@ import Prelude import Control.Monad.IO.Class (liftIO) import Data.Time.Clock (getCurrentTime) -import Database.Persist (Entity (..)) +import Database.Persist import Text.Blaze.Html (Html) -import Yesod.Core (defaultLayout) +import Yesod.Auth (requireAuthId) +import Yesod.Core (Route, defaultLayout) +import Yesod.Core.Handler (setMessage, redirect) +import Yesod.Form.Functions (runFormPost) +import Yesod.Form.Types (FormResult (..)) import Yesod.Persist.Core (runDB, get404, getBy404) -import Vervis.Foundation (Handler) +import Vervis.Form.Discussion +import Vervis.Foundation (App, Handler) import Vervis.Model +import Vervis.Settings (widgetFile) import Vervis.Widget.Discussion -getDiscussion :: DiscussionId -> Handler Html -getDiscussion did = defaultLayout $ discussionW did +getDiscussion :: (Int -> Route App) -> DiscussionId -> Handler Html +getDiscussion reply did = defaultLayout $ discussionW did reply -getComment :: DiscussionId -> Int -> Handler Html -getComment did num = do +getMessage :: (Int -> Route App) -> DiscussionId -> Int -> Handler Html +getMessage reply did num = do (msg, shr) <- runDB $ do Entity _mid m <- getBy404 $ UniqueMessage did num p <- get404 $ messageAuthor m s <- get404 $ personIdent p return (m, s) now <- liftIO getCurrentTime - defaultLayout $ messageW shr (messageCreated msg) now (messageContent msg) + defaultLayout $ messageW now shr msg reply + +getReply + :: (Int -> Route App) + -> (Int -> Route App) + -> DiscussionId + -> Int + -> Handler Html +getReply replyG replyP did num = do + (msg, shr) <- runDB $ do + Entity _mid m <- getBy404 $ UniqueMessage did num + p <- get404 $ messageAuthor m + s <- get404 $ personIdent p + return (m, s) + now <- liftIO getCurrentTime + ((_result, widget), enctype) <- runFormPost newMessageForm + defaultLayout $(widgetFile "discussion/reply") + +postReply + :: (Int -> Route App) + -> (Int -> Route App) + -> (Int -> Route App) + -> DiscussionId + -> Int + -> Handler Html +postReply replyG replyP after did cnum = do + ((result, widget), enctype) <- runFormPost newMessageForm + now <- liftIO getCurrentTime + case result of + FormSuccess nm -> do + author <- requireAuthId + mnum <- runDB $ do + (parent, next) <- do + discussion <- get404 did + Entity mid _message <- getBy404 $ UniqueMessage did cnum + return (mid, discussionNextMessage discussion) + update did [DiscussionNextMessage +=. 1] + let message = Message + { messageAuthor = author + , messageCreated = now + , messageContent = nmContent nm + , messageParent = Just parent + , messageRoot = did + , messageNumber = next + } + insert_ message + return $ messageNumber message + setMessage "Message submitted." + redirect $ after mnum + FormMissing -> do + setMessage "Field(s) missing." + (msg, shr) <- runDB $ do + Entity _mid m <- getBy404 $ UniqueMessage did cnum + p <- get404 $ messageAuthor m + s <- get404 $ personIdent p + return (m, s) + defaultLayout $(widgetFile "discussion/reply") + FormFailure _l -> do + setMessage "Message submission failed, see errors below." + (msg, shr) <- runDB $ do + Entity _mid m <- getBy404 $ UniqueMessage did cnum + p <- get404 $ messageAuthor m + s <- get404 $ personIdent p + return (m, s) + defaultLayout $(widgetFile "discussion/reply") diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 12994f6..dc2aa01 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -23,7 +23,10 @@ module Vervis.Handler.Ticket , postTicketR , getTicketEditR , getTicketDiscussionR - , getTicketCommentR + , getTicketMessageR + , postTicketMessageR + , getTicketTopReplyR + , getTicketReplyR ) where @@ -77,7 +80,7 @@ getTicketsR shar proj = do postTicketsR :: Text -> Text -> Handler Html postTicketsR shar proj = do - ((result, widget), enctype) <- runFormPost newTicketForm {-pid next author-} + ((result, widget), enctype) <- runFormPost newTicketForm case result of FormSuccess nt -> do author <- requireAuthId @@ -181,20 +184,41 @@ getTicketEditR shar proj num = do ((_result, widget), enctype) <- runFormPost $ editTicketForm ticket user defaultLayout $(widgetFile "ticket/edit") +selectDiscussionId :: Text -> Text -> Int -> AppDB DiscussionId +selectDiscussionId shar proj tnum = do + Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar + Entity pid _project <- getBy404 $ UniqueProject proj sid + Entity _tid ticket <- getBy404 $ UniqueTicket pid tnum + return $ ticketDiscuss ticket + getTicketDiscussionR :: Text -> Text -> Int -> Handler Html getTicketDiscussionR shar proj num = do - did <- runDB $ do - Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar - Entity pid _project <- getBy404 $ UniqueProject proj sid - Entity _tid ticket <- getBy404 $ UniqueTicket pid num - return $ ticketDiscuss ticket - getDiscussion did + did <- runDB $ selectDiscussionId shar proj num + getDiscussion (TicketReplyR shar proj num) did -getTicketCommentR :: Text -> Text -> Int -> Int -> Handler Html -getTicketCommentR shar proj tnum cnum = do - did <- runDB $ do - Entity sid _sharer <- getBy404 $ UniqueSharerIdent shar - Entity pid _project <- getBy404 $ UniqueProject proj sid - Entity _tid ticket <- getBy404 $ UniqueTicket pid tnum - return $ ticketDiscuss ticket - getComment did cnum +getTicketMessageR :: Text -> Text -> Int -> Int -> Handler Html +getTicketMessageR shar proj tnum cnum = do + did <- runDB $ selectDiscussionId shar proj tnum + getMessage (TicketReplyR shar proj tnum) did cnum + +postTicketMessageR :: Text -> Text -> Int -> Int -> Handler Html +postTicketMessageR shar proj tnum cnum = do + did <- runDB $ selectDiscussionId shar proj tnum + postReply + (TicketReplyR shar proj tnum) + (TicketMessageR shar proj tnum) + (const $ TicketR shar proj tnum) + did + cnum + +getTicketTopReplyR :: Text -> Text -> Int -> Handler Html +getTicketTopReplyR shar proj num = error "Not implemented yet" + +getTicketReplyR :: Text -> Text -> Int -> Int -> Handler Html +getTicketReplyR shar proj tnum cnum = do + did <- runDB $ selectDiscussionId shar proj tnum + getReply + (TicketReplyR shar proj tnum) + (TicketMessageR shar proj tnum) + did + cnum diff --git a/src/Vervis/Widget/Discussion.hs b/src/Vervis/Widget/Discussion.hs index 1d80d81..9b1e988 100644 --- a/src/Vervis/Widget/Discussion.hs +++ b/src/Vervis/Widget/Discussion.hs @@ -28,6 +28,7 @@ import Data.Text (Text) import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) import Data.Tree (Tree (..)) import Text.Cassius (cassiusFile) +import Yesod.Core (Route) import Yesod.Core.Handler (newIdent) import Yesod.Core.Widget (whamlet, toWidget, handlerToWidget) @@ -40,25 +41,30 @@ import Vervis.Model import Vervis.Render (renderSourceT) import Vervis.Settings (widgetFile) -messageW :: Sharer -> UTCTime -> UTCTime -> Text -> Widget -messageW sharer created now content = +messageW :: UTCTime -> Sharer -> Message -> (Int -> Route App) -> Widget +messageW now shr msg reply = $(widgetFile "discussion/widget/message") -messageTreeW :: Text -> UTCTime -> Tree (Message, Sharer) -> Widget -messageTreeW cReplies now t = go t +messageTreeW + :: (Int -> Route App) + -> Text + -> UTCTime + -> Tree (Message, Sharer) + -> Widget +messageTreeW reply cReplies now t = go t where go (Node (message, sharer) trees) = do - messageW sharer (messageCreated message) now (messageContent message) + messageW now sharer message reply [whamlet|
$forall tree <- trees ^{go tree} |] -discussionW :: DiscussionId -> Widget -discussionW did = do +discussionW :: DiscussionId -> (Int -> Route App) -> Widget +discussionW did reply = do forest <- handlerToWidget $ getDiscussionTree did cReplies <- newIdent now <- liftIO getCurrentTime toWidget $(cassiusFile "templates/discussion/widget/tree.cassius") - traverse_ (messageTreeW cReplies now) forest + traverse_ (messageTreeW reply cReplies now) forest diff --git a/templates/discussion/reply.hamlet b/templates/discussion/reply.hamlet new file mode 100644 index 0000000..460a267 --- /dev/null +++ b/templates/discussion/reply.hamlet @@ -0,0 +1,19 @@ +$# This file is part of Vervis. +$# +$# Written in 2016 by fr33domlover . +$# +$# ♡ Copying is an act of love. Please copy, reuse and share. +$# +$# The author(s) have dedicated all copyright and related and neighboring +$# rights to this software to the public domain worldwide. This software is +$# distributed without any warranty. +$# +$# You should have received a copy of the CC0 Public Domain Dedication along +$# with this software. If not, see +$# . + +^{messageW now shr msg replyG} + +
+ ^{widget} + diff --git a/templates/discussion/widget/message.hamlet b/templates/discussion/widget/message.hamlet index 9075e82..e92d2a4 100644 --- a/templates/discussion/widget/message.hamlet +++ b/templates/discussion/widget/message.hamlet @@ -13,9 +13,11 @@ $# with this software. If not, see $# .
- - #{fromMaybe (sharerIdent sharer) $ sharerName sharer} + + #{fromMaybe (sharerIdent shr) $ sharerName shr}
- #{showEventTime $ intervalToEventTime $ diffUTCTime now created} + #{showEventTime $ intervalToEventTime $ diffUTCTime now (messageCreated msg)}