Enable new top-level comments, discussion system works now

config/routes

@@ -60,7 +60,7 @@
 /u/#Text/p/#Text/t/!new                 TicketNewR        GET
 /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               TicketDiscussionR GET POST
 /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

src/Vervis/Handler/Discussion.hs

@@ -16,6 +16,8 @@
 module Vervis.Handler.Discussion
     ( getDiscussion
     , getMessage
+    , getTopReply
+    , postTopReply
     , getReply
     , postReply
     )
@@ -54,6 +56,47 @@ getMessage reply getdid num = do
     now <- liftIO getCurrentTime
     defaultLayout $ messageW now shr msg reply
 
+getTopReply :: Route App -> Handler Html
+getTopReply replyP = do
+    ((_result, widget), enctype) <- runFormPost newMessageForm
+    defaultLayout $(widgetFile "discussion/top-reply")
+
+postTopReply
+    :: Route App
+    -> (Int -> Route App)
+    -> AppDB DiscussionId
+    -> Handler Html
+postTopReply replyP after getdid = do
+    ((result, widget), enctype) <- runFormPost newMessageForm
+    now <- liftIO getCurrentTime
+    case result of
+        FormSuccess nm -> do
+            author <- requireAuthId
+            mnum <- runDB $ do
+                did <- getdid
+                next <- do
+                    discussion <- get404 did
+                    return $ discussionNextMessage discussion
+                update did [DiscussionNextMessage +=. 1]
+                let message = Message
+                        { messageAuthor  = author
+                        , messageCreated = now
+                        , messageContent = nmContent nm
+                        , messageParent  = Nothing
+                        , messageRoot    = did
+                        , messageNumber  = next
+                        }
+                insert_ message
+                return $ messageNumber message
+            setMessage "Message submitted."
+            redirect $ after mnum
+        FormMissing -> do
+            setMessage "Field(s) missing."
+            defaultLayout $(widgetFile "discussion/top-reply")
+        FormFailure _l -> do
+            setMessage "Message submission failed, see errors below."
+            defaultLayout $(widgetFile "discussion/top-reply")
+
 getReply
     :: (Int -> Route App)
     -> (Int -> Route App)

src/Vervis/Handler/Ticket.hs

@@ -23,6 +23,7 @@ module Vervis.Handler.Ticket
     , postTicketR
     , getTicketEditR
     , getTicketDiscussionR
+    , postTicketDiscussionR
     , getTicketMessageR
     , postTicketMessageR
     , getTicketTopReplyR
@@ -197,6 +198,13 @@ getTicketDiscussionR shar proj num =
         (TicketReplyR shar proj num)
         (selectDiscussionId shar proj num)
 
+postTicketDiscussionR :: Text -> Text -> Int -> Handler Html
+postTicketDiscussionR shar proj num =
+    postTopReply
+        (TicketDiscussionR shar proj num)
+        (const $ TicketR shar proj num)
+        (selectDiscussionId shar proj num)
+
 getTicketMessageR :: Text -> Text -> Int -> Int -> Handler Html
 getTicketMessageR shar proj tnum cnum =
     getMessage
@@ -214,7 +222,8 @@ postTicketMessageR shar proj tnum cnum =
         cnum
 
 getTicketTopReplyR :: Text -> Text -> Int -> Handler Html
-getTicketTopReplyR shar proj num = error "Not implemented yet"
+getTicketTopReplyR shar proj num =
+    getTopReply $ TicketDiscussionR shar proj num
 
 getTicketReplyR :: Text -> Text -> Int -> Int -> Handler Html
 getTicketReplyR shar proj tnum cnum =

src/Vervis/Widget/Discussion.hs

@@ -32,7 +32,9 @@ import Yesod.Core (Route)
 import Yesod.Core.Handler (newIdent)
 import Yesod.Core.Widget (whamlet, toWidget, handlerToWidget)
 
-import Data.EventTime.Local (intervalToEventTime, showEventTime)
+import qualified Data.Text as T (filter)
+
+import Data.EventTime.Local
 import Data.Time.Clock.Local ()
 import Vervis.Discussion (getDiscussionTree)
 import Vervis.Foundation
@@ -43,7 +45,13 @@ import Vervis.Settings (widgetFile)
 
 messageW :: UTCTime -> Sharer -> Message -> (Int -> Route App) -> Widget
 messageW now shr msg reply =
-    $(widgetFile "discussion/widget/message")
+    let showTime =
+            showEventTime .
+            intervalToEventTime .
+            FriendlyConvert .
+            diffUTCTime now
+        showContent = renderSourceT Markdown . T.filter (/= '\r')
+    in  $(widgetFile "discussion/widget/message")
 
 messageTreeW
     :: (Int -> Route App)

templates/discussion/top-reply.hamlet

@@ -0,0 +1,17 @@
+$# 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/>.
+
+<form method=POST action=@{replyP} enctype=#{enctype}>
+  ^{widget}
+  <input type=submit>

templates/discussion/widget/message.hamlet

@@ -16,8 +16,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <a href=@{PersonR $ sharerIdent shr}>
     #{fromMaybe (sharerIdent shr) $ sharerName shr}
 <div>
-  #{showEventTime $ intervalToEventTime $ diffUTCTime now (messageCreated msg)}
+  #{showTime $ messageCreated msg}
 <div>
-  ^{renderSourceT Markdown $ messageContent msg}
+  ^{showContent $ messageContent msg}
 <div>
   <a href=@{reply $ messageNumber msg}>reply