S2S: Project: Revoke: Handle parent revoking the delegator-Grant

src/Vervis/Actor/Project.hs

@@ -4848,6 +4848,218 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
             Just () ->
                 done "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 parent revoking a delegator-Grant it gave me:
+--          * Delete the whole Dest record
+--          * Forward the Revoke to my followers
+--          * Send Accept to parent+followers & my followers
+--      * If it's a child 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
+--            parent/collab/team), send a Revoke
+projectRevoke
+    :: UTCTime
+    -> ProjectId
+    -> Verse
+    -> AP.Revoke URIMode
+    -> ActE (Text, Act (), Next)
+projectRevoke now projectID (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 <$> tryParent revokedFirstDB) <|>
+                runExceptT (Right <$> lift mzero)
+        fromMaybeE
+            maybeMode
+            "Revoked activity isn't a relevant Grant I'm aware of"
+
+    case mode of
+        Left p -> revokeParent revokedRest p
+        Right () -> error "revokeChild c"
+
+    where
+
+    verifyDestHolder :: DestId -> ActDBE ()
+    verifyDestHolder destID = do
+        mh <- lift $ getValBy $ UniqueDestHolderProject destID
+        case mh of
+            Just (DestHolderProject _ j) | j == projectID -> pure ()
+            _ -> throwE "Revoke object is a Grant for some other project/team"
+
+    tryParent' usAcceptID send = do
+        DestUsAccept destID _ <- lift $ lift $ getJust usAcceptID
+        ExceptT $ lift $ runExceptT $ verifyDestHolder destID
+        topic <- do
+            t <- lift . lift $ getDestTopic destID
+            bitraverse
+                (\ (l, k) ->
+                    case k of
+                        Left j -> pure (l, j)
+                        Right _ -> error "Project Dest topic is a Group, impossible"
+                )
+                pure
+                t
+        return (destID, usAcceptID, topic, send)
+
+    tryParent (Left (_actorByKey, _actorEntity, itemID)) = do
+        Entity sendID (DestThemSendDelegatorLocal usAcceptID _localID _) <-
+            lift $ MaybeT $ getBy $ UniqueDestThemSendDelegatorLocalGrant itemID
+        tryParent' usAcceptID (Left sendID) --(Left localID)
+    tryParent (Right remoteActivityID) = do
+        Entity sendID (DestThemSendDelegatorRemote usAcceptID _remoteID _) <-
+            lift $ MaybeT $ getBy $ UniqueDestThemSendDelegatorRemoteGrant remoteActivityID
+        tryParent' usAcceptID (Right sendID) --(Right remoteID)
+
+    revokeParent revokedRest (destID, usAcceptID, parent, send) = do
+
+        let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
+        unless (author == bimap (LocalActorProject . snd) snd parent) $
+            throwE "Sender isn't the parent Project he revoked Grant came from"
+
+        unless (null revokedRest) $
+            throwE "Parent revoking the delegator-Grant and something more"
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (project, actorRecip) <- lift $ do
+                p <- getJust projectID
+                (p,) <$> getJust (projectActor p)
+
+            maybeRevokeDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for maybeRevokeDB $ \ _revokeDB -> do
+
+                -- Delete uses of this Dest from my Component records
+                case send of
+                    Left sendID ->
+                        deleteWhere [ComponentGatherLocalParent ==. sendID]
+                    Right sendID ->
+                        deleteWhere [ComponentGatherRemoteParent ==. sendID]
+
+                -- Delete uses of this Dest from my Source records
+                case send of
+                    Left sendID -> do
+                        gatherIDs <-
+                            map (sourceUsGatherToLocalGather . entityVal) <$>
+                                selectList [SourceUsGatherToLocalTo ==. sendID] []
+                        deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs]
+                        deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs]
+                        deleteWhere [SourceUsGatherToLocalGather <-. gatherIDs]
+                        deleteWhere [SourceUsGatherId <-. gatherIDs]
+                    Right sendID -> do
+                        gatherIDs <-
+                            map (sourceUsGatherToRemoteGather . entityVal) <$>
+                                selectList [SourceUsGatherToRemoteTo ==. sendID] []
+                        deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs]
+                        deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs]
+                        deleteWhere [SourceUsGatherToRemoteGather <-. gatherIDs]
+                        deleteWhere [SourceUsGatherId <-. gatherIDs]
+
+                -- Delete the whole Dest record
+                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 parent of
+                    Left (l, _j) -> do
+                        deleteBy $ UniqueDestTopicProjectTopic l
+                        delete l
+                    Right (r, _) -> delete r
+                deleteBy $ UniqueDestHolderProject destID
+                delete destID
+
+                -- Prepare forwarding Remove to my followers
+                sieve <- lift $ do
+                    topicHash <- encodeKeyHashid projectID
+                    let topicByHash =
+                            LocalActorProject topicHash
+                    return $ makeRecipientSet [] [localActorFollowers topicByHash]
+
+                -- Prepare Accept activity
+                accept@(actionAccept, _, _, _) <- prepareAccept
+                let recipByKey = LocalActorProject projectID
+                acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
+                _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept
+
+                return (projectActor project, sieve, acceptID, accept)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (topicActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
+                let topicByID = LocalActorProject projectID
+                forwardActivity authorIdMsig body topicByID topicActorID sieve
+                lift $
+                    sendActivity
+                        topicByID topicActorID localRecipsAccept
+                        remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+                done "Deleted the Parent/Dest, forwarded Revoke, sent Accept"
+
+        where
+
+        prepareAccept = do
+            encodeRouteHome <- getEncodeRouteHome
+
+            audParent <- makeAudSenderWithFollowers authorIdMsig
+            audMe <-
+                AudLocal [] . pure . LocalStageProjectFollowers <$>
+                    encodeKeyHashid projectID
+            uRevoke <- lift $ getActivityURI authorIdMsig
+
+            let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audParent, 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)
+
 -- Meaning: An actor is undoing some previous action
 -- Behavior:
 --      * If they're undoing their Following of me:
@@ -4983,6 +5195,7 @@ projectBehavior now projectID (Left verse@(Verse _authorIdMsig body)) =
         AP.JoinActivity join     -> projectJoin now projectID verse join
         AP.RejectActivity reject -> projectReject now projectID verse reject
         AP.RemoveActivity remove -> projectRemove now projectID verse remove
+        AP.RevokeActivity revoke -> projectRevoke now projectID verse revoke
         AP.UndoActivity undo     -> projectUndo now projectID verse undo
         _ -> throwE "Unsupported activity type for Project"
 projectBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Project"