Implement reply-to-existing-comment

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

src/Vervis/Form/Discussion.hs

@@ -0,0 +1,39 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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

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

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")

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")
 
-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
-
-getTicketCommentR :: Text -> Text -> Int -> Int -> Handler Html
-getTicketCommentR shar proj tnum cnum = do
-    did <- runDB $ do
+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
-    getComment did cnum
+
+getTicketDiscussionR :: Text -> Text -> Int -> Handler Html
+getTicketDiscussionR shar proj num = do
+    did <- runDB $ selectDiscussionId shar proj num
+    getDiscussion (TicketReplyR shar proj num) did
+
+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

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|
             <div .#{cReplies}>
               $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

templates/discussion/reply.hamlet

@@ -0,0 +1,19 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ 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
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+^{messageW now shr msg replyG}
+
+<form method=POST action=@{replyP $ messageNumber msg} enctype=#{enctype}>
+  ^{widget}
+  <input type=submit>

templates/discussion/widget/message.hamlet

@@ -13,9 +13,11 @@ $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 <div>
-  <a href=@{PersonR $ sharerIdent sharer}>
-    #{fromMaybe (sharerIdent sharer) $ sharerName sharer}
+  <a href=@{PersonR $ sharerIdent shr}>
+    #{fromMaybe (sharerIdent shr) $ sharerName shr}
 <div>
-  #{showEventTime $ intervalToEventTime $ diffUTCTime now created}
+  #{showEventTime $ intervalToEventTime $ diffUTCTime now (messageCreated msg)}
 <div>
-  ^{renderSourceT Markdown content}
+  ^{renderSourceT Markdown $ messageContent msg}
+<div>
+  <a href=@{reply $ messageNumber msg}>reply

templates/ticket/one.hamlet

@@ -37,4 +37,4 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 <h3>Discussion
 
-^{discussionW $ ticketDiscuss ticket}
+^{discussionW (ticketDiscuss ticket) (TicketReplyR shar proj num)}

vervis.cabal

@@ -76,6 +76,7 @@ library
                        Vervis.Field.Person
                        Vervis.Field.Project
                        Vervis.Field.Repo
+                       Vervis.Form.Discussion
                        Vervis.Form.Key
                        Vervis.Form.Person
                        Vervis.Form.Project