diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 9bd461b..e155404 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -979,6 +979,19 @@ groupAdd now groupID (Verse authorIdMsig body) add = do -- - Resource's followers -- - My followers -- - The Accept sender (my collaborator) +-- +-- * Remove-Resource-Passive mode: +-- * Verify the Effort is enabled +-- * Verify the sender is the resource +-- * Delete the entire Effort 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 child/member to whom I'd sent the Grant +-- * CC: - groupAccept :: UTCTime -> GroupId @@ -1015,7 +1028,8 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do runExceptT (Right . Left <$> tryAddChildPassive accepteeDB) <|> runExceptT (Right . Left <$> tryAddParentActive accepteeDB) <|> runExceptT (Right . Left <$> tryAddParentPassive accepteeDB) <|> - runExceptT (Right . Right <$> tryRemoveParent myInboxID accepteeDB) + runExceptT (Right . Right . Left <$> tryRemoveParent myInboxID accepteeDB) <|> + runExceptT (Right . Right . Right <$> tryRemoveResource myInboxID accepteeDB) fromMaybeE maybeCollab "Accepted activity isn't an Invite/Join/Add/Remove I'm aware of" @@ -1024,7 +1038,8 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do Left (Left collab) -> addCollab collab Left (Right resource) -> addResource resource Right (Left cp) -> addChildParent cp - Right (Right parent) -> removeParent parent + Right (Right (Left parent)) -> removeParent parent + Right (Right (Right resource)) -> removeResource resource where @@ -1247,6 +1262,23 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do lift $ MaybeT $ getValBy $ UniqueEffortThemGestureRemoteAdd remoteActivityID tryAddResourcePassive' themID + tryRemoveResource' itemID = do + EffortRemove sendID _ <- + lift $ MaybeT $ getValBy $ UniqueEffortRemove itemID + EffortUsSendDelegator effortID grantID <- lift $ lift $ getJust sendID + lift $ verifyEffortHolder effortID + topic <- lift . lift $ getEffortTopic effortID + return (effortID, sendID, grantID, topic) + + tryRemoveResource inboxID (Left (_actorByKey, _actorEntity, itemID)) = do + InboxItemLocal _ _ i <- + lift $ MaybeT $ getValBy $ UniqueInboxItemLocal inboxID itemID + tryRemoveResource' i + tryRemoveResource inboxID (Right remoteActivityID) = do + InboxItemRemote _ _ i <- + lift $ MaybeT $ getValBy $ UniqueInboxItemRemote inboxID remoteActivityID + tryRemoveResource' i + componentIsAuthor ident = let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig in author == bimap (resourceToActor . componentResource . snd) snd ident @@ -2199,6 +2231,216 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do return (action, recipientSet, remoteActors, fwdHosts) + removeResource (effortID, sendID, grantID, resource) = do + + topic <- + lift $ traverseOf _Left (traverseOf _2 $ withDB . getLocalResource) resource + + -- Verify the sender is the topic + unless (theyIsAuthor' topic) $ + throwE "The Accept isn't by the to-be-removed resource" + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (group, actorRecip) <- lift $ do + p <- getJust groupID + (p,) <$> getJust (groupActor p) + + maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do + + -- Grab extension-Grants that I'm about to revoke + distributes <- selectList [EffortUsDistributeEffort ==. sendID] [] + leafs <- selectList [EffortUsLeafEffort ==. sendID] [] + + -- Delete the whole Effort record + deleteWhere [EffortRemoveSend ==. sendID] + let distributeIDs = map entityKey distributes + deleteWhere [EffortUsDistributeFromLocalDistribute <-. distributeIDs] + deleteWhere [EffortUsDistributeFromRemoteDistribute <-. distributeIDs] + deleteWhere [EffortUsDistributeId <-. distributeIDs] + let leafIDs = map entityKey leafs + deleteWhere [EffortUsLeafFromLocalLeaf <-. leafIDs] + deleteWhere [EffortUsLeafFromRemoteLeaf <-. leafIDs] + deleteWhere [EffortUsLeafToLocalLeaf <-. leafIDs] + deleteWhere [EffortUsLeafToRemoteLeaf <-. leafIDs] + deleteWhere [EffortUsLeafId <-. leafIDs] + case resource of + Left (localID, _) -> do + acceptID <- getKeyByJust $ UniqueEffortThemAcceptLocal localID + deleteWhere [EffortThemDelegateLocalEffort ==. acceptID] + delete acceptID + Right (remoteID, _) -> do + acceptID <- getKeyByJust $ UniqueEffortThemAcceptRemote remoteID + deleteWhere [EffortThemDelegateRemoteEffort ==. acceptID] + delete acceptID + delete sendID + origin <- + requireEitherAlt + (getKeyBy $ UniqueEffortOriginUs effortID) + (getKeyBy $ UniqueEffortOriginThem effortID) + "Neither us nor them" + "Both us and them" + case origin of + Left usID -> do + deleteBy $ UniqueEffortUsAccept usID + deleteBy $ UniqueEffortUsGestureLocal usID + deleteBy $ UniqueEffortUsGestureRemote usID + delete usID + Right themID -> do + deleteBy $ UniqueEffortThemGestureLocal themID + deleteBy $ UniqueEffortThemGestureRemote themID + delete themID + case resource of + Left (l, _) -> delete l + Right (r, _) -> delete r + delete effortID + + -- 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, _, _, _) <- prepareMainRevoke (bimap snd snd topic) grantID + let recipByKey = LocalActorGroup groupID + revokeID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now + _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke + + -- Prepare and insert Revokes on all the extension-Grants + revokesD <- for distributes $ \ (Entity _ (EffortUsDistribute _ startID grantID)) -> do + DestUsStart acceptID _ <- getJust startID + DestUsAccept destID _ <- getJust acceptID + resource <- do + p <- getDestTopic destID + bitraverse + (\case + Right j -> pure $ LocalActorGroup j + Left _ -> error "I'm a group but I have a resource who is a Project" + ) + pure + (bimap snd snd p) + return (resource, grantID) + revokesL <- for leafs $ \ (Entity _ (EffortUsLeaf _ enableID grantID)) -> do + CollabEnable collabID _ <- getJust enableID + recip <- getCollabRecip collabID + return + ( bimap + (LocalActorPerson . collabRecipLocalPerson . entityVal) + (collabRecipRemoteActor . entityVal) + recip + , grantID + ) + revokes <- for (revokesD ++ 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 "[Remove-Resource mode] Deleted the Resource/Effort, forwarded Accept, sent Revokes" + + where + + prepareMainRevoke resource grantID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + recipHash <- encodeKeyHashid groupID + let topicByHash = LocalActorGroup recipHash + + resourceHash <- bitraverse hashLocalResource pure resource + + audRemover <- lift $ makeAudSenderOnly authorIdMsig + audResource <- + case resourceHash of + Left lr -> + let la = resourceToActor lr + in pure $ AudLocal [la] [localActorFollowers la] + 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, audResource, 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 + + 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 + + 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) + -- Meaning: Someone has created a group with my ID URI -- Behavior: -- * Verify I'm in a just-been-created state