diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 821b705..d2d3a10 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -1032,7 +1032,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (obiid, doc, luAct) deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer recips = do - (pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer _ projects _) -> do + (pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer _ _ projects _) -> do (pids, remotes) <- traverseCollect (uncurry $ deliverLocalProject shr) projects pids' <- do diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index f27a10d..93f63df 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -808,7 +808,7 @@ deliverLocal ] deliverLocal shrAuthor ibidAuthor _fsidAuthor obiid = deliverLocal' True (LocalActorSharer shrAuthor) ibidAuthor obiid . localRecipSieve sieve True where - sieve = [(shrAuthor, LocalSharerRelatedSet (LocalSharerDirectSet False True) [] [] [])] + sieve = [(shrAuthor, LocalSharerRelatedSet (LocalSharerDirectSet False True) [] [] [] [])] data RemoteRecipient = RemoteRecipient { remoteRecipientActor :: RemoteActorId @@ -879,7 +879,7 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci map (personInbox . entityVal) <$> selectList [PersonIdent <-. sids] [Asc PersonInbox] getOtherInboxes :: (ShrIdent, LocalSharerRelatedSet) -> AppDB [InboxId] - getOtherInboxes (shr, LocalSharerRelatedSet _ _ projects repos) = do + getOtherInboxes (shr, LocalSharerRelatedSet _ _ _ projects repos) = do msid <- getKeyBy $ UniqueSharer shr case msid of Nothing -> return [] @@ -915,24 +915,28 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] [] getOtherFollowerSets :: (ShrIdent, LocalSharerRelatedSet) -> AppDB [FollowerSetId] - getOtherFollowerSets (shr, LocalSharerRelatedSet _ tickets projects repos) = do + getOtherFollowerSets (shr, LocalSharerRelatedSet _ tickets patches projects repos) = do msid <- getKeyBy $ UniqueSharer shr case msid of Nothing -> return [] Just sid -> do mpid <- getKeyBy $ UniquePersonIdent sid - (\ t j r -> map E.unValue t ++ j ++ r) + (\ tp j r -> map E.unValue tp ++ j ++ r) <$> case mpid of Nothing -> pure [] - Just pid -> getSharerTicketFollowerSets pid tickets + Just pid -> getSharerTicketFollowerSets pid tickets patches <*> getProjectFollowerSets sid projects <*> getRepoFollowerSets sid repos where - getSharerTicketFollowerSets pid tickets = do + getSharerTicketFollowerSets pid tickets patches = do let talkhids = [talkhid | (talkhid, t) <- tickets , localRecipTicketFollowers t ] + ++ + [talkhid | (talkhid, p) <- patches + , localRecipPatchFollowers p + ] talids <- catMaybes <$> traverse decodeKeyHashid talkhids E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup) -> do E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor @@ -986,15 +990,51 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci E.isNothing (tar E.?. TicketAuthorRemoteId) ) return $ lt E.^. LocalTicketFollowers - getRepoFollowerSets sid repos = - let rps = + getRepoFollowerSets sid repos = do + let rpsR = [rp | (rp, r) <- repos , let d = localRecipRepoDirect r in localRecipRepoFollowers d && (localRecipRepo d || not requireOwner || isAuthor (LocalActorRepo shr rp)) ] - in map (repoFollowers . entityVal) <$> - selectList [RepoSharer ==. sid, RepoIdent <-. rps] [] + fsidsR <- + map (repoFollowers . entityVal) <$> + selectList [RepoSharer ==. sid, RepoIdent <-. rpsR] [] + let rpsP = + if requireOwner + then + [ (rp, localRecipRepoPatchRelated r) + | (rp, r) <- repos + , localRecipRepo (localRecipRepoDirect r) || isAuthor (LocalActorRepo shr rp) + ] + else + map (second localRecipRepoPatchRelated) repos + fsidssP <- for rpsP $ \ (rp, patches) -> do + mrid <- getKeyBy $ UniqueRepo rp sid + case mrid of + Nothing -> return [] + Just rid -> getPatchFollowerSets rid patches + return $ fsidsR ++ map E.unValue (concat fsidssP) + where + getPatchFollowerSets rid patches = do + let ltkhids = + [ltkhid | (ltkhid, p) <- patches + , localRecipPatchFollowers p + ] + ltids <- catMaybes <$> traverse decodeKeyHashid ltkhids + E.select $ E.from $ \ (lt `E.InnerJoin` t `E.InnerJoin` tcl `E.InnerJoin` trl `E.LeftOuterJoin` tup `E.LeftOuterJoin` tar) -> do + E.on $ E.just (tcl E.^. TicketContextLocalId) E.==. tar E.?. TicketAuthorRemoteTicket + E.on $ E.just (tcl E.^. TicketContextLocalId) E.==. tup E.?. TicketUnderProjectProject + E.on $ tcl E.^. TicketContextLocalId E.==. trl E.^. TicketRepoLocalContext + E.on $ t E.^. TicketId E.==. tcl E.^. TicketContextLocalTicket + E.on $ lt E.^. LocalTicketTicket E.==. t E.^. TicketId + E.where_ $ + trl E.^. TicketRepoLocalRepo E.==. E.val rid E.&&. + E.not_ + ( E.isNothing (tup E.?. TicketUnderProjectId) E.&&. + E.isNothing (tar E.?. TicketAuthorRemoteId) + ) + return $ lt E.^. LocalTicketFollowers getLocalFollowers :: [FollowerSetId] -> AppDB [InboxId] getLocalFollowers fsids = do @@ -1027,7 +1067,7 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci toTuples (E.Value iid, E.Value h, E.Value raid, E.Value luA, E.Value luI, E.Value ms) = ((iid, h), RemoteRecipient raid luA luI ms) getTeams :: (ShrIdent, LocalSharerRelatedSet) -> AppDB [InboxId] - getTeams (shr, LocalSharerRelatedSet _ tickets projects repos) = do + getTeams (shr, LocalSharerRelatedSet _ tickets _ projects repos) = do msid <- getKeyBy $ UniqueSharer shr case msid of Nothing -> return [] diff --git a/src/Vervis/ActivityPub/Recipient.hs b/src/Vervis/ActivityPub/Recipient.hs index 35f8251..0ed7f91 100644 --- a/src/Vervis/ActivityPub/Recipient.hs +++ b/src/Vervis/ActivityPub/Recipient.hs @@ -17,6 +17,7 @@ module Vervis.ActivityPub.Recipient ( LocalActor (..) , LocalPersonCollection (..) , LocalTicketDirectSet (..) + , LocalPatchDirectSet (..) , LocalProjectDirectSet (..) , LocalProjectRelatedSet (..) , LocalRepoDirectSet (..) @@ -100,14 +101,16 @@ data LocalPersonCollection = LocalPersonCollectionSharerFollowers ShrIdent | LocalPersonCollectionSharerTicketTeam ShrIdent (KeyHashid TicketAuthorLocal) | LocalPersonCollectionSharerTicketFollowers ShrIdent (KeyHashid TicketAuthorLocal) + | LocalPersonCollectionSharerPatchFollowers ShrIdent (KeyHashid TicketAuthorLocal) | LocalPersonCollectionProjectTeam ShrIdent PrjIdent | LocalPersonCollectionProjectFollowers ShrIdent PrjIdent | LocalPersonCollectionProjectTicketTeam ShrIdent PrjIdent (KeyHashid LocalTicket) | LocalPersonCollectionProjectTicketFollowers ShrIdent PrjIdent (KeyHashid LocalTicket) - | LocalPersonCollectionRepoTeam ShrIdent RpIdent - | LocalPersonCollectionRepoFollowers ShrIdent RpIdent + | LocalPersonCollectionRepoTeam ShrIdent RpIdent + | LocalPersonCollectionRepoFollowers ShrIdent RpIdent + | LocalPersonCollectionRepoPatchFollowers ShrIdent RpIdent (KeyHashid LocalTicket) deriving Eq parseLocalPersonCollection @@ -118,6 +121,8 @@ parseLocalPersonCollection (SharerTicketTeamR shr talkhid) = Just $ LocalPersonCollectionSharerTicketTeam shr talkhid parseLocalPersonCollection (SharerTicketFollowersR shr talkhid) = Just $ LocalPersonCollectionSharerTicketFollowers shr talkhid +parseLocalPersonCollection (SharerPatchFollowersR shr talkhid) = + Just $ LocalPersonCollectionSharerPatchFollowers shr talkhid parseLocalPersonCollection (ProjectTeamR shr prj) = Just $ LocalPersonCollectionProjectTeam shr prj parseLocalPersonCollection (ProjectFollowersR shr prj) = @@ -130,18 +135,22 @@ parseLocalPersonCollection (RepoTeamR shr rp) = Just $ LocalPersonCollectionRepoTeam shr rp parseLocalPersonCollection (RepoFollowersR shr rp) = Just $ LocalPersonCollectionRepoFollowers shr rp +parseLocalPersonCollection (RepoPatchFollowersR shr rp ltkhid) = + Just $ LocalPersonCollectionRepoPatchFollowers shr rp ltkhid parseLocalPersonCollection _ = Nothing renderLocalPersonCollection :: LocalPersonCollection -> Route App renderLocalPersonCollection (LocalPersonCollectionSharerFollowers shr) = SharerFollowersR shr renderLocalPersonCollection (LocalPersonCollectionSharerTicketTeam shr talkhid) = SharerTicketTeamR shr talkhid renderLocalPersonCollection (LocalPersonCollectionSharerTicketFollowers shr talkhid) = SharerTicketFollowersR shr talkhid +renderLocalPersonCollection (LocalPersonCollectionSharerPatchFollowers shr talkhid) = SharerPatchFollowersR shr talkhid renderLocalPersonCollection (LocalPersonCollectionProjectTeam shr prj) = ProjectTeamR shr prj renderLocalPersonCollection (LocalPersonCollectionProjectFollowers shr prj) = ProjectFollowersR shr prj renderLocalPersonCollection (LocalPersonCollectionProjectTicketTeam shr prj ltkhid) = ProjectTicketTeamR shr prj ltkhid renderLocalPersonCollection (LocalPersonCollectionProjectTicketFollowers shr prj ltkhid) = ProjectTicketParticipantsR shr prj ltkhid renderLocalPersonCollection (LocalPersonCollectionRepoTeam shr rp) = RepoTeamR shr rp renderLocalPersonCollection (LocalPersonCollectionRepoFollowers shr rp) = RepoFollowersR shr rp +renderLocalPersonCollection (LocalPersonCollectionRepoPatchFollowers shr rp ltkhid) = RepoPatchFollowersR shr rp ltkhid parseLocalRecipient :: Route App -> Maybe (Either LocalActor LocalPersonCollection) @@ -159,6 +168,8 @@ parseLocalRecipient r = data LocalTicketRecipientDirect = LocalTicketTeam | LocalTicketFollowerz deriving (Eq, Ord) +data LocalPatchRecipientDirect = LocalPatchFollowers deriving (Eq, Ord) + data LocalProjectRecipientDirect = LocalProject | LocalProjectTeam @@ -176,7 +187,9 @@ data LocalRepoRecipientDirect | LocalRepoFollowers deriving (Eq, Ord) -data LocalRepoRecipient = LocalRepoDirect LocalRepoRecipientDirect +data LocalRepoRecipient + = LocalRepoDirect LocalRepoRecipientDirect + | LocalRepoPatchRelated (KeyHashid LocalTicket) LocalPatchRecipientDirect deriving (Eq, Ord) data LocalSharerRecipientDirect @@ -187,6 +200,7 @@ data LocalSharerRecipientDirect data LocalSharerRecipient = LocalSharerDirect LocalSharerRecipientDirect | LocalSharerTicketRelated (KeyHashid TicketAuthorLocal) LocalTicketRecipientDirect + | LocalSharerPatchRelated (KeyHashid TicketAuthorLocal) LocalPatchRecipientDirect | LocalProjectRelated PrjIdent LocalProjectRecipient | LocalRepoRelated RpIdent LocalRepoRecipient deriving (Eq, Ord) @@ -216,6 +230,10 @@ groupedRecipientFromCollection (LocalPersonCollectionSharerTicketFollowers shr talkhid) = LocalSharerRelated shr $ LocalSharerTicketRelated talkhid LocalTicketFollowerz +groupedRecipientFromCollection + (LocalPersonCollectionSharerPatchFollowers shr talkhid) = + LocalSharerRelated shr $ + LocalSharerPatchRelated talkhid LocalPatchFollowers groupedRecipientFromCollection (LocalPersonCollectionProjectTeam shr prj) = LocalSharerRelated shr $ LocalProjectRelated prj $ @@ -240,6 +258,10 @@ groupedRecipientFromCollection (LocalPersonCollectionRepoFollowers shr rp) = LocalSharerRelated shr $ LocalRepoRelated rp $ LocalRepoDirect LocalRepoFollowers +groupedRecipientFromCollection + (LocalPersonCollectionRepoPatchFollowers shr rp ltkhid) = + LocalSharerRelated shr $ LocalRepoRelated rp $ + LocalRepoPatchRelated ltkhid LocalPatchFollowers ------------------------------------------------------------------------------- -- Recipient set types @@ -256,6 +278,11 @@ data LocalTicketDirectSet = LocalTicketDirectSet } deriving Eq +newtype LocalPatchDirectSet = LocalPatchDirectSet + { localRecipPatchFollowers :: Bool + } + deriving Eq + data LocalProjectDirectSet = LocalProjectDirectSet { localRecipProject :: Bool , localRecipProjectTeam :: Bool @@ -279,7 +306,10 @@ data LocalRepoDirectSet = LocalRepoDirectSet deriving Eq data LocalRepoRelatedSet = LocalRepoRelatedSet - { localRecipRepoDirect :: LocalRepoDirectSet + { localRecipRepoDirect + :: LocalRepoDirectSet + , localRecipRepoPatchRelated + :: [(KeyHashid LocalTicket, LocalPatchDirectSet)] } deriving Eq @@ -294,6 +324,8 @@ data LocalSharerRelatedSet = LocalSharerRelatedSet :: LocalSharerDirectSet , localRecipSharerTicketRelated :: [(KeyHashid TicketAuthorLocal, LocalTicketDirectSet)] + , localRecipSharerPatchRelated + :: [(KeyHashid TicketAuthorLocal, LocalPatchDirectSet)] , localRecipProjectRelated :: [(PrjIdent, LocalProjectRelatedSet)] , localRecipRepoRelated @@ -310,17 +342,28 @@ groupLocalRecipients (\ (LocalSharerRelated shr _) -> shr) (\ (LocalSharerRelated _ lsr) -> lsr) where - lsr2set = mk . partitionEithers4 . map lsr2e . NE.toList + lsr2set = mk . partitionLSR . NE.toList where - lsr2e (LocalSharerDirect d) = Left $ Left d - lsr2e (LocalSharerTicketRelated talkhid ltr) = Left $ Right (talkhid, ltr) - lsr2e (LocalProjectRelated prj lpr) = Right $ Left (prj, lpr) - lsr2e (LocalRepoRelated rp lrr) = Right $ Right (rp, lrr) - mk (ds, ts, ps, rs) = + partitionLSR = foldr f ([], [], [], [], []) + where + f i (ds, ts, ps, js, rs) = + case i of + LocalSharerDirect d -> + (d:ds, ts, ps, js, rs) + LocalSharerTicketRelated talkhid ltr -> + (ds, (talkhid, ltr):ts, ps, js, rs) + LocalSharerPatchRelated talkhid lpr -> + (ds, ts, (talkhid, lpr):ps, js, rs) + LocalProjectRelated prj ljr -> + (ds, ts, ps, (prj, ljr):js, rs) + LocalRepoRelated rp lrr -> + (ds, ts, ps, js, (rp, lrr):rs) + mk (ds, ts, ps, js, rs) = LocalSharerRelatedSet (lsrs2set ds) (map (second ltrs2set) $ groupWithExtract fst snd ts) - (map (second lpr2set) $ groupWithExtract fst snd ps) + (map (second lprs2set) $ groupWithExtract fst snd ps) + (map (second ljr2set) $ groupWithExtract fst snd js) (map (second lrr2set) $ groupWithExtract fst snd rs) where lsrs2set = foldl' f initial @@ -337,16 +380,20 @@ groupLocalRecipients s { localRecipTicketTeam = True } f s LocalTicketFollowerz = s { localRecipTicketFollowers = True } - lpr2set = uncurry mk . partitionEithers . map lpr2e . NE.toList + lprs2set = foldl' f initial where - lpr2e (LocalProjectDirect d) = Left d - lpr2e (LocalProjectTicketRelated num ltrs) = Right (num, ltrs) + initial = LocalPatchDirectSet False + f s LocalPatchFollowers = s { localRecipPatchFollowers = True } + ljr2set = uncurry mk . partitionEithers . map ljr2e . NE.toList + where + ljr2e (LocalProjectDirect d) = Left d + ljr2e (LocalProjectTicketRelated num ltrs) = Right (num, ltrs) mk ds ts = LocalProjectRelatedSet - (lprs2set ds) + (ljrs2set ds) (map (second ltrs2set) $ groupWithExtract fst snd ts) where - lprs2set = foldl' f initial + ljrs2set = foldl' f initial where initial = LocalProjectDirectSet False False False f s LocalProject = @@ -355,16 +402,21 @@ groupLocalRecipients s { localRecipProjectTeam = True } f s LocalProjectFollowers = s { localRecipProjectFollowers = True } - lrr2set = LocalRepoRelatedSet . foldl' f initial . NE.map unwrap + lrr2set = uncurry mk . partitionEithers . map lrr2e . NE.toList where - unwrap (LocalRepoDirect d) = d - initial = LocalRepoDirectSet False False False - f s LocalRepo = s { localRecipRepo = True } - f s LocalRepoTeam = s { localRecipRepoTeam = True } - f s LocalRepoFollowers = s { localRecipRepoFollowers = True } - partitionEithers4 = adapt . bimap partitionEithers partitionEithers . partitionEithers - where - adapt ((l1, l2), (l3, l4)) = (l1, l2, l3, l4) + lrr2e (LocalRepoDirect d) = Left d + lrr2e (LocalRepoPatchRelated num ltrs) = Right (num, ltrs) + mk ds ps = + LocalRepoRelatedSet + (lrrs2set ds) + (map (second lprs2set) $ groupWithExtract fst snd ps) + where + lrrs2set = foldl' f initial + where + initial = LocalRepoDirectSet False False False + f s LocalRepo = s { localRecipRepo = True } + f s LocalRepoTeam = s { localRecipRepoTeam = True } + f s LocalRepoFollowers = s { localRecipRepoFollowers = True } ------------------------------------------------------------------------------- -- Parse URIs into a grouped recipient set @@ -468,12 +520,13 @@ localRecipSieve' sieve allowSharers allowOthers = where onlyActorsJ (LocalProjectRelatedSet (LocalProjectDirectSet j _t _f) _ts) = LocalProjectRelatedSet (LocalProjectDirectSet (j && allowOthers) False False) [] - onlyActorsR (LocalRepoRelatedSet (LocalRepoDirectSet r _t _f)) = - LocalRepoRelatedSet $ LocalRepoDirectSet (r && allowOthers) False False - onlyActorsS (LocalSharerRelatedSet (LocalSharerDirectSet s _f) _ts js rs) = + onlyActorsR (LocalRepoRelatedSet (LocalRepoDirectSet r _t _f) _ps) = + LocalRepoRelatedSet (LocalRepoDirectSet (r && allowOthers) False False) [] + onlyActorsS (LocalSharerRelatedSet (LocalSharerDirectSet s _f) _ts _ps js rs) = LocalSharerRelatedSet (LocalSharerDirectSet (s && allowSharers) False) [] + [] (map (second onlyActorsJ) js) (map (second onlyActorsR) rs) @@ -482,12 +535,13 @@ localRecipSieve' sieve allowSharers allowOthers = if allowSharers || allowOthers then Just (shr, onlyActorsS s) else Nothing - applySharerRelated shr (These (LocalSharerRelatedSet s' t' j' r') (LocalSharerRelatedSet s t j r)) = + applySharerRelated shr (These (LocalSharerRelatedSet s' t' p' j' r') (LocalSharerRelatedSet s t p j r)) = Just ( shr , LocalSharerRelatedSet (applySharer s' s) (mapMaybe (uncurry applyTicketRelated) $ sortAlign t' t) + (mapMaybe (uncurry applyPatchRelated) $ sortAlign p' p) (mapMaybe (uncurry applyProjectRelated) $ sortAlign j' j) (mapMaybe (uncurry applyRepoRelated) $ sortAlign r' r) ) @@ -501,6 +555,12 @@ localRecipSieve' sieve allowSharers allowOthers = LocalTicketDirectSet (t && t') (f && f') applyTicketRelated _ _ = Nothing + applyPatchRelated ltkhid (These p' p) = Just (ltkhid, applyPatch p' p) + where + applyPatch (LocalPatchDirectSet f') (LocalPatchDirectSet f) = + LocalPatchDirectSet $ f && f' + applyPatchRelated _ _ = Nothing + applyProjectRelated _ (This _) = Nothing applyProjectRelated prj (That j) = if allowOthers @@ -522,8 +582,13 @@ localRecipSieve' sieve allowSharers allowOthers = if allowOthers then Just (rp, onlyActorsR r) else Nothing - applyRepoRelated rp (These (LocalRepoRelatedSet r') (LocalRepoRelatedSet r)) = - Just (rp, LocalRepoRelatedSet $ applyRepo r' r) + applyRepoRelated rp (These (LocalRepoRelatedSet r' p') (LocalRepoRelatedSet r p)) = + Just + ( rp + , LocalRepoRelatedSet + (applyRepo r' r) + (mapMaybe (uncurry applyPatchRelated) $ sortAlign p' p) + ) where applyRepo (LocalRepoDirectSet r' t' f') (LocalRepoDirectSet r t f) = LocalRepoDirectSet (r && (r' || allowOthers)) (t && t') (f && f')