diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index f5aae90..5ee206a 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -2883,24 +2883,954 @@ groupReject -> ActE (Text, Act (), Next) 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: --- * Verify the resource is me --- * Verify A isn't removing themselves --- * Verify A is authorized by me to remove actors from me --- * Verify B already has a Grant for me --- * Remove the whole Collab record from DB --- * Forward the Remove to my followers --- * Send a Revoke: --- * To: Actor B --- * CC: Actor A, B's followers, my followers +-- * If C is my collaborators collection: +-- * Verify A isn't removing themselves +-- * Verify A is authorized by me to remove actors from me +-- * Verify B already has a Grant for me +-- * Remove the whole Collab record from DB +-- * Forward the Remove to my followers +-- * Send a Revoke: +-- * To: Actor B +-- * 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 :: UTCTime -> GroupId -> Verse -> AP.Remove URIMode -> 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 -- Behavior: