S2S: Component: Add: Port team-mode from Project

src/Vervis/Actor/Common.hs

@@ -2170,8 +2170,24 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
 --              * Project's followers
 --              * My followers
 --
---  * If the object is me:
+--  * If the target is my teams list:
---      * Verify the target is some project's components collection URI
+--        * Verify the object is a team, find in DB/HTTP
+--        * Verify the Add is authorized
+--        * Verify it's not already an active team of mine
+--        * Verify it's not already in an Origin-Us process where I saw the Add
+--          and sent my Accept
+--        * Verify it's not already in an Origin-Them process, where I saw the
+--          Add and the potential team's Accept
+--        * Insert the Add to my inbox
+--        * Create a Squad record in DB
+--        * Forward the Add to my followers
+--        * Publish an Accept to:
+--          * The object team + followers
+--          * Add sender + followers
+--          * My followers
+--        * Record my Accept in the Squad record
+--
+--  * If the object is me & target is some project's components collection URI
 --      * For each Stem record I have for this project:
 --          * Verify it's not enabled yet, i.e. I'm not already a component
 --            of this project
@@ -2182,6 +2198,17 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
 --      * Create a Stem record in DB
 --      * Insert the Add to my inbox
 --      * Forward the Add to my followers
+--
+--  * If I'm the object, being added to some teams' resource list:
+--        * Verify the target is a team, find in DB/HTTP
+--        * Verify it's not already an active team of mine
+--        * Verify it's not already in an Origin-Us process where I saw the Add
+--          and sent my Accept
+--        * Verify it's not already in an Origin-Them process, where I saw the
+--          Add and the potential team's Accept
+--        * Insert the Add to my inbox
+--        * Create a Squad record in DB
+--        * Forward the Add to my followers
 componentAdd
     :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
     => (topic -> KomponentId)
@@ -2199,7 +2226,7 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add =
         throwE "Add role isn't admin"
     case (target, object) of
         (Left at, _)
