UI, Web: Re-enable ticket/MR replies view and commenting forms/buttons

src/Vervis/Client.hs

@@ -16,6 +16,7 @@
 module Vervis.Client
     ( makeServerInput
 
+    , comment
     --, createThread
     --, createReply
     --, follow
@@ -112,19 +113,42 @@ makeServerInput maybeCapURI maybeSummary audience specific = do
             }
     return (recipientSet, remoteActors, fwdHosts, action)
 
+comment
+    :: KeyHashid Person
+    -> PandocMarkdown
+    -> [LocalActorBy KeyHashid]
+    -> [LocalStageBy KeyHashid]
+    -> Route App
+    -> Maybe FedURI
+    -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Note URIMode)
+comment senderHash source actors stages topicR muParent = do
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    content <- ExceptT . pure $ renderPandocMarkdown source
+    let audience = [AudLocal actors stages]
+        uTopic = encodeRouteHome topicR
+        note = AP.Note
+            { AP.noteId        = Nothing
+            , AP.noteAttrib    = encodeRouteLocal $ PersonR senderHash
+            , AP.noteAudience  = emptyAudience
+            , AP.noteReplyTo   = Just $ fromMaybe uTopic muParent
+            , AP.noteContext   = Just uTopic
+            , AP.notePublished = Nothing
+            , AP.noteSource    = source
+            , AP.noteContent   = content
+            }
+    return (Nothing, audience, note)
+
 {-
 createThread
-    :: (MonadSite m, SiteEnv m ~ App)
+    :: KeyHashid Person
-    => ShrIdent
+    -> PandocMarkdown
-    -> TextPandocMarkdown
     -> Host
     -> [Route App]
     -> [Route App]
     -> Route App
-    -> m (Either Text (Note URIMode))
+    -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Note URIMode)
-createThread shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context = runExceptT $ do
+createThread senderHash source hDest recipsA recipsC context = runExceptT $ do
-    error "Temporarily disabled"
-    {-
     encodeRouteLocal <- getEncodeRouteLocal
     let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
     contentHtml <- ExceptT . pure $ renderPandocMarkdown msg
@@ -147,7 +171,6 @@ createThread shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context =
         , noteSource    = msg
         , noteContent   = contentHtml
         }
-    -}
 
 createReply
     :: ShrIdent

src/Vervis/Form/Discussion.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -14,8 +14,7 @@
  -}
 
 module Vervis.Form.Discussion
-    ( NewMessage (..)
+    ( newMessageForm
-    , newMessageForm
     )
 where
 
@@ -24,16 +23,15 @@ import Yesod.Form
 
 import qualified Data.Text as T
 
+import Web.Text
+
 import Vervis.Foundation (Form, Handler)
 import Vervis.Model
 
-data NewMessage = NewMessage
+newMessageAForm :: AForm Handler PandocMarkdown
-    { nmContent :: Text
+newMessageAForm =
-    }
+    pandocMarkdownFromText . T.filter (/= '\r') . unTextarea <$>
+        areq textareaField "" Nothing
 
-newMessageAForm :: AForm Handler NewMessage
+newMessageForm :: Form PandocMarkdown
-newMessageAForm = NewMessage
-    <$> (T.filter (/= '\r') . unTextarea <$> areq textareaField "" Nothing)
-
-newMessageForm :: Form NewMessage
 newMessageForm = renderDivs newMessageAForm

src/Vervis/Foundation.hs

@@ -838,8 +838,6 @@ instance YesodBreadcrumbs App where
         PersonFollowR _   -> ("", Nothing)
         PersonUnfollowR _ -> ("", Nothing)
 
-        ReplyR _ -> ("", Nothing)
-
         PersonStampR p k -> ("Stamp #" <> keyHashidText k, Just $ PersonR p)
 
         GroupR g             -> ("Team &" <> keyHashidText g, Just HomeR)
@@ -910,9 +908,10 @@ instance YesodBreadcrumbs App where
         TicketDepsR d t        -> ("Dependencies", Just $ TicketR d t)
         TicketReverseDepsR d t -> ("Dependants", Just $ TicketR d t)
 
-        TicketFollowR _ _   -> ("", Nothing)
+        TicketFollowR _ _    -> ("", Nothing)
-        TicketUnfollowR _ _ -> ("", Nothing)
+        TicketUnfollowR _ _  -> ("", Nothing)
-        TicketReplyR _ _    -> ("", Nothing)
+        TicketReplyR d t     -> ("Reply", Just $ TicketR d t)
+        TicketReplyOnR d t _ -> ("Reply", Just $ TicketR d t)
 
         TicketDepR d t p -> (keyHashidText p, Just $ TicketDepsR d t)
 
@@ -941,9 +940,10 @@ instance YesodBreadcrumbs App where
         BundleR l c b  -> ("Bundle " <> keyHashidText b, Just $ ClothR l c)
         PatchR l c b p -> ("Patch " <> keyHashidText p, Just $ BundleR l c b)
 
-        ClothApplyR _ _    -> ("", Nothing)
+        ClothApplyR _ _     -> ("", Nothing)
-        ClothFollowR _ _   -> ("", Nothing)
+        ClothFollowR _ _    -> ("", Nothing)
-        ClothUnfollowR _ _ -> ("", Nothing)
+        ClothUnfollowR _ _  -> ("", Nothing)
-        ClothReplyR _ _    -> ("", Nothing)
+        ClothReplyR l c     -> ("Reply", Just $ ClothR l c)
+        ClothReplyOnR l c _ -> ("Reply", Just $ ClothR l c)
 
         ClothDepR l c p -> (keyHashidText p, Just $ ClothDepsR l c)

src/Vervis/Handler/Cloth.hs

@@ -29,7 +29,11 @@ module Vervis.Handler.Cloth
     , postClothApplyR
     , postClothFollowR
     , postClothUnfollowR
+
+    , getClothReplyR
     , postClothReplyR
+    , getClothReplyOnR
+    , postClothReplyOnR
 
 
 
@@ -120,6 +124,7 @@ import Vervis.Style
 import Vervis.Ticket
 import Vervis.Time (showDate)
 import Vervis.Web.Actor
+import Vervis.Web.Discussion
 import Vervis.Web.Repo
 import Vervis.Widget
 import Vervis.Widget.Discussion
@@ -127,6 +132,10 @@ import Vervis.Widget.Person
 
 import qualified Vervis.Client as C
 
+selectDiscussionID loomHash clothHash = do
+    (_, _, Entity _ ticket, _, _, _) <- getCloth404 loomHash clothHash
+    return $ ticketDiscuss ticket
+
 getClothR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
 getClothR loomHash clothHash = do
     (repoID, mbranch, ticket, author, resolve, proposal) <- runDB $ do
@@ -329,7 +338,7 @@ getClothR loomHash clothHash = do
                 discussionW
                     (return $ ticketDiscuss ticket)
                     (ClothReplyR loomHash clothHash)
-                    (ReplyR . hashMessageKey)
+                    (ClothReplyOnR loomHash clothHash . hashMessageKey)
         cRelevant <- newIdent
         cIrrelevant <- newIdent
         let relevant filt =
@@ -377,15 +386,13 @@ getClothR loomHash clothHash = do
 
 getClothDiscussionR
     :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
-getClothDiscussionR _ _ = do
+getClothDiscussionR loomHash clothHash = do
-    error "Temporarily disabled"
+    hashMsg <- getEncodeKeyHashid
-    {-
+    serveDiscussion
-    encodeHid <- getEncodeKeyHashid
+        (ClothDiscussionR loomHash clothHash)
-    getDiscussion
+        (ClothReplyOnR loomHash clothHash . hashMsg)
-        (ProjectClothReplyR shar proj ltkhid . encodeHid)
+        (ClothReplyR loomHash clothHash)
-        (ProjectClothTopReplyR shar proj ltkhid)
+        (selectDiscussionID loomHash clothHash)
-        (selectDiscussionId shar proj ltkhid)
-    -}
 
 getClothEventsR
     :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
@@ -671,22 +678,49 @@ postClothFollowR _ = error "Temporarily disabled"
 postClothUnfollowR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler ()
 postClothUnfollowR _ = error "Temporarily disabled"
 
+getClothReplyR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler Html
+getClothReplyR loomHash clothHash =
+    getTopReply $ ClothReplyR loomHash clothHash
+
 postClothReplyR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler Html
-postClothReplyR _ _ = error "Temporarily disabled"
+postClothReplyR loomHash clothHash =
-    {-
+    postReply
-    hLocal <- getsYesod $ appInstanceHost . appSettings
+        (ClothReplyR loomHash clothHash)
-    postTopReply
+        [LocalActorLoom loomHash]
-        hLocal
+        [ LocalStageLoomFollowers loomHash
-        [ProjectR shr prj]
+        , LocalStageClothFollowers loomHash clothHash
-        [ ProjectFollowersR shr prj
-        , ProjectTicketParticipantsR shr prj ltkhid
-        , ProjectTicketTeamR shr prj ltkhid
         ]
-        (ProjectTicketR shr prj ltkhid)
+        (ClothR loomHash clothHash)
-        (ProjectR shr prj)
+        Nothing
-        (ProjectTicketDiscussionR shr prj ltkhid)
+
-        (const $ ProjectTicketR shr prj ltkhid)
+getClothReplyOnR
-    -}
+    :: KeyHashid Loom
+    -> KeyHashid TicketLoom
+    -> KeyHashid Message
+    -> Handler Html
+getClothReplyOnR loomHash clothHash msgHash = do
+    msgID <- decodeKeyHashid404 msgHash
+    hashMsg <- getEncodeKeyHashid
+    getReply
+        (ClothReplyOnR loomHash clothHash . hashMsg)
+        (selectDiscussionID loomHash clothHash)
+        msgID
+
+postClothReplyOnR
+    :: KeyHashid Loom
+    -> KeyHashid TicketLoom
+    -> KeyHashid Message
+    -> Handler Html
+postClothReplyOnR loomHash clothHash msgHash = do
+    msgID <- decodeKeyHashid404 msgHash
+    postReply
+        (ClothReplyOnR loomHash clothHash msgHash)
+        [LocalActorLoom loomHash]
+        [ LocalStageLoomFollowers loomHash
+        , LocalStageClothFollowers loomHash clothHash
+        ]
+        (ClothR loomHash clothHash)
+        (Just (selectDiscussionID loomHash clothHash, msgID))
 
 
 
@@ -853,13 +887,6 @@ getSharerProposalR shr talkhid = do
     where
     here = SharerProposalR shr talkhid
 
-getSharerProposalDiscussionR
-    :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
-getSharerProposalDiscussionR shr talkhid =
-    getRepliesCollection (SharerProposalDiscussionR shr talkhid) $ do
-        (_, Entity _ lt, _, _, _, _) <- getSharerProposal404 shr talkhid
-        return $ localTicketDiscuss lt
-
 getSharerProposalDepsR
     :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
 getSharerProposalDepsR shr talkhid =
@@ -1196,13 +1223,6 @@ getRepoProposalR shr rp ltkhid = do
     where
     here = RepoProposalR shr rp ltkhid
 
-getRepoProposalDiscussionR
-    :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
-getRepoProposalDiscussionR shr rp ltkhid =
-    getRepliesCollection (RepoProposalDiscussionR shr rp ltkhid) $ do
-        (_, _, _, Entity _ lt, _, _, _, _, _) <- getRepoProposal404 shr rp ltkhid
-        return $ localTicketDiscuss lt
-
 getRepoProposalDepsR
     :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent
 getRepoProposalDepsR shr rp ltkhid =

src/Vervis/Handler/Person.hs

@@ -28,8 +28,6 @@ module Vervis.Handler.Person
     , postPersonFollowR
     , postPersonUnfollowR
 
-    , postReplyR
-
     , getPersonStampR
     )
 where
@@ -402,8 +400,5 @@ postPersonFollowR _ = error "Temporarily disabled"
 postPersonUnfollowR :: KeyHashid Person -> Handler ()
 postPersonUnfollowR _ = error "Temporarily disabled"
 
-postReplyR :: KeyHashid Message -> Handler ()
-postReplyR _ = error "Temporarily disabled"
-
 getPersonStampR :: KeyHashid Person -> KeyHashid SigKey -> Handler TypedContent
 getPersonStampR = servePerActorKey personActor LocalActorPerson

src/Vervis/Handler/Ticket.hs

@@ -26,7 +26,11 @@ module Vervis.Handler.Ticket
 
     , postTicketFollowR
     , postTicketUnfollowR
+
+    , getTicketReplyR
     , postTicketReplyR
+    , getTicketReplyOnR
+    , postTicketReplyOnR
 
 
 
@@ -53,11 +57,6 @@ module Vervis.Handler.Ticket
     , getClaimRequestsTicketR
     , postClaimRequestsTicketR
     , getClaimRequestNewR
-    , postProjectTicketDiscussionR
-    , getMessageR
-    , postProjectTicketMessageR
-    , getProjectTicketTopReplyR
-    , getProjectTicketReplyR
     , postProjectTicketDepsR
     , getProjectTicketDepNewR
     , postTicketDepOldR
@@ -67,7 +66,6 @@ module Vervis.Handler.Ticket
 
     , getSharerTicketsR
     , getSharerTicketR
-    , getSharerTicketDiscussionR
     , getSharerTicketDepsR
     , getSharerTicketReverseDepsR
     , getSharerTicketTeamR
@@ -160,6 +158,10 @@ import Vervis.Web.Discussion
 import Vervis.Widget.Discussion
 import Vervis.Widget.Person
 
+selectDiscussionID deckHash taskHash = do
+    (_, _, Entity _ ticket, _, _) <- getTicket404 deckHash taskHash
+    return $ ticketDiscuss ticket
+
 getTicketR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler TypedContent
 getTicketR deckHash ticketHash = do
     (ticket, author, resolve) <- runDB $ do
@@ -275,7 +277,7 @@ getTicketR deckHash ticketHash = do
                 discussionW
                     (return $ ticketDiscuss ticket)
                     (TicketReplyR deckHash ticketHash)
-                    (ReplyR . hashMessageKey)
+                    (TicketReplyOnR deckHash ticketHash . hashMessageKey)
         cRelevant <- newIdent
         cIrrelevant <- newIdent
         let relevant filt =
@@ -293,15 +295,13 @@ getTicketR deckHash ticketHash = do
 
 getTicketDiscussionR
     :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler TypedContent
-getTicketDiscussionR _ _ = do
+getTicketDiscussionR deckHash taskHash = do
-    error "Temporarily disabled"
+    hashMsg <- getEncodeKeyHashid
-    {-
+    serveDiscussion
-    encodeHid <- getEncodeKeyHashid
+        (TicketDiscussionR deckHash taskHash)
-    getDiscussion
+        (TicketReplyOnR deckHash taskHash . hashMsg)
-        (ProjectTicketReplyR shar proj ltkhid . encodeHid)
+        (TicketReplyR deckHash taskHash)
-        (ProjectTicketTopReplyR shar proj ltkhid)
+        (selectDiscussionID deckHash taskHash)
-        (selectDiscussionId shar proj ltkhid)
-    -}
 
 getTicketEventsR
     :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler TypedContent
@@ -426,22 +426,49 @@ postTicketFollowR _ = error "Temporarily disabled"
 postTicketUnfollowR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler ()
 postTicketUnfollowR _ = error "Temporarily disabled"
 
+getTicketReplyR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler Html
+getTicketReplyR deckHash taskHash =
+    getTopReply $ TicketReplyR deckHash taskHash
+
 postTicketReplyR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler Html
-postTicketReplyR _ _ = error "Temporarily disabled"
+postTicketReplyR deckHash taskHash =
-    {-
+    postReply
-    hLocal <- getsYesod $ appInstanceHost . appSettings
+        (TicketReplyR deckHash taskHash)
-    postTopReply
+        [LocalActorDeck deckHash]
-        hLocal
+        [ LocalStageDeckFollowers deckHash
-        [ProjectR shr prj]
+        , LocalStageTicketFollowers deckHash taskHash
-        [ ProjectFollowersR shr prj
-        , ProjectTicketParticipantsR shr prj ltkhid
-        , ProjectTicketTeamR shr prj ltkhid
         ]
-        (ProjectTicketR shr prj ltkhid)
+        (TicketR deckHash taskHash)
-        (ProjectR shr prj)
+        Nothing
-        (ProjectTicketDiscussionR shr prj ltkhid)
+
-        (const $ ProjectTicketR shr prj ltkhid)
+getTicketReplyOnR
-    -}
+    :: KeyHashid Deck
+    -> KeyHashid TicketDeck
+    -> KeyHashid Message
+    -> Handler Html
+getTicketReplyOnR deckHash taskHash msgHash = do
+    msgID <- decodeKeyHashid404 msgHash
+    hashMsg <- getEncodeKeyHashid
+    getReply
+        (TicketReplyOnR deckHash taskHash . hashMsg)
+        (selectDiscussionID deckHash taskHash)
+        msgID
+
+postTicketReplyOnR
+    :: KeyHashid Deck
+    -> KeyHashid TicketDeck
+    -> KeyHashid Message
+    -> Handler Html
+postTicketReplyOnR deckHash taskHash msgHash = do
+    msgID <- decodeKeyHashid404 msgHash
+    postReply
+        (TicketReplyOnR deckHash taskHash msgHash)
+        [LocalActorDeck deckHash]
+        [ LocalStageDeckFollowers deckHash
+        , LocalStageTicketFollowers deckHash taskHash
+        ]
+        (TicketR deckHash taskHash)
+        (Just (selectDiscussionID deckHash taskHash, msgID))
 
 
 
@@ -803,58 +830,6 @@ postClaimRequestsTicketR shr prj ltkhid = do
             setMessage "Submission failed, see errors below."
             defaultLayout $(widgetFile "ticket/claim-request/new")
 
-selectDiscussionId
-    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> AppDB DiscussionId
-selectDiscussionId shr prj ltkhid = do
-    (_es, _ej, _et, Entity _ lticket, _etcl, _etpl, _author, _) <- getProjectTicket404 shr prj ltkhid
-    return $ localTicketDiscuss lticket
-
-getMessageR :: ShrIdent -> KeyHashid LocalMessage -> Handler TypedContent
-getMessageR shr hid = do
-    lmid <- decodeKeyHashid404 hid
-    getDiscussionMessage shr lmid
-
-postProjectTicketMessageR
-    :: ShrIdent
-    -> PrjIdent
-    -> KeyHashid LocalTicket
-    -> KeyHashid Message
-    -> Handler Html
-postProjectTicketMessageR shr prj ltkhid mkhid = do
-    encodeHid <- getEncodeKeyHashid
-    mid <- decodeKeyHashid404 mkhid
-    hLocal <- getsYesod $ appInstanceHost . appSettings
-    postReply
-        hLocal
-        [ProjectR shr prj]
-        [ ProjectFollowersR shr prj
-        , ProjectTicketParticipantsR shr prj ltkhid
-        , ProjectTicketTeamR shr prj ltkhid
-        ]
-        (ProjectTicketR shr prj ltkhid)
-        (ProjectR shr prj)
-        (ProjectTicketReplyR shr prj ltkhid . encodeHid)
-        (ProjectTicketMessageR shr prj ltkhid . encodeHid)
-        (const $ ProjectTicketR shr prj ltkhid)
-        (selectDiscussionId shr prj ltkhid)
-        mid
-
-getProjectTicketTopReplyR
-    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
-getProjectTicketTopReplyR shr prj ltkhid =
-    getTopReply $ ProjectTicketDiscussionR shr prj ltkhid
-
-getProjectTicketReplyR
-    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid Message -> Handler Html
-getProjectTicketReplyR shr prj ltkhid mkhid = do
-    encodeHid <- getEncodeKeyHashid
-    mid <- decodeKeyHashid404 mkhid
-    getReply
-        (ProjectTicketReplyR shr prj ltkhid . encodeHid)
-        (ProjectTicketMessageR shr prj ltkhid . encodeHid)
-        (selectDiscussionId shr prj ltkhid)
-        mid
-
 postProjectTicketDepsR
     :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
 postProjectTicketDepsR _shr _prj _ltkhid = error "Temporarily disabled"
@@ -1104,13 +1079,6 @@ getSharerTicketR shr talkhid = do
     where
     here = SharerTicketR shr talkhid
 
-getSharerTicketDiscussionR
-    :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
-getSharerTicketDiscussionR shr talkhid =
-    getRepliesCollection (SharerTicketDiscussionR shr talkhid) $ do
-        (_, Entity _ lt, _, _, _) <- getSharerTicket404 shr talkhid
-        return $ localTicketDiscuss lt
-
 getSharerTicketDepsR
     :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
 getSharerTicketDepsR shr talkhid =

src/Vervis/Persist/Discussion.hs

@@ -17,9 +17,9 @@ module Vervis.Persist.Discussion
     ( MessageTreeNodeAuthor (..)
     , MessageTreeNode (..)
     , getDiscussionTree
-    --, getRepliesCollection
     , getLocalParentMessageId
     , getMessageParent
+    , getMessageFromID
     )
 where
 
@@ -35,8 +35,9 @@ import Data.Maybe (isNothing, mapMaybe)
 import Data.Text (Text)
 import Data.Tree (Forest)
 import Database.Esqueleto hiding (isNothing)
+import Yesod.Core
 import Yesod.Core.Content
-import Yesod.Persist.Core (runDB)
+import Yesod.Persist.Core
 
 import qualified Data.HashMap.Lazy as M (fromList, lookup)
 import qualified Database.Esqueleto as E
@@ -71,8 +72,29 @@ data MessageTreeNode = MessageTreeNode
     , mtnAuthor    :: MessageTreeNodeAuthor
     }
 
-getMessages :: AppDB DiscussionId -> Handler [MessageTreeNode]
+getLocalAuthor lmid aid name = do
-getMessages getdid = runDB $ do
+    authorByKey <- getLocalActor aid
+    code <-
+        case authorByKey of
+            LocalActorPerson personID -> do
+                person <- getJust personID
+                return $ "~" <> username2text (personUsername person)
+            LocalActorGroup groupID -> do
+                groupHash <- encodeKeyHashid groupID
+                return $ "&" <> keyHashidText groupHash
+            LocalActorRepo repoID -> do
+                repoHash <- encodeKeyHashid repoID
+                return $ "^" <> keyHashidText repoHash
+            LocalActorDeck deckID -> do
+                deckHash <- encodeKeyHashid deckID
+                return $ "=" <> keyHashidText deckHash
+            LocalActorLoom loomID -> do
+                loomHash <- encodeKeyHashid loomID
+                return $ "+" <> keyHashidText loomHash
+    return $ MessageTreeNodeLocal lmid authorByKey code name
+
+getAllMessages :: AppDB DiscussionId -> Handler [MessageTreeNode]
+getAllMessages getdid = runDB $ do
     did <- getdid
     l <- select $ from $ \ (lm `InnerJoin` m `InnerJoin` a) -> do
             on $ lm ^. LocalMessageAuthor ==. a ^. ActorId
@@ -103,25 +125,8 @@ getMessages getdid = runDB $ do
     return $ locals ++ remotes
     where
     mklocal (Entity mid m, Value lmid, Value aid, Value name) = do
-        authorByKey <- getLocalActor aid
+        author <- getLocalAuthor lmid aid name
-        code <-
+        return $ MessageTreeNode mid m author
-            case authorByKey of
-                LocalActorPerson personID -> do
-                    person <- getJust personID
-                    return $ "~" <> username2text (personUsername person)
-                LocalActorGroup groupID -> do
-                    groupHash <- encodeKeyHashid groupID
-                    return $ "&" <> keyHashidText groupHash
-                LocalActorRepo repoID -> do
-                    repoHash <- encodeKeyHashid repoID
-                    return $ "^" <> keyHashidText repoHash
-                LocalActorDeck deckID -> do
-                    deckHash <- encodeKeyHashid deckID
-                    return $ "=" <> keyHashidText deckHash
-                LocalActorLoom loomID -> do
-                    loomHash <- encodeKeyHashid loomID
-                    return $ "+" <> keyHashidText loomHash
-        return $ MessageTreeNode mid m $ MessageTreeNodeLocal lmid authorByKey code name
     mkremote (Entity mid m, Value h, Value luMsg, Value luAuthor, Value name) =
         MessageTreeNode mid m $ MessageTreeNodeRemote h luMsg luAuthor name
 
@@ -149,57 +154,10 @@ sortByTime = sortForestOn $ messageCreated . mtnMessage
 -- | Get the tree of messages in a given discussion, with siblings sorted from
 -- old to new.
 getDiscussionTree :: AppDB DiscussionId -> Handler (Forest MessageTreeNode)
-getDiscussionTree getdid = sortByTime . discussionTree <$> getMessages getdid
+getDiscussionTree getdid =
+    sortByTime . discussionTree <$> getAllMessages getdid
 
-{-
+getMessageFromRoute
-getRepliesCollection :: Route App -> AppDB DiscussionId -> Handler TypedContent
-getRepliesCollection here getDiscussionId404 = do
-    (locals, remotes) <- runDB $ do
-        did <- getDiscussionId404
-        (,) <$> selectLocals did <*> selectRemotes did
-    encodeRouteLocal <- getEncodeRouteLocal
-    encodeRouteHome <- getEncodeRouteHome
-    encodeHid <- getEncodeKeyHashid
-    hashPerson <- getEncodeKeyHashid
-    let localUri' = localUri hashPerson encodeRouteHome encodeHid
-        replies = Collection
-            { collectionId         = encodeRouteLocal here
-            , collectionType       = CollectionTypeUnordered
-            , collectionTotalItems = Just $ length locals + length remotes
-            , collectionCurrent    = Nothing
-            , collectionFirst      = Nothing
-            , collectionLast       = Nothing
-            , collectionItems      =
-                map localUri' locals ++ map remoteUri remotes
-            }
-    provideHtmlAndAP replies $ redirectToPrettyJSON here
-    where
-    selectLocals did =
-        E.select $ E.from $
-            \ (m `E.InnerJoin` lm) -> do
-                E.on $ m E.^. MessageId E.==. lm E.^. LocalMessageRest
-                E.where_ $
-                    m E.^. MessageRoot E.==. E.val did E.&&.
-                    E.isNothing (m E.^. MessageParent) E.&&.
-                    E.isNothing (lm E.^. LocalMessageUnlinkedParent)
-                return (lm E.^. LocalMessageAuthor, lm E.^. LocalMessageId)
-    selectRemotes did =
-        E.select $ E.from $
-            \ (m `E.InnerJoin` rm `E.InnerJoin` ro `E.InnerJoin` i) -> do
-                E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
-                E.on $ rm E.^. RemoteMessageIdent E.==. ro E.^. RemoteObjectId
-                E.on $ m E.^. MessageId E.==. rm E.^. RemoteMessageRest
-                E.where_ $
-                    m E.^. MessageRoot E.==. E.val did E.&&.
-                    E.isNothing (m E.^. MessageParent) E.&&.
-                    E.isNothing (rm E.^. RemoteMessageLostParent)
-                return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent)
-    localUri hashPerson encR encH (E.Value pid, E.Value lmid) =
-        encR $ PersonMessageR (hashPerson pid) (encH lmid)
-    remoteUri (E.Value h, E.Value lu) = ObjURI h lu
--}
-
-getMessage
     :: LocalActorBy Key
     -> LocalMessageId
     -> ExceptT Text AppDB
