diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 64e2b77..31acd6f 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -293,8 +293,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source _ -> throwE "Local context isn't a ticket route" atMostSharer :: e -> (ShrIdent, LocalSharerRelatedSet) -> ExceptT e Handler (Maybe ShrIdent) - atMostSharer _ (shr, LocalSharerRelatedSet s [] []) = return $ if localRecipSharer s then Just shr else Nothing - atMostSharer e (_ , LocalSharerRelatedSet _ _ _ ) = throwE e + atMostSharer _ (shr, LocalSharerRelatedSet s [] [] []) = return $ if localRecipSharer s then Just shr else Nothing + atMostSharer e (_ , LocalSharerRelatedSet _ _ _ _ ) = throwE e verifyTicketRecipients :: (ShrIdent, PrjIdent, KeyHashid LocalTicket) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent] verifyTicketRecipients (shr, prj, num) recips = do @@ -303,7 +303,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source unless (prj == prj') $ throwE "Note project recipients mismatch context's project" unless (localRecipProject $ localRecipProjectDirect lprSet) $ throwE "Note context's project not addressed" unless (localRecipProjectFollowers $ localRecipProjectDirect lprSet) $ throwE "Note context's project followers not addressed" - (num', ltrSet) <- verifySingleton (localRecipTicketRelated lprSet) "Note ticket-related recipient sets" + (num', ltrSet) <- verifySingleton (localRecipProjectTicketRelated lprSet) "Note ticket-related recipient sets" unless (num == num') $ throwE "Note project recipients mismatch context's ticket number" unless (localRecipTicketTeam ltrSet) $ throwE "Note ticket team not addressed" @@ -973,7 +973,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT , LocalProjectRelatedSet { localRecipProjectDirect = LocalProjectDirectSet True True True - , localRecipTicketRelated = [] + , localRecipProjectTicketRelated = [] } ) ] @@ -1006,7 +1006,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 ee71726..c74df0e 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -719,7 +719,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 @@ -770,7 +770,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do 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 [] @@ -806,15 +806,32 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] [] getOtherFollowerSets :: (ShrIdent, LocalSharerRelatedSet) -> AppDB [FollowerSetId] - getOtherFollowerSets (shr, LocalSharerRelatedSet _ projects repos) = do + getOtherFollowerSets (shr, LocalSharerRelatedSet _ tickets projects repos) = do msid <- getKeyBy $ UniqueSharer shr case msid of Nothing -> return [] - Just sid -> - (++) - <$> getProjectFollowerSets sid projects + Just sid -> do + mpid <- getKeyBy $ UniquePersonIdent sid + (\ t j r -> map E.unValue t ++ j ++ r) + <$> case mpid of + Nothing -> pure [] + Just pid -> getSharerTicketFollowerSets pid tickets + <*> getProjectFollowerSets sid projects <*> getRepoFollowerSets sid repos where + getSharerTicketFollowerSets pid tickets = do + let talkhids = + [talkhid | (talkhid, t) <- tickets + , localRecipTicketFollowers t + ] + 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 + E.on $ tal E.^. TicketAuthorLocalTicket E.==. lt E.^. LocalTicketId + E.where_ $ + tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&. + E.isNothing (tup E.?. TicketUnderProjectId) + return $ lt E.^. LocalTicketFollowers getProjectFollowerSets sid projects = do let prjsJ = [prj | (prj, j) <- projects @@ -828,12 +845,12 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do let prjsT = if requireOwner then - [ (prj, localRecipTicketRelated j) + [ (prj, localRecipProjectTicketRelated j) | (prj, j) <- projects , localRecipProject (localRecipProjectDirect j) || LocalActorProject shr prj == author ] else - map (second localRecipTicketRelated) projects + map (second localRecipProjectTicketRelated) projects fsidssT <- for prjsT $ \ (prj, tickets) -> do mjid <- getKeyBy $ UniqueProject prj sid case mjid of @@ -900,15 +917,20 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do 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 _ projects repos) = do + getTeams (shr, LocalSharerRelatedSet _ tickets projects repos) = do msid <- getKeyBy $ UniqueSharer shr case msid of Nothing -> return [] - Just sid -> - LO.union - <$> getProjectTeams sid projects + Just sid -> do + mpid <- getKeyBy $ UniquePersonIdent sid + (\ t j r -> t `LO.union` j `LO.union` r) + <$> case mpid of + Nothing -> pure [] + Just pid -> getSharerTicketTeams pid tickets + <*> getProjectTeams sid projects <*> getRepoTeams sid repos where + getSharerTicketTeams _pid _tickets = pure [] getProjectTeams sid projects = do let prjs = [prj | (prj, LocalProjectRelatedSet d ts) <- projects diff --git a/src/Vervis/ActivityPub/Recipient.hs b/src/Vervis/ActivityPub/Recipient.hs index 5297879..816b9c4 100644 --- a/src/Vervis/ActivityPub/Recipient.hs +++ b/src/Vervis/ActivityPub/Recipient.hs @@ -96,12 +96,16 @@ renderLocalActor (LocalActorProject shr prj) = ProjectR shr prj renderLocalActor (LocalActorRepo shr rp) = RepoR shr rp data LocalPersonCollection - = LocalPersonCollectionSharerFollowers ShrIdent - | LocalPersonCollectionProjectTeam ShrIdent PrjIdent - | LocalPersonCollectionProjectFollowers ShrIdent PrjIdent - | LocalPersonCollectionTicketTeam ShrIdent PrjIdent (KeyHashid LocalTicket) - | LocalPersonCollectionTicketFollowers ShrIdent PrjIdent (KeyHashid LocalTicket) - | LocalPersonCollectionRepoTeam ShrIdent RpIdent + = LocalPersonCollectionSharerFollowers ShrIdent + | LocalPersonCollectionSharerTicketTeam ShrIdent (KeyHashid TicketAuthorLocal) + | LocalPersonCollectionSharerTicketFollowers 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 deriving Eq @@ -109,14 +113,18 @@ parseLocalPersonCollection :: Route App -> Maybe LocalPersonCollection parseLocalPersonCollection (SharerFollowersR shr) = Just $ LocalPersonCollectionSharerFollowers shr +parseLocalPersonCollection (SharerTicketTeamR shr talkhid) = + Just $ LocalPersonCollectionSharerTicketTeam shr talkhid +parseLocalPersonCollection (SharerTicketFollowersR shr talkhid) = + Just $ LocalPersonCollectionSharerTicketFollowers shr talkhid parseLocalPersonCollection (ProjectTeamR shr prj) = Just $ LocalPersonCollectionProjectTeam shr prj parseLocalPersonCollection (ProjectFollowersR shr prj) = Just $ LocalPersonCollectionProjectFollowers shr prj parseLocalPersonCollection (ProjectTicketTeamR shr prj num) = - Just $ LocalPersonCollectionTicketTeam shr prj num + Just $ LocalPersonCollectionProjectTicketTeam shr prj num parseLocalPersonCollection (ProjectTicketParticipantsR shr prj num) = - Just $ LocalPersonCollectionTicketFollowers shr prj num + Just $ LocalPersonCollectionProjectTicketFollowers shr prj num parseLocalPersonCollection (RepoTeamR shr rp) = Just $ LocalPersonCollectionRepoTeam shr rp parseLocalPersonCollection (RepoFollowersR shr rp) = @@ -124,13 +132,15 @@ parseLocalPersonCollection (RepoFollowersR shr rp) = parseLocalPersonCollection _ = Nothing renderLocalPersonCollection :: LocalPersonCollection -> Route App -renderLocalPersonCollection (LocalPersonCollectionSharerFollowers shr) = SharerFollowersR shr -renderLocalPersonCollection (LocalPersonCollectionProjectTeam shr prj) = ProjectTeamR shr prj -renderLocalPersonCollection (LocalPersonCollectionProjectFollowers shr prj) = ProjectFollowersR shr prj -renderLocalPersonCollection (LocalPersonCollectionTicketTeam shr prj ltkhid) = ProjectTicketTeamR shr prj ltkhid -renderLocalPersonCollection (LocalPersonCollectionTicketFollowers shr prj ltkhid) = ProjectTicketParticipantsR shr prj ltkhid -renderLocalPersonCollection (LocalPersonCollectionRepoTeam shr rp) = RepoTeamR shr rp -renderLocalPersonCollection (LocalPersonCollectionRepoFollowers shr rp) = RepoFollowersR shr rp +renderLocalPersonCollection (LocalPersonCollectionSharerFollowers shr) = SharerFollowersR shr +renderLocalPersonCollection (LocalPersonCollectionSharerTicketTeam shr talkhid) = SharerTicketTeamR shr talkhid +renderLocalPersonCollection (LocalPersonCollectionSharerTicketFollowers shr talkhid) = SharerTicketFollowersR 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 parseLocalRecipient :: Route App -> Maybe (Either LocalActor LocalPersonCollection) @@ -156,7 +166,7 @@ data LocalProjectRecipientDirect data LocalProjectRecipient = LocalProjectDirect LocalProjectRecipientDirect - | LocalTicketRelated (KeyHashid LocalTicket) LocalTicketRecipientDirect + | LocalProjectTicketRelated (KeyHashid LocalTicket) LocalTicketRecipientDirect deriving (Eq, Ord) data LocalRepoRecipientDirect @@ -175,6 +185,7 @@ data LocalSharerRecipientDirect data LocalSharerRecipient = LocalSharerDirect LocalSharerRecipientDirect + | LocalSharerTicketRelated (KeyHashid TicketAuthorLocal) LocalTicketRecipientDirect | LocalProjectRelated PrjIdent LocalProjectRecipient | LocalRepoRelated RpIdent LocalRepoRecipient deriving (Eq, Ord) @@ -196,6 +207,14 @@ groupedRecipientFromCollection groupedRecipientFromCollection (LocalPersonCollectionSharerFollowers shr) = LocalSharerRelated shr $ LocalSharerDirect LocalSharerFollowers +groupedRecipientFromCollection + (LocalPersonCollectionSharerTicketTeam shr talkhid) = + LocalSharerRelated shr $ + LocalSharerTicketRelated talkhid LocalTicketTeam +groupedRecipientFromCollection + (LocalPersonCollectionSharerTicketFollowers shr talkhid) = + LocalSharerRelated shr $ + LocalSharerTicketRelated talkhid LocalTicketFollowerz groupedRecipientFromCollection (LocalPersonCollectionProjectTeam shr prj) = LocalSharerRelated shr $ LocalProjectRelated prj $ @@ -205,13 +224,13 @@ groupedRecipientFromCollection LocalSharerRelated shr $ LocalProjectRelated prj $ LocalProjectDirect LocalProjectFollowers groupedRecipientFromCollection - (LocalPersonCollectionTicketTeam shr prj num) = + (LocalPersonCollectionProjectTicketTeam shr prj num) = LocalSharerRelated shr $ LocalProjectRelated prj $ - LocalTicketRelated num LocalTicketTeam + LocalProjectTicketRelated num LocalTicketTeam groupedRecipientFromCollection - (LocalPersonCollectionTicketFollowers shr prj num) = + (LocalPersonCollectionProjectTicketFollowers shr prj num) = LocalSharerRelated shr $ LocalProjectRelated prj $ - LocalTicketRelated num LocalTicketFollowerz + LocalProjectTicketRelated num LocalTicketFollowerz groupedRecipientFromCollection (LocalPersonCollectionRepoTeam shr rp) = LocalSharerRelated shr $ LocalRepoRelated rp $ @@ -244,8 +263,10 @@ data LocalProjectDirectSet = LocalProjectDirectSet deriving Eq data LocalProjectRelatedSet = LocalProjectRelatedSet - { localRecipProjectDirect :: LocalProjectDirectSet - , localRecipTicketRelated :: [(KeyHashid LocalTicket, LocalTicketDirectSet)] + { localRecipProjectDirect + :: LocalProjectDirectSet + , localRecipProjectTicketRelated + :: [(KeyHashid LocalTicket, LocalTicketDirectSet)] } deriving Eq @@ -268,9 +289,14 @@ data LocalSharerDirectSet = LocalSharerDirectSet deriving Eq data LocalSharerRelatedSet = LocalSharerRelatedSet - { localRecipSharerDirect :: LocalSharerDirectSet - , localRecipProjectRelated :: [(PrjIdent, LocalProjectRelatedSet)] - , localRecipRepoRelated :: [(RpIdent, LocalRepoRelatedSet)] + { localRecipSharerDirect + :: LocalSharerDirectSet + , localRecipSharerTicketRelated + :: [(KeyHashid TicketAuthorLocal, LocalTicketDirectSet)] + , localRecipProjectRelated + :: [(PrjIdent, LocalProjectRelatedSet)] + , localRecipRepoRelated + :: [(RpIdent, LocalRepoRelatedSet)] } deriving Eq @@ -283,14 +309,16 @@ groupLocalRecipients (\ (LocalSharerRelated shr _) -> shr) (\ (LocalSharerRelated _ lsr) -> lsr) where - lsr2set = mk . partitionEithers3 . map lsr2e . NE.toList + lsr2set = mk . partitionEithers4 . map lsr2e . NE.toList where - lsr2e (LocalSharerDirect d) = Left d - lsr2e (LocalProjectRelated prj lpr) = Right $ Left (prj, lpr) - lsr2e (LocalRepoRelated rp lrr) = Right $ Right (rp, lrr) - mk (ds, ps, rs) = + 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) = LocalSharerRelatedSet (lsrs2set ds) + (map (second ltrs2set) $ groupWithExtract fst snd ts) (map (second lpr2set) $ groupWithExtract fst snd ps) (map (second lrr2set) $ groupWithExtract fst snd rs) where @@ -301,10 +329,17 @@ groupLocalRecipients s { localRecipSharer = True } f s LocalSharerFollowers = s { localRecipSharerFollowers = True } + ltrs2set = foldl' f initial + where + initial = LocalTicketDirectSet False False + f s LocalTicketTeam = + s { localRecipTicketTeam = True } + f s LocalTicketFollowerz = + s { localRecipTicketFollowers = True } lpr2set = uncurry mk . partitionEithers . map lpr2e . NE.toList where - lpr2e (LocalProjectDirect d) = Left d - lpr2e (LocalTicketRelated num ltrs) = Right (num, ltrs) + lpr2e (LocalProjectDirect d) = Left d + lpr2e (LocalProjectTicketRelated num ltrs) = Right (num, ltrs) mk ds ts = LocalProjectRelatedSet (lprs2set ds) @@ -319,13 +354,6 @@ groupLocalRecipients s { localRecipProjectTeam = True } f s LocalProjectFollowers = s { localRecipProjectFollowers = True } - ltrs2set = foldl' f initial - where - initial = LocalTicketDirectSet False False - f s LocalTicketTeam = - s { localRecipTicketTeam = True } - f s LocalTicketFollowerz = - s { localRecipTicketFollowers = True } lrr2set = LocalRepoRelatedSet . foldl' f initial . NE.map unwrap where unwrap (LocalRepoDirect d) = d @@ -333,15 +361,16 @@ groupLocalRecipients f s LocalRepo = s { localRecipRepo = True } f s LocalRepoTeam = s { localRecipRepoTeam = True } f s LocalRepoFollowers = s { localRecipRepoFollowers = True } - partitionEithers3 = adapt . second partitionEithers . partitionEithers + partitionEithers4 = adapt . bimap partitionEithers partitionEithers . partitionEithers where - adapt (l1, (l2, l3)) = (l1, l2, l3) + adapt ((l1, l2), (l3, l4)) = (l1, l2, l3, l4) ------------------------------------------------------------------------------- -- Parse URIs into a grouped recipient set ------------------------------------------------------------------------------- -makeRecipientSet :: [LocalActor] -> [LocalPersonCollection] -> LocalRecipientSet +makeRecipientSet + :: [LocalActor] -> [LocalPersonCollection] -> LocalRecipientSet makeRecipientSet actors collections = groupLocalRecipients $ map groupedRecipientFromActor actors ++ @@ -431,9 +460,10 @@ localRecipSieve sieve allowActors = LocalProjectRelatedSet (LocalProjectDirectSet j False False) [] onlyActorsR (LocalRepoRelatedSet (LocalRepoDirectSet r _t _f)) = LocalRepoRelatedSet $ LocalRepoDirectSet r False False - onlyActorsS (LocalSharerRelatedSet (LocalSharerDirectSet s _f) js rs) = + onlyActorsS (LocalSharerRelatedSet (LocalSharerDirectSet s _f) _ts js rs) = LocalSharerRelatedSet (LocalSharerDirectSet s False) + [] (map (second onlyActorsJ) js) (map (second onlyActorsR) rs) @@ -442,17 +472,25 @@ localRecipSieve sieve allowActors = if allowActors then Just (shr, onlyActorsS s) else Nothing - applySharerRelated shr (These (LocalSharerRelatedSet s' j' r') (LocalSharerRelatedSet s j r)) = + applySharerRelated shr (These (LocalSharerRelatedSet s' t' j' r') (LocalSharerRelatedSet s t j r)) = Just ( shr , LocalSharerRelatedSet (applySharer s' s) + (mapMaybe (uncurry applyTicketRelated) $ sortAlign t' t) (mapMaybe (uncurry applyProjectRelated) $ sortAlign j' j) (mapMaybe (uncurry applyRepoRelated) $ sortAlign r' r) ) where applySharer (LocalSharerDirectSet s' f') (LocalSharerDirectSet s f) = LocalSharerDirectSet (s && (s' || allowActors)) (f && f') + + applyTicketRelated ltkhid (These t' t) = Just (ltkhid, applyTicket t' t) + where + applyTicket (LocalTicketDirectSet t' f') (LocalTicketDirectSet t f) = + LocalTicketDirectSet (t && t') (f && f') + applyTicketRelated _ _ = Nothing + applyProjectRelated _ (This _) = Nothing applyProjectRelated prj (That j) = if allowActors @@ -468,11 +506,7 @@ localRecipSieve sieve allowActors = where applyProject (LocalProjectDirectSet j' t' f') (LocalProjectDirectSet j t f) = LocalProjectDirectSet (j && (j' || allowActors)) (t && t') (f && f') - applyTicketRelated ltkhid (These t' t) = Just (ltkhid, applyTicket t' t) - where - applyTicket (LocalTicketDirectSet t' f') (LocalTicketDirectSet t f) = - LocalTicketDirectSet (t && t') (f && f') - applyTicketRelated _ _ = Nothing + applyRepoRelated _ (This _) = Nothing applyRepoRelated rp (That r) = if allowActors