From c91908941b79dbf4e6fc3b199e89d3adc9464e09 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 11 May 2020 18:59:29 +0000 Subject: [PATCH] S2S: sharerCreateNoteF & projectCreateNoteF can handle sharer-hosted tickets --- src/Vervis/API.hs | 5 - src/Vervis/ActivityPub.hs | 100 +++++++-- src/Vervis/Federation/Discussion.hs | 328 ++++++++++++++-------------- 3 files changed, 242 insertions(+), 191 deletions(-) diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index b2b663c..76c6d27 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -149,11 +149,6 @@ parseComment luParent = do MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid" _ -> throwE "Not a local message route" -data NoteContext - = NoteContextSharerTicket ShrIdent TicketAuthorLocalId - | NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId - deriving Eq - noteC :: Entity Person -> Sharer diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index e091894..98e0edd 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -14,7 +14,8 @@ -} module Vervis.ActivityPub - ( hostIsLocal + ( NoteContext (..) + , hostIsLocal , verifyHostLocal , parseContext , parseParent @@ -43,6 +44,7 @@ module Vervis.ActivityPub , deliverLocal , RemoteRecipient (..) , deliverLocal' + , insertRemoteActivityToLocalInboxes ) where @@ -119,6 +121,11 @@ import Vervis.Time import Vervis.Widget.Repo import Vervis.Widget.Sharer +data NoteContext + = NoteContextSharerTicket ShrIdent TicketAuthorLocalId + | NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId + deriving Eq + hostIsLocal :: (MonadSite m, SiteEnv m ~ App) => Host -> m Bool hostIsLocal h = asksSite $ (== h) . appInstanceHost . appSettings @@ -132,7 +139,7 @@ verifyHostLocal h t = do parseContext :: (MonadSite m, SiteEnv m ~ App) => FedURI - -> ExceptT Text m (Either (ShrIdent, PrjIdent, KeyHashid LocalTicket) FedURI) + -> ExceptT Text m (Either NoteContext FedURI) parseContext uContext = do let ObjURI hContext luContext = uContext local <- hostIsLocal hContext @@ -142,7 +149,12 @@ parseContext uContext = do Nothing -> throwE "Local context isn't a valid route" Just r -> return r case route of - ProjectTicketR shr prj num -> return (shr, prj, num) + SharerTicketR shr talkhid -> + NoteContextSharerTicket shr <$> + decodeKeyHashidE talkhid "Note context invalid talkhid" + ProjectTicketR shr prj ltkhid -> + NoteContextProjectTicket shr prj <$> + decodeKeyHashidE ltkhid "Note context invalid ltkhid" _ -> throwE "Local context isn't a ticket route" else return $ Right uContext @@ -735,15 +747,25 @@ data RemoteRecipient = RemoteRecipient -- * Insert activity to inboxes of actors -- * If collections are listed, insert activity to the local members and return -- the remote members -deliverLocal' - :: Bool -- ^ Whether to deliver to collection only if owner actor is addressed - -> LocalActor - -> InboxId - -> OutboxItemId +insertActivityToLocalInboxes + :: PersistRecordBackend record SqlBackend + => (InboxId -> InboxItemId -> record) + -- ^ Database record to insert as an new inbox item to each inbox + -> Bool + -- ^ Whether to deliver to collection only if owner actor is addressed + -> Maybe LocalActor + -- ^ An actor whose collections are excluded from requiring an owner, i.e. + -- even if owner is required, this actor's collections will be delivered + -- to, even if this actor isn't addressed. This is meant to be the + -- activity's author. + -> Maybe InboxId + -- ^ A user person's inbox to exclude from delivery, even if this person is + -- listed in the recipient set. This is meant to be the activity's + -- author. -> LocalRecipientSet -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] -deliverLocal' requireOwner author ibidAuthor obiid recips = do - ibidsSharer <- L.delete ibidAuthor <$> getSharerInboxes recips +insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor recips = do + ibidsSharer <- deleteAuthor <$> getSharerInboxes recips ibidsOther <- concat <$> traverse getOtherInboxes recips (ibidsFollowers, remotesFollowers) <- do @@ -754,13 +776,23 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do ibidsTeams <- foldl' LO.union [] <$> traverse getTeams recips - let ibids = L.delete ibidAuthor (ibidsFollowers `LO.union` ibidsTeams `LO.union` ibidsSharer) ++ ibidsOther + let ibids = deleteAuthor (ibidsFollowers `LO.union` ibidsTeams `LO.union` ibidsSharer) ++ ibidsOther ibiids <- insertMany $ replicate (length ibids) $ InboxItem True - insertMany_ $ - map (\ (ibid, ibiid) -> InboxItemLocal ibid obiid ibiid) - (zip ibids ibiids) + insertMany_ $ zipWith makeInboxItem ibids ibiids return remotesFollowers where + isAuthor :: LocalActor -> Bool + isAuthor = + case mauthor of + Nothing -> const False + Just author -> (== author) + + deleteAuthor :: [InboxId] -> [InboxId] + deleteAuthor = + case mibidAuthor of + Nothing -> id + Just ibidAuthor -> L.delete ibidAuthor + getSharerInboxes :: LocalRecipientSet -> AppDB [InboxId] getSharerInboxes sharers = do let shrs = @@ -801,7 +833,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do [shr | (shr, s) <- sharers , let d = localRecipSharerDirect s in localRecipSharerFollowers d && - (localRecipSharer d || not requireOwner || LocalActorSharer shr == author) + (localRecipSharer d || not requireOwner || isAuthor (LocalActorSharer shr)) ] sids <- selectKeysList [SharerIdent <-. shrs] [] map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] [] @@ -838,7 +870,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do [prj | (prj, j) <- projects , let d = localRecipProjectDirect j in localRecipProjectFollowers d && - (localRecipProject d || not requireOwner || LocalActorProject shr prj == author) + (localRecipProject d || not requireOwner || isAuthor (LocalActorProject shr prj)) ] fsidsJ <- map (projectFollowers . entityVal) <$> @@ -848,7 +880,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do then [ (prj, localRecipProjectTicketRelated j) | (prj, j) <- projects - , localRecipProject (localRecipProjectDirect j) || LocalActorProject shr prj == author + , localRecipProject (localRecipProjectDirect j) || isAuthor (LocalActorProject shr prj) ] else map (second localRecipProjectTicketRelated) projects @@ -882,7 +914,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do [rp | (rp, r) <- repos , let d = localRecipRepoDirect r in localRecipRepoFollowers d && - (localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author) + (localRecipRepo d || not requireOwner || isAuthor (LocalActorRepo shr rp)) ] in map (repoFollowers . entityVal) <$> selectList [RepoSharer ==. sid, RepoIdent <-. rps] [] @@ -935,7 +967,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do getProjectTeams sid projects = do let prjs = [prj | (prj, LocalProjectRelatedSet d ts) <- projects - , (localRecipProject d || not requireOwner || LocalActorProject shr prj == author) && + , (localRecipProject d || not requireOwner || isAuthor (LocalActorProject shr prj)) && (localRecipProjectTeam d || any (localRecipTicketTeam . snd) ts) ] jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] [] @@ -946,8 +978,36 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do [rp | (rp, r) <- repos , let d = localRecipRepoDirect r in localRecipRepoTeam d && - (localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author) + (localRecipRepo d || not requireOwner || isAuthor (LocalActorRepo shr rp)) ] rids <- selectKeysList [RepoSharer ==. sid, RepoIdent <-. rps] [] pids <- map (repoCollabPerson . entityVal) <$> selectList [RepoCollabRepo <-. rids] [] map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox] + +-- | Given a list of local recipients, which may include actors and +-- collections, +-- +-- * Insert activity to inboxes of actors +-- * If collections are listed, insert activity to the local members and return +-- the remote members +deliverLocal' + :: Bool -- ^ Whether to deliver to collection only if owner actor is addressed + -> LocalActor + -> InboxId + -> OutboxItemId + -> LocalRecipientSet + -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] +deliverLocal' requireOwner author ibidAuthor obiid = + insertActivityToLocalInboxes makeItem requireOwner (Just author) (Just ibidAuthor) + where + makeItem ibid ibiid = InboxItemLocal ibid obiid ibiid + +insertRemoteActivityToLocalInboxes + :: Bool + -> RemoteActivityId + -> LocalRecipientSet + -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] +insertRemoteActivityToLocalInboxes requireOwner ractid = + insertActivityToLocalInboxes makeItem requireOwner Nothing Nothing + where + makeItem ibid ibiid = InboxItemRemote ibid ractid ibiid diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index c60cd97..cb1d9c9 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -27,6 +27,7 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Data.Bifunctor import Data.ByteString (ByteString) +import Data.Either import Data.Foldable import Data.Function import Data.List (sort, deleteBy, nub, union, unionBy, partition) @@ -55,6 +56,7 @@ import Web.ActivityPub import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids +import Yesod.MonadSite import Control.Monad.Trans.Except.Local import Data.Tuple.Local @@ -69,6 +71,7 @@ import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident import Vervis.Settings +import Vervis.Ticket sharerCreateNoteF :: UTCTime @@ -101,56 +104,55 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext Right _ -> Right <$> insertToInbox luCreate (personInbox personRecip) where - checkContextParent context mparent = runExceptT $ do - case context of - Left (shr, prj, ltkhid) -> do - mdid <- lift $ runMaybeT $ do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - jid <- MaybeT $ getKeyBy $ UniqueProject prj sid - ltid <- decodeKeyHashidM ltkhid - lt <- MaybeT $ get ltid - tpl <- - MaybeT $ getValBy $ - UniqueTicketProjectLocal $ localTicketTicket lt - guard $ ticketProjectLocalProject tpl == jid + checkContextParent (Left context) mparent = runExceptT $ do + did <- + case context of + NoteContextSharerTicket shr talid -> do + (_, Entity _ lt, _, project) <- do + mticket <- lift $ getSharerTicket shr talid + fromMaybeE mticket "Note context no such local sharer-hosted ticket" return $ localTicketDiscuss lt - did <- fromMaybeE mdid "Context: No such local ticket" - for_ mparent $ \ parent -> - case parent of - Left (shrP, lmidP) -> - void $ getLocalParentMessageId did shrP lmidP - Right (ObjURI hParent luParent) -> do - mrm <- lift $ runMaybeT $ do - iid <- MaybeT $ getKeyBy $ UniqueInstance hParent - roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent - MaybeT $ getValBy $ UniqueRemoteMessageIdent roid - for_ mrm $ \ rm -> do - let mid = remoteMessageRest rm - m <- lift $ getJust mid - unless (messageRoot m == did) $ - throwE "Remote parent belongs to a different discussion" - Right (ObjURI hContext luContext) -> do - mdid <- lift $ runMaybeT $ do - iid <- MaybeT $ getKeyBy $ UniqueInstance hContext - roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luContext - rd <- MaybeT $ getValBy $ UniqueRemoteDiscussionIdent roid - return $ remoteDiscussionDiscuss rd - for_ mparent $ \ parent -> - case parent of - Left (shrP, lmidP) -> do - did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion" - void $ getLocalParentMessageId did shrP lmidP - Right (ObjURI hParent luParent) -> do - mrm <- lift $ runMaybeT $ do - iid <- MaybeT $ getKeyBy $ UniqueInstance hParent - roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent - MaybeT $ getValBy $ UniqueRemoteMessageIdent roid - for_ mrm $ \ rm -> do - let mid = remoteMessageRest rm - m <- lift $ getJust mid - did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion" - unless (messageRoot m == did) $ - throwE "Remote parent belongs to a different discussion" + NoteContextProjectTicket shr prj ltid -> do + (_, _, _, Entity _ lt, _, _) <- do + mticket <- lift $ getProjectTicket shr prj ltid + fromMaybeE mticket "Note context no such local project-hosted ticket" + return $ localTicketDiscuss lt + for_ mparent $ \ parent -> + case parent of + Left (shrP, lmidP) -> + void $ getLocalParentMessageId did shrP lmidP + Right (ObjURI hParent luParent) -> do + mrm <- lift $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance hParent + roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent + MaybeT $ getValBy $ UniqueRemoteMessageIdent roid + for_ mrm $ \ rm -> do + let mid = remoteMessageRest rm + m <- lift $ getJust mid + unless (messageRoot m == did) $ + throwE "Remote parent belongs to a different discussion" + checkContextParent (Right (ObjURI hContext luContext)) mparent = runExceptT $ do + mdid <- lift $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance hContext + roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luContext + rd <- MaybeT $ getValBy $ UniqueRemoteDiscussionIdent roid + return $ remoteDiscussionDiscuss rd + for_ mparent $ \ parent -> + case parent of + Left (shrP, lmidP) -> do + did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion" + void $ getLocalParentMessageId did shrP lmidP + Right (ObjURI hParent luParent) -> do + mrm <- lift $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance hParent + roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent + MaybeT $ getValBy $ UniqueRemoteMessageIdent roid + for_ mrm $ \ rm -> do + let mid = remoteMessageRest rm + m <- lift $ getJust mid + did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion" + unless (messageRoot m == did) $ + throwE "Remote parent belongs to a different discussion" insertToInbox luCreate ibidRecip = do let iidAuthor = remoteAuthorInstance author roid <- @@ -167,12 +169,6 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext return $ "Activity already exists in inbox of /s/" <> recip Just _ -> return $ "Activity inserted to inbox of /s/" <> recip -data CreateNoteRecipColl - = CreateNoteRecipProjectFollowers - | CreateNoteRecipTicketParticipants - | CreateNoteRecipTicketTeam - deriving Eq - projectCreateNoteF :: UTCTime -> ShrIdent @@ -195,84 +191,94 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent if uParent == uContext then return Nothing else Just <$> parseParent uParent + (localRecips, _remoteRecips) <- do + mrecips <- parseAudience $ activityAudience $ actbActivity body + fromMaybeE mrecips "Create Note with no recipients" + msig <- checkForward shrRecip prjRecip case context of - Right _ -> return $ recip <> " not using; context isn't local" - Left (shr, prj, ltkhid) -> - if shr /= shrRecip || prj /= prjRecip - then return $ recip <> " not using; context is a different project" - else do - msig <- checkForward shrRecip prjRecip - hLocal <- getsYesod $ appInstanceHost . appSettings - let colls = - findRelevantCollections hLocal ltkhid $ - activityAudience $ actbActivity body - mremotesHttp <- runDBExcept $ do - (sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent ltkhid mparent - lift $ join <$> do - mmid <- insertToDiscussion luCreate luNote published ibid did meparent fsidTicket - for mmid $ \ (ractid, mid) -> do - updateOrphans luNote did mid - for msig $ \ sig -> do - remoteRecips <- deliverLocal ractid colls sid fsidProject fsidTicket - (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips - lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do - let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e) - forkHandler handler $ - deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp - return $ recip <> " inserted new ticket comment" + Right _ -> return "Not using; context isn't local" + Left (NoteContextSharerTicket shr talid) -> do + mremotesHttp <- runDBExcept $ do + (jid, ibid) <- lift getProjectRecip404 + (_, _, _, project) <- do + mticket <- lift $ getSharerTicket shr talid + fromMaybeE mticket "Context: No such sharer-ticket" + case project of + Left (Entity _ tpl) + | ticketProjectLocalProject tpl == jid -> do + mractid <- lift $ insertToProjectInbox ibid luCreate + case mractid of + Nothing -> return $ Left "Activity already in my inbox" + Just ractid -> + case msig of + Nothing -> + return $ Left + "Context is a sharer-ticket, \ + \but no inbox forwarding \ + \header for me, so doing \ + \nothing, just storing in inbox" + Just sig -> lift $ Right <$> do + let sieve = + makeRecipientSet + [] + [ LocalPersonCollectionProjectFollowers shrRecip prjRecip + , LocalPersonCollectionProjectTeam shrRecip prjRecip + ] + remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips + (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips + _ -> return $ Left "Context is a sharer-ticket of another project" + case mremotesHttp of + Left msg -> return msg + Right (sig, remotesHttp) -> do + forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp + return "Stored to inbox and did inbox forwarding" + 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 $ insertToProjectInbox ibid luCreate + 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 luNote published did meparent ractid + case mmid of + Nothing -> return $ Left "I already have this comment, just storing in inbox" + Just mid -> lift $ do + updateOrphans luNote did mid + case msig of + Nothing -> + return $ Left "Storing in inbox, caching comment, no inbox forwarding header" + Just 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 (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 now shrRecip prjRecip (actbBL body) sig remotesHttp + return "Stored to inbox, cached comment, and did inbox forwarding" where - findRelevantCollections hLocal ctx = nub . mapMaybe decide . concatRecipients - where - decide u = do - let ObjURI h lu = u - guard $ h == hLocal - route <- decodeRouteLocal lu - case route of - ProjectFollowersR shr prj - | shr == shrRecip && prj == prjRecip - -> Just CreateNoteRecipProjectFollowers - ProjectTicketParticipantsR shr prj tkhid - | shr == shrRecip && prj == prjRecip && tkhid == ctx - -> Just CreateNoteRecipTicketParticipants - ProjectTicketTeamR shr prj tkhid - | shr == shrRecip && prj == prjRecip && tkhid == ctx - -> Just CreateNoteRecipTicketTeam - _ -> Nothing - recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip] - getContextAndParent ltkhid mparent = do - mt <- do - sid <- lift $ getKeyBy404 $ UniqueSharer shrRecip - Entity jid j <- lift $ getBy404 $ UniqueProject prjRecip sid - ltid <- decodeKeyHashidE ltkhid "Context: Not a valid ticket khid" - mlt <- lift $ get ltid - for mlt $ \ lt -> do - mtpl <- lift $ getValBy $ UniqueTicketProjectLocal $ localTicketTicket lt - tpl <- fromMaybeE mtpl "No TPL" - unless (ticketProjectLocalProject tpl == jid) $ - throwE "Context: Local ticket khid belongs to different project" - return (jid, projectInbox j, projectFollowers j, sid, lt) - (jid, ibid, fsidProject, sid, lt) <- fromMaybeE mt "Context: No such local ticket" - let did = localTicketDiscuss lt - meparent <- for mparent $ \ parent -> - case parent of - Left (shrParent, lmidParent) -> Left <$> getLocalParentMessageId did shrParent lmidParent - Right p@(ObjURI hParent luParent) -> do - mrm <- lift $ runMaybeT $ do - iid <- MaybeT $ getKeyBy $ UniqueInstance hParent - roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent - MaybeT $ getValBy $ UniqueRemoteMessageIdent roid - case mrm of - Just rm -> Left <$> do - let mid = remoteMessageRest rm - m <- lift $ getJust mid - unless (messageRoot m == did) $ - throwE "Remote parent belongs to a different discussion" - return mid - Nothing -> return $ Right p - return (sid, fsidProject, localTicketFollowers lt, jid, ibid, did, meparent) - insertToDiscussion luCreate luNote published ibid did meparent fsid = do + getProjectRecip404 = do + sid <- getKeyBy404 $ UniqueSharer shrRecip + Entity jid j <- getBy404 $ UniqueProject prjRecip sid + return (jid, projectInbox j) + insertToProjectInbox ibid luCreate = do let iidAuthor = remoteAuthorInstance author - raidAuthor = remoteAuthorId author roid <- either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate) ractid <- either entityKey id <$> insertBy' RemoteActivity @@ -280,6 +286,29 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent , remoteActivityContent = persistJSONFromBL $ actbBL body , remoteActivityReceived = now } + ibiid <- insert $ InboxItem False + new <- isRight <$> insertBy' (InboxItemRemote ibid ractid ibiid) + return $ + if new + then Just ractid + else Nothing + getParent did (Left (shrParent, lmidParent)) = Left <$> getLocalParentMessageId did shrParent lmidParent + getParent did (Right p@(ObjURI hParent luParent)) = do + mrm <- lift $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance hParent + roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent + MaybeT $ getValBy $ UniqueRemoteMessageIdent roid + case mrm of + Just rm -> Left <$> do + let mid = remoteMessageRest rm + m <- lift $ getJust mid + unless (messageRoot m == did) $ + throwE "Remote parent belongs to a different discussion" + return mid + Nothing -> return $ Right p + insertToDiscussion luNote published did meparent ractid = do + let iidAuthor = remoteAuthorInstance author + raidAuthor = remoteAuthorId author mid <- insert Message { messageCreated = published , messageSource = src @@ -290,11 +319,11 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent _ -> Nothing , messageRoot = did } - roid2 <- + roidNote <- either entityKey id <$> insertBy' (RemoteObject iidAuthor luNote) mrmid <- insertUnique RemoteMessage { remoteMessageAuthor = raidAuthor - , remoteMessageIdent = roid2 + , remoteMessageIdent = roidNote , remoteMessageRest = mid , remoteMessageCreate = ractid , remoteMessageLostParent = @@ -306,11 +335,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent Nothing -> do delete mid return Nothing - Just _ -> do - -- insertUnique_ $ RemoteFollow raidAuthor fsid False True - ibiid <- insert $ InboxItem False - insert_ $ InboxItemRemote ibid ractid ibiid - return $ Just (ractid, mid) + Just _ -> return $ Just mid updateOrphans luNote did mid = do let hAuthor = objUriAuthority $ remoteAuthorURI author uNote = ObjURI hAuthor luNote @@ -341,32 +366,3 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&. m E.^. MessageRoot `op` E.val did return (rm E.^. RemoteMessageId, m E.^. MessageId) - deliverLocal - :: RemoteActivityId - -> [CreateNoteRecipColl] - -> SharerId - -> FollowerSetId - -> FollowerSetId - -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] - deliverLocal ractid recips sid fsidProject fsidTicket = do - (teamPids, teamRemotes) <- - if CreateNoteRecipTicketTeam `elem` recips - then getTicketTeam sid - else return ([], []) - (tfsPids, tfsRemotes) <- - if CreateNoteRecipTicketParticipants `elem` recips - then getFollowers fsidTicket - else return ([], []) - (jfsPids, jfsRemotes) <- - if CreateNoteRecipProjectFollowers `elem` recips - then getFollowers fsidProject - else return ([], []) - let pids = union teamPids tfsPids `union` jfsPids - remotes = teamRemotes `unionRemotes` tfsRemotes `unionRemotes` jfsRemotes - for_ pids $ \ pid -> do - ibid <- personInbox <$> getJust pid - ibiid <- insert $ InboxItem True - mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid - when (isNothing mibrid) $ - delete ibiid - return remotes