@@ -208,7 +166,7 @@ getMessage
         , Entity LocalMessage
         , Entity Message
         )
-getMessage authorByKey localMsgID = do
+getMessageFromRoute authorByKey localMsgID = do
     authorByEntity <- do
         maybeActor <- lift $ getLocalActorEntity authorByKey
         fromMaybeE maybeActor "No such author in DB"
@@ -233,7 +191,7 @@ getLocalParentMessageId
     -> (LocalActorBy Key, LocalMessageId)
     -> ExceptT Text AppDB MessageId
 getLocalParentMessageId discussionID (authorByKey, localMsgID) = do
-    (_, _, _, Entity msgID msg) <- getMessage authorByKey localMsgID
+    (_, _, _, Entity msgID msg) <- getMessageFromRoute authorByKey localMsgID
     unless (messageRoot msg == discussionID) $
         throwE "Local parent belongs to a different discussion"
     return msgID
@@ -259,3 +217,30 @@ getMessageParent did (Right p@(ObjURI hParent luParent)) = do
                 throwE "Remote parent belongs to a different discussion"
             return mid
         Nothing -> return $ Right p
+
+getMessageFromID :: AppDB DiscussionId -> MessageId -> AppDB MessageTreeNode
+getMessageFromID getdid mid = do
+    did <- getdid
+    m <- get404 mid
+    unless (messageRoot m == did) notFound
+    mlocal <- getBy $ UniqueLocalMessage mid
+    mremote <- getBy $ UniqueRemoteMessage mid
+    author <- case (mlocal, mremote) of
+        (Nothing, Nothing) -> fail "Message with no author"
+        (Just _, Just _) -> fail "Message used as both local and remote"
+        (Just (Entity lmid lm), Nothing) -> do
+            let actorID = localMessageAuthor lm
+            name <- actorName <$> getJust actorID
+            getLocalAuthor lmid actorID name
+        (Nothing, Just (Entity _rmid rm)) -> do
+            ra <- getJust $ remoteMessageAuthor rm
+            roA <- getJust $ remoteActorIdent ra
+            roM <- getJust $ remoteMessageIdent rm
+            i <- getJust $ remoteObjectInstance roA
+            return $
+                MessageTreeNodeRemote
+                    (instanceHost i)
+                    (remoteObjectIdent roM)
+                    (remoteObjectIdent roA)
+                    (remoteActorName ra)
+    return $ MessageTreeNode mid m author

src/Vervis/Web/Discussion.hs

@@ -14,11 +14,10 @@
  -}
 
 module Vervis.Web.Discussion
-    ( getDiscussion
+    ( serveDiscussion
-    --, getTopReply
+    , getTopReply
-    --, postTopReply
+    , getReply
-    --, getReply
+    , postReply
-    --, postReply
     , serveMessage
     )
 where
@@ -42,6 +41,7 @@ import Yesod.Form.Types (FormResult (..))
 import Yesod.Persist.Core (runDB, get404, getBy404)
 
 import qualified Data.Text as T
+import qualified Database.Esqueleto as E
 
 import Data.Aeson.Encode.Pretty.ToEncoding
 import Database.Persist.JSON
@@ -57,6 +57,7 @@ import qualified Web.ActivityPub as AP
 
 import Data.Either.Local
 import Database.Persist.Local
+import Yesod.Form.Local
 import Yesod.Persist.Local
 
 import Vervis.API
@@ -73,41 +74,65 @@ import Vervis.Settings
 import Vervis.Ticket
 import Vervis.Widget.Discussion
 
-getDiscussion
+import qualified Vervis.Client as C
-    :: (MessageId -> Route App)
+
+getRepliesCollection
+    :: Route App -> AppDB DiscussionId -> Handler (AP.Collection FedURI URIMode)
+getRepliesCollection here getDiscussionId404 = do
+    (locals, remotes) <- runDB $ do
+        did <- getDiscussionId404
+        (,) <$> selectLocals did <*> selectRemotes did
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    hashMsg <- getEncodeKeyHashid
+    hashActor <- getHashLocalActor
+    let localUri (authorByKey, localMsgID) =
+            encodeRouteHome $
+                messageRoute (hashActor authorByKey) (hashMsg localMsgID)
+    return AP.Collection
+        { AP.collectionId         = encodeRouteLocal here
+        , AP.collectionType       = AP.CollectionTypeUnordered
+        , AP.collectionTotalItems = Just $ length locals + length remotes
+        , AP.collectionCurrent    = Nothing
+        , AP.collectionFirst      = Nothing
+        , AP.collectionLast       = Nothing
+        , AP.collectionItems      =
+            map localUri locals ++ map remoteUri remotes
+        }
+    where
+    selectLocals did = do
+        locals <- E.select $ E.from $ \ (m `E.InnerJoin` lm) -> do
+            E.on $ m E.^. MessageId E.==. lm E.^. LocalMessageRest
+            E.where_ $
+                m E.^. MessageRoot E.==. E.val did E.&&.
+                E.isNothing (m E.^. MessageParent) E.&&.
+                E.isNothing (lm E.^. LocalMessageUnlinkedParent)
+            return (lm E.^. LocalMessageAuthor, lm E.^. LocalMessageId)
+        for locals $ \ (E.Value actorID, E.Value localMsgID) -> do
+            actorByKey <- getLocalActor actorID
+            return (actorByKey, localMsgID)
+    selectRemotes did =
+        E.select $ E.from $
+            \ (m `E.InnerJoin` rm `E.InnerJoin` ro `E.InnerJoin` i) -> do
+                E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
+                E.on $ rm E.^. RemoteMessageIdent E.==. ro E.^. RemoteObjectId
+                E.on $ m E.^. MessageId E.==. rm E.^. RemoteMessageRest
+                E.where_ $
+                    m E.^. MessageRoot E.==. E.val did E.&&.
+                    E.isNothing (m E.^. MessageParent) E.&&.
+                    E.isNothing (rm E.^. RemoteMessageLostParent)
+                return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent)
+    remoteUri (E.Value h, E.Value lu) = ObjURI h lu
+
+serveDiscussion
+    :: Route App
+    -> (MessageId -> Route App)
     -> Route App
     -> AppDB DiscussionId
-    -> Handler Html
+    -> Handler TypedContent
-getDiscussion reply topic getdid =
+serveDiscussion here reply topic getdid = do
-    defaultLayout $ discussionW getdid topic reply
+    replies <- getRepliesCollection here getdid
-
+    provideHtmlAndAP replies (discussionW getdid topic reply)
-{-
-getNode :: AppDB DiscussionId -> MessageId -> AppDB MessageTreeNode
-getNode getdid mid = do
-    did <- getdid
-    m <- get404 mid
-    unless (messageRoot m == did) notFound
-    mlocal <- getBy $ UniqueLocalMessage mid
-    mremote <- getBy $ UniqueRemoteMessage mid
-    author <- case (mlocal, mremote) of
-        (Nothing, Nothing) -> fail "Message with no author"
-        (Just _, Just _) -> fail "Message used as both local and remote"
-        (Just (Entity lmid lm), Nothing) -> do
-            p <- getJust $ localMessageAuthor lm
-            s <- getJust $ personIdent p
-            return $ MessageTreeNodeLocal lmid s
-        (Nothing, Just (Entity _rmid rm)) -> do
-            ra <- getJust $ remoteMessageAuthor rm
-            roA <- getJust $ remoteActorIdent ra
-            roM <- getJust $ remoteMessageIdent rm
-            i <- getJust $ remoteObjectInstance roA
-            return $
-                MessageTreeNodeRemote
-                    (instanceHost i)
-                    (remoteObjectIdent roM)
-                    (remoteObjectIdent roA)
-                    (remoteActorName ra)
-    return $ MessageTreeNode mid m author
 
 {-
 getNodeL :: AppDB DiscussionId -> LocalMessageId -> AppDB MessageTreeNode
@@ -127,111 +152,68 @@ getTopReply replyP = do
     ((_result, widget), enctype) <- runFormPost newMessageForm
     defaultLayout $(widgetFile "discussion/top-reply")
 
-postTopReply
+getReply'
-    :: Host
-    -> [Route App]
-    -> [Route App]
-    -> Route App
-    -> Route App
-    -> Route App
-    -> (LocalMessageId -> Route App)
-    -> Handler Html
-postTopReply hDest recipsA recipsC context recipF replyP after = do
-    ((result, widget), enctype) <- runFormPost newMessageForm
-    (eperson, sharer) <- do
-        ep@(Entity _ p) <- requireVerifiedAuth
-        s <- runDB $ get404 (personIdent p)
-        return (ep, s)
-    let shrAuthor = sharerIdent sharer
-    eobiid <- runExceptT $ do
-        msg <- case result of
-            FormMissing -> throwE "Field(s) missing."
-            FormFailure _l -> throwE "Message submission failed, see errors below."
-            FormSuccess nm ->
-                return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm
-        note <- ExceptT $ createThread shrAuthor msg hDest recipsA recipsC context
-        noteC eperson sharer note
-    case eobiid of
-        Left e -> do
-            setMessage $ toHtml e
-            defaultLayout $(widgetFile "discussion/top-reply")
-        Right obiid -> do
-            setMessage "Message submitted."
-
-            encodeRouteFed <- getEncodeRouteFed
-            let encodeRecipRoute = encodeRouteFed hDest
-            (summary, audience, follow) <- C.follow shrAuthor (encodeRecipRoute context) (encodeRecipRoute recipF) False
-            eobiidFollow <- runExceptT $ followC shrAuthor (Just summary) audience follow
-            case eobiidFollow of
-                Left e -> setMessage $ toHtml $ "Following failed: " <> e
-                Right _ -> return ()
-
-            mlmid <- runDB $ getKeyBy $ UniqueLocalMessageCreate obiid
-            case mlmid of
-                Nothing -> error "noteC succeeded but no lmid found for obiid"
-                Just lmid -> redirect $ after lmid
-
-getReply
     :: (MessageId -> Route App)
     -> (MessageId -> Route App)
     -> AppDB DiscussionId
     -> MessageId
     -> Handler Html
-getReply replyG replyP getdid midParent = do
+getReply' replyG replyP getdid midParent = do
-    mtn <- runDB $ getNode getdid midParent
+    mtn <- runDB $ getMessageFromID getdid midParent
     now <- liftIO getCurrentTime
     ((_result, widget), enctype) <- runFormPost newMessageForm
     defaultLayout $(widgetFile "discussion/reply")
 
-postReply
+getReply
-    :: Host
+    :: (MessageId -> Route App)
-    -> [Route App]
-    -> [Route App]
-    -> Route App
-    -> Route App
-    -> (MessageId -> Route App)
-    -> (MessageId -> Route App)
-    -> (LocalMessageId -> Route App)
     -> AppDB DiscussionId
     -> MessageId
     -> Handler Html
-postReply hDest recipsA recipsC context recipF replyG replyP after getdid midParent = do
+getReply replyR = getReply' replyR replyR
-    ((result, widget), enctype) <- runFormPost newMessageForm
+
-    (eperson, sharer) <- do
+postReply
-        ep@(Entity _ p) <- requireVerifiedAuth
+    :: Route App
-        s <- runDB $ get404 (personIdent p)
+    -> [LocalActorBy KeyHashid]
-        return (ep, s)
+    -> [LocalStageBy KeyHashid]
-    let shrAuthor = sharerIdent sharer
+    -> Route App
-    eobiid <- runExceptT $ do
+    -> Maybe (AppDB DiscussionId, MessageId)
-        msg <- case result of
+    -> Handler Html
-            FormMissing -> throwE "Field(s) missing."
+postReply formR actors stages topicR maybeParent = do
-            FormFailure _l -> throwE "Message submission failed, see errors below."
+    source <- runFormPostRedirect formR newMessageForm
-            FormSuccess nm ->
+    person@(Entity senderID sender) <- requireAuth
-                return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm
+    senderHash <- encodeKeyHashid senderID
-        note <- ExceptT $ createReply shrAuthor msg hDest recipsA recipsC context midParent
+    errorOrCreate <- runExceptT $ do
-        noteC eperson sharer note
+        muParent <- for maybeParent $ \ (getdid, midParent) -> do
-    case eobiid of
+            MessageTreeNode _ _ author <-
+                lift $ runDB $ getMessageFromID getdid midParent
+            case author of
+                MessageTreeNodeLocal localMsgID authorByKey _ _ -> do
+                    encodeRouteHome <- getEncodeRouteHome
+                    localMsgHash <- encodeKeyHashid localMsgID
+                    authorByHash <- hashLocalActor authorByKey
+                    return $ encodeRouteHome $
+                        messageRoute authorByHash localMsgHash
+                MessageTreeNodeRemote h _ luAuthor _ ->
+                    return $ ObjURI h luAuthor
+        (maybeSummary, audience, note) <-
+            C.comment senderHash source actors stages topicR muParent
+        hLocal <- asksSite siteInstanceHost
+        let specific =
+                AP.CreateActivity $
+                    AP.Create (AP.CreateNote hLocal note) Nothing
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            lift $ C.makeServerInput Nothing maybeSummary audience specific
+        actor <- lift $ runDB $ getJust $ personActor sender
+        createNoteC
+            person actor Nothing localRecips remoteRecips fwdHosts
+            action note Nothing
+    case errorOrCreate of
         Left e -> do
             setMessage $ toHtml e
-            mtn <- runDB $ getNode getdid midParent
+            redirect formR
-            now <- liftIO getCurrentTime
+        Right createID -> do
-            defaultLayout $(widgetFile "discussion/reply")
-        Right obiid -> do
             setMessage "Message submitted."
-
+            redirect topicR
-            encodeRouteFed <- getEncodeRouteFed
-            let encodeRecipRoute = encodeRouteFed hDest
-            (summary, audience, follow) <- C.follow shrAuthor (encodeRecipRoute context) (encodeRecipRoute recipF) False
-            eobiidFollow <- runExceptT $ followC shrAuthor (Just summary) audience follow
-            case eobiidFollow of
-                Left e -> setMessage $ toHtml $ "Following failed: " <> e
-                Right _ -> return ()
-
-            mlmid <- runDB $ getKeyBy $ UniqueLocalMessageCreate obiid
-            case mlmid of
-                Nothing -> error "noteC succeeded but no lmid found for obiid"
-                Just lmid -> redirect $ after lmid
--}
 
 serveMessage authorHash localMessageHash = do
     authorID <- decodeKeyHashid404 authorHash

th/routes

@@ -148,8 +148,6 @@
 /people/#PersonKeyHashid/follow                          PersonFollowR     POST
 /people/#PersonKeyHashid/unfollow                        PersonUnfollowR   POST
 
-/reply/#MessageKeyHashid                                 ReplyR            POST
-
 /people/#PersonKeyHashid/stamps/#SigKeyKeyHashid         PersonStampR      GET
 
 ---- Group ------------------------------------------------------------------
@@ -236,9 +234,10 @@
 -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/unclaim    TicketUnclaimR     POST
 -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/assign     TicketAssignR      GET POST
 -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/unassign   TicketUnassignR    POST
-/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/follow     TicketFollowR      POST
+/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/follow                  TicketFollowR   POST
-/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/unfollow   TicketUnfollowR    POST
+/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/unfollow                TicketUnfollowR POST
-/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/reply      TicketReplyR       POST
+/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/reply                   TicketReplyR    GET POST
+/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/reply/#MessageKeyHashid TicketReplyOnR  GET POST
 
 ---- Ticket Dependency -------------------------------------------------------
 
@@ -291,7 +290,8 @@
 /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/apply      ClothApplyR       POST
 /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/follow     ClothFollowR      POST
 /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/unfollow   ClothUnfollowR    POST
-/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/reply      ClothReplyR       POST
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/reply      ClothReplyR       GET POST
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/reply/#MessageKeyHashid ClothReplyOnR GET POST
 
 ---- Cloth Dependency --------------------------------------------------------