From f7f15e0f63fa36f5b6b0789bd0bf48996ab52425 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 20 Apr 2019 21:34:45 +0000 Subject: [PATCH] When sending ticket comment in regular Vervis UI, deliver it using ActivityPub --- src/Vervis/Handler/Discussion.hs | 167 +++++++++++++++++++----------- src/Vervis/Handler/Ticket.hs | 35 +++++-- templates/discussion/reply.hamlet | 2 +- 3 files changed, 130 insertions(+), 74 deletions(-) diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index f995724..d9ddaf9 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/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 - now <- liftIO getCurrentTime - case result of - FormSuccess nm -> do - author <- requireAuthId - mnum <- runDB $ do - did <- getdid - mid <- insert Message - { messageCreated = now - , messageContent = nmContent nm - , messageParent = Nothing - , messageRoot = did + 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 + shrAuthor <- do + Entity _ p <- requireVerifiedAuth + lift $ runDB $ sharerIdent <$> get404 (personIdent p) + 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 - { localMessageAuthor = author - , localMessageRest = mid - , localMessageUnlinkedParent = Nothing - } - return lmid + , noteReplyTo = Just uContext + , noteContext = Just uContext + , notePublished = Just now + , noteContent = msg + } + 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 - 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") + redirect $ after lmid getReply :: (MessageId -> Route App) @@ -196,50 +213,76 @@ getReply -> AppDB DiscussionId -> MessageId -> Handler Html -getReply replyG replyP getdid mid = do - mtn <- runDB $ getNode getdid mid +getReply replyG replyP getdid midParent = do + 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 - now <- liftIO getCurrentTime - case result of - FormSuccess nm -> do - author <- requireAuthId - msgid <- runDB $ do - did <- getdid - parent <- do - message <- get404 mid - unless (messageRoot message == did) notFound - return mid - mid <- insert Message - { messageCreated = now - , messageContent = nmContent nm - , messageParent = Just parent - , messageRoot = did + 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 + (shrAuthor, uParent) <- do + Entity _ p <- requireVerifiedAuth + lift $ runDB $ do + _m <- get404 midParent + shr <- sharerIdent <$> get404 (personIdent p) + mlocal <- getBy $ UniqueLocalMessage midParent + mremote <- getValBy $ UniqueRemoteMessage midParent + parent <- case (mlocal, mremote) of + (Nothing, Nothing) -> error "Message with no author" + (Just _, Just _) -> error "Message used as both local and remote" + (Just (Entity lmidParent lm), Nothing) -> do + p <- getJust $ localMessageAuthor lm + s <- getJust $ personIdent p + 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 - { localMessageAuthor = author - , localMessageRest = mid - , localMessageUnlinkedParent = Nothing - } - return lmid + , noteReplyTo = Just uParent + , noteContext = Just uContext + , notePublished = Just now + , noteContent = msg + } + 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 - 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") + redirect $ after lmid diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 5427c7a..4974d08 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/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) - (const $ TicketR shar proj num) - (selectDiscussionId shar proj num) + hLocal + [ ProjectR shr prj + , 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) - (TicketMessageR shar proj tnum . encodeHid) - (const $ TicketR shar proj tnum) - (selectDiscussionId shar proj tnum) + hLocal + [ ProjectR shr prj + , TicketParticipantsR shr prj num + , 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 diff --git a/templates/discussion/reply.hamlet b/templates/discussion/reply.hamlet index 8d87ff7..33202b3 100644 --- a/templates/discussion/reply.hamlet +++ b/templates/discussion/reply.hamlet @@ -14,6 +14,6 @@ $# . ^{messageW now mtn replyG} -
+ ^{widget}