S2S: Project: Accept: Implement team mode

src/Vervis/Actor/Project.hs

@@ -223,6 +223,37 @@ import Vervis.Web.Collab
 --        delegation Grant I got from B
 --          * To: The parent/collaborator/team to whom I'd sent the Grant
 --          * CC: -
+--
+--  * Add-a-Team mode
+--         * Give me a new team active SquadOriginUs
+--              * Respond with error, we aren't supposed to get any Accept
+--         * Give me a new team passive SquadOriginThem
+--              * Option 1: I haven't yet seen parent's Accept
+--                  * Verify sender is the parent
+--              * Option 2: I saw it, but not my collaborator's Accept
+--                  * Verify the accept is authorized
+--              * Otherwise respond with error, no Accept is needed
+--
+--     * Insert the Accept to my inbox
+--
+--     * In team-passive mode,
+--          * Option 1: Record team's Accept in the Dest record
+--          * Option 2: Record my collaborator's Accept in the Squad record
+--              * Prepare to send my own Accept
+--
+--     * Forward the Accept to my followers
+--
+--     * Possibly send a Grant/Accept:
+--         * Team-passive
+--              * In option 2
+--              * Accept
+--              * Object: The Add
+--              * Fulfills: My collaborator's Accept
+--              * To: Team
+--              * CC:
+--                  - Team's followers
+--                  - My followers
+--                  - The Accept sender (my collaborator)
 projectAccept
     :: UTCTime
     -> ProjectId
@@ -236,10 +267,10 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
 
     collabOrComp_or_child <- withDBExcept $ do
 
-        myInboxID <- lift $ do
+        (myInboxID, meResourceID) <- lift $ do
             project <- getJust projectID
             actor <- getJust $ projectActor project
-            return $ actorInbox actor
+            return (actorInbox actor, projectResource project)
 
         -- Find the accepted activity in our DB
         accepteeDB <- do
@@ -261,7 +292,9 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                 runExceptT (Right . Left <$> tryAddChildPassive accepteeDB) <|>
                 runExceptT (Right . Left <$> tryAddParentActive accepteeDB) <|>
                 runExceptT (Right . Left <$> tryAddParentPassive accepteeDB) <|>
-                runExceptT (Right . Right <$> tryRemoveChild myInboxID accepteeDB)
+                runExceptT (Right . Right . Left <$> tryRemoveChild myInboxID accepteeDB) <|>
+                runExceptT (Right . Right . Right <$> tryAddTeamActive meResourceID accepteeDB) <|>
+                runExceptT (Right . Right . Right <$> tryAddTeamPassive meResourceID accepteeDB)
         fromMaybeE
             maybeCollab
             "Accepted activity isn't an Invite/Join/Add/Remove I'm aware of"
@@ -270,7 +303,8 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
         Left (Left collab) -> addCollab collab
         Left (Right comp) -> addComp comp
         Right (Left cp) -> addChildParent cp
-        Right (Right child) -> removeChild child
+        Right (Right (Left child)) -> removeChild child
+        Right (Right (Right team)) -> addTeam team
 
     where
 
@@ -497,6 +531,41 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
             lift $ MaybeT $ getValBy $ UniqueInboxItemRemote inboxID remoteActivityID
         tryRemoveChild' i
 
+    verifySquadHolder :: ResourceId -> SquadId -> MaybeT ActDB ()
+    verifySquadHolder meResourceID squadID = do
+        Squad _ r <- lift $ getJust squadID
+        guard $ r == meResourceID
+
+    tryAddTeamActive' r squadID = do
+        usID <- lift $ MaybeT $ getKeyBy $ UniqueSquadOriginUs squadID
+        lift $ verifySquadHolder r squadID
+        topic <- lift . lift $ getSquadTeam squadID
+        return (squadID, topic, Left ())
+
+    tryAddTeamActive r (Left (_actorByKey, _actorEntity, itemID)) = do
+        SquadUsGestureLocal squadID _ <-
+            lift $ MaybeT $ getValBy $ UniqueSquadUsGestureLocalActivity itemID
+        tryAddTeamActive' r squadID
+    tryAddTeamActive r (Right remoteActivityID) = do
+        SquadUsGestureRemote squadID _ _ <-
+            lift $ MaybeT $ getValBy $ UniqueSquadUsGestureRemoteActivity remoteActivityID
+        tryAddTeamActive' r squadID
+
+    tryAddTeamPassive' r themID = do
+        SquadOriginThem squadID <- lift . lift $ getJust themID
+        lift $ verifySquadHolder r squadID
+        topic <- lift . lift $ getSquadTeam squadID
+        return (squadID, topic, Right themID)
+
+    tryAddTeamPassive r (Left (_actorByKey, _actorEntity, itemID)) = do
+        SquadThemGestureLocal themID _ <-
+            lift $ MaybeT $ getValBy $ UniqueSquadThemGestureLocalAdd itemID
+        tryAddTeamPassive' r themID
+    tryAddTeamPassive r (Right remoteActivityID) = do
+        SquadThemGestureRemote themID _ _ <-
+            lift $ MaybeT $ getValBy $ UniqueSquadThemGestureRemoteAdd remoteActivityID
+        tryAddTeamPassive' r themID
+
     componentIsAuthor ident =
         let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
         in  author == bimap (resourceToActor . componentResource . snd) snd ident
@@ -506,6 +575,11 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
         let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
         in  author == bimap (LocalActorProject . snd) snd ident
 
+    theyIsAuthor' :: Either (a, GroupId) (b, RemoteActorId) -> Bool
+    theyIsAuthor' ident =
+        let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
+        in  author == bimap (LocalActorGroup . snd) snd ident
+
     addCollab (collabID, fulfills, inviterOrJoiner) = do
 
         collab <-
@@ -1428,6 +1502,157 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
 
             return (action, recipientSet, remoteActors, fwdHosts)
 
+    addTeam (squadID, topic, mode) = do
+
+        (themID, mode') <-
+            case mode of
+
+                -- Team-active mode
+                -- Respond with error, we aren't supposed to get any Accept
+                Left () -> throwE "Team-active (SquadOriginUs) mode, I'm not expecting any Accept"
+
+                -- Team-passive mode
+                -- Option 1: I haven't yet seen team's Accept
+                --   * Verify sender is the team
+                -- Option 2: I saw it, but not my collaborator's Accept
+                --   * Verify the accept is authorized
+                -- Otherwise respond with error, no Accept is needed
+                Right themID -> (themID,) <$> do
+                    (maybeTeamAccept, maybeUsGesture) <-
+                        lift $ withDB $ liftA2 (,)
+                            (case bimap fst fst topic of
+                                Left localID -> (() <$) <$> getBy (UniqueSquadThemAcceptLocalTopic localID)
+                                Right remoteID -> (() <$) <$> getBy (UniqueSquadThemAcceptRemoteTopic remoteID)
+                            )
+                            (do l <- getBy $ UniqueSquadUsGestureLocal squadID
+                                r <- getBy $ UniqueSquadUsGestureRemote squadID
+                                case (isJust l, isJust r) of
+                                    (False, False) -> pure Nothing
+                                    (False, True) -> pure $ Just ()
+                                    (True, False) -> pure $ Just ()
+                                    (True, True) -> error "Both SquadUsGestureLocal and SquadUsGestureRemote"
+                            )
+                    case (isJust maybeTeamAccept, isJust maybeUsGesture) of
+                        (False, True) -> error "Impossible/bug, didn't see team's Accept but recorded my collaborator's Accept"
+                        (False, False) -> do
+                            unless (theyIsAuthor' topic) $
+                                throwE "The Accept I'm waiting for is from my new team"
+                            return $ Left ()
+                        (True, False) -> do
+                            let muCap = AP.activityCapability $ actbActivity body
+                            uCap <- fromMaybeE muCap "No capability provided"
+                            verifyCapability''
+                                uCap
+                                authorIdMsig
+                                (LocalResourceProject projectID)
+                                AP.RoleAdmin
+                            return $ Right ()
+                        (True, True) -> throwE "Just waiting for Grant from team, or already have it, anyway not needing any further Accept"
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (recipActorID, recipActor) <- lift $ do
+                recip <- getJust projectID
+                let actorID = projectActor recip
+                (actorID,) <$> getJust actorID
+
+            maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
+            for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do
+
+                idsForGrant <-
+                    lift $ case mode' of
+
+                        -- Getting an Accept from the team
+                        -- Record team's Accept in the Squad record
+                        Left () -> do
+                            case (topic, acceptDB) of
+                                (Left (localID, _), Left (_, _, acceptID)) ->
+                                    insert_ $ SquadThemAcceptLocal themID localID acceptID
+                                (Right (remoteID, _), Right (_, _, acceptID)) ->
+                                    insert_ $ SquadThemAcceptRemote themID remoteID acceptID
+                                _ -> error "projectAccept impossible v"
+                            return Nothing
+
+                        -- Getting an Accept from my collaborator
+                        -- Record my collaborator's Accept in the Squad record
+                        -- Prepare to send my own Accept
+                        Right () -> Just <$> do
+                            case acceptDB of
+                                Left (_, _, acceptID) ->
+                                    insert_ $ SquadUsGestureLocal squadID acceptID
+                                Right (author, _, acceptID) ->
+                                    insert_ $ SquadUsGestureRemote squadID (remoteAuthorId author) acceptID
+                            acceptID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+                            insert_ $ SquadUsAccept squadID acceptID
+                            return acceptID
+
+                -- Prepare forwarding of Accept to my followers
+                let recipByID = LocalActorProject projectID
+                recipByHash <- hashLocalActor recipByID
+                let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
+
+                maybeAct <-
+                    for idsForGrant $ \ acceptID -> lift $ do
+                        accept@(actionAccept, _, _, _) <-
+                            prepareSquadAccept (bimap snd snd topic)
+                        let recipByKey = LocalActorProject projectID
+                        _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept
+                        return (acceptID, accept)
+
+                return (recipActorID, sieve, maybeAct, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (recipActorID, sieve, maybeGrant, inboxItemID) -> do
+                let recipByID = LocalActorProject projectID
+                forwardActivity authorIdMsig body recipByID recipActorID sieve
+                lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) ->
+                    sendActivity
+                        recipByID recipActorID localRecipsGrant
+                        remoteRecipsGrant fwdHostsGrant grantID actionGrant
+                doneDB inboxItemID "[Team] Forwarded the Accept and maybe published a Grant/Accept"
+
+        where
+
+        prepareSquadAccept topic = do
+            encodeRouteHome <- getEncodeRouteHome
+
+            audMyCollab <- lift $ makeAudSenderOnly authorIdMsig
+            audSquad <-
+                case topic of
+                    Left j -> do
+                        h <- encodeKeyHashid j
+                        return $
+                            AudLocal [LocalActorGroup h] [LocalStageGroupFollowers h]
+                    Right raID -> do
+                        ra <- getJust raID
+                        ObjURI h lu <- getRemoteActorURI ra
+                        return $
+                            AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
+            audMe <-
+                AudLocal [] . pure . LocalStageProjectFollowers <$>
+                    encodeKeyHashid projectID
+            uCollabAccept <- lift $ getActivityURI authorIdMsig
+            let uAdd = AP.acceptObject accept
+
+                (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audMyCollab, audSquad, audMe]
+
+                recips = map encodeRouteHome audLocal ++ audRemote
+                action = AP.Action
+                    { AP.actionCapability = Nothing
+                    , AP.actionSummary    = Nothing
+                    , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                    , AP.actionFulfills   = [uCollabAccept]
+                    , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                        { AP.acceptObject   = uAdd
+                        , AP.acceptResult   = Nothing
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
 checkExistingComponents
     :: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE ()
 checkExistingComponents projectID componentDB = do