S2S: Group: Remove: Port parent-child modes from Project
This commit is contained in:
parent
5e0a2e1088
commit
1e69a6e952
1 changed files with 941 additions and 11 deletions
|
@ -2883,9 +2883,9 @@ 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
|
||||||
|
@ -2894,13 +2894,943 @@ groupReject = topicReject groupResource LocalResourceGroup
|
||||||
-- * 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:
|
||||||
|
|
Loading…
Reference in a new issue