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

src/Vervis/Actor/Common.hs

@@ -231,6 +231,37 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
 --          * If I've already seen the project's accept, respond with error
 --          * Otherwise, just ignore the Accept
 --     * Otherwise respond with error
+--
+--  * 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)
 topicAccept
     :: forall topic.
        (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
@@ -246,14 +277,6 @@ topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) a
     -- Check input
     acceptee <- parseAccept accept
 
-    -- Verify the capability URI, if provided, is one of:
-    --   * Outbox item URI of a local actor, i.e. a local activity
-    --   * A remote URI
-    maybeCap <-
-        traverse
-            (nameExceptT "Accept capability" . parseActivityURI')
-            (AP.activityCapability $ actbActivity body)
-
     -- Grab me from DB
     (resourceID, recipActorID, recipActor) <- lift $ withDB $ do
         resourceID <- grabResource <$> getJust recipKey
@@ -261,7 +284,7 @@ topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) a
         recipActor <- getJust recipActorID
         return (resourceID, recipActorID, recipActor)
 
-    collabOrStem <- withDBExcept $ do
+    mode <- withDBExcept $ do
 
         -- Find the accepted activity in our DB
         accepteeDB <- do
@@ -274,20 +297,30 @@ topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) a
         -- component, grabbing the Stem record from our DB
         maybeCollabOrStem <-
             lift $ runMaybeT $
-                Left . Left <$> tryInviteCollab accepteeDB <|>
+                Left . Left . Left <$> tryInviteCollab accepteeDB <|>
-                Left . Right <$> tryJoinCollab accepteeDB <|>
+                Left . Left . Right <$> tryJoinCollab accepteeDB <|>
-                Right . Left <$> tryInviteComp accepteeDB <|>
+                Left . Right . Left <$> tryInviteComp accepteeDB <|>
-                Right . Right <$> tryAddComp accepteeDB
+                Left . Right . Right <$> tryAddComp accepteeDB <|>
+                Right <$> tryAddTeamActive resourceID accepteeDB <|>
+                Right <$> tryAddTeamPassive resourceID accepteeDB
         fromMaybeE maybeCollabOrStem "Accepted activity isn't an Invite/Join/Add I'm aware of"
 
-    case collabOrStem of
+    case mode of
-        Left collab ->
+        Left (Left collab) ->
-            topicAcceptCollab maybeCap recipActorID recipActor collab
+            topicAcceptCollab recipActorID recipActor collab
-        Right stem ->
+        Left (Right stem) ->
-            topicAcceptStem maybeCap recipActorID recipActor stem
+            topicAcceptStem recipActorID recipActor stem
+        Right team -> addTeam team
 
     where
 
+    meID = recipKey
+    toComponent = topicComponent
+
+    meComponent = toComponent recipKey
+    meResource = componentResource meComponent
+    meActor = resourceToActor meResource
+
     topicResource :: forall f. f topic -> LocalResourceBy f
     topicResource = componentResource . topicComponent
 
@@ -343,6 +376,41 @@ topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) a
             lift $ (,remoteActorFollowers actor,remoteActivityID) <$> getRemoteActorURI actor
         return (stemID, originID, Right adder)
 
+    verifySquadHolder :: ResourceId -> SquadId -> MaybeT ActDB ()
+    verifySquadHolder meResourceID squadID = do
+        Squad _ r <- lift $ getJust squadID
+        guard $ r == meResourceID
+
+    tryAddTeamActive' r squadID = do
+        usID <- MaybeT $ getKeyBy $ UniqueSquadOriginUs squadID
+        verifySquadHolder r squadID
+        topic <- lift $ getSquadTeam squadID
+        return (squadID, topic, Left ())
+
+    tryAddTeamActive r (Left (_actorByKey, _actorEntity, itemID)) = do
+        SquadUsGestureLocal squadID _ <-
+            MaybeT $ getValBy $ UniqueSquadUsGestureLocalActivity itemID
+        tryAddTeamActive' r squadID
+    tryAddTeamActive r (Right remoteActivityID) = do
+        SquadUsGestureRemote squadID _ _ <-
+            MaybeT $ getValBy $ UniqueSquadUsGestureRemoteActivity remoteActivityID
+        tryAddTeamActive' r squadID
+
+    tryAddTeamPassive' r themID = do
+        SquadOriginThem squadID <- lift $ getJust themID
+        verifySquadHolder r squadID
+        topic <- lift $ getSquadTeam squadID
+        return (squadID, topic, Right themID)
+
+    tryAddTeamPassive r (Left (_actorByKey, _actorEntity, itemID)) = do
+        SquadThemGestureLocal themID _ <-
+            MaybeT $ getValBy $ UniqueSquadThemGestureLocalAdd itemID
+        tryAddTeamPassive' r themID
+    tryAddTeamPassive r (Right remoteActivityID) = do
+        SquadThemGestureRemote themID _ _ <-
+            MaybeT $ getValBy $ UniqueSquadThemGestureRemoteAdd remoteActivityID
+        tryAddTeamPassive' r themID
+
     prepareGrant isInvite sender role = do
         encodeRouteHome <- getEncodeRouteHome
         encodeRouteLocal <- getEncodeRouteLocal
@@ -405,7 +473,15 @@ topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) a
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
-    topicAcceptCollab maybeCap recipActorID recipActor collab = do
+    topicAcceptCollab recipActorID recipActor collab = do
+
+        -- Verify the capability URI, if provided, is one of:
+        --   * Outbox item URI of a local actor, i.e. a local activity
+        --   * A remote URI
+        maybeCap <-
+            traverse
+                (nameExceptT "Accept capability" . parseActivityURI')
+                (AP.activityCapability $ actbActivity body)
 
         maybeNew <- withDBExcept $ do
 
@@ -568,7 +644,15 @@ topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) a
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
-    topicAcceptStem maybeCap recipActorID recipActor stem = do
+    topicAcceptStem recipActorID recipActor stem = do
+
+        -- Verify the capability URI, if provided, is one of:
+        --   * Outbox item URI of a local actor, i.e. a local activity
+        --   * A remote URI
+        maybeCap <-
+            traverse
+                (nameExceptT "Accept capability" . parseActivityURI')
+                (AP.activityCapability $ actbActivity body)
 
         maybeNew <- withDBExcept $ do
 
@@ -695,6 +779,159 @@ topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) a
                     remoteRecipsReact fwdHostsReact reactID actionReact
                 doneDB inboxItemID "Forwarded the Accept and published an Accept"
 
+    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
+
+    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
+                                meResource
+                                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
+            meResourceID <- lift $ grabResource <$> getJust meID
+            Resource meActorID <- lift $ getJust meResourceID
+            meActorDB <- lift $ getJust meActorID
+
+            maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox meActorDB) 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 "topicAccept 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 meActorDB) now
+                            insert_ $ SquadUsAccept squadID acceptID
+                            return acceptID
+
+                -- Prepare forwarding of Accept to my followers
+                sieve <- do
+                    h <- hashLocalActor meActor
+                    return $ makeRecipientSet [] [localActorFollowers h]
+
+                maybeAct <-
+                    for idsForGrant $ \ acceptID -> lift $ do
+                        accept@(actionAccept, _, _, _) <-
+                            prepareSquadAccept (bimap snd snd topic)
+                        _luAccept <- updateOutboxItem' meActor acceptID actionAccept
+                        return (acceptID, accept)
+
+                return (meActorID, sieve, maybeAct, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (recipActorID, sieve, maybeGrant, inboxItemID) -> do
+                forwardActivity authorIdMsig body meActor recipActorID sieve
+                lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) ->
+                    sendActivity
+                        meActor 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 . localActorFollowers <$>
+                    hashLocalActor meActor
+            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)
+
 topicReject
     :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
     => (topic -> ResourceId)

src/Vervis/Actor/Deck.hs

@@ -541,38 +541,6 @@ deckFollow now recipDeckID verse follow = do
 -- Access
 ------------------------------------------------------------------------------
 
--- Meaning: An actor accepted something
--- Behavior:
---     * If it's on an Invite where I'm the resource:
---         * Verify the Accept is by the Invite target
---         * Forward the Accept to my followers
---         * Send a Grant:
---             * To: Accepter (i.e. Invite target)
---             * CC: Invite sender, Accepter's followers, my followers
---     * If it's on a Join where I'm the resource:
---         * Verify the Accept is authorized
---         * Forward the Accept to my followers
---         * Send a Grant:
---             * To: Join sender
---             * CC: Accept sender, Join sender's followers, my followers
---     * If it's an Invite (that I know about) where I'm invited to a project:
---          * If I haven't yet seen the project's approval:
---              * Verify the author is the project
---              * Record the approval in the Stem record in DB
---          * If I saw project's approval, but not my collaborators' approval:
---              * Verify the Accept is authorized
---              * Record the approval in the Stem record in DB
---              * Forward to my followers
---              * Publish and send an Accept:
---                  * To: Inviter, project, Accept author
---                  * CC: Project followers, my followers
---              * Record it in the Stem record in DB as well
---          * If I already saw both approvals, respond with error
---     * If it's an Add (that I know about and already Accepted) where I'm
---       invited to a project:
---          * If I've already seen the project's accept, respond with error
---          * Otherwise, just ignore the Accept
---     * Otherwise respond with error
 deckAccept
     :: UTCTime
     -> DeckId