S2S: Component: Remove: Port team-mode from Project
This commit is contained in:
Pere Lev
parent
02f46a21f9
commit
4d06d8e840
1 changed files with 298 additions and 1 deletions
|
|
@ -1502,8 +1502,21 @@ componentInvite grabKomponent topicComponent now topicKey (Verse authorIdMsig bo
|
|||
-- * To: Actor B
|
||||
-- * 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
|
||||
-- * 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
|
||||
:: forall topic.
|
||||
(PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||
|
|
@ -1525,10 +1538,15 @@ componentRemove grabKomponent topicComponent now topicKey (Verse authorIdMsig bo
|
|||
(Left (Right target), _)
|
||||
| addTargetComponentProjects target == Just (topicComponent topicKey) ->
|
||||
removeProjectActive item
|
||||
(Left (Right target), _)
|
||||
| (resourceFromNG <$> addTargetResourceTeams target) == Just meResource ->
|
||||
removeTeamActive item
|
||||
(_, Left la) | la == resourceToActor (topicResource topicKey) ->
|
||||
case collection of
|
||||
Left (Right (ATProjectComponents j)) ->
|
||||
removeProjectPassive $ Left j
|
||||
Left (Right (ATGroupEfforts g)) ->
|
||||
removeTeamPassive $ Left g
|
||||
Right (ObjURI h luColl) -> do
|
||||
-- NOTE this is HTTP GET done synchronously in the activity
|
||||
-- handler
|
||||
|
|
@ -1543,12 +1561,21 @@ componentRemove grabKomponent topicComponent now topicKey (Verse authorIdMsig bo
|
|||
let typ = AP.actorType d
|
||||
if typ == AP.ActorTypeProject && Just luColl == AP.rwcComponents rwc
|
||||
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 "This Remove isn't for me"
|
||||
|
||||
where
|
||||
|
||||
toComponent = topicComponent
|
||||
meID = topicKey
|
||||
|
||||
meComponent = toComponent meID
|
||||
meResource = componentResource meComponent
|
||||
meActor = resourceToActor meResource
|
||||
|
||||
topicResource :: forall f. f topic -> LocalResourceBy f
|
||||
topicResource = componentResource . topicComponent
|
||||
|
||||
|
|
@ -1961,6 +1988,276 @@ componentRemove grabKomponent topicComponent now topicKey (Verse authorIdMsig bo
|
|||
forwardActivity authorIdMsig body topicByID topicActorID sieve
|
||||
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
|
||||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||
=> (topic -> ResourceId)
|
||||
|
|
|
|||
Loading…
Reference in a new issue