S2S: Project: Remove: Implement team mode

src/Vervis/Actor/Project.hs

@@ -5214,6 +5214,15 @@ projectReject = topicReject projectResource LocalResourceProject
 --              * To: Actor B
 --              * CC: Actor A, B's followers, my followers
 --
+--      * If C is my teams collection:
+--          * Verify A is authorized by me to remove teams from me
+--          * Verify B is an active team of mine
+--          * Remove the whole Squad 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 parents of a child of mine:
 --          * Record this Remove in the Source record
 --          * Forward to followers
@@ -5225,6 +5234,10 @@ projectReject = topicReject projectResource LocalResourceProject
 --      * If I'm B, being removed from the projects of a component of mine:
 --          * Do nothing, just waiting for component to send a Revoke on the
 --            start-Grant
+--
+--      * If I'm B, being removed from the resources of a team of mine:
+--          * Do nothing, just waiting for team to send a Revoke on the
+--            delegator-Grant
 projectRemove
     :: UTCTime
     -> ProjectId
@@ -5244,12 +5257,16 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
             removeChildActive item
         (Left (Right (ATProjectParents j)), _) | j == projectID ->
             removeParentActive item
+        (Left (Right (ATProjectTeams j)), _) | j == projectID ->
+            removeTeamActive item
         (_, Left (LocalActorProject j)) | j == projectID ->
             case collection of
                 Left (Right (ATProjectParents j)) | j /= projectID ->
                     removeChildPassive $ Left j
                 Left (Right (ATProjectChildren j)) | j /= projectID ->
                     removeParentPassive $ Left j
+                Left (Right (ATGroupEfforts g)) ->
+                    removeTeamPassive $ Left g
                 Left (Right at) | isJust (addTargetComponentProjects at) ->
                     removeComponentPassive $ Left $ fromJust $ addTargetComponentProjects at
                 Right (ObjURI h luColl) -> do
@@ -5264,16 +5281,14 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
                             AP.ResourceActor a -> pure a
                             AP.ResourceChild _ _ -> throwE "Remove.origin remote ResourceChild"
                     let typ = AP.actorType d
-
-
-
-
                     if typ == AP.ActorTypeProject && Just luColl == AP.rwcSubprojects rwc
                         then removeParentPassive $ Right $ ObjURI h lu
                     else if typ == AP.ActorTypeProject && Just luColl == AP.rwcParentsOrProjects rwc
                         then removeChildPassive $ Right $ ObjURI h lu
                     else if AP.actorTypeIsComponent typ && Just luColl == AP.rwcParentsOrProjects rwc
                         then removeComponentPassive $ Right $ ObjURI h lu
+                    else if typ == AP.ActorTypeTeam && Just luColl == AP.rwcTeamResources rwc
+                        then removeTeamPassive $ Right $ ObjURI h lu
                     else throwE "Weird collection situation"
                 _ -> throwE "I'm being removed from somewhere irrelevant"
         _ -> throwE "This Remove isn't for me"
@@ -6575,6 +6590,287 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
             Just inboxItemID ->
                 doneDB inboxItemID "[Component-passive] Saw the removal attempt, just waiting for the Revoke"
 
+    removeTeamActive team = do
+
+        -- If team is local, find it in our DB
+        -- If team is remote, HTTP GET it, verify it's an actor of Project
+        -- 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.
+        teamDB <-
+            bitraverse
+                (\case
+                    LocalActorGroup g -> withDBExcept $ getEntityE g "Team not found in DB"
+                    _ -> throwE "Local proposed team 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 "Team @id mismatch"
+                        Left (Just err) -> throwE $ T.pack $ displayException err
+                        Right Nothing -> throwE "Team isn't an actor"
+                        Right (Just actor) -> do
+                            case remoteActorType $ entityVal actor of
+                                AP.ActorTypeTeam -> pure ()
+                                _ -> throwE "Remote team type isn't Team"
+                            return (u, actor)
+                )
+                team
+
+        -- 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 team
+        verifyCapability''
+            uCap
+            authorIdMsig
+            (LocalResourceProject projectID)
+            AP.RoleAdmin
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (project, actorRecip) <- lift $ do
+                p <- getJust projectID
+                (p,) <$> getJust (projectActor p)
+
+            -- Verify it's an active team of mine
+            squads <- lift $ case teamDB of
+                Left (Entity g _) ->
+                    fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Left (t, s))) $
+                    E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do
+                        E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad
+                        E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad
+                        E.on $ topic E.^. SquadTopicLocalId E.==. send E.^. SquadThemSendDelegatorLocalTopic
+                        E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicLocalSquad
+                        E.where_ $
+                            squad E.^. SquadHolder E.==. E.val (projectResource project) E.&&.
+                            topic E.^. SquadTopicLocalGroup E.==. E.val g
+                        return
+                            ( squad E.^. SquadId
+                            , send E.^. SquadThemSendDelegatorLocalSquad
+                            , start E.^. SquadUsStartId
+                            , topic E.^. SquadTopicLocalId
+                            , send E.^. SquadThemSendDelegatorLocalId
+                            )
+                Right (_, Entity a _) ->
+                    fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Right (t, s))) $
+                    E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do
+                        E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad
+                        E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad
+                        E.on $ topic E.^. SquadTopicRemoteId E.==. send E.^. SquadThemSendDelegatorRemoteTopic
+                        E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicRemoteSquad
+                        E.where_ $
+                            squad E.^. SquadHolder E.==. E.val (projectResource project) E.&&.
+                            topic E.^. SquadTopicRemoteTopic E.==. E.val a
+                        return
+                            ( squad E.^. SquadId
+                            , send E.^. SquadThemSendDelegatorRemoteSquad
+                            , start E.^. SquadUsStartId
+                            , topic E.^. SquadTopicRemoteId
+                            , send E.^. SquadThemSendDelegatorRemoteId
+                            )
+
+            (E.Value squadID, E.Value usAcceptID, E.Value squadStartID, topic) <-
+                verifySingleE squads "No squad" "Multiple squads"
+
+            maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
+            lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
+
+                -- Delete uses of this Squad from my Component records
+                deleteWhere [ComponentConveyTeam ==. squadStartID]
+
+                -- Delete uses of this Squad from my Source records
+                conveyIDs <- selectKeysList [SourceUsConveyTeam ==. squadStartID] []
+                deleteWhere [SourceUsConveyFromLocalConvey <-. conveyIDs]
+                deleteWhere [SourceUsConveyFromRemoteConvey <-. conveyIDs]
+                deleteWhere [SourceUsConveyId <-. conveyIDs]
+
+                -- Delete the whole Squad record
+                delete squadStartID
+                case topic 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 topic 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 teamDB
+                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 "[Team-active] Deleted the Team/Squad, forwarded Remove, sent Accept"
+
+        where
+
+        prepareAccept teamDB = do
+            encodeRouteHome <- getEncodeRouteHome
+
+            audRemover <- lift $ makeAudSenderOnly authorIdMsig
+            audTeam <-
+                case teamDB of
+                    Left (Entity g _) -> do
+                        h <- encodeKeyHashid g
+                        return $ AudLocal [LocalActorGroup h] [LocalStageGroupFollowers h]
+                    Right (ObjURI h lu, Entity _ ra) ->
+                        return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
+            audMe <-
+                AudLocal [] . pure . LocalStageProjectFollowers <$>
+                    encodeKeyHashid projectID
+            uRemove <- lift $ getActivityURI authorIdMsig
+
+            let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audRemover, audTeam, 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)
+
+    removeTeamPassive team = do
+
+        -- If team is local, find it in our DB
+        -- If team is remote, HTTP GET it, verify it's an actor of Project
+        -- 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.
+        teamDB <-
+            bitraverse
+                (\ g -> withDBExcept $ getEntityE g "Team 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 "Team @id mismatch"
+                        Left (Just err) -> throwE $ T.pack $ displayException err
+                        Right Nothing -> throwE "Team isn't an actor"
+                        Right (Just actor) -> do
+                            case remoteActorType $ entityVal actor of
+                                AP.ActorTypeTeam -> pure ()
+                                _ -> throwE "Remote team type isn't Team"
+                            return (u, actor)
+                )
+                team
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (project, actorRecip) <- lift $ do
+                p <- getJust projectID
+                (p,) <$> getJust (projectActor p)
+
+            -- Verify it's an active team of mine
+            squads <- lift $ case teamDB of
+                Left (Entity g _) ->
+                    fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Left (t, s))) $
+                    E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do
+                        E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad
+                        E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad
+                        E.on $ topic E.^. SquadTopicLocalId E.==. send E.^. SquadThemSendDelegatorLocalTopic
+                        E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicLocalSquad
+                        E.where_ $
+                            squad E.^. SquadHolder E.==. E.val (projectResource project) E.&&.
+                            topic E.^. SquadTopicLocalGroup E.==. E.val g
+                        return
+                            ( squad E.^. SquadId
+                            , send E.^. SquadThemSendDelegatorLocalSquad
+                            , start E.^. SquadUsStartId
+                            , topic E.^. SquadTopicLocalId
+                            , send E.^. SquadThemSendDelegatorLocalId
+                            )
+                Right (_, Entity a _) ->
+                    fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Right (t, s))) $
+                    E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do
+                        E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad
+                        E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad
+                        E.on $ topic E.^. SquadTopicRemoteId E.==. send E.^. SquadThemSendDelegatorRemoteTopic
+                        E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicRemoteSquad
+                        E.where_ $
+                            squad E.^. SquadHolder E.==. E.val (projectResource project) E.&&.
+                            topic E.^. SquadTopicRemoteTopic E.==. E.val a
+                        return
+                            ( squad E.^. SquadId
+                            , send E.^. SquadThemSendDelegatorRemoteSquad
+                            , start E.^. SquadUsStartId
+                            , topic E.^. SquadTopicRemoteId
+                            , send E.^. SquadThemSendDelegatorRemoteId
+                            )
+
+            (E.Value squadID, E.Value usAcceptID, E.Value squadStartID, topic) <-
+                verifySingleE squads "No squad" "Multiple squads"
+
+            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 "[Team-passive] Saw the removal attempt, just waiting for the Revoke"
+
 -- Meaning: An actor is revoking Grant activities
 -- Behavior:
 --  * For each revoked activity: