S2S: Project: Revoke: Implement component & team modes

src/Vervis/Actor/Person/Client.hs

@@ -1249,9 +1249,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs _ mluMembers _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
-                unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
-                    throwE "Remove origin isn't a collabs list"
                 return $ ObjURI h lu
             )
             resource

src/Vervis/Actor/Project.hs

@@ -5018,6 +5018,14 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
 --          * Delete that extension from my Source record
 --          * For each further extension I did on that Grant (to a
 --            parent/collab/team), send a Revoke
+--      * If it's a team revoking a delegator-Grant it gave me:
+--          * Delete the whole Squad record
+--          * Forward the Revoke to my followers
+--          * Send Accept to team+followers & my followers
+--      * If it's a component revoking a Grant it had extended to me:
+--          * Delete that extension from my Component record
+--          * For each further extension I did on that Grant (to a
+--            parent/collab/team), send a Revoke
 projectRevoke
     :: UTCTime
     -> ProjectId
@@ -5045,18 +5053,24 @@ projectRevoke now projectID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lus
             a <- getActivity $ second (ObjURI h) revokedFirst
             fromMaybeE a "Can't find revoked in DB"
 
+        meResourceID <- lift $ projectResource <$> getJust projectID
+
         let adapt = maybe (Right Nothing) (either Left (Right . Just))
         maybeMode <-
             ExceptT $ fmap adapt $ runMaybeT $
-                runExceptT (Left <$> tryParent revokedFirstDB) <|>
+                runExceptT (Left . Left <$> tryParent revokedFirstDB) <|>
-                runExceptT (Right <$> tryChild revokedFirstDB)
+                runExceptT (Left . Right <$> tryChild revokedFirstDB) <|>
+                runExceptT (Right . Left <$> tryTeam meResourceID revokedFirstDB) <|>
+                runExceptT (Right . Right <$> tryComponent revokedFirstDB)
         fromMaybeE
             maybeMode
             "Revoked activity isn't a relevant Grant I'm aware of"
 
     case mode of
-        Left p -> revokeParent revokedRest p
+        Left (Left p) -> revokeParent revokedRest p
-        Right c -> revokeChild revokedRest c
+        Left (Right c) -> revokeChild revokedRest c
+        Right (Left t) -> revokeTeam revokedRest t
+        Right (Right c) -> revokeComponent revokedRest c
 
     where
 
@@ -5115,6 +5129,48 @@ projectRevoke now projectID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lus
         SourceTopicRemote sourceID actorID <- lift $ lift $ getJust topicID
         tryChild' sourceID $ Right (topicID, actorID, delegID, themAcceptID)
 
+    verifySquadHolder :: ResourceId -> SquadId -> MaybeT ActDB ()
+    verifySquadHolder meResourceID squadID = do
+        Squad _ resourceID <- lift $ getJust squadID
+        guard $ resourceID == meResourceID
+
+    tryTeam' meResourceID usAcceptID send = do
+        SquadUsAccept squadID _ <- lift $ lift $ getJust usAcceptID
+        lift $ verifySquadHolder meResourceID squadID
+        topic <- lift . lift $ getSquadTeam squadID
+        return (squadID, usAcceptID, topic, send)
+
+    tryTeam r (Left (_actorByKey, _actorEntity, itemID)) = do
+        Entity sendID (SquadThemSendDelegatorLocal usAcceptID _localID _) <-
+            lift $ MaybeT $ getBy $ UniqueSquadThemSendDelegatorLocalGrant itemID
+        tryTeam' r usAcceptID (Left sendID) --(Left localID)
+    tryTeam r (Right remoteActivityID) = do
+        Entity sendID (SquadThemSendDelegatorRemote usAcceptID _remoteID _) <-
+            lift $ MaybeT $ getBy $ UniqueSquadThemSendDelegatorRemoteGrant remoteActivityID
+        tryTeam' r usAcceptID (Right sendID) --(Right remoteID)
+
+    verifyComponentHolder :: ComponentId -> MaybeT ActDB ()
+    verifyComponentHolder componentID = do
+        Component j _ <- lift $ getJust componentID
+        guard $ j == projectID
+
+    tryComponent' componentID component = do
+        lift $ verifyComponentHolder componentID
+        enableID <- lift $ MaybeT $ getKeyBy $ UniqueComponentEnable componentID
+        return (enableID, component)
+
+    tryComponent (Left (_actorByKey, _actorEntity, itemID)) = do
+        Entity delegID (ComponentDelegateLocal topicID _) <-
+            lift $ MaybeT $ getBy $ UniqueComponentDelegateLocalGrant itemID
+        ComponentLocal componentID komponentID <- lift $ lift $ getJust topicID
+        compByKey <- lift $ lift $ getLocalComponent komponentID
+        tryComponent' componentID $ Left (topicID, compByKey, komponentID, delegID)
+    tryComponent (Right remoteActivityID) = do
+        Entity delegID (ComponentDelegateRemote topicID _) <-
+            lift $ MaybeT $ getBy $ UniqueComponentDelegateRemoteGrant remoteActivityID
+        ComponentRemote componentID actorID <- lift $ lift $ getJust topicID
+        tryComponent' componentID $ Right (topicID, actorID, delegID)
+
     revokeParent revokedRest (destID, usAcceptID, parent, send) = do
 
         let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
@@ -5367,6 +5423,240 @@ projectRevoke now projectID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lus
 
             return (action, recipientSet, remoteActors, fwdHosts)
 
+    revokeTeam revokedRest (squadID, usAcceptID, team, send) = do
+
+        let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
+        unless (author == bimap (LocalActorGroup . snd) snd team) $
+            throwE "Sender isn't the Team the revoked Grant came from"
+
+        unless (null revokedRest) $
+            throwE "Team 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 $ \ (inboxItemID, _revokeDB) -> do
+
+                maybeStartID <- getKeyBy $ UniqueSquadUsStart usAcceptID
+
+                -- Delete uses of this Squad from my Component records
+                for_ maybeStartID $ \ squadStartID ->
+                    deleteWhere [ComponentConveyTeam ==. squadStartID]
+
+                -- Delete uses of this Squad from my Source records
+                for_ maybeStartID $ \ squadStartID -> do
+                    conveyIDs <- selectKeysList [SourceUsConveyTeam ==. squadStartID] []
+                    deleteWhere [SourceUsConveyFromLocalConvey <-. conveyIDs]
+                    deleteWhere [SourceUsConveyFromRemoteConvey <-. conveyIDs]
+                    deleteWhere [SourceUsConveyId <-. conveyIDs]
+
+                -- Delete the whole Squad record
+                for_ maybeStartID delete
+                case send of
+                    Left sendID -> delete sendID
+                    Right sendID -> delete sendID
+                origin <-
+                    requireEitherAlt
+                        (getKeyBy $ UniqueSquadOriginUs squadID)
+                        (getKeyBy $ UniqueSquadOriginThem squadID)
+                        "Neither us nor them"
+                        "Both us and them"
+                deleteBy $ UniqueSquadUsGestureLocal squadID
+                deleteBy $ UniqueSquadUsGestureRemote squadID
+                case origin of
+                    Left usID -> delete usID
+                    Right themID -> do
+                        deleteBy $ UniqueSquadThemAcceptLocal themID
+                        deleteBy $ UniqueSquadThemAcceptRemote themID
+                        deleteBy $ UniqueSquadThemGestureLocal themID
+                        deleteBy $ UniqueSquadThemGestureRemote themID
+                        delete themID
+                delete usAcceptID
+                case team of
+                    Left (l, _) -> delete l
+                    Right (r, _) -> delete r
+                delete squadID
+
+                -- 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, 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 = LocalActorProject projectID
+                forwardActivity authorIdMsig body topicByID topicActorID sieve
+                lift $
+                    sendActivity
+                        topicByID topicActorID localRecipsAccept
+                        remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+                doneDB inboxItemID "Deleted the Team/Squad, forwarded Revoke, sent Accept"
+
+        where
+
+        prepareAccept = do
+            encodeRouteHome <- getEncodeRouteHome
+
+            audTeam <- makeAudSenderWithFollowers authorIdMsig
+            audMe <-
+                AudLocal [] . pure . LocalStageProjectFollowers <$>
+                    encodeKeyHashid projectID
+            uRevoke <- lift $ getActivityURI authorIdMsig
+
+            let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audTeam, 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)
+
+    revokeComponent revokedRest (enableID, component) = do
+
+        let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
+        unless (author == bimap (resourceToActor . componentResource . view _2) (view _2) component) $
+            throwE "Sender isn't the component the revoked Grant came from"
+
+        unless (null revokedRest) $
+            throwE "Component revoking the start-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 $ \ (inboxItemID, _revokeDB) -> do
+
+                -- Collect the extensions I'll need to revoke
+                furthersL <- selectList [ComponentFurtherLocalComponent ==. enableID] []
+                furthersR <- selectList [ComponentFurtherRemoteComponent ==. enableID] []
+                gathers <- selectList [ComponentGatherComponent ==. enableID] []
+                conveys <- selectList [ComponentConveyComponent ==. enableID] []
+
+                -- Delete the records of these extensions
+                deleteWhere [ComponentFurtherLocalComponent ==. enableID]
+                deleteWhere [ComponentFurtherRemoteComponent ==. enableID]
+                deleteWhere [ComponentGatherComponent ==. enableID]
+                deleteWhere [ComponentConveyComponent ==. enableID]
+                case component of
+                    Left (_, _, _, delegID) -> delete delegID
+                    Right (_, _, delegID) -> delete delegID
+
+                -- Prepare and insert Revokes on all the extension-Grants
+                revokesFL <- for furthersL $ \ (Entity _ (ComponentFurtherLocal _ delegID grantID)) -> do
+                    CollabDelegLocal _ recipID _ <- getJust delegID
+                    CollabRecipLocal _ personID <- getJust recipID
+                    return (Left $ LocalActorPerson personID, grantID)
+                revokesFR <- for furthersR $ \ (Entity _ (ComponentFurtherRemote _ delegID grantID)) -> do
+                    CollabDelegRemote _ recipID _ <- getJust delegID
+                    CollabRecipRemote _ actorID <- getJust recipID
+                    return (Right actorID, grantID)
+                revokesG <- for gathers $ \ (Entity _ (ComponentGather _ startID grantID)) -> do
+                    DestUsStart acceptID _ <- getJust startID
+                    DestUsAccept destID _ <- getJust acceptID
+                    parent <- do
+                        p <- bimap snd snd <$> 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
+                            p
+                    return (parent, grantID)
+                revokesC <- for conveys $ \ (Entity _ (ComponentConvey _ startID grantID)) -> do
+                    SquadUsStart acceptID _ <- getJust startID
+                    SquadUsAccept squadID _ <- getJust acceptID
+                    team <- bimap snd snd <$> getSquadTeam squadID
+                    return (first LocalActorGroup team, grantID)
+                revokes <- for (revokesFL ++ revokesFR ++ revokesG ++ revokesC) $ \ (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, revokes, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (topicActorID, revokes, inboxItemID) -> do
+                let topicByID = LocalActorProject projectID
+                lift $ for_ revokes $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
+                    sendActivity
+                        topicByID topicActorID localRecipsExt
+                        remoteRecipsExt fwdHostsExt extID actionExt
+                doneDB inboxItemID "Deleted the ComponentDelegate* record, sent Revokes"
+
+        where
+
+        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
+
+            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:

src/Vervis/Data/Collab.hs

@@ -368,6 +368,30 @@ parseAddTarget = \case
     GroupChildrenR g ->
         ATGroupChildren <$>
         WAP.decodeKeyHashidE g "Inavlid team children hashid"
+    RepoProjectsR k ->
+        ATRepoProjects <$>
+        WAP.decodeKeyHashidE k "Inavlid hashid"
+    DeckProjectsR k ->
+        ATDeckProjects <$>
+        WAP.decodeKeyHashidE k "Inavlid hashid"
+    LoomProjectsR k ->
+        ATLoomProjects <$>
+        WAP.decodeKeyHashidE k "Inavlid hashid"
+    ProjectTeamsR k ->
+        ATProjectTeams <$>
+        WAP.decodeKeyHashidE k "Inavlid hashid"
+    RepoTeamsR k ->
+        ATRepoTeams <$>
+        WAP.decodeKeyHashidE k "Inavlid hashid"
+    DeckTeamsR k ->
+        ATDeckTeams <$>
+        WAP.decodeKeyHashidE k "Inavlid hashid"
+    LoomTeamsR k ->
+        ATLoomTeams <$>
+        WAP.decodeKeyHashidE k "Inavlid hashid"
+    GroupEffortsR k ->
+        ATGroupEfforts <$>
+        WAP.decodeKeyHashidE k "Inavlid hashid"
     _ -> throwE "Not an Add target collection route"
 
 parseCollabs route = do
@@ -425,6 +449,11 @@ data AddTarget
     | ATRepoProjects RepoId
     | ATDeckProjects DeckId
     | ATLoomProjects LoomId
+    | ATProjectTeams ProjectId
+    | ATRepoTeams RepoId
+    | ATDeckTeams DeckId
+    | ATLoomTeams LoomId
+    | ATGroupEfforts GroupId
     deriving Eq
 
 addTargetResource :: AddTarget -> LocalResourceBy Key
@@ -437,6 +466,11 @@ addTargetResource = \case
     ATRepoProjects r -> LocalResourceRepo r
     ATDeckProjects d -> LocalResourceDeck d
     ATLoomProjects l -> LocalResourceLoom l
+    ATProjectTeams j -> LocalResourceProject j
+    ATRepoTeams r -> LocalResourceRepo r
+    ATDeckTeams d -> LocalResourceDeck d
+    ATLoomTeams l -> LocalResourceLoom l
+    ATGroupEfforts g -> LocalResourceGroup g
 
 addTargetComponentProjects = \case
     ATRepoProjects r -> Just $ ComponentRepo r
@@ -475,33 +509,7 @@ parseAdd sender (AP.Add object target role _context) = do
     parseCollection u = do
         routeOrRemote <- parseFedURI u
         bitraverse
-            (\case
+            parseAddTarget
-                ProjectComponentsR j ->
-                    ATProjectComponents <$>
-                    WAP.decodeKeyHashidE j "Inavlid project components hashid"
-                ProjectParentsR j ->
-                    ATProjectParents <$>
-                    WAP.decodeKeyHashidE j "Inavlid project parents hashid"
-                ProjectChildrenR j ->
-                    ATProjectChildren <$>
-                    WAP.decodeKeyHashidE j "Inavlid project children hashid"
-                GroupParentsR g ->
-                    ATGroupParents <$>
-                    WAP.decodeKeyHashidE g "Inavlid team parents hashid"
-                GroupChildrenR g ->
-                    ATGroupChildren <$>
-                    WAP.decodeKeyHashidE g "Inavlid team children hashid"
-                RepoProjectsR r ->
-                    ATRepoProjects <$>
-                    WAP.decodeKeyHashidE r "Inavlid repo projects hashid"
-                DeckProjectsR d ->
-                    ATDeckProjects <$>
-                    WAP.decodeKeyHashidE d "Inavlid deck projects hashid"
-                LoomProjectsR l ->
-                    ATLoomProjects <$>
-                    WAP.decodeKeyHashidE l "Inavlid loom projects hashid"
-                _ -> throwE "Not an Add target collection route"
-            )
             pure
             routeOrRemote