forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Deliver to project inbox in postOutboxR and postProjectInboxR

Browse source
This commit is contained in:
fr33domlover 2019-06-09 21:06:26 +00:00
parent 322d09658e
commit 970fa240fc
1 changed files with 24 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

41
src/Vervis/Federation.hs
View file

@ -725,9 +725,9 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a
hLocal <- getsYesod $ appInstanceHost . appSettings hLocal <- getsYesod $ appInstanceHost . appSettings
let colls = findRelevantCollections hLocal num audience let colls = findRelevantCollections hLocal num audience
mremotesHttp <- runDBExcept $ do mremotesHttp <- runDBExcept $ do
(sid, fsid, jid, did, meparent) <- getContextAndParent num mparent (sid, fsid, jid, ibid, did, meparent) <- getContextAndParent num mparent
lift $ join <$> do lift $ join <$> do
mmid <- insertToDiscussion luNote published did meparent fsid mmid <- insertToDiscussion luNote published ibid did meparent fsid
for mmid $ \ (ractid, mid) -> do for mmid $ \ (ractid, mid) -> do
updateOrphans luNote did mid updateOrphans luNote did mid
for msig $ \ sig -> do for msig $ \ sig -> do
@ -784,9 +784,10 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a
getContextAndParent num mparent = do getContextAndParent num mparent = do
mt <- lift $ do mt <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
jid <- getKeyBy404 $ UniqueProject prjRecip sid Entity jid j <- getBy404 $ UniqueProject prjRecip sid
fmap (jid,sid,) <$> getValBy (UniqueTicket jid num) fmap (jid, projectInbox j, sid ,) <$>
(jid, sid, t) <- fromMaybeE mt "Context: No such local ticket" getValBy (UniqueTicket jid num)
(jid, ibid, sid, t) <- fromMaybeE mt "Context: No such local ticket"
let did = ticketDiscuss t let did = ticketDiscuss t
meparent <- for mparent $ \ parent -> meparent <- for mparent $ \ parent ->
case parent of case parent of
@ -803,8 +804,8 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a
throwE "Remote parent belongs to a different discussion" throwE "Remote parent belongs to a different discussion"
return mid return mid
Nothing -> return $ Right $ l2f hParent luParent Nothing -> return $ Right $ l2f hParent luParent
return (sid, ticketFollowers t, jid, did, meparent) return (sid, ticketFollowers t, jid, ibid, did, meparent)
insertToDiscussion luNote published did meparent fsid = do insertToDiscussion luNote published ibid did meparent fsid = do
ractid <- either entityKey id <$> insertBy' RemoteActivity ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityInstance = iidSender { remoteActivityInstance = iidSender
, remoteActivityIdent = activityId activity , remoteActivityIdent = activityId activity
@ -838,6 +839,8 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a
return Nothing return Nothing
Just _ -> do Just _ -> do
insertUnique_ $ RemoteFollow raidSender fsid False insertUnique_ $ RemoteFollow raidSender fsid False
ibiid <- insert $ InboxItem False
insert_ $ InboxItemRemote ibid ractid ibiid
return $ Just (ractid, mid) return $ Just (ractid, mid)
updateOrphans luNote did mid = do updateOrphans luNote did mid = do
let uNote = l2f hSender luNote let uNote = l2f hSender luNote
@ -1079,10 +1082,10 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
Just (shr, prj, num) -> do Just (shr, prj, num) -> do
mt <- lift $ runMaybeT $ do mt <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
jid <- MaybeT $ getKeyBy $ UniqueProject prj sid Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid
t <- MaybeT $ getValBy $ UniqueTicket jid num t <- MaybeT $ getValBy $ UniqueTicket jid num
return (sid, t) return (sid, projectInbox j, t)
(sid, t) <- fromMaybeE mt "Context: No such local ticket" (sid, ibidProject, t) <- fromMaybeE mt "Context: No such local ticket"
let did = ticketDiscuss t let did = ticketDiscuss t
mmidParent <- for mparent $ \ parent -> mmidParent <- for mparent $ \ parent ->
case parent of case parent of
@ -1098,7 +1101,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
throwE "Remote parent belongs to a different discussion" throwE "Remote parent belongs to a different discussion"
return mid return mid
lift $ insertUnique_ $ Follow pid (ticketFollowers t) False lift $ insertUnique_ $ Follow pid (ticketFollowers t) False
return (did, Left <$> mmidParent, Just (sid, ticketFollowers t)) return (did, Left <$> mmidParent, Just (sid, ticketFollowers t, ibidProject))
Nothing -> do Nothing -> do
(rd, rdnew) <- lift $ do (rd, rdnew) <- lift $ do
let (hContext, luContext) = f2l uContext let (hContext, luContext) = f2l uContext
@ -1386,7 +1389,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
:: PersonId :: PersonId
-> OutboxItemId -> OutboxItemId
-> [ShrIdent] -> [ShrIdent]
-> Maybe (SharerId, FollowerSetId) -> Maybe (SharerId, FollowerSetId, InboxId)
-> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] -> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
deliverLocal pidAuthor obid recips mticket = do deliverLocal pidAuthor obid recips mticket = do
recipPids <- traverse getPersonId $ nub recips recipPids <- traverse getPersonId $ nub recips
@ -1395,7 +1398,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
(morePids, remotes) <- (morePids, remotes) <-
lift $ case mticket of lift $ case mticket of
Nothing -> return ([], []) Nothing -> return ([], [])
Just (sid, fsid) -> do Just (sid, fsid, _) -> do
(teamPids, teamRemotes) <- getTicketTeam sid (teamPids, teamRemotes) <- getTicketTeam sid
(fsPids, fsRemotes) <- getFollowers fsid (fsPids, fsRemotes) <- getFollowers fsid
return return
@ -1440,10 +1443,14 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished s
-- lists have the same instance. -- lists have the same instance.
, map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat teamRemotes fsRemotes , map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat teamRemotes fsRemotes
) )
lift $ for_ (union recipPids morePids) $ \ pid -> do lift $ do
ibid <- personInbox <$> getJust pid for_ mticket $ \ (_, _, ibidProject) -> do
ibiid <- insert $ InboxItem True ibiid <- insert $ InboxItem False
insert_ $ InboxItemLocal ibid obid ibiid insert_ $ InboxItemLocal ibidProject obid ibiid
for_ (union recipPids morePids) $ \ pid -> do
ibid <- personInbox <$> getJust pid
ibiid <- insert $ InboxItem True
insert_ $ InboxItemLocal ibid obid ibiid
return remotes return remotes
where where
getPersonId :: ShrIdent -> ExceptT Text AppDB PersonId getPersonId :: ShrIdent -> ExceptT Text AppDB PersonId