forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Group: Remove: Port parent-child modes from Project

Browse source
This commit is contained in:
Pere Lev 2024-05-14 12:58:46 +03:00
parent 5e0a2e1088
commit 1e69a6e952
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
1 changed files with 941 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

952
src/Vervis/Actor/Group.hs
View file

@ -2883,24 +2883,954 @@ groupReject
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
groupReject = topicReject groupResource LocalResourceGroup groupReject = topicReject groupResource LocalResourceGroup
-- Meaning: An actor A is removing actor B from a resource -- Meaning: An actor A is removing actor B from collection C
-- Behavior: -- Behavior:
-- * Verify the resource is me -- * If C is my collaborators collection:
-- * Verify A isn't removing themselves -- * Verify A isn't removing themselves
-- * Verify A is authorized by me to remove actors from me -- * Verify A is authorized by me to remove actors from me
-- * Verify B already has a Grant for me -- * Verify B already has a Grant for me
-- * Remove the whole Collab record from DB -- * Remove the whole Collab record from DB
-- * Forward the Remove to my followers -- * Forward the Remove to my followers
-- * Send a Revoke: -- * Send a Revoke:
-- * 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 parents collection:
-- * Verify A isn't removing themselves
-- * Verify A is authorized by me to remove actors from me
-- * Verify B is an active child of mine
-- * Remove the whole Source record from DB
-- * Forward the Remove to my followers
-- * Send a Revoke on the delegator-Grant I had for B:
-- * To: Actor B
-- * CC: Actor A, B's followers, my followers
-- * Send a Revoke on every extention-Grant I extended on every
-- delegation Grant I got from B
-- * To: The child/member to whom I'd sent the Grant
-- * CC: -
-- * If C is my children collection:
-- * Verify A isn't removing themselves
-- * Verify A is authorized by me to remove actors from me
-- * Verify B is an active parent of mine
-- * Remove the whole Dest 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, being removed from the children of a parent of mine:
-- * Record this Remove in the Source record
-- * Forward to followers
-- * If I'm B, being removed from the parents of a child of mine:
-- * Do nothing, just waiting for parent to send a Revoke on the
-- delegator-Grant
groupRemove groupRemove
:: UTCTime :: UTCTime
-> GroupId -> GroupId
-> Verse -> Verse
-> AP.Remove URIMode -> AP.Remove URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
groupRemove = topicRemove groupResource LocalResourceGroup groupRemove now groupID (Verse authorIdMsig body) remove = do
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
(collection, item) <- parseRemove author remove
case (collection, item) of
(Left (Left (LocalResourceGroup j)), _) | j == groupID ->
removeCollab item
(Left (Right (ATGroupChildren j)), _) | j == groupID ->
removeChildActive item
(Left (Right (ATGroupParents j)), _) | j == groupID ->
removeParentActive item
(_, Left (LocalActorGroup j)) | j == groupID ->
case collection of
Left (Right (ATGroupParents j)) | j /= groupID ->
removeChildPassive $ Left j
Left (Right (ATGroupChildren j)) | j /= groupID ->
removeParentPassive $ Left j
Right (ObjURI h luColl) -> do
-- NOTE this is HTTP GET done synchronously in the activity
-- handler
manager <- asksEnv envHttpManager
c <- AP.fetchAPID_T manager (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) h luColl
lu <- fromMaybeE (AP.collectionContext c) "No context"
j <- AP.fetchAPID_T manager (AP.actorId . AP.actorLocal . AP.teamActor) h lu
case (luColl == AP.teamChildren j, luColl == AP.teamParents j) of
(True, False) ->
removeParentPassive $ Right $ ObjURI h lu
(False, True) ->
removeChildPassive $ Right $ ObjURI h lu
_ -> throwE "Weird collection situation"
_ -> throwE "I'm being removed from somewhere irrelevant"
_ -> throwE "This Remove isn't for me"
where
removeCollab member = do
-- Check remove
memberByKey <-
bitraverse
(\case
LocalActorPerson p -> pure p
_ -> throwE "Not accepting non-person actors as collabs"
)
pure
member
-- Verify the specified capability gives relevant access
uCap <- do
let muCap = AP.activityCapability $ actbActivity body
fromMaybeE muCap "No capability provided"
verifyCapability''
uCap
authorIdMsig
(LocalResourceGroup groupID)
AP.RoleAdmin
maybeNew <- withDBExcept $ do
-- Find member in our DB
memberDB <-
bitraverse
(flip getEntityE "Member not found in DB")
(\ u@(ObjURI h lu) -> (,u) <$> do
maybeActor <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance h
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu
MaybeT $ getBy $ UniqueRemoteActor roid
fromMaybeE maybeActor "Remote removee not found in DB"
)
memberByKey
-- Grab me from DB
resourceID <- lift $ groupResource <$> getJust groupID
Resource topicActorID <- lift $ getJust resourceID
topicActor <- lift $ getJust topicActorID
-- Find the collab that the member already has for me
existingCollabIDs <-
lift $ case memberDB of
Left (Entity personID _) ->
fmap (map $ over _1 Left) $
E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
E.on $
collab E.^. CollabId E.==.
recipl E.^. CollabRecipLocalCollab
E.where_ $
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
recipl E.^. CollabRecipLocalPerson E.==. E.val personID
return
( recipl E.^. persistIdField
, recipl E.^. CollabRecipLocalCollab
)
Right (Entity remoteActorID _, _) ->
fmap (map $ over _1 Right) $
E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
E.on $
collab E.^. CollabId E.==.
recipr E.^. CollabRecipRemoteCollab
E.where_ $
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
return
( recipr E.^. persistIdField
, recipr E.^. CollabRecipRemoteCollab
)
(recipID, E.Value collabID) <-
case existingCollabIDs of
[] -> throwE "Remove object isn't a member of me"
[collab] -> return collab
_ -> error "Multiple collabs found for removee"
-- Verify the Collab is enabled
maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
Entity enableID (CollabEnable _ grantID) <-
fromMaybeE maybeEnabled "Remove object isn't a member of me yet"
-- Verify that at least 1 more enabled Admin collab for me exists
otherCollabIDs <-
lift $ E.select $ E.from $ \ (collab `E.InnerJoin` enable) -> do
E.on $
collab E.^. CollabId E.==.
enable E.^. CollabEnableCollab
E.where_ $
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
collab E.^. CollabId E.!=. E.val collabID E.&&.
collab E.^. CollabRole E.==. E.val AP.RoleAdmin
return $ collab E.^. CollabId
when (null otherCollabIDs) $
throwE "No other admins exist, can't remove"
maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
-- Delete the whole Collab record
deleteBy $ UniqueCollabDelegLocal enableID
deleteBy $ UniqueCollabDelegRemote enableID
delete enableID
case recipID of
Left (E.Value l) -> do
deleteBy $ UniqueCollabRecipLocalJoinCollab l
deleteBy $ UniqueCollabRecipLocalAcceptCollab l
delete l
Right (E.Value r) -> do
deleteBy $ UniqueCollabRecipRemoteJoinCollab r
deleteBy $ UniqueCollabRecipRemoteAcceptCollab r
delete r
fulfills <- do
mf <- runMaybeT $ asum
[ Left <$> MaybeT (getKeyBy $ UniqueCollabFulfillsLocalTopicCreation collabID)
, Right . Left <$> MaybeT (getKeyBy $ UniqueCollabFulfillsInvite collabID)
, Right . Right <$> MaybeT (getKeyBy $ UniqueCollabFulfillsJoin collabID)
]
maybe (error $ "No fulfills for collabID#" ++ show collabID) pure mf
case fulfills of
Left fc -> delete fc
Right (Left fi) -> do
deleteBy $ UniqueCollabInviterLocal fi
deleteBy $ UniqueCollabInviterRemote fi
delete fi
Right (Right fj) -> do
deleteBy $ UniqueCollabApproverLocal fj
deleteBy $ UniqueCollabApproverRemote fj
delete fj
delete collabID
-- Prepare forwarding Remove to my followers
sieve <- lift $ do
topicHash <- encodeKeyHashid groupID
let topicByHash =
LocalActorGroup topicHash
return $ makeRecipientSet [] [localActorFollowers topicByHash]
-- Prepare a Revoke activity and insert to my outbox
revoke@(actionRevoke, _, _, _) <-
lift $ prepareRevoke memberDB grantID
let recipByKey = LocalActorGroup groupID
revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
_luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
return (topicActorID, sieve, revokeID, revoke, inboxItemID)
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), inboxItemID) -> do
let topicByID = LocalActorGroup groupID
forwardActivity authorIdMsig body topicByID topicActorID sieve
lift $ sendActivity
topicByID topicActorID localRecipsRevoke
remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke
doneDB inboxItemID "[Collab] Deleted the Grant/Collab, forwarded Remove, sent Revoke"
where
prepareRevoke member grantID = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
recipHash <- encodeKeyHashid groupID
let topicByHash = LocalActorGroup recipHash
memberHash <- bitraverse (encodeKeyHashid . entityKey) pure member
audRemover <- makeAudSenderOnly authorIdMsig
let audience =
let audMember =
case memberHash of
Left p ->
AudLocal [LocalActorPerson p] [LocalStagePersonFollowers p]
Right (Entity _ actor, ObjURI h lu) ->
AudRemote h [lu] (maybeToList $ remoteActorFollowers actor)
audTopic = AudLocal [] [localActorFollowers topicByHash]
in [audRemover, audMember, audTopic]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience audience
recips = map encodeRouteHome audLocal ++ audRemote
uRemove <- getActivityURI authorIdMsig
luGrant <- do
grantHash <- encodeKeyHashid grantID
return $ encodeRouteLocal $ activityRoute topicByHash grantHash
let action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uRemove]
, AP.actionSpecific = AP.RevokeActivity AP.Revoke
{ AP.revokeObject = luGrant :| []
}
}
return (action, recipientSet, remoteActors, fwdHosts)
removeParentActive parent = do
-- If parent is local, find it in our DB
-- If parent is remote, HTTP GET it, verify it's an actor of Group
-- 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.
parentDB <-
bitraverse
(\case
LocalActorGroup j -> withDBExcept $ getEntityE j "Parent not found in DB"
_ -> throwE "Local proposed parent 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 "Parent @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Parent isn't an actor"
Right (Just actor) -> do
case remoteActorType $ entityVal actor of
AP.ActorTypeTeam -> pure ()
_ -> throwE "Remote parent type isn't Group"
return (u, actor)
)
parent
-- 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 parent
verifyCapability''
uCap
authorIdMsig
(LocalResourceGroup groupID)
AP.RoleAdmin
maybeNew <- withDBExcept $ do
-- Grab me from DB
(group, actorRecip) <- lift $ do
p <- getJust groupID
(p,) <$> getJust (groupActor p)
-- Verify it's an active parent of mine
sources <- lift $ case parentDB of
Left (Entity j _) ->
fmap (map $ \ (s, h, d, E.Value a, E.Value t, E.Value i) -> (s, h, d, Left (a, t, i))) $
E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do
E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource
E.on $ topic E.^. SourceTopicGroupTopic E.==. accept E.^. SourceThemAcceptLocalTopic
E.on $ holder E.^. SourceHolderGroupId E.==. topic E.^. SourceTopicGroupHolder
E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderGroupSource
E.where_ $
holder E.^. SourceHolderGroupGroup E.==. E.val groupID E.&&.
topic E.^. SourceTopicGroupParent E.==. E.val j
return
( source E.^. SourceId
, holder E.^. SourceHolderGroupId
, send
, accept E.^. SourceThemAcceptLocalId
, topic E.^. SourceTopicGroupTopic
, topic E.^. SourceTopicGroupId
)
Right (_, Entity a _) ->
fmap (map $ \ (s, h, d, E.Value a, E.Value t) -> (s, h, d, Right (a, t))) $
E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do
E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource
E.on $ topic E.^. SourceTopicRemoteId E.==. accept E.^. SourceThemAcceptRemoteTopic
E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicRemoteSource
E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderGroupSource
E.where_ $
holder E.^. SourceHolderGroupGroup E.==. E.val groupID E.&&.
topic E.^. SourceTopicRemoteTopic E.==. E.val a
return
( source E.^. SourceId
, holder E.^. SourceHolderGroupId
, send
, accept E.^. SourceThemAcceptRemoteId
, topic E.^. SourceTopicRemoteId
)
(E.Value sourceID, E.Value holderID, Entity sendID (SourceUsSendDelegator _ grantID), topic) <-
verifySingleE sources "No source" "Multiple sources"
maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
-- Grab extension-Grants that I'm about to revoke
gathers <- selectList [SourceUsGatherSource ==. sendID] []
leafs <- selectList [SourceUsLeafSource ==. sendID] []
-- Delete the whole Source record
deleteWhere [SourceRemoveSend ==. sendID]
let gatherIDs = map entityKey gathers
deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs]
deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs]
deleteWhere [SourceUsGatherId <-. gatherIDs]
let leafIDs = map entityKey leafs
deleteWhere [SourceUsLeafFromLocalLeaf <-. leafIDs]
deleteWhere [SourceUsLeafFromRemoteLeaf <-. leafIDs]
deleteWhere [SourceUsLeafToLocalLeaf <-. leafIDs]
deleteWhere [SourceUsLeafToRemoteLeaf <-. leafIDs]
deleteWhere [SourceUsLeafId <-. leafIDs]
case topic of
Left (localID, _, _) -> do
deleteWhere [SourceThemDelegateLocalSource ==. localID]
delete localID
Right (remoteID, _) -> do
deleteWhere [SourceThemDelegateRemoteSource ==. remoteID]
delete remoteID
delete sendID
origin <-
requireEitherAlt
(getKeyBy $ UniqueSourceOriginUs sourceID)
(getKeyBy $ UniqueSourceOriginThem sourceID)
"Neither us nor them"
"Both us and them"
case origin of
Left usID -> do
deleteBy $ UniqueSourceUsAccept usID
deleteBy $ UniqueSourceUsGestureLocal usID
deleteBy $ UniqueSourceUsGestureRemote usID
delete usID
Right themID -> do
deleteBy $ UniqueSourceThemGestureLocal themID
deleteBy $ UniqueSourceThemGestureRemote themID
delete themID
case topic of
Left (_, l, j) -> delete j >> delete l
Right (_, r) -> delete r
delete holderID
delete sourceID
-- Prepare forwarding Remove to my followers
sieve <- lift $ do
topicHash <- encodeKeyHashid groupID
let topicByHash =
LocalActorGroup topicHash
return $ makeRecipientSet [] [localActorFollowers topicByHash]
-- Prepare main Revoke activity and insert to my outbox
revoke@(actionRevoke, _, _, _) <-
lift $ prepareMainRevoke parentDB grantID
let recipByKey = LocalActorGroup groupID
revokeID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
_luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
-- Prepare and insert Revokes on all the extension-Grants
revokesG <- for gathers $ \ (Entity _ (SourceUsGather _ startID grantID)) -> do
DestUsStart acceptID _ <- getJust startID
DestUsAccept destID _ <- getJust acceptID
parent <- do
p <- getDestTopic destID
bitraverse
(\case
Right j -> pure $ LocalActorGroup j
Left _ -> error "I'm a group but I have a parent who is a Project"
)
pure
(bimap snd snd p)
return (parent, grantID)
revokesL <- for leafs $ \ (Entity _ (SourceUsLeaf _ enableID grantID)) -> do
CollabEnable collabID _ <- getJust enableID
recip <- getCollabRecip collabID
return
( bimap
(LocalActorPerson . collabRecipLocalPerson . entityVal)
(collabRecipRemoteActor . entityVal)
recip
, grantID
)
revokes <- for (revokesG ++ revokesL) $ \ (actor, grantID) -> do
ext@(actionExt, _, _, _) <- prepareExtRevoke actor grantID
let recipByKey = LocalActorGroup groupID
extID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
_luExt <- updateOutboxItem' recipByKey extID actionExt
return (extID, ext)
return (groupActor group, sieve, revokeID, revoke, revokes, inboxItemID)
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), revokes, inboxItemID) -> do
let topicByID = LocalActorGroup groupID
forwardActivity authorIdMsig body topicByID topicActorID sieve
lift $ do
sendActivity
topicByID topicActorID localRecipsRevoke
remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke
for_ revokes $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
sendActivity
topicByID topicActorID localRecipsExt
remoteRecipsExt fwdHostsExt extID actionExt
doneDB inboxItemID "[Parent-active] Deleted the Source, forwarded Remove, sent Revokes"
where
prepareMainRevoke parent grantID = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
recipHash <- encodeKeyHashid groupID
let topicByHash = LocalActorGroup recipHash
parentHash <- bitraverse (encodeKeyHashid . entityKey) pure parent
audRemover <- makeAudSenderOnly authorIdMsig
let audParent =
case parentHash of
Left j ->
AudLocal [LocalActorGroup j] [LocalStageGroupFollowers j]
Right (ObjURI h lu, Entity _ actor) ->
AudRemote h [lu] (maybeToList $ remoteActorFollowers actor)
audMe = AudLocal [] [localActorFollowers topicByHash]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audRemover, audParent, audMe]
recips = map encodeRouteHome audLocal ++ audRemote
uRemove <- getActivityURI authorIdMsig
luGrant <- do
grantHash <- encodeKeyHashid grantID
return $ encodeRouteLocal $ activityRoute topicByHash grantHash
let action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uRemove]
, AP.actionSpecific = AP.RevokeActivity AP.Revoke
{ AP.revokeObject = luGrant :| []
}
}
return (action, recipientSet, remoteActors, fwdHosts)
prepareExtRevoke recipient grantID = do
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
groupHash <- encodeKeyHashid groupID
let topicByHash = LocalActorGroup groupHash
audRecip <-
case recipient of
Left a -> do
h <- hashLocalActor a
return $ AudLocal [h] [localActorFollowers h]
Right actorID -> do
actor <- getJust actorID
ObjURI h lu <- getRemoteActorURI actor
return $
AudRemote h [lu] (maybeToList $ remoteActorFollowers actor)
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audRecip]
recips = map encodeRouteHome audLocal ++ audRemote
uRemove <- lift $ getActivityURI authorIdMsig
luGrant <- do
grantHash <- encodeKeyHashid grantID
return $ encodeRouteLocal $ activityRoute topicByHash grantHash
let action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uRemove]
, AP.actionSpecific = AP.RevokeActivity AP.Revoke
{ AP.revokeObject = luGrant :| []
}
}
return (action, recipientSet, remoteActors, fwdHosts)
removeChildActive child = do
-- If child is local, find it in our DB
-- If child is remote, HTTP GET it, verify it's an actor of Group
-- 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.
childDB <-
bitraverse
(\case
LocalActorGroup j -> withDBExcept $ getEntityE j "Child not found in DB"
_ -> throwE "Local proposed child 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 "Child @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Child isn't an actor"
Right (Just actor) -> do
case remoteActorType $ entityVal actor of
AP.ActorTypeTeam -> pure ()
_ -> throwE "Remote child type isn't Group"
return (u, actor)
)
child
-- 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 child
verifyCapability''
uCap
authorIdMsig
(LocalResourceGroup groupID)
AP.RoleAdmin
maybeNew <- withDBExcept $ do
-- Grab me from DB
(group, actorRecip) <- lift $ do
p <- getJust groupID
(p,) <$> getJust (groupActor p)
-- Verify it's an active child of mine
dests <- lift $ case childDB of
Left (Entity j _) ->
fmap (map $ \ (d, h, a, z, E.Value l, E.Value t, E.Value s) -> (d, h, a, z, Left (l, t, s))) $
E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do
E.on $ accept E.^. DestUsAcceptId E.==. start E.^. DestUsStartDest
E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
E.on $ topic E.^. DestTopicGroupTopic E.==. send E.^. DestThemSendDelegatorLocalTopic
E.on $ holder E.^. DestHolderGroupId E.==. topic E.^. DestTopicGroupHolder
E.on $ dest E.^. DestId E.==. holder E.^. DestHolderGroupDest
E.where_ $
holder E.^. DestHolderGroupGroup E.==. E.val groupID E.&&.
topic E.^. DestTopicGroupChild E.==. E.val j
return
( dest E.^. DestId
, holder E.^. DestHolderGroupId
, send E.^. DestThemSendDelegatorLocalDest
, start E.^. DestUsStartId
, topic E.^. DestTopicGroupTopic
, topic E.^. DestTopicGroupId
, send E.^. DestThemSendDelegatorLocalId
)
Right (_, Entity a _) ->
fmap (map $ \ (d, h, a, z, E.Value t, E.Value s) -> (d, h, a, z, Right (t, s))) $
E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do
E.on $ accept E.^. DestUsAcceptId E.==. start E.^. DestUsStartDest
E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
E.on $ topic E.^. DestTopicRemoteId E.==. send E.^. DestThemSendDelegatorRemoteTopic
E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest
E.on $ dest E.^. DestId E.==. holder E.^. DestHolderGroupDest
E.where_ $
holder E.^. DestHolderGroupGroup E.==. E.val groupID E.&&.
topic E.^. DestTopicRemoteTopic E.==. E.val a
return
( dest E.^. DestId
, holder E.^. DestHolderGroupId
, send E.^. DestThemSendDelegatorRemoteDest
, start E.^. DestUsStartId
, topic E.^. DestTopicRemoteId
, send E.^. DestThemSendDelegatorRemoteId
)
(E.Value destID, E.Value holderID, E.Value usAcceptID, E.Value destStartID, topic) <-
verifySingleE dests "No dest" "Multiple dests"
maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
-- Delete uses of this Dest from my Project records
--deleteWhere [ComponentGatherChild ==. destStartID]
-- Delete uses of this Dest from my Source records
gatherIDs <- selectKeysList [SourceUsGatherDest ==. destStartID] []
deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs]
deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs]
deleteWhere [SourceUsGatherId <-. gatherIDs]
-- Delete the whole Dest record
delete destStartID
case topic of
Left (_, _, sendID) -> delete sendID
Right (_, sendID) -> delete sendID
origin <-
requireEitherAlt
(getKeyBy $ UniqueDestOriginUs destID)
(getKeyBy $ UniqueDestOriginThem destID)
"Neither us nor them"
"Both us and them"
deleteBy $ UniqueDestUsGestureLocal destID
deleteBy $ UniqueDestUsGestureRemote destID
case origin of
Left usID -> delete usID
Right themID -> do
deleteBy $ UniqueDestThemAcceptLocal themID
deleteBy $ UniqueDestThemAcceptRemote themID
deleteBy $ UniqueDestThemGestureLocal themID
deleteBy $ UniqueDestThemGestureRemote themID
delete themID
delete usAcceptID
case topic of
Left (l, j, _) -> delete j >> delete l
Right (r, _) -> delete r
delete holderID
delete destID
-- Prepare forwarding Remove to my followers
sieve <- lift $ do
topicHash <- encodeKeyHashid groupID
let topicByHash =
LocalActorGroup topicHash
return $ makeRecipientSet [] [localActorFollowers topicByHash]
-- Prepare Accept activity
accept@(actionAccept, _, _, _) <- prepareAccept childDB
let recipByKey = LocalActorGroup groupID
acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
_luAccept <- updateOutboxItem' recipByKey acceptID actionAccept
return (groupActor group, 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
let topicByID = LocalActorGroup groupID
forwardActivity authorIdMsig body topicByID topicActorID sieve
lift $
sendActivity
topicByID topicActorID localRecipsAccept
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
doneDB inboxItemID "[Child-active] Deleted the Dest, forwarded Remove, sent Accept"
where
prepareAccept childDB = do
encodeRouteHome <- getEncodeRouteHome
audRemover <- lift $ makeAudSenderOnly authorIdMsig
audChild <-
case childDB of
Left (Entity j _) -> do
h <- encodeKeyHashid j
return $ AudLocal [LocalActorGroup h] [LocalStageGroupFollowers h]
Right (ObjURI h lu, Entity _ ra) ->
return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
audMe <-
AudLocal [] . pure . LocalStageGroupFollowers <$>
encodeKeyHashid groupID
uRemove <- lift $ getActivityURI authorIdMsig
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audRemover, audChild, 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)
removeParentPassive parent = do
-- If parent is local, find it in our DB
-- If parent is remote, HTTP GET it, verify it's an actor of Group
-- 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.
parentDB <-
bitraverse
(\ j -> withDBExcept $ getEntityE j "Parent 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 "Parent @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Parent isn't an actor"
Right (Just actor) -> do
case remoteActorType $ entityVal actor of
AP.ActorTypeTeam -> pure ()
_ -> throwE "Remote parent type isn't Group"
return (u, actor)
)
parent
maybeNew <- withDBExcept $ do
-- Grab me from DB
(group, actorRecip) <- lift $ do
p <- getJust groupID
(p,) <$> getJust (groupActor p)
-- Verify it's an active parent of mine
sources <- lift $ case parentDB of
Left (Entity j _) ->
fmap (map $ \ (s, h, d, E.Value a, E.Value t, E.Value i) -> (s, h, d, Left (a, t, i))) $
E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do
E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource
E.on $ topic E.^. SourceTopicGroupTopic E.==. accept E.^. SourceThemAcceptLocalTopic
E.on $ holder E.^. SourceHolderGroupId E.==. topic E.^. SourceTopicGroupHolder
E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderGroupSource
E.where_ $
holder E.^. SourceHolderGroupGroup E.==. E.val groupID E.&&.
topic E.^. SourceTopicGroupParent E.==. E.val j
return
( source E.^. SourceId
, holder E.^. SourceHolderGroupId
, send
, accept E.^. SourceThemAcceptLocalId
, topic E.^. SourceTopicGroupTopic
, topic E.^. SourceTopicGroupId
)
Right (_, Entity a _) ->
fmap (map $ \ (s, h, d, E.Value a, E.Value t) -> (s, h, d, Right (a, t))) $
E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do
E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource
E.on $ topic E.^. SourceTopicRemoteId E.==. accept E.^. SourceThemAcceptRemoteTopic
E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicRemoteSource
E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderGroupSource
E.where_ $
holder E.^. SourceHolderGroupGroup E.==. E.val groupID E.&&.
topic E.^. SourceTopicRemoteTopic E.==. E.val a
return
( source E.^. SourceId
, holder E.^. SourceHolderGroupId
, send
, accept E.^. SourceThemAcceptRemoteId
, topic E.^. SourceTopicRemoteId
)
(E.Value sourceID, E.Value holderID, Entity sendID (SourceUsSendDelegator _ grantID), topic) <-
verifySingleE sources "No source" "Multiple sources"
maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
lift $ for maybeRemoveDB $ \ (removeID, _) -> do
-- Record the removal attempt
insert_ $ SourceRemove sendID removeID
-- Prepare forwarding Remove to my followers
sieve <- lift $ do
topicHash <- encodeKeyHashid groupID
let topicByHash =
LocalActorGroup topicHash
return $ makeRecipientSet [] [localActorFollowers topicByHash]
return (groupActor group, sieve, removeID)
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (topicActorID, sieve, inboxItemID) -> do
let topicByID = LocalActorGroup groupID
forwardActivity authorIdMsig body topicByID topicActorID sieve
doneDB inboxItemID "[Parent-passive] Recorded removal attempt, forwarded Remove"
removeChildPassive child = do
-- If child is local, find it in our DB
-- If child is remote, HTTP GET it, verify it's an actor of Group
-- 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.
childDB <-
bitraverse
(\ j -> withDBExcept $ getEntityE j "Child 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 "Child @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Child isn't an actor"
Right (Just actor) -> do
case remoteActorType $ entityVal actor of
AP.ActorTypeTeam -> pure ()
_ -> throwE "Remote child type isn't Group"
return (u, actor)
)
child
maybeNew <- withDBExcept $ do
-- Grab me from DB
(group, actorRecip) <- lift $ do
p <- getJust groupID
(p,) <$> getJust (groupActor p)
-- Verify it's an active child of mine
dests <- lift $ case childDB of
Left (Entity j _) ->
fmap (map $ \ (d, h, a, E.Value l, E.Value t, E.Value s) -> (d, h, a, Left (l, t, s))) $
E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` send) -> do
E.on $ topic E.^. DestTopicGroupTopic E.==. send E.^. DestThemSendDelegatorLocalTopic
E.on $ holder E.^. DestHolderGroupId E.==. topic E.^. DestTopicGroupHolder
E.on $ dest E.^. DestId E.==. holder E.^. DestHolderGroupDest
E.where_ $
holder E.^. DestHolderGroupGroup E.==. E.val groupID E.&&.
topic E.^. DestTopicGroupChild E.==. E.val j
return
( dest E.^. DestId
, holder E.^. DestHolderGroupId
, send E.^. DestThemSendDelegatorLocalDest
, topic E.^. DestTopicGroupTopic
, topic E.^. DestTopicGroupId
, send E.^. DestThemSendDelegatorLocalId
)
Right (_, Entity a _) ->
fmap (map $ \ (d, h, a, E.Value t, E.Value s) -> (d, h, a, Right (t, s))) $
E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` send) -> do
E.on $ topic E.^. DestTopicRemoteId E.==. send E.^. DestThemSendDelegatorRemoteTopic
E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest
E.on $ dest E.^. DestId E.==. holder E.^. DestHolderGroupDest
E.where_ $
holder E.^. DestHolderGroupGroup E.==. E.val groupID E.&&.
topic E.^. DestTopicRemoteTopic E.==. E.val a
return
( dest E.^. DestId
, holder E.^. DestHolderGroupId
, send E.^. DestThemSendDelegatorRemoteDest
, topic E.^. DestTopicRemoteId
, send E.^. DestThemSendDelegatorRemoteId
)
(E.Value destID, E.Value holderID, E.Value usAcceptID, topic) <-
verifySingleE dests "No dest" "Multiple dests"
maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) 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 "[Child-passive] Saw the removal attempt, just waiting for the Revoke"
-- Meaning: An actor is undoing some previous action -- Meaning: An actor is undoing some previous action
-- Behavior: -- Behavior: