diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index c51f963..c073c0d 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -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