1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-28 23:54:51 +09:00

Support sharer-hosted tickets in AP local dispatch and delivery

This commit is contained in:
fr33domlover 2020-04-09 17:39:36 +00:00
parent ef4a8f4015
commit 90bac5c34e
3 changed files with 122 additions and 66 deletions

View file

@ -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

View file

@ -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

View file

@ -97,10 +97,14 @@ renderLocalActor (LocalActorRepo shr rp) = RepoR shr rp
data LocalPersonCollection
= LocalPersonCollectionSharerFollowers ShrIdent
| LocalPersonCollectionSharerTicketTeam ShrIdent (KeyHashid TicketAuthorLocal)
| LocalPersonCollectionSharerTicketFollowers ShrIdent (KeyHashid TicketAuthorLocal)
| LocalPersonCollectionProjectTeam ShrIdent PrjIdent
| LocalPersonCollectionProjectFollowers ShrIdent PrjIdent
| LocalPersonCollectionTicketTeam ShrIdent PrjIdent (KeyHashid LocalTicket)
| LocalPersonCollectionTicketFollowers ShrIdent PrjIdent (KeyHashid LocalTicket)
| 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) =
@ -125,10 +133,12 @@ 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 (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 (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
@ -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 (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, ps, rs) =
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 (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