S2S: Project: Accept: Implement remove-child mode
This commit is contained in:
Pere Lev
parent
bf8ae421ff
commit
223fbf3d0e
1 changed files with 264 additions and 6 deletions
|
|
@ -196,6 +196,19 @@ import Vervis.Web.Collab
|
|||
-- - Parent's followers
|
||||
-- - My followers
|
||||
-- - The Accept sender (my collaborator)
|
||||
--
|
||||
-- * Remove-Child-Passive mode:
|
||||
-- * Verify the Source is enabled
|
||||
-- * Verify the sender is the child
|
||||
-- * Delete the entire Source record
|
||||
-- * Forward the Accept 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 parent/collaborator/team to whom I'd sent the Grant
|
||||
-- * CC: -
|
||||
projectAccept
|
||||
:: UTCTime
|
||||
-> ProjectId
|
||||
|
|
@ -209,6 +222,11 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
|
||||
collabOrComp_or_child <- withDBExcept $ do
|
||||
|
||||
myInboxID <- lift $ do
|
||||
project <- getJust projectID
|
||||
actor <- getJust $ projectActor project
|
||||
return $ actorInbox actor
|
||||
|
||||
-- Find the accepted activity in our DB
|
||||
accepteeDB <- do
|
||||
a <- getActivity acceptee
|
||||
|
|
@ -225,18 +243,20 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
runExceptT (Left . Left <$> tryJoinCollab accepteeDB) <|>
|
||||
runExceptT (Left . Right <$> tryInviteComp accepteeDB) <|>
|
||||
runExceptT (Left . Right <$> tryAddComp accepteeDB) <|>
|
||||
runExceptT (Right <$> tryAddChildActive accepteeDB) <|>
|
||||
runExceptT (Right <$> tryAddChildPassive accepteeDB) <|>
|
||||
runExceptT (Right <$> tryAddParentActive accepteeDB) <|>
|
||||
runExceptT (Right <$> tryAddParentPassive accepteeDB)
|
||||
runExceptT (Right . Left <$> tryAddChildActive accepteeDB) <|>
|
||||
runExceptT (Right . Left <$> tryAddChildPassive accepteeDB) <|>
|
||||
runExceptT (Right . Left <$> tryAddParentActive accepteeDB) <|>
|
||||
runExceptT (Right . Left <$> tryAddParentPassive accepteeDB) <|>
|
||||
runExceptT (Right . Right <$> tryRemoveChild myInboxID accepteeDB)
|
||||
fromMaybeE
|
||||
maybeCollab
|
||||
"Accepted activity isn't an Invite/Join/Add I'm aware of"
|
||||
"Accepted activity isn't an Invite/Join/Add/Remove I'm aware of"
|
||||
|
||||
case collabOrComp_or_child of
|
||||
Left (Left collab) -> addCollab collab
|
||||
Left (Right comp) -> addComp comp
|
||||
Right cp -> addChildParent cp
|
||||
Right (Left cp) -> addChildParent cp
|
||||
Right (Right child) -> removeChild child
|
||||
|
||||
where
|
||||
|
||||
|
|
@ -441,6 +461,32 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
lift $ MaybeT $ getValBy $ UniqueDestThemGestureRemoteAdd remoteActivityID
|
||||
tryAddParentPassive' themID
|
||||
|
||||
tryRemoveChild' itemID = do
|
||||
SourceRemove sendID _ <-
|
||||
lift $ MaybeT $ getValBy $ UniqueSourceRemove itemID
|
||||
SourceUsSendDelegator sourceID grantID <- lift $ lift $ getJust sendID
|
||||
ExceptT $ lift $ runExceptT $ verifySourceHolder sourceID
|
||||
topic <- do
|
||||
t <- lift . lift $ getSourceTopic sourceID
|
||||
bitraverse
|
||||
(\ (l, k) ->
|
||||
case k of
|
||||
Left j -> pure (l, j)
|
||||
Right _ -> error "Project Source topic is a Group, impossible"
|
||||
)
|
||||
pure
|
||||
t
|
||||
return (sourceID, sendID, grantID, topic)
|
||||
|
||||
tryRemoveChild inboxID (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||
InboxItemLocal _ _ i <-
|
||||
lift $ MaybeT $ getValBy $ UniqueInboxItemLocal inboxID itemID
|
||||
tryRemoveChild' i
|
||||
tryRemoveChild inboxID (Right remoteActivityID) = do
|
||||
InboxItemRemote _ _ i <-
|
||||
lift $ MaybeT $ getValBy $ UniqueInboxItemRemote inboxID remoteActivityID
|
||||
tryRemoveChild' i
|
||||
|
||||
componentIsAuthor ident =
|
||||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
in author == bimap (componentActor . snd) snd ident
|
||||
|
|
@ -1127,6 +1173,218 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
removeChild (sourceID, sendID, grantID, child) = do
|
||||
|
||||
-- Verify the sender is the topic
|
||||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
unless (author == bimap (LocalActorProject . snd) snd child) $
|
||||
throwE "The Accept isn't by the to-be-removed child project"
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(project, actorRecip) <- lift $ do
|
||||
p <- getJust projectID
|
||||
(p,) <$> getJust (projectActor p)
|
||||
|
||||
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
|
||||
lift $ for maybeAcceptDB $ \ acceptDB -> 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 [SourceUsGatherToLocalGather <-. gatherIDs]
|
||||
deleteWhere [SourceUsGatherToRemoteGather <-. gatherIDs]
|
||||
deleteWhere [SourceUsGatherId <-. gatherIDs]
|
||||
let leafIDs = map entityKey leafs
|
||||
deleteWhere [SourceUsLeafFromLocalLeaf <-. leafIDs]
|
||||
deleteWhere [SourceUsLeafFromRemoteLeaf <-. leafIDs]
|
||||
deleteWhere [SourceUsLeafToLocalLeaf <-. leafIDs]
|
||||
deleteWhere [SourceUsLeafToRemoteLeaf <-. leafIDs]
|
||||
case child of
|
||||
Left (localID, _) -> do
|
||||
acceptID <- getKeyByJust $ UniqueSourceThemAcceptLocal localID
|
||||
deleteWhere [SourceThemDelegateLocalSource ==. acceptID]
|
||||
delete acceptID
|
||||
Right (remoteID, _) -> do
|
||||
acceptID <- getKeyByJust $ UniqueSourceThemAcceptRemote remoteID
|
||||
deleteWhere [SourceThemDelegateRemoteSource ==. acceptID]
|
||||
delete acceptID
|
||||
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 child of
|
||||
Left (l, _) -> do
|
||||
deleteBy $ UniqueSourceTopicProjectTopic l
|
||||
delete l
|
||||
Right (r, _) ->
|
||||
delete r
|
||||
deleteBy $ UniqueSourceHolderProject sourceID
|
||||
delete sourceID
|
||||
|
||||
-- Prepare forwarding Remove to my followers
|
||||
sieve <- lift $ do
|
||||
topicHash <- encodeKeyHashid projectID
|
||||
let topicByHash =
|
||||
LocalActorProject topicHash
|
||||
return $ makeRecipientSet [] [localActorFollowers topicByHash]
|
||||
|
||||
-- Prepare main Revoke activity and insert to my outbox
|
||||
revoke@(actionRevoke, _, _, _) <- prepareMainRevoke (bimap snd snd child) grantID
|
||||
let recipByKey = LocalActorProject projectID
|
||||
revokeID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
|
||||
_luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
|
||||
|
||||
-- Prepare and insert Revokes on all the extension-Grants
|
||||
revokesG <- for gathers $ \ (Entity _ (SourceUsGather _ acceptID grantID)) -> do
|
||||
DestUsAccept destID _ <- getJust acceptID
|
||||
parent <- do
|
||||
p <- getDestTopic destID
|
||||
bitraverse
|
||||
(\case
|
||||
Left j -> pure $ LocalActorProject j
|
||||
Right _ -> error "I'm a project but I have a parent who is a Group"
|
||||
)
|
||||
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 = LocalActorProject projectID
|
||||
extID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
|
||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||
return (extID, ext)
|
||||
|
||||
return (projectActor project, sieve, revokeID, revoke, revokes)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), revokes) -> do
|
||||
let topicByID = LocalActorProject projectID
|
||||
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
|
||||
done "[Remove-Child mode] Deleted the Child/Source, forwarded Accept, sent Revokes"
|
||||
|
||||
where
|
||||
|
||||
prepareMainRevoke child grantID = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
recipHash <- encodeKeyHashid projectID
|
||||
let topicByHash = LocalActorProject recipHash
|
||||
|
||||
childHash <- bitraverse encodeKeyHashid pure child
|
||||
|
||||
audRemover <- lift $ makeAudSenderOnly authorIdMsig
|
||||
audChild <-
|
||||
case childHash of
|
||||
Left j ->
|
||||
pure $
|
||||
AudLocal [LocalActorProject j] [LocalStageProjectFollowers j]
|
||||
Right actorID -> do
|
||||
actor <- getJust actorID
|
||||
ObjURI h lu <- getRemoteActorURI actor
|
||||
return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers actor)
|
||||
let audMe = AudLocal [] [localActorFollowers topicByHash]
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audRemover, audChild, audMe]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
|
||||
let uRemove = AP.acceptObject accept
|
||||
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
|
||||
|
||||
projectHash <- encodeKeyHashid projectID
|
||||
let topicByHash = LocalActorProject projectHash
|
||||
|
||||
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
|
||||
|
||||
let uRemove = AP.acceptObject accept
|
||||
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)
|
||||
|
||||
checkExistingComponents
|
||||
:: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE ()
|
||||
checkExistingComponents projectID componentDB = do
|
||||
|
|
|
|||
Loading…
Reference in a new issue