forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Component: Remove: Port team-mode from Project

Browse source
This commit is contained in:
Pere Lev 2024-07-01 16:51:00 +03:00
parent 02f46a21f9
commit 4d06d8e840
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
1 changed files with 298 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

299
src/Vervis/Actor/Common.hs
View file

@ -1502,8 +1502,21 @@ componentInvite grabKomponent topicComponent now topicKey (Verse authorIdMsig bo
-- * To: Actor B -- * To: Actor B
-- * CC: Actor A, B's followers, my followers -- * CC: Actor A, B's followers, my followers
-- --
-- * If C is my teams collection:
-- * Verify A is authorized by me to remove teams from me
-- * Verify B is an active team of mine
-- * Remove the whole Squad record from DB
-- * Forward the Remove to my followers
-- * Send an Accept on the Remove:
-- * To: Actor B
-- * CC: Actor A, B's followers, my followers
--
-- * If I'm B, and C is some project's components collection -- * If I'm B, and C is some project's components collection
-- * Just forward to my followers -- * Just forward to my followers
--
-- * If I'm B, being removed from the resources of a team of mine:
-- * Do nothing, just waiting for team to send a Revoke on the
-- delegator-Grant
componentRemove componentRemove
:: forall topic. :: forall topic.
(PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
@ -1525,10 +1538,15 @@ componentRemove grabKomponent topicComponent now topicKey (Verse authorIdMsig bo
(Left (Right target), _) (Left (Right target), _)
| addTargetComponentProjects target == Just (topicComponent topicKey) -> | addTargetComponentProjects target == Just (topicComponent topicKey) ->
removeProjectActive item removeProjectActive item
(Left (Right target), _)
| (resourceFromNG <$> addTargetResourceTeams target) == Just meResource ->
removeTeamActive item
(_, Left la) | la == resourceToActor (topicResource topicKey) -> (_, Left la) | la == resourceToActor (topicResource topicKey) ->
case collection of case collection of
Left (Right (ATProjectComponents j)) -> Left (Right (ATProjectComponents j)) ->
removeProjectPassive $ Left j removeProjectPassive $ Left j
Left (Right (ATGroupEfforts g)) ->
removeTeamPassive $ Left g
Right (ObjURI h luColl) -> do Right (ObjURI h luColl) -> do
-- NOTE this is HTTP GET done synchronously in the activity -- NOTE this is HTTP GET done synchronously in the activity
-- handler -- handler
@ -1543,12 +1561,21 @@ componentRemove grabKomponent topicComponent now topicKey (Verse authorIdMsig bo
let typ = AP.actorType d let typ = AP.actorType d
if typ == AP.ActorTypeProject && Just luColl == AP.rwcComponents rwc if typ == AP.ActorTypeProject && Just luColl == AP.rwcComponents rwc
then removeProjectPassive $ Right $ ObjURI h lu then removeProjectPassive $ Right $ ObjURI h lu
else throwE "Weird collection situation" else if typ == AP.ActorTypeTeam && Just luColl == AP.rwcTeamResources rwc
then removeTeamPassive $ Right $ ObjURI h lu
else throwE "Weird collection situation"
_ -> throwE "I'm being removed from somewhere irrelevant" _ -> throwE "I'm being removed from somewhere irrelevant"
_ -> throwE "This Remove isn't for me" _ -> throwE "This Remove isn't for me"
where where
toComponent = topicComponent
meID = topicKey
meComponent = toComponent meID
meResource = componentResource meComponent
meActor = resourceToActor meResource
topicResource :: forall f. f topic -> LocalResourceBy f topicResource :: forall f. f topic -> LocalResourceBy f
topicResource = componentResource . topicComponent topicResource = componentResource . topicComponent
@ -1961,6 +1988,276 @@ componentRemove grabKomponent topicComponent now topicKey (Verse authorIdMsig bo
forwardActivity authorIdMsig body topicByID topicActorID sieve forwardActivity authorIdMsig body topicByID topicActorID sieve
doneDB inboxItemID "[Project-passive] Just forwarded Remove" doneDB inboxItemID "[Project-passive] Just forwarded Remove"
removeTeamActive team = do
-- If team is local, find it in our DB
-- If team is remote, HTTP GET it, verify it's an actor of Project
-- type, and store in our DB (if it's already there, no need for HTTP)
--
-- NOTE: This is a blocking HTTP GET done right here in the handler,
-- which is NOT a good idea. Ideally, it would be done async, and the
-- handler result would be sent later in a separate (e.g. Accept) activity.
-- But for the PoC level, the current situation will hopefully do.
teamDB <-
bitraverse
(\case
LocalActorGroup g -> withDBExcept $ getEntityE g "Team not found in DB"
_ -> throwE "Local proposed team of non-Group type"
)
(\ u@(ObjURI h lu) -> do
instanceID <-
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
result <-
ExceptT $ first (T.pack . displayException) <$>
fetchRemoteActor' instanceID h lu
case result of
Left Nothing -> throwE "Team @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Team isn't an actor"
Right (Just actor) -> do
case remoteActorType $ entityVal actor of
AP.ActorTypeTeam -> pure ()
_ -> throwE "Remote team type isn't Team"
return (u, actor)
)
team
-- Verify that a capability is provided
uCap <- do
let muCap = AP.activityCapability $ actbActivity body
fromMaybeE muCap "No capability provided"
-- Verify the sender is authorized by me to remove a team
verifyCapability''
uCap
authorIdMsig
meResource
AP.RoleAdmin
maybeNew <- withDBExcept $ do
-- Grab me from DB
meKomponentID <- lift $ grabKomponent <$> getJust meID
Komponent meResourceID <- lift $ getJust meKomponentID
Resource meActorID <- lift $ getJust meResourceID
meActorDB <- lift $ getJust meActorID
-- Verify it's an active team of mine
squads <- lift $ case teamDB of
Left (Entity g _) ->
fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Left (t, s))) $
E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do
E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad
E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad
E.on $ topic E.^. SquadTopicLocalId E.==. send E.^. SquadThemSendDelegatorLocalTopic
E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicLocalSquad
E.where_ $
squad E.^. SquadHolder E.==. E.val meResourceID E.&&.
topic E.^. SquadTopicLocalGroup E.==. E.val g
return
( squad E.^. SquadId
, send E.^. SquadThemSendDelegatorLocalSquad
, start E.^. SquadUsStartId
, topic E.^. SquadTopicLocalId
, send E.^. SquadThemSendDelegatorLocalId
)
Right (_, Entity a _) ->
fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Right (t, s))) $
E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do
E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad
E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad
E.on $ topic E.^. SquadTopicRemoteId E.==. send E.^. SquadThemSendDelegatorRemoteTopic
E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicRemoteSquad
E.where_ $
squad E.^. SquadHolder E.==. E.val meResourceID E.&&.
topic E.^. SquadTopicRemoteTopic E.==. E.val a
return
( squad E.^. SquadId
, send E.^. SquadThemSendDelegatorRemoteSquad
, start E.^. SquadUsStartId
, topic E.^. SquadTopicRemoteId
, send E.^. SquadThemSendDelegatorRemoteId
)
(E.Value squadID, E.Value usAcceptID, E.Value squadStartID, topic) <-
verifySingleE squads "No squad" "Multiple squads"
maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox meActorDB) False
lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
-- Delete the whole Squad record
delete squadStartID
case topic of
Left (_, sendID) -> delete sendID
Right (_, sendID) -> delete sendID
origin <-
requireEitherAlt
(getKeyBy $ UniqueSquadOriginUs squadID)
(getKeyBy $ UniqueSquadOriginThem squadID)
"Neither us nor them"
"Both us and them"
deleteBy $ UniqueSquadUsGestureLocal squadID
deleteBy $ UniqueSquadUsGestureRemote squadID
case origin of
Left usID -> delete usID
Right themID -> do
deleteBy $ UniqueSquadThemAcceptLocal themID
deleteBy $ UniqueSquadThemAcceptRemote themID
deleteBy $ UniqueSquadThemGestureLocal themID
deleteBy $ UniqueSquadThemGestureRemote themID
delete themID
delete usAcceptID
case topic of
Left (l, _) -> delete l
Right (r, _) -> delete r
delete squadID
-- Prepare forwarding Remove to my followers
sieve <- lift $ do
h <- hashLocalActor meActor
return $ makeRecipientSet [] [localActorFollowers h]
-- Prepare Accept activity
accept@(actionAccept, _, _, _) <- prepareAccept teamDB
acceptID <- insertEmptyOutboxItem' (actorOutbox meActorDB) now
_luAccept <- updateOutboxItem' meActor acceptID actionAccept
return (meActorID, sieve, acceptID, accept, inboxItemID)
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (topicActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
forwardActivity authorIdMsig body meActor topicActorID sieve
lift $
sendActivity
meActor topicActorID localRecipsAccept
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
doneDB inboxItemID "[Team-active] Deleted the Team/Squad, forwarded Remove, sent Accept"
where
prepareAccept teamDB = do
encodeRouteHome <- getEncodeRouteHome
audRemover <- lift $ makeAudSenderOnly authorIdMsig
audTeam <-
case teamDB of
Left (Entity g _) -> do
h <- encodeKeyHashid g
return $ AudLocal [LocalActorGroup h] [LocalStageGroupFollowers h]
Right (ObjURI h lu, Entity _ ra) ->
return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
audMe <-
AudLocal [] . pure . localActorFollowers <$>
hashLocalActor meActor
uRemove <- lift $ getActivityURI authorIdMsig
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audRemover, audTeam, audMe]
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uRemove]
, AP.actionSpecific = AP.AcceptActivity AP.Accept
{ AP.acceptObject = uRemove
, AP.acceptResult = Nothing
}
}
return (action, recipientSet, remoteActors, fwdHosts)
removeTeamPassive team = do
-- If team is local, find it in our DB
-- If team is remote, HTTP GET it, verify it's an actor of Project
-- type, and store in our DB (if it's already there, no need for HTTP)
--
-- NOTE: This is a blocking HTTP GET done right here in the handler,
-- which is NOT a good idea. Ideally, it would be done async, and the
-- handler result would be sent later in a separate (e.g. Accept) activity.
-- But for the PoC level, the current situation will hopefully do.
teamDB <-
bitraverse
(\ g -> withDBExcept $ getEntityE g "Team not found in DB")
(\ u@(ObjURI h lu) -> do
instanceID <-
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
result <-
ExceptT $ first (T.pack . displayException) <$>
fetchRemoteActor' instanceID h lu
case result of
Left Nothing -> throwE "Team @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Team isn't an actor"
Right (Just actor) -> do
case remoteActorType $ entityVal actor of
AP.ActorTypeTeam -> pure ()
_ -> throwE "Remote team type isn't Team"
return (u, actor)
)
team
maybeNew <- withDBExcept $ do
-- Grab me from DB
meKomponentID <- lift $ grabKomponent <$> getJust meID
Komponent meResourceID <- lift $ getJust meKomponentID
Resource meActorID <- lift $ getJust meResourceID
meActorDB <- lift $ getJust meActorID
-- Verify it's an active team of mine
squads <- lift $ case teamDB of
Left (Entity g _) ->
fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Left (t, s))) $
E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do
E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad
E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad
E.on $ topic E.^. SquadTopicLocalId E.==. send E.^. SquadThemSendDelegatorLocalTopic
E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicLocalSquad
E.where_ $
squad E.^. SquadHolder E.==. E.val meResourceID E.&&.
topic E.^. SquadTopicLocalGroup E.==. E.val g
return
( squad E.^. SquadId
, send E.^. SquadThemSendDelegatorLocalSquad
, start E.^. SquadUsStartId
, topic E.^. SquadTopicLocalId
, send E.^. SquadThemSendDelegatorLocalId
)
Right (_, Entity a _) ->
fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Right (t, s))) $
E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do
E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad
E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad
E.on $ topic E.^. SquadTopicRemoteId E.==. send E.^. SquadThemSendDelegatorRemoteTopic
E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicRemoteSquad
E.where_ $
squad E.^. SquadHolder E.==. E.val meResourceID E.&&.
topic E.^. SquadTopicRemoteTopic E.==. E.val a
return
( squad E.^. SquadId
, send E.^. SquadThemSendDelegatorRemoteSquad
, start E.^. SquadUsStartId
, topic E.^. SquadTopicRemoteId
, send E.^. SquadThemSendDelegatorRemoteId
)
(E.Value squadID, E.Value usAcceptID, E.Value squadStartID, topic) <-
verifySingleE squads "No squad" "Multiple squads"
maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox meActorDB) False
lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
return inboxItemID
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just inboxItemID ->
doneDB inboxItemID "[Team-passive] Saw the removal attempt, just waiting for the Revoke"
topicJoin topicJoin
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
=> (topic -> ResourceId) => (topic -> ResourceId)