-            | addTargetComponentProjects at == Just (toComponent meID) -> do
+            | addTargetComponentProjects at == Just meComponent -> do
                 project <-
                     bitraverse
                         (\case
@@ -2209,31 +2236,42 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add =
                         pure
                         object
                 addProjectActive role project
+            | (resourceFromNG <$> addTargetResourceTeams at) == Just meResource ->
+                addTeamActive object
         (_, Left la)
             | resourceToActor (componentResource $ toComponent meID) == la -> do
                 case target of
                     Left (ATProjectComponents j) ->
                         addProjectPassive role $ Left j
+                    Left (ATGroupEfforts g) ->
+                        addTeamPassive $ Left g
                     Right (ObjURI h luColl) -> do
                         -- NOTE this is HTTP GET done synchronously in the activity
                         -- handler
                         manager <- asksEnv envHttpManager
                         c <- AP.fetchAPID_T manager (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) h luColl
                         lu <- fromMaybeE (AP.collectionContext c) "No context"
-                        j <- AP.fetchAPID_T manager (AP.actorId . AP.actorLocal . AP.projectActor) h lu
+                        rwc <- AP.fetchRWC_T manager h lu
-                        if luColl == AP.projectComponents j
+                        AP.Actor l d <-
+                            case AP.rwcResource rwc of
+                                AP.ResourceActor a -> pure a
+                                AP.ResourceChild _ _ -> throwE "Add.target remote ResourceChild"
+                        let typ = AP.actorType d
+                        if typ == AP.ActorTypeProject && Just luColl == AP.rwcComponents rwc
                             then addProjectPassive role $ Right $ ObjURI h lu
-                            else throwE "Non-components collection"
+                        else if typ == AP.ActorTypeTeam && Just luColl == AP.rwcTeamResources rwc
+                            then addTeamPassive $ Right $ ObjURI h lu
+                        else throwE "Non-components collection"
                     _ -> throwE "I'm being added somewhere irrelevant"
         _ -> throwE "This Add isn't for me"
 
     where
 
-    addProjectActive role project = do
+    meComponent = toComponent meID
+    meResource = componentResource meComponent
+    meActor = resourceToActor meResource
 
-        let meComponent = toComponent meID
+    addProjectActive role project = do
-            meResource = componentResource meComponent
-            meActor = resourceToActor meResource
 
         -- Check capability
         capability <- do
@@ -2484,6 +2522,220 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add =
                 Right (author, _, addID) ->
                     insert_ $ StemProjectGestureRemote originID (remoteAuthorId author) addID
 
+    addTeamActive 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
+        let teamDB' = second (entityKey . snd) teamDB
+
+        -- 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 add a team
+        verifyCapability''
+            uCap
+            authorIdMsig
+            meResource
+            AP.RoleAdmin
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            meKomponentID <- lift $ grabKomponent <$> getJust meID
+            Komponent meResourceID <- lift $ getJust meKomponentID
+            Resource meActorID <- lift $ getJust meResourceID
+            meActorDB <- lift $ getJust meActorID
+
+            -- Verify the object isn't already a team of mine, and that no
+            -- Squad record is already in Add-Accept state
+            verifyNoStartedResourceTeams meResourceID teamDB'
+
+            -- Insert the Add to my inbox
+            mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox meActorDB) False
+            lift $ for mractid $ \ (inboxItemID, addDB) -> do
+
+                -- Create a Squad record in DB
+                acceptID <- insertEmptyOutboxItem' (actorOutbox meActorDB) now
+                insertSquad meResourceID teamDB' addDB acceptID
+
+                -- Prepare forwarding the Add to my followers
+                sieve <- do
+                    h <- hashLocalActor meActor
+                    return $ makeRecipientSet [] [localActorFollowers h]
+
+                -- Prepare an Accept activity and insert to my outbox
+                accept@(actionAccept, _, _, _) <- prepareAccept teamDB
+                _luAccept <- updateOutboxItem' meActor  acceptID actionAccept
+
+                return (meActorID, sieve, acceptID, accept, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (meActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
+                forwardActivity authorIdMsig body meActor meActorID sieve
+                lift $ sendActivity
+                    meActor meActorID localRecipsAccept
+                    remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+                doneDB inboxItemID "[Team-active] Recorded a team-in-progress, forwarded the Add, sent an Accept"
+
+        where
+
+        insertSquad resourceID topicDB addDB acceptID = do
+            squadID <- insert $ Squad AP.RoleAdmin resourceID
+            case topicDB of
+                Left (Entity g _) -> insert_ $ SquadTopicLocal squadID g
+                Right a -> insert_ $ SquadTopicRemote squadID a
+            insert_ $ SquadOriginUs squadID
+            case addDB of
+                Left (_, _, addID) ->
+                    insert_ $ SquadUsGestureLocal squadID addID
+                Right (author, _, addID) ->
+                    insert_ $ SquadUsGestureRemote squadID (remoteAuthorId author) addID
+
+            insert_ $ SquadUsAccept squadID acceptID
+
+        prepareAccept teamDB = do
+            encodeRouteHome <- getEncodeRouteHome
+
+            audAdder <- makeAudSenderWithFollowers authorIdMsig
+            audTeam <-
+                case teamDB of
+                    Left (Entity g _) -> do
+                        gh <- encodeKeyHashid g
+                        return $ AudLocal [LocalActorGroup gh] [LocalStageGroupFollowers gh]
+                    Right (ObjURI h lu, Entity _ ra) ->
+                        return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
+            audMe <-
+                AudLocal [] . pure . localActorFollowers <$>
+                    hashLocalActor meActor
+            uAdd <- lift $ getActivityURI authorIdMsig
+
+            let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audAdder, audTeam, audMe]
+
+                recips = map encodeRouteHome audLocal ++ audRemote
+                action = AP.Action
+                    { AP.actionCapability = Nothing
+                    , AP.actionSummary    = Nothing
+                    , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                    , AP.actionFulfills   = [uAdd]
+                    , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                        { AP.acceptObject   = uAdd
+                        , AP.acceptResult   = Nothing
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
+    addTeamPassive 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
+        let teamDB' = second (entityKey . snd) teamDB
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            meKomponentID <- lift $ grabKomponent <$> getJust meID
+            Komponent meResourceID <- lift $ getJust meKomponentID
+            Resource meActorID <- lift $ getJust meResourceID
+            meActorDB <- lift $ getJust meActorID
+
+            -- Verify the object isn't already a team of mine, and that no
+            -- Squad record is already in Add-Accept state
+            verifyNoStartedResourceTeams meResourceID teamDB'
+
+            -- Insert the Add to my inbox
+            mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox meActorDB) False
+            lift $ for mractid $ \ (inboxItemID, addDB) -> do
+
+                -- Create a Squad record in DB
+                insertSquad meResourceID teamDB' addDB
+
+                -- Prepare forwarding the Add to my followers
+                sieve <- do
+                    h <- hashLocalActor meActor
+                    return $ makeRecipientSet [] [localActorFollowers h]
+
+                return (meActorID, sieve, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (meActorID, sieve, inboxItemID) -> do
+                forwardActivity authorIdMsig body meActor meActorID sieve
+                doneDB inboxItemID "[Team-passive] Recorded a team-in-progress, forwarded the Add"
+
+        where
+
+        insertSquad resourceID topicDB addDB = do
+            squadID <- insert $ Squad AP.RoleAdmin resourceID
+            case topicDB of
+                Left (Entity g _) -> insert_ $ SquadTopicLocal squadID g
+                Right a -> insert_ $ SquadTopicRemote squadID a
+            themID <- insert $ SquadOriginThem squadID
+            case addDB of
+                Left (_, _, addID) ->
+                    insert_ $ SquadThemGestureLocal themID addID
+                Right (author, _, addID) ->
+                    insert_ $ SquadThemGestureRemote themID (remoteAuthorId author) addID
+
 -- Meaning: An actor is revoking Grant activities
 -- Behavior:
 --  * For each revoked activity: