sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-28 22:04:51 +09:00
Code Issues Activity

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

Browse source
This commit is contained in:
fr33domlover 2019-04-20 21:34:45 +00:00
parent 4f5c6532ee
commit f7f15e0f63
3 changed files with 130 additions and 74 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

167
src/Vervis/Handler/Discussion.hs
View file

@ -27,13 +27,15 @@ import Prelude
import Control.Monad import Control.Monad
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except
import Data.Maybe import Data.Maybe
import Data.Time.Clock (getCurrentTime) import Data.Time.Clock (getCurrentTime)
import Database.Persist import Database.Persist
import Database.Persist.Sql import Database.Persist.Sql
import Data.Traversable import Data.Traversable
import Text.Blaze.Html (Html) import Text.Blaze.Html (Html)
import Yesod.Auth (requireAuthId) import Data.Text (Text)
import Yesod.Auth
import Yesod.Core import Yesod.Core
import Yesod.Core.Handler import Yesod.Core.Handler
import Yesod.Form.Functions (runFormPost) import Yesod.Form.Functions (runFormPost)
@ -42,6 +44,7 @@ import Yesod.Persist.Core (runDB, get404, getBy404)
import Network.FedURI import Network.FedURI
import Web.ActivityPub import Web.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
@ -50,6 +53,7 @@ import Yesod.Persist.Local
import Vervis.Discussion import Vervis.Discussion
import Vervis.Form.Discussion import Vervis.Form.Discussion
import Vervis.Federation
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
@ -157,38 +161,51 @@ getTopReply replyP = do
defaultLayout $(widgetFile "discussion/top-reply") defaultLayout $(widgetFile "discussion/top-reply")
postTopReply postTopReply
:: Route App :: Text
-> [Route App]
-> Route App
-> Route App
-> (LocalMessageId -> Route App) -> (LocalMessageId -> Route App)
-> AppDB DiscussionId
-> Handler Html -> Handler Html
postTopReply replyP after getdid = do postTopReply hDest recips context replyP after = do
((result, widget), enctype) <- runFormPost newMessageForm ((result, widget), enctype) <- runFormPost newMessageForm
now <- liftIO getCurrentTime elmid <- runExceptT $ do
case result of msg <- case result of
FormSuccess nm -> do FormMissing -> throwE "Field(s) missing."
author <- requireAuthId FormFailure _l -> throwE "Message submission failed, see errors below."
mnum <- runDB $ do FormSuccess nm -> return $ nmContent nm
did <- getdid encodeRouteFed <- getEncodeRouteFed
mid <- insert Message encodeRouteLocal <- getEncodeRouteLocal
{ messageCreated = now let encodeRecipRoute = l2f hDest . encodeRouteLocal
, messageContent = nmContent nm now <- liftIO getCurrentTime
, messageParent = Nothing shrAuthor <- do
, messageRoot = did 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 , 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." 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 getReply
:: (MessageId -> Route App) :: (MessageId -> Route App)
@ -196,50 +213,76 @@ getReply
-> AppDB DiscussionId -> AppDB DiscussionId
-> MessageId -> MessageId
-> Handler Html -> 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 now <- liftIO getCurrentTime
((_result, widget), enctype) <- runFormPost newMessageForm ((_result, widget), enctype) <- runFormPost newMessageForm
defaultLayout $(widgetFile "discussion/reply") defaultLayout $(widgetFile "discussion/reply")
postReply postReply
:: (MessageId -> Route App) :: Text
-> [Route App]
-> Route App
-> (MessageId -> Route App)
-> (MessageId -> Route App) -> (MessageId -> Route App)
-> (LocalMessageId -> Route App) -> (LocalMessageId -> Route App)
-> AppDB DiscussionId -> AppDB DiscussionId
-> MessageId -> MessageId
-> Handler Html -> Handler Html
postReply replyG replyP after getdid mid = do postReply hDest recips context replyG replyP after getdid midParent = do
((result, widget), enctype) <- runFormPost newMessageForm ((result, widget), enctype) <- runFormPost newMessageForm
now <- liftIO getCurrentTime elmid <- runExceptT $ do
case result of msg <- case result of
FormSuccess nm -> do FormMissing -> throwE "Field(s) missing."
author <- requireAuthId FormFailure _l -> throwE "Message submission failed, see errors below."
msgid <- runDB $ do FormSuccess nm -> return $ nmContent nm
did <- getdid encodeRouteFed <- getEncodeRouteFed
parent <- do encodeRouteLocal <- getEncodeRouteLocal
message <- get404 mid let encodeRecipRoute = l2f hDest . encodeRouteLocal
unless (messageRoot message == did) notFound now <- liftIO getCurrentTime
return mid (shrAuthor, uParent) <- do
mid <- insert Message Entity _ p <- requireVerifiedAuth
{ messageCreated = now lift $ runDB $ do
, messageContent = nmContent nm _m <- get404 midParent
, messageParent = Just parent shr <- sharerIdent <$> get404 (personIdent p)
, messageRoot = did 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 , 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." 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")

35
src/Vervis/Handler/Ticket.hs
View file

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

2
templates/discussion/reply.hamlet
View file

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