S2S: Project: Grant: Implement team mode

src/Vervis/Actor/Project.hs

@@ -2910,6 +2910,13 @@ data GrantKind
 --          * For each grant I've been delegated from my children, send an
 --            extension-Grant to the new parent
 --
+--      * Option 5 - Almost-Team sending me the delegator-Grant
+--          * Update the Squad record, enabling the team
+--          * Send a start-Grant giving access-to-me
+--          * For each of my components, send an extension-Grant to the team
+--          * For each grant I've been delegated from my children, send an
+--            extension-Grant to the team
+--
 --      * If neither of those, raise an error
 projectGrant
     :: UTCTime
@@ -2922,11 +2929,17 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
     grant' <- checkGrant grant
     let adapt = maybe (Right Nothing) (either Left (Right . Just))
     maybeMode <-
-        withDBExcept $ ExceptT $ fmap adapt $ runMaybeT $
+        withDBExcept $ do
-            runExceptT (Left . Left <$> tryComp grant') <|>
+            (_myInboxID, meResourceID) <- lift $ do
-            runExceptT (Left . Right <$> tryCollab grant') <|>
+                project <- getJust projectID
-            runExceptT (Right . Left <$> tryChild grant') <|>
+                actor <- getJust $ projectActor project
-            runExceptT (Right . Right <$> tryParent grant')
+                return (actorInbox actor, projectResource project)
+            ExceptT $ fmap adapt $ runMaybeT $
+                runExceptT (Left . Left <$> tryComp grant') <|>
+                runExceptT (Left . Right <$> tryCollab grant') <|>
+                runExceptT (Right . Left <$> tryChild grant') <|>
+                runExceptT (Right . Right . Left <$> tryParent grant') <|>
+                runExceptT (Right . Right . Right <$> tryTeam meResourceID grant')
     mode <-
         fromMaybeE
             maybeMode
@@ -2938,8 +2951,10 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
             handleCollab enableID role recip
         Right (Left (role, sendID, topic)) ->
             handleChild role sendID topic
-        Right (Right (role, topic, acceptID)) ->
+        Right (Right (Left (role, topic, acceptID))) ->
             handleParent role topic acceptID
+        Right (Right (Right (role, topic, acceptID))) ->
+            handleTeam role topic acceptID
 
     where
 
@@ -4487,6 +4502,366 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
 
             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
+            (recipActorID, recipActor) <- lift $ do
+                recip <- getJust projectID
+                let actorID = projectActor recip
+                (actorID,) <$> getJust actorID
+
+            maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) 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 "projectGrant.team impossible"
+
+                startID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
+                squadStartID <- lift $ insert $ SquadUsStart acceptID startID
+
+                -- Prepare a start-Grant
+                start@(actionStart, _, _, _) <- lift $ prepareStartGrant role squadStartID
+                let recipByKey = LocalActorProject projectID
+                _luStart <- lift $ updateOutboxItem' recipByKey startID actionStart
+
+                -- For each Component in me, prepare a delegation-extension Grant
+                localComponents <-
+                    lift $
+                    E.select $ E.from $ \ (deleg `E.InnerJoin` local `E.InnerJoin` comp `E.InnerJoin` enable) -> do
+                        E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
+                        E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
+                        E.on $ deleg E.^. ComponentDelegateLocalComponent E.==.local E.^. ComponentLocalId
+                        E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
+                        return
+                            ( deleg E.^. ComponentDelegateLocalGrant
+                            , comp
+                            , enable
+                            )
+                localExtensions <- lift $ for localComponents $ \ (E.Value startID, Entity componentID component, Entity enableID _) -> do
+                    extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+                    insert_ $ ComponentConvey enableID squadStartID extID
+                    componentIdent <- do
+                        i <- getComponentIdent componentID
+                        bitraverse
+                            (pure . snd)
+                            (\ (_, raID) -> getRemoteActorURI =<< getJust raID)
+                            i
+                    uStart <- do
+                        encodeRouteHome <- getEncodeRouteHome
+                        c <-
+                            case componentIdent of
+                                Left ci -> hashComponent ci
+                                Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible"
+                        s <- encodeKeyHashid startID
+                        return $ encodeRouteHome $ activityRoute (resourceToActor $ componentResource c) s
+                    ext@(actionExt, _, _, _) <-
+                        prepareExtensionGrant componentIdent uStart (min role (componentRole component)) enableID squadStartID
+                    let recipByKey = LocalActorProject projectID
+                    _luExt <- updateOutboxItem' recipByKey extID actionExt
+                    return (extID, ext)
+
+                remoteComponents <-
+                    lift $
+                    E.select $ E.from $ \ (deleg `E.InnerJoin` remote `E.InnerJoin` comp `E.InnerJoin` enable) -> do
+                        E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
+                        E.on $ remote E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId
+                        E.on $ deleg E.^. ComponentDelegateRemoteComponent E.==.remote E.^. ComponentRemoteId
+                        E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
+                        return
+                            ( deleg E.^. ComponentDelegateRemoteGrant
+                            , comp
+                            , enable
+                            )
+                remoteExtensions <- lift $ for remoteComponents $ \ (E.Value startID, Entity componentID component, Entity enableID _) -> do
+                    extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+                    insert_ $ ComponentConvey enableID squadStartID extID
+                    componentIdent <- do
+                        i <- getComponentIdent componentID
+                        bitraverse
+                            (pure . snd)
+                            (\ (_, raID) -> getRemoteActorURI =<< getJust raID)
+                            i
+                    uStart <- do
+                        ra <- getJust startID
+                        getRemoteActivityURI ra
+                    ext@(actionExt, _, _, _) <-
+                        prepareExtensionGrant componentIdent uStart (min role (componentRole component)) enableID squadStartID
+                    let recipByKey = LocalActorProject projectID
+                    _luExt <- updateOutboxItem' recipByKey extID actionExt
+                    return (extID, ext)
+
+                -- For each Grant I got from a child, prepare a
+                -- delegation-extension Grant
+                l <-
+                    lift $ fmap (map $ over _2 Left) $
+                    E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do
+                        E.on $ accept E.^. SourceThemAcceptLocalId E.==. deleg E.^. SourceThemDelegateLocalSource
+                        E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource
+                        E.on $ topic E.^. SourceTopicLocalId E.==. accept E.^. SourceThemAcceptLocalTopic
+                        E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicLocalSource
+                        E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource
+                        E.where_ $ holder E.^. SourceHolderProjectProject E.==. E.val projectID
+                        return
+                            ( send E.^. SourceUsSendDelegatorId
+                            , deleg
+                            )
+                r <-
+                    lift $ fmap (map $ over _2 Right) $
+                    E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do
+                        E.on $ accept E.^. SourceThemAcceptRemoteId E.==. deleg E.^. SourceThemDelegateRemoteSource
+                        E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource
+                        E.on $ topic E.^. SourceTopicRemoteId E.==. accept E.^. SourceThemAcceptRemoteTopic
+                        E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicRemoteSource
+                        E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource
+                        E.where_ $ holder E.^. SourceHolderProjectProject E.==. E.val projectID
+                        return
+                            ( send E.^. SourceUsSendDelegatorId
+                            , deleg
+                            )
+                fromChildren <- lift $ for (l ++ r) $ \ (E.Value sendID, deleg) -> do
+                    extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+
+                    conveyID <- insert $ SourceUsConvey sendID squadStartID extID
+                    case bimap entityKey entityKey deleg of
+                        Left localID -> insert_ $ SourceUsConveyFromLocal conveyID localID
+                        Right remoteID -> insert_ $ SourceUsConveyFromRemote conveyID remoteID
+
+                    (AP.Doc h a, grant) <- getGrantActivityBody $ bimap (sourceThemDelegateLocalGrant . entityVal) (sourceThemDelegateRemoteGrant . entityVal) deleg
+                    uStart <-
+                        case AP.activityId a of
+                            Nothing -> error "SourceThemDelegate grant has no 'id'"
+                            Just lu -> pure $ ObjURI h lu
+                    ext@(actionExt, _, _, _) <-
+                        prepareExtensionGrantFromChild uStart grant role squadStartID
+                    let recipByKey = LocalActorProject projectID
+                    _luExt <- updateOutboxItem' recipByKey extID actionExt
+                    return (extID, ext)
+
+                return
+                    ( recipActorID
+                    , (startID, start) : localExtensions ++ remoteExtensions ++ fromChildren
+                    , inboxItemID
+                    )
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (recipActorID, exts, inboxItemID) -> do
+                let recipByID = LocalActorProject projectID
+                lift $ for_ exts $
+                    \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
+                        sendActivity
+                            recipByID recipActorID localRecipsExt
+                            remoteRecipsExt fwdHostsExt extID actionExt
+                doneDB inboxItemID "[Team] Sent start-Grant and extensions from components and children"
+
+        where
+
+        prepareExtensionGrant component uStart role enableID startID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            projectHash <- encodeKeyHashid projectID
+
+            uDeleg <- lift $ getActivityURI authorIdMsig
+            uComponent <-
+                case component of
+                    Left c -> do
+                        a <- resourceToActor . componentResource <$> hashComponent c
+                        return $ encodeRouteHome $ renderLocalActor a
+                    Right u -> pure u
+
+            enableHash <- encodeKeyHashid enableID
+
+            audTeam <- lift $ makeAudSenderOnly authorIdMsig
+            uTeam <- lift $ getActorURI authorIdMsig
+
+            resultR <- do
+                startHash <- encodeKeyHashid startID
+                return $ ProjectTeamLiveR projectHash startHash
+
+            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   = [uStart]
+                    , AP.actionSpecific   = AP.GrantActivity AP.Grant
+                        { AP.grantObject    = AP.RXRole role
+                        , AP.grantContext   = uComponent
+                        , AP.grantTarget    = uTeam
+                        , AP.grantResult    =
+                            Just
+                                ( encodeRouteLocal resultR
+                                , Nothing
+                                )
+                        , AP.grantStart     = Just now
+                        , AP.grantEnd       = Nothing
+                        , AP.grantAllows    = AP.Distribute
+                        , AP.grantDelegates = Just uStart
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
+        prepareStartGrant role startID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            projectHash <- encodeKeyHashid projectID
+
+            uDeleg <- lift $ getActivityURI authorIdMsig
+
+            audTeam <- lift $ makeAudSenderOnly authorIdMsig
+            uTeam <- lift $ getActorURI authorIdMsig
+
+            resultR <- do
+                startHash <- encodeKeyHashid startID
+                return $ ProjectTeamLiveR projectHash startHash
+
+            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 $ ProjectR projectHash
+                        , AP.grantTarget    = uTeam
+                        , AP.grantResult    =
+                            Just
+                                ( encodeRouteLocal resultR
+                                , Nothing
+                                )
+                        , AP.grantStart     = Just now
+                        , AP.grantEnd       = Nothing
+                        , AP.grantAllows    = AP.Distribute
+                        , AP.grantDelegates = Nothing
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
+        prepareExtensionGrantFromChild uStart grant role startID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            projectHash <- encodeKeyHashid projectID
+            finalRole <-
+                case AP.grantObject grant of
+                    AP.RXRole r -> pure $ min role r
+                    AP.RXDelegator -> error "Why was I delegated a Grant with object=delegator?"
+
+            uDeleg <- lift $ getActivityURI authorIdMsig
+            audTeam <- lift $ makeAudSenderOnly authorIdMsig
+            uTeam <- lift $ getActorURI authorIdMsig
+
+            resultR <- do
+                startHash <- encodeKeyHashid startID
+                return $ ProjectTeamLiveR projectHash startHash
+
+            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   = [uStart]
+                    , AP.actionSpecific   = AP.GrantActivity AP.Grant
+                        { AP.grantObject    = AP.RXRole finalRole
+                        , AP.grantContext   = AP.grantContext grant
+                        , AP.grantTarget    = uTeam
+                        , AP.grantResult    =
+                            Just
+                                ( encodeRouteLocal resultR
+                                , Nothing
+                                )
+                        , AP.grantStart     = Just now
+                        , AP.grantEnd       = Nothing
+                        , AP.grantAllows    = AP.Distribute
+                        , AP.grantDelegates = Just uStart
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
 -- Meaning: An actor A invited actor B to a resource
 -- Behavior:
 --      * Verify the resource is my collabs or components list