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

src/Vervis/Actor/Common.hs

@@ -2208,13 +2208,15 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
         withDBExcept $ do
             meResourceID <- lift $ grabResource <$> getJust recipKey
             ExceptT $ fmap adapt $ runMaybeT $
-                runExceptT (id <$> tryStem grant')
+                runExceptT (Left <$> tryStem grant') <|>
+                runExceptT (Right <$> tryTeam meResourceID grant')
     mode <-
         fromMaybeE
             maybeMode
             "Not a relevant Grant that I'm aware of"
     case mode of
-        stem -> handleStem stem
+        Left stem -> handleStem stem
+        Right team -> handleTeam team
 
     where
 
@@ -2406,6 +2408,141 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
+    tryTeam _            (GKDelegationStart _)    = lift mzero
+    tryTeam _            (GKDelegationExtend _ _) = lift mzero
+    tryTeam meResourceID GKDelegator              = do
+        uFulfills <-
+            case AP.activityFulfills $ actbActivity body of
+                [] -> throwE "No fulfills"
+                [u] -> pure u
+                _ -> throwE "Multiple fulfills"
+        fulfills <- ExceptT $ lift $ lift $ runExceptT $ first (\ (a, _, i) -> (a, i)) <$> parseActivityURI' uFulfills
+        fulfillsDB <- ExceptT $ MaybeT $ either (Just . Left) (fmap Right) <$> runExceptT (getActivity fulfills)
+        -- Find the Squad record from the fulfills
+        squadID <-
+            lift $
+            case fulfillsDB of
+                Left (_, _, addID) ->
+                    (do SquadUsGestureLocal squadID _ <- MaybeT $ getValBy $ UniqueSquadUsGestureLocalActivity addID
+                        _ <- MaybeT $ getBy $ UniqueSquadOriginUs squadID
+                        return squadID
+                    )
+                    <|>
+                    (do SquadThemGestureLocal themID _ <- MaybeT $ getValBy $ UniqueSquadThemGestureLocalAdd addID
+                        SquadOriginThem squadID <- lift $ getJust themID
+                        return squadID
+                    )
+                Right addID ->
+                    (do SquadUsGestureRemote squadID _ _ <- MaybeT $ getValBy $ UniqueSquadUsGestureRemoteActivity addID
+                        _ <- MaybeT $ getBy $ UniqueSquadOriginUs squadID
+                        return squadID
+                    )
+                    <|>
+                    (do SquadThemGestureRemote themID _ _ <- MaybeT $ getValBy $ UniqueSquadThemGestureRemoteAdd addID
+                        SquadOriginThem squadID <- lift $ getJust themID
+                        return squadID
+                    )
+        -- Verify this Squad record is mine
+        Squad role r <- lift $ lift $ getJust squadID
+        lift $ guard $ r == meResourceID
+        -- Verify the Grant sender is the Squad topic
+        topic <- lift $ lift $ getSquadTeam squadID
+        topicForCheck <-
+            lift $ lift $
+            bitraverse
+                (pure . snd)
+                (\ (_, raID) -> getRemoteActorURI =<< getJust raID)
+                topic
+        unless (first LocalActorGroup topicForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $
+            throwE "Squad topic and Grant author aren't the same actor"
+        -- Verify I sent my Accept
+        maybeMe <- lift $ lift $ getKeyBy $ UniqueSquadUsAccept squadID
+        meAcceptID <- fromMaybeE maybeMe "I haven't sent my Accept"
+        -- Verify I haven't yet seen a delegator-Grant from the team
+        case bimap fst fst topic of
+            Left localID -> do
+                m <- lift $ lift $ getBy $ UniqueSquadThemSendDelegatorLocalTopic localID
+                verifyNothingE m "Already have a SquadThemSendDelegatorLocal"
+            Right remoteID -> do
+                m <- lift $ lift $ getBy $ UniqueSquadThemSendDelegatorRemoteTopic remoteID
+                verifyNothingE m "Already have a SquadThemSendDelegatorRemote"
+        return (role, topic, meAcceptID)
+
+    handleTeam (role, topic, acceptID) = do
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            meResourceID <- lift $ grabResource <$> getJust meID
+            Resource meActorID <- lift $ getJust meResourceID
+            meActorDB <- lift $ getJust meActorID
+
+            maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox meActorDB) False
+            for maybeGrantDB $ \ (inboxItemID, grantDB) -> do
+
+                -- Record the delegator-Grant in DB
+                to <- case (grantDB, bimap fst fst topic) of
+                    (Left (_, _, grantID), Left localID) -> Left <$> do
+                        mk <- lift $ insertUnique $ SquadThemSendDelegatorLocal acceptID localID grantID
+                        fromMaybeE mk "I already have such a SquadThemSendDelegatorLocal"
+                    (Right (_, _, grantID), Right remoteID) -> Right <$> do
+                        mk <- lift $ insertUnique $ SquadThemSendDelegatorRemote acceptID remoteID grantID
+                        fromMaybeE mk "I already have such a SquadThemSendDelegatorRemote"
+                    _ -> error "componentGrant.team impossible"
+
+                startID <- lift $ insertEmptyOutboxItem' (actorOutbox meActorDB) now
+                squadStartID <- lift $ insert $ SquadUsStart acceptID startID
+
+                -- Prepare a start-Grant
+                start@(actionStart, _, _, _) <- lift $ prepareStartGrant role squadStartID
+                _luStart <- lift $ updateOutboxItem' meActor startID actionStart
+
+                return (meActorID, startID, start, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (recipActorID, extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt), inboxItemID) -> do
+                lift $ sendActivity
+                            meActor recipActorID localRecipsExt
+                            remoteRecipsExt fwdHostsExt extID actionExt
+                doneDB inboxItemID "[Team] Sent start-Grant"
+
+        where
+
+        prepareStartGrant role startID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            meHash <- hashLocalActor meActor
+
+            uDeleg <- lift $ getActivityURI authorIdMsig
+
+            audTeam <- lift $ makeAudSenderOnly authorIdMsig
+            uTeam <- lift $ getActorURI authorIdMsig
+
+            let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audTeam]
+
+                recips = map encodeRouteHome audLocal ++ audRemote
+                action = AP.Action
+                    { AP.actionCapability = Just uDeleg
+                    , AP.actionSummary    = Nothing
+                    , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                    , AP.actionFulfills   = [uDeleg]
+                    , AP.actionSpecific   = AP.GrantActivity AP.Grant
+                        { AP.grantObject    = AP.RXRole role
+                        , AP.grantContext   = encodeRouteHome $ renderLocalActor meHash
+                        , AP.grantTarget    = uTeam
+                        , AP.grantResult    = Nothing
+                        , AP.grantStart     = Just now
+                        , AP.grantEnd       = Nothing
+                        , AP.grantAllows    = AP.Distribute
+                        , AP.grantDelegates = Nothing
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
 -- Meaning: An actor is adding some object to some target
 -- Behavior:
 --  * If target is my context (i.e. parents) collection: