diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 5ee206a..6fd045c 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -3832,6 +3832,366 @@ groupRemove now groupID (Verse authorIdMsig body) remove = do Just inboxItemID -> doneDB inboxItemID "[Child-passive] Saw the removal attempt, just waiting for the Revoke" +-- Meaning: An actor is revoking Grant activities +-- Behavior: +-- * For each revoked activity: +-- * If it's a child revoking a delegator-Grant it gave me: +-- * Delete the whole Dest record +-- * Forward the Revoke to my followers +-- * Send Accept to child+followers & my followers +-- * If it's a parent revoking a Grant it had extended to me: +-- * Delete that extension from my Source record +-- * For each further extension I did on that Grant (to a +-- child/collab), send a Revoke +groupRevoke + :: UTCTime + -> GroupId + -> Verse + -> AP.Revoke URIMode + -> ActE (Text, Act (), Next) +groupRevoke now groupID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lusRest)) = do + + ObjURI h _ <- lift $ getActorURI authorIdMsig + parseRevoked <- do + hl <- hostIsLocal h + return $ + \ lu -> + if hl + then + Left . (\ (a, _, i) -> (a, i)) <$> + parseLocalActivityURI' lu + else pure $ Right lu + revokedFirst <- parseRevoked luFirst + revokedRest <- traverse parseRevoked lusRest + + mode <- withDBExcept $ do + + revokedFirstDB <- do + a <- getActivity $ second (ObjURI h) revokedFirst + fromMaybeE a "Can't find revoked in DB" + + let adapt = maybe (Right Nothing) (either Left (Right . Just)) + maybeMode <- + ExceptT $ fmap adapt $ runMaybeT $ + runExceptT (Left <$> tryChild revokedFirstDB) <|> + runExceptT (Right <$> tryParent revokedFirstDB) + fromMaybeE + maybeMode + "Revoked activity isn't a relevant Grant I'm aware of" + + case mode of + Left p -> revokeChild revokedRest p + Right c -> revokeParent revokedRest c + + where + + verifyDestHolder :: DestId -> MaybeT ActDB () + verifyDestHolder destID = do + DestHolderGroup _ j <- MaybeT $ getValBy $ UniqueDestHolderGroup destID + guard $ j == groupID + + tryChild' usAcceptID send = do + DestUsAccept destID _ <- lift $ lift $ getJust usAcceptID + lift $ verifyDestHolder destID + topic <- do + t <- lift . lift $ getDestTopic destID + bitraverse + (\ (l, k) -> + case k of + Right j -> pure (l, j) + Left _ -> error "Group Dest topic is a Project, impossible" + ) + pure + t + return (destID, usAcceptID, topic, send) + + tryChild (Left (_actorByKey, _actorEntity, itemID)) = do + Entity sendID (DestThemSendDelegatorLocal usAcceptID _localID _) <- + lift $ MaybeT $ getBy $ UniqueDestThemSendDelegatorLocalGrant itemID + tryChild' usAcceptID (Left sendID) --(Left localID) + tryChild (Right remoteActivityID) = do + Entity sendID (DestThemSendDelegatorRemote usAcceptID _remoteID _) <- + lift $ MaybeT $ getBy $ UniqueDestThemSendDelegatorRemoteGrant remoteActivityID + tryChild' usAcceptID (Right sendID) --(Right remoteID) + + verifySourceHolder :: SourceId -> MaybeT ActDB () + verifySourceHolder sourceID = do + SourceHolderGroup _ j <- MaybeT $ getValBy $ UniqueSourceHolderGroup sourceID + guard $ j == groupID + + tryParent' sourceID child = do + lift $ verifySourceHolder sourceID + sendID <- lift $ MaybeT $ getKeyBy $ UniqueSourceUsSendDelegator sourceID + return (sendID, child) + + tryParent (Left (_actorByKey, _actorEntity, itemID)) = do + Entity delegID (SourceThemDelegateLocal themAcceptID _) <- + lift $ MaybeT $ getBy $ UniqueSourceThemDelegateLocal itemID + SourceThemAcceptLocal topicID _ <- lift $ lift $ getJust themAcceptID + SourceTopicLocal sourceID <- lift $ lift $ getJust topicID + SourceTopicGroup _ _ j <- do + mj <- lift $ lift $ getValBy $ UniqueSourceTopicGroupTopic topicID + fromMaybeE mj "The parent to whom this revoked Grant was sent isn't a Group" + tryParent' sourceID $ Left (topicID, j, delegID, themAcceptID) + tryParent (Right remoteActivityID) = do + Entity delegID (SourceThemDelegateRemote themAcceptID _) <- + lift $ MaybeT $ getBy $ UniqueSourceThemDelegateRemote remoteActivityID + SourceThemAcceptRemote topicID _ <- lift $ lift $ getJust themAcceptID + SourceTopicRemote sourceID actorID <- lift $ lift $ getJust topicID + tryParent' sourceID $ Right (topicID, actorID, delegID, themAcceptID) + + revokeChild revokedRest (destID, usAcceptID, child, send) = do + + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + unless (author == bimap (LocalActorGroup . snd) snd child) $ + throwE "Sender isn't the child Group the revoked Grant came from" + + unless (null revokedRest) $ + throwE "Child revoking the delegator-Grant and something more" + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (group, actorRecip) <- lift $ do + p <- getJust groupID + (p,) <$> getJust (groupActor p) + + maybeRevokeDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for maybeRevokeDB $ \ (inboxItemID, _revokeDB) -> do + + maybeStartID <- getKeyBy $ UniqueDestUsStart usAcceptID + + -- Delete uses of this Dest from my Effort records + --for_ maybeStartID $ \ destStartID -> + -- deleteWhere [ComponentGatherChild ==. destStartID] + + -- Delete uses of this Dest from my Source records + for_ maybeStartID $ \ destStartID -> do + gatherIDs <- selectKeysList [SourceUsGatherDest ==. destStartID] [] + deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs] + deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs] + deleteWhere [SourceUsGatherId <-. gatherIDs] + + -- Delete the whole Dest record + for_ maybeStartID delete + case send 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 child of + Left (l, _j) -> do + deleteBy $ UniqueDestTopicGroupTopic l + delete l + Right (r, _) -> delete r + deleteBy $ UniqueDestHolderGroup destID + 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 + 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 "Deleted the Child/Dest, forwarded Revoke, sent Accept" + + where + + prepareAccept = do + encodeRouteHome <- getEncodeRouteHome + + audChild <- makeAudSenderWithFollowers authorIdMsig + audMe <- + AudLocal [] . pure . LocalStageGroupFollowers <$> + encodeKeyHashid groupID + uRevoke <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audChild, audMe] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uRevoke] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uRevoke + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + revokeParent revokedRest (sendID, parent) = do + + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + unless (author == bimap (LocalActorGroup . view _2) (view _2) parent) $ + throwE "Sender isn't the parent Group the revoked Grant came from" + + unless (null revokedRest) $ + throwE "Parent revoking the start/extension-Grant and something more" + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (group, actorRecip) <- lift $ do + p <- getJust groupID + (p,) <$> getJust (groupActor p) + + maybeRevokeDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for maybeRevokeDB $ \ (inboxItemID, _revokeDB) -> do + + -- Collect the extensions I'll need to revoke + gatherIDs <- + case parent of + Left (_, _, delegID, _) -> + map (sourceUsGatherFromLocalGather . entityVal) <$> + selectList [SourceUsGatherFromLocalFrom ==. delegID] [] + Right (_, _, delegID, _) -> + map (sourceUsGatherFromRemoteGather . entityVal) <$> + selectList [SourceUsGatherFromRemoteFrom ==. delegID] [] + gathers <- selectList [SourceUsGatherId <-. gatherIDs] [] + leafIDs <- + case parent of + Left (_, _, delegID, _) -> + map (sourceUsLeafFromLocalLeaf . entityVal) <$> + selectList [SourceUsLeafFromLocalFrom ==. delegID] [] + Right (_, _, delegID, _) -> + map (sourceUsLeafFromRemoteLeaf . entityVal) <$> + selectList [SourceUsLeafFromRemoteFrom ==. delegID] [] + leafs <- selectList [SourceUsLeafId <-. leafIDs] [] + + -- Delete the records of these extensions + deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs] + deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs] + deleteWhere [SourceUsGatherId <-. gatherIDs] + deleteWhere [SourceUsLeafFromLocalLeaf <-. leafIDs] + deleteWhere [SourceUsLeafFromRemoteLeaf <-. leafIDs] + deleteWhere [SourceUsLeafToLocalLeaf <-. leafIDs] + deleteWhere [SourceUsLeafToRemoteLeaf <-. leafIDs] + deleteWhere [SourceUsLeafId <-. leafIDs] + case parent of + Left (_, _, delegID, _) -> delete delegID + Right (_, _, delegID, _) -> delete delegID + + -- 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, revokes, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, revokes, inboxItemID) -> do + let topicByID = LocalActorGroup groupID + lift $ for_ revokes $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + topicByID topicActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + doneDB inboxItemID "Deleted the SourceThemDelegate* record, sent Revokes" + + where + + 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 + + uRevoke <- 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 = [uRevoke] + , AP.actionSpecific = AP.RevokeActivity AP.Revoke + { AP.revokeObject = luGrant :| [] + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + -- Meaning: An actor is undoing some previous action -- Behavior: -- * If they're undoing their Following of me: @@ -3967,6 +4327,7 @@ groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) = AP.JoinActivity join -> groupJoin now groupID verse join AP.RejectActivity reject -> groupReject now groupID verse reject AP.RemoveActivity remove -> groupRemove now groupID verse remove + AP.RevokeActivity revoke -> groupRevoke now groupID verse revoke AP.UndoActivity undo -> groupUndo now groupID verse undo _ -> throwE "Unsupported activity type for Group" groupBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Group"