When sending ticket comment in regular Vervis UI, deliver it using ActivityPub

src/Vervis/Handler/Discussion.hs

@@ -27,13 +27,15 @@ import Prelude
 
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except
 import Data.Maybe
 import Data.Time.Clock (getCurrentTime)
 import Database.Persist
 import Database.Persist.Sql
 import Data.Traversable
 import Text.Blaze.Html (Html)
-import Yesod.Auth (requireAuthId)
+import Data.Text (Text)
+import Yesod.Auth
 import Yesod.Core
 import Yesod.Core.Handler
 import Yesod.Form.Functions (runFormPost)
@@ -42,6 +44,7 @@ import Yesod.Persist.Core (runDB, get404, getBy404)
 
 import Network.FedURI
 import Web.ActivityPub
+import Yesod.Auth.Unverified
 import Yesod.FedURI
 import Yesod.Hashids
 
@@ -50,6 +53,7 @@ import Yesod.Persist.Local
 
 import Vervis.Discussion
 import Vervis.Form.Discussion
+import Vervis.Federation
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
@@ -157,38 +161,51 @@ getTopReply replyP = do
     defaultLayout $(widgetFile "discussion/top-reply")
 
 postTopReply
-    :: Route App
+    :: Text
+    -> [Route App]
+    -> Route App
+    -> Route App
     -> (LocalMessageId -> Route App)
-    -> AppDB DiscussionId
     -> Handler Html
-postTopReply replyP after getdid = do
+postTopReply hDest recips context replyP after = do
     ((result, widget), enctype) <- runFormPost newMessageForm
+    elmid <- runExceptT $ do
+        msg <- case result of
+            FormMissing -> throwE "Field(s) missing."
+            FormFailure _l -> throwE "Message submission failed, see errors below."
+            FormSuccess nm -> return $ nmContent nm
+        encodeRouteFed <- getEncodeRouteFed
+        encodeRouteLocal <- getEncodeRouteLocal
+        let encodeRecipRoute = l2f hDest . encodeRouteLocal
         now <- liftIO getCurrentTime
-    case result of
+        shrAuthor <- do
-        FormSuccess nm -> do
+            Entity _ p <- requireVerifiedAuth
-            author <- requireAuthId
+            lift $ runDB $ sharerIdent <$> get404 (personIdent p)
-            mnum <- runDB $ do
+        let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
-                did <- getdid
+            uContext = encodeRecipRoute context
-                mid <- insert Message
+            note = Note
-                    { messageCreated = now
+                { noteId        = Nothing
-                    , messageContent = nmContent nm
+                , noteAttrib    = luAuthor
-                    , messageParent  = Nothing
+                , noteAudience  = Audience
-                    , messageRoot    = did
+                    { audienceTo      = map encodeRecipRoute recips
+                    , audienceBto     = []
+                    , audienceCc      = []
+                    , audienceBcc     = []
+                    , audienceGeneral = []
                     }
-                lmid <- insert LocalMessage
+                , noteReplyTo   = Just uContext
-                    { localMessageAuthor         = author
+                , noteContext   = Just uContext
-                    , localMessageRest           = mid
+                , notePublished = Just now
-                    , localMessageUnlinkedParent = Nothing
+                , noteContent   = msg
                 }
-                return lmid
+        ExceptT $ handleOutboxNote hLocal note
+    case elmid of
+        Left e -> do
+            setMessage $ toHtml e
+            defaultLayout $(widgetFile "discussion/top-reply")
+        Right lmid -> do
             setMessage "Message submitted."
-            redirect $ after mnum
+            redirect $ after lmid
-        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
     :: (MessageId -> Route App)
@@ -196,50 +213,76 @@ getReply
     -> AppDB DiscussionId
     -> MessageId
     -> Handler Html
-getReply replyG replyP getdid mid = do
+getReply replyG replyP getdid midParent = do
-    mtn <- runDB $ getNode getdid mid
+    mtn <- runDB $ getNode getdid midParent
     now <- liftIO getCurrentTime
     ((_result, widget), enctype) <- runFormPost newMessageForm
     defaultLayout $(widgetFile "discussion/reply")
 
 postReply
-    :: (MessageId -> Route App)
+    :: Text
+    -> [Route App]
+    -> Route App
+    -> (MessageId -> Route App)
     -> (MessageId -> Route App)
     -> (LocalMessageId -> Route App)
     -> AppDB DiscussionId
     -> MessageId
     -> Handler Html
-postReply replyG replyP after getdid mid = do
+postReply hDest recips context replyG replyP after getdid midParent = do
     ((result, widget), enctype) <- runFormPost newMessageForm
+    elmid <- runExceptT $ do
+        msg <- case result of
+            FormMissing -> throwE "Field(s) missing."
+            FormFailure _l -> throwE "Message submission failed, see errors below."
+            FormSuccess nm -> return $ nmContent nm
+        encodeRouteFed <- getEncodeRouteFed
+        encodeRouteLocal <- getEncodeRouteLocal
+        let encodeRecipRoute = l2f hDest . encodeRouteLocal
         now <- liftIO getCurrentTime
-    case result of
+        (shrAuthor, uParent) <- do
-        FormSuccess nm -> do
+            Entity _ p <- requireVerifiedAuth
-            author <- requireAuthId
+            lift $ runDB $ do
-            msgid <- runDB $ do
+                _m <- get404 midParent
-                did <- getdid
+                shr <- sharerIdent <$> get404 (personIdent p)
-                parent <- do
+                mlocal <- getBy $ UniqueLocalMessage midParent
-                    message <- get404 mid
+                mremote <- getValBy $ UniqueRemoteMessage midParent
-                    unless (messageRoot message == did) notFound
+                parent <- case (mlocal, mremote) of
-                    return mid
+                    (Nothing, Nothing) -> error "Message with no author"
-                mid <- insert Message
+                    (Just _, Just _) -> error "Message used as both local and remote"
-                    { messageCreated = now
+                    (Just (Entity lmidParent lm), Nothing) -> do
-                    , messageContent = nmContent nm
+                        p <- getJust $ localMessageAuthor lm
-                    , messageParent  = Just parent
+                        s <- getJust $ personIdent p
-                    , messageRoot    = did
+                        lmkhid <- encodeKeyHashid lmidParent
+                        return $ encodeRouteFed $ MessageR (sharerIdent s) lmkhid
+                    (Nothing, Just rm) -> do
+                        i <- getJust $ remoteMessageInstance rm
+                        return $ l2f (instanceHost i) (remoteMessageIdent rm)
+                return (shr, parent)
+        let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
+            uContext = encodeRecipRoute context
+            note = Note
+                { noteId        = Nothing
+                , noteAttrib    = luAuthor
+                , noteAudience  = Audience
+                    { audienceTo      = map encodeRecipRoute recips
+                    , audienceBto     = []
+                    , audienceCc      = []
+                    , audienceBcc     = []
+                    , audienceGeneral = []
                     }
-                lmid <- insert LocalMessage
+                , noteReplyTo   = Just uParent
-                    { localMessageAuthor         = author
+                , noteContext   = Just uContext
-                    , localMessageRest           = mid
+                , notePublished = Just now
-                    , localMessageUnlinkedParent = Nothing
+                , noteContent   = msg
                 }
-                return lmid
+        ExceptT $ handleOutboxNote hLocal note
+    case elmid of
+        Left e -> do
+            setMessage $ toHtml e
+            mtn <- runDB $ getNode getdid midParent
+            now <- liftIO getCurrentTime
+            defaultLayout $(widgetFile "discussion/reply")
+        Right lmid -> do
             setMessage "Message submitted."
-            redirect $ after msgid
+            redirect $ after lmid
-        FormMissing -> do
-            setMessage "Field(s) missing."
-            mtn <- runDB $ getNode getdid mid
-            defaultLayout $(widgetFile "discussion/reply")
-        FormFailure _l -> do
-            setMessage "Message submission failed, see errors below."
-            mtn <- runDB $ getNode getdid mid
-            defaultLayout $(widgetFile "discussion/reply")

src/Vervis/Handler/Ticket.hs

@@ -97,7 +97,7 @@ import Vervis.Model.Ident
 import Vervis.Model.Ticket
 import Vervis.Model.Workflow
 import Vervis.Render (renderSourceT)
-import Vervis.Settings (widgetFile)
+import Vervis.Settings
 import Vervis.Style
 import Vervis.Ticket
 import Vervis.TicketFilter (filterTickets)
@@ -644,11 +644,17 @@ getTicketDiscussionR shar proj num = do
         (selectDiscussionId shar proj num)
 
 postTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html
-postTicketDiscussionR shar proj num =
+postTicketDiscussionR shr prj num = do
+    hLocal <- getsYesod $ appInstanceHost . appSettings
     postTopReply
-        (TicketDiscussionR shar proj num)
+        hLocal
-        (const $ TicketR shar proj num)
+        [ ProjectR shr prj
-        (selectDiscussionId shar proj num)
+        , TicketParticipantsR shr prj num
+        , TicketTeamR shr prj num
+        ]
+        (TicketR shr prj num)
+        (TicketDiscussionR shr prj num)
+        (const $ TicketR shr prj num)
 
 getMessageR :: ShrIdent -> KeyHashid LocalMessage -> Handler TypedContent
 getMessageR shr hid = do
@@ -656,14 +662,21 @@ getMessageR shr hid = do
     getDiscussionMessage shr lmid
 
 postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> KeyHashid Message -> Handler Html
-postTicketMessageR shar proj tnum hid = do
+postTicketMessageR shr prj num mkhid = do
     encodeHid <- getEncodeKeyHashid
-    mid <- decodeKeyHashid404 hid
+    mid <- decodeKeyHashid404 mkhid
+    hLocal <- getsYesod $ appInstanceHost . appSettings
     postReply
-        (TicketReplyR shar proj tnum . encodeHid)
+        hLocal
-        (TicketMessageR shar proj tnum . encodeHid)
+        [ ProjectR shr prj
-        (const $ TicketR shar proj tnum)
+        , TicketParticipantsR shr prj num
-        (selectDiscussionId shar proj tnum)
+        , TicketTeamR shr prj num
+        ]
+        (TicketR shr prj num)
+        (TicketReplyR shr prj num . encodeHid)
+        (TicketMessageR shr prj num . encodeHid)
+        (const $ TicketR shr prj num)
+        (selectDiscussionId shr prj num)
         mid
 
 getTicketTopReplyR :: ShrIdent -> PrjIdent -> Int -> Handler Html

templates/discussion/reply.hamlet

@@ -14,6 +14,6 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 ^{messageW now mtn replyG}
 
-<form method=POST action=@{replyP mid} enctype=#{enctype}>
+<form method=POST action=@{replyP midParent} enctype=#{enctype}>
   ^{widget}
   <input type=submit>