S2S: Group: Port Revoke handler from Project

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"