diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index ad99df8..52ee746 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -15,7 +15,7 @@ module Vervis.Federation.Discussion ( personCreateNoteF - --, deckCreateNoteF + , deckCreateNoteF --, loomCreateNoteF ) where @@ -53,13 +53,14 @@ import Yesod.HttpSignature import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest -import Web.ActivityPub hiding (ActorLocal (..)) import Web.Text import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite +import qualified Web.ActivityPub as AP + import Control.Monad.Trans.Except.Local import Data.Tuple.Local import Database.Persist.Local @@ -78,6 +79,7 @@ import Vervis.Persist.Discussion import Vervis.Recipient import Vervis.Settings import Vervis.Ticket +import Vervis.Web.Delivery -- | Insert the new remote comment into the discussion tree. If we didn't have -- this comment before, return the database ID of the newly created cached @@ -170,7 +172,7 @@ personCreateNoteF -> ActivityBody -> Maybe (RecipientRoutes, ByteString) -> LocalURI - -> Note URIMode + -> AP.Note URIMode -> ExceptT Text Handler Text personCreateNoteF now recipPersonHash author body mfwd luCreate note = do @@ -238,68 +240,74 @@ personCreateNoteF now recipPersonHash author body mfwd luCreate note = do unless (messageRoot m == did) $ throwE "Remote parent belongs to a different discussion" -{- -projectCreateNoteF +deckCreateNoteF :: UTCTime - -> KeyHashid Project + -> KeyHashid Deck -> RemoteAuthor -> ActivityBody - -> Maybe (LocalRecipientSet, ByteString) + -> Maybe (RecipientRoutes, ByteString) -> LocalURI - -> Note URIMode + -> AP.Note URIMode -> ExceptT Text Handler Text -projectCreateNoteF now deckRecip author body mfwd luCreate note = do - (luNote, published, context, mparent, source, content) <- checkNote note - case context of - Right _ -> return "Not using; context isn't local" - Left (NoteContextProjectTicket shr prj ltid) -> do - mremotesHttp <- runDBExcept $ do - (jid, ibid) <- lift getProjectRecip404 - (_, _, _, Entity _ lt, _, Entity _ tpl, _, _) <- do - mticket <- lift $ getProjectTicket shr prj ltid - fromMaybeE mticket "Context: No such project-ticket" - if ticketProjectLocalProject tpl == jid - then do - mractid <- lift $ insertToInbox now author body ibid luCreate False - case mractid of - Nothing -> return $ Left "Activity already in my inbox" - Just ractid -> do - let did = localTicketDiscuss lt - meparent <- traverse (getParent did) mparent - mmid <- lift $ insertToDiscussion author luNote published source content did meparent ractid - case mmid of - Nothing -> return $ Left "I already have this comment, just storing in inbox" - Just mid -> lift $ do - updateOrphans author luNote did mid - case mfwd of - Nothing -> - return $ Left "Storing in inbox, caching comment, no inbox forwarding header" - Just (localRecips, sig) -> Right <$> do - ltkhid <- encodeKeyHashid ltid - let sieve = - makeRecipientSet - [] - [ LocalPersonCollectionProjectFollowers shrRecip prjRecip - , LocalPersonCollectionProjectTeam shrRecip prjRecip - , LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid - --, LocalPersonCollectionProjectTicketTeam shrRecip prjRecip ltkhid - ] - remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips - (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips - else return $ Left "Context is a project-ticket of another project" - case mremotesHttp of - Left msg -> return msg - Right (sig, remotesHttp) -> do - forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp - return "Stored to inbox, cached comment, and did inbox forwarding" - Left (NoteContextRepoProposal _ _ _) -> return "Context is a repo-patch, ignoring activity" - where - getProjectRecip404 = do - sid <- getKeyBy404 $ UniqueSharer shrRecip - Entity jid j <- getBy404 $ UniqueProject prjRecip sid - a <- getJust $ projectActor j - return (jid, actorInbox a) --} +deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do + + recipDeckID <- decodeKeyHashid404 recipDeckHash + (luNote, published, Comment maybeParent topic source content) <- do + (luId, luAuthor, published, comment) <- parseRemoteComment note + unless (luAuthor == objUriLocal (remoteAuthorURI author)) $ + throwE "Create author != note author" + return (luId, published, comment) + + case topic of + Right _ -> + pure "Topic is remote, i.e. not mine, so ignoring activity" + Left (CommentTopicCloth _ _) -> + pure "Topic is a local cloth, i.e. not mine, so ignoring activity" + Left (CommentTopicTicket deckID taskID) + | deckID /= recipDeckID -> + pure "Topic is some other deck's ticket, so ignoring activity" + | otherwise -> do + msgOrForward <- runDBExcept $ do + + Entity recipActorID recipActor <- lift $ do + deck <- get404 recipDeckID + let actorID = deckActor deck + Entity actorID <$> getJust actorID + + (_d, _td, Entity _ ticket, _a, _r) <- do + mticket <- lift $ getTicket recipDeckID taskID + fromMaybeE mticket "Topic: No such ticket in DB" + + mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luCreate False + case mractid of + Nothing -> return $ Left "Activity already in my inbox" + Just createID -> do + let did = ticketDiscuss ticket + meparent <- traverse (getMessageParent did) maybeParent + mmid <- lift $ insertToDiscussion author luNote published source content did meparent createID + case mmid of + Nothing -> return $ Left "I already have this comment, just storing in inbox" + Just mid -> lift $ do + updateOrphans author luNote did mid + case mfwd of + Nothing -> + return $ Left "Storing in inbox, caching comment, no inbox forwarding header" + Just (localRecips, sig) -> Right <$> do + taskHash <- encodeKeyHashid taskID + let sieve = + makeRecipientSet + [] + [ LocalStageDeckFollowers recipDeckHash + , LocalStageTicketFollowers recipDeckHash taskHash + ] + forwardActivityDB + (actbBL body) localRecips sig recipActorID + (LocalActorDeck recipDeckHash) sieve createID + case msgOrForward of + Left msg -> return msg + Right forwardHttp -> do + forkWorker "projectCreateNoteF inbox-forwarding" forwardHttp + return "Stored to inbox, cached comment, and did inbox forwarding" {- repoCreateNoteF diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index ef8c96e..680ca9a 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -100,6 +100,7 @@ import Vervis.Access import Vervis.API import Vervis.Federation.Auth import Vervis.Federation.Collab +import Vervis.Federation.Discussion import Vervis.Federation.Ticket import Vervis.FedURI import Vervis.Form.Project @@ -184,14 +185,12 @@ postDeckInboxR recipDeckHash = case specific of AP.AcceptActivity accept -> deckAcceptF now recipDeckHash author body mfwd luActivity accept - {- - CreateActivity (Create obj mtarget) -> + AP.CreateActivity (AP.Create obj mtarget) -> case obj of - CreateNote _ note -> - (,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body mfwd luActivity note - CreateTicket _ ticket -> - (,Nothing) <$> projectCreateTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket mtarget - _ -> error "Unsupported create object type for projects" + AP.CreateNote _ note -> + (,Nothing) <$> deckCreateNoteF now recipDeckHash author body mfwd luActivity note + _ -> error "Unsupported create object type for decks" + {- FollowActivity follow -> (,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body mfwd luActivity follow -}