S2S: Implement component delegator-Grant handler

src/Vervis/Actor/Common.hs

@@ -23,6 +23,7 @@ module Vervis.Actor.Common
     , topicRemove
     , topicJoin
     , topicCreateMe
+    , componentGrant
     )
 where
 
@@ -1680,3 +1681,237 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
                 }
 
         return (action, recipientSet, remoteActors, fwdHosts)
+
+-- Meaning: An actor is granting access-to-some-resource to another actor
+-- Behavior:
+--      * If I approved an Add-to-project where I'm the component, and the
+--        project is now giving me the delegator-Grant:
+--          * Record this in the Stem record in DB
+--          * Forward to my followers
+--          * Start a delegation chain giving access-to-me, send this new Grant
+--            to the project to distribute further, and use the delegator-Grant
+--            as the capability
+--              * To: Project
+--              * CC: My followers, project followers
+--      * If I approved an Invite-to-project where I'm the component, and the
+--        project is now giving me the delegator-Grant:
+--          * Record this in the Stem record in DB
+--          * Forward to my followers
+--          * Start a delegation chain giving access-to-me, send this new Grant
+--            to the project to distribute further, and use the delegator-Grant
+--            as the capability
+--              * To: Project
+--              * CC: My followers, project followers
+--      * If the Grant is for an Add/Invite that hasn't had the full approval
+--        chain, or I already got the delegator-Grant, raise an error
+--      * Otherwise, if I've already seen this Grant or it's simply not related
+--        to me, ignore it
+componentGrant
+    :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
+    => (topic -> ActorId)
+    -> (forall f. f topic -> GrantResourceBy f)
+    -> (forall f. f topic -> ComponentBy f)
+    -> UTCTime
+    -> Key topic
+    -> Verse
+    -> AP.Grant URIMode
+    -> ActE (Text, Act (), Next)
+componentGrant grabActor topicResource topicComponent now recipKey (Verse authorIdMsig body) grant = do
+
+    -- Check grant
+    project <- checkDelegatorGrant grant
+
+    -- Check the Add/Invite that it's related to
+    fulfills <-
+        case AP.activityFulfills $ actbActivity body of
+            [u] ->
+                first (\ (actor, _, item) -> (actor, item)) <$>
+                    nameExceptT "Grant.fulfills" (parseActivityURI' u)
+            _ -> throwE "Expecting a single 'fulfills' URI"
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab me from DB
+        (recipActorID, recipActor) <- lift $ do
+            recip <- getJust recipKey
+            let actorID = grabActor recip
+            (actorID,) <$> getJust actorID
+
+        -- Find the fulfilled activity in our DB
+        fulfillsDB <- do
+            a <- getActivity fulfills
+            fromMaybeE a "Can't find fulfilled in DB"
+
+        -- See if the fulfilled activity is an Invite or Add on a local
+        -- component, grabbing the Stem record from our DB
+        stem <- do
+            maybeStem <-
+                lift $ runMaybeT $
+                    Left <$> tryInviteComp fulfillsDB <|>
+                    Right <$> tryAddComp fulfillsDB
+            fromMaybeE maybeStem "Fulfilled activity isn't an Invite/Add I'm aware of"
+
+        -- Find the local component and verify it's me
+        let stemID = either id id stem
+        ident <- lift $ getStemIdent stemID
+        unless (topicComponent recipKey == ident) $
+            throwE "Fulfilled object is an Invite/Add for some other component"
+
+        -- Find the project, verify it's identical to the Grant sender
+        stemProject <-
+            lift $
+            requireEitherAlt
+                (getBy $ UniqueStemProjectLocal stemID)
+                (getBy $ UniqueStemProjectRemote stemID)
+                "Found Stem with no project"
+                "Found Stem with multiple projects"
+        case (stemProject, authorIdMsig) of
+            (Left (Entity _ sjl), Left (LocalActorProject projectID, _, _))
+                | stemProjectLocalProject sjl == projectID ->
+                    return ()
+            (Right (Entity _ sjr), Right (author, _, _))
+                | stemProjectRemoteProject sjr == remoteAuthorId author ->
+                    return ()
+            _ -> throwE "The Grant I'm waiting for is by the project"
+
+        -- Verify I sent the Component's Accept but haven't already received
+        -- the delegator-Grant
+        compAccept <- do
+            mk <- lift $ getKeyBy $ UniqueStemComponentAccept stemID
+            fromMaybeE mk "Getting a delegator-Grant but never approved this Invite/Add"
+        gl <- lift $ getBy $ UniqueStemProjectGrantLocal compAccept
+        gr <- lift $ getBy $ UniqueStemProjectGrantRemote compAccept
+        unless (isNothing gl && isNothing gr) $
+            throwE "I already received a delegator-Grant for this Invite/Add"
+
+        maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
+        lift $ for maybeGrantDB $ \ grantDB -> do
+
+            -- Prepare forwarding to my followers
+            sieve <- do
+                recipHash <- encodeKeyHashid recipKey
+                let recipByHash =
+                        grantResourceLocalActor $ topicResource recipHash
+                return $ makeRecipientSet [] [localActorFollowers recipByHash]
+
+            -- Update the Stem record in DB
+            case (stemProject, grantDB) of
+                (Left (Entity j _), Left (_, _, g)) -> insert_ $ StemProjectGrantLocal compAccept j g
+                (Right (Entity j _), Right (_, _, g)) -> insert_ $ StemProjectGrantRemote compAccept j g
+                _ -> error "componentGrant impossible"
+            chainID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+            insert_ $ StemDelegateLocal compAccept chainID
+
+            -- Prepare a Grant activity and insert to my outbox
+            chain <- do
+                Stem role <- getJust stemID
+                chain@(actionChain, _, _, _) <- prepareChain role
+                let recipByKey = grantResourceLocalActor $ topicResource recipKey
+                _luChain <- updateOutboxItem' recipByKey chainID actionChain
+                return chain
+
+            return (recipActorID, sieve, chainID, chain)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (recipActorID, sieve, chainID, (actionChain, localRecipsChain, remoteRecipsChain, fwdHostsChain)) -> do
+            let recipByID = grantResourceLocalActor $ topicResource recipKey
+            forwardActivity authorIdMsig body recipByID recipActorID sieve
+            lift $ sendActivity
+                recipByID recipActorID localRecipsChain remoteRecipsChain
+                fwdHostsChain chainID actionChain
+            done "Recorded and forwarded the delegator-Grant, sent a delegation-starter Grant"
+
+    where
+
+    checkDelegatorGrant g = do
+        (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
+            parseGrant' g
+        case role of
+            AP.RXRole _ -> throwE "Not a delegator Grant"
+            AP.RXDelegator -> pure ()
+        project <-
+            bitraverse
+                (\case
+                    GrantResourceProject j -> return j
+                    _ -> throwE "Resource isn't a project"
+                )
+                pure
+                resource
+        case (project, authorIdMsig) of
+            (Left j, Left (a, _, _)) | LocalActorProject j == a -> pure ()
+            (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
+            _ -> throwE "Author and resource aren't the same project actor"
+        case recipient of
+            Left (GrantRecipComponent' c)
+                | topicComponent recipKey == c -> pure ()
+            _ -> throwE "Grant recipient isn't me"
+        for_ mstart $ \ start ->
+            unless (start < now) $ throwE "Start time is in the future"
+        for_ mend $ \ _ ->
+            throwE "End time is specified"
+        unless (usage == AP.Invoke) $
+            throwE "Usage isn't Invoke"
+        for_ mdeleg $ \ _ ->
+            throwE "'delegates' is specified"
+        return project
+
+    tryInviteComp (Left (_, _, itemID)) = do
+        originInviteID <-
+            stemProjectGestureLocalOrigin <$>
+                MaybeT (getValBy $ UniqueStemProjectGestureLocalInvite itemID)
+        lift $ stemOriginInviteStem <$> getJust originInviteID
+    tryInviteComp (Right remoteActivityID) = do
+        StemProjectGestureRemote originInviteID _ _ <-
+            MaybeT $ getValBy $
+                UniqueStemProjectGestureRemoteInvite remoteActivityID
+        lift $ stemOriginInviteStem <$> getJust originInviteID
+
+    tryAddComp (Left (_, __, itemID)) = do
+        StemComponentGestureLocal stemID _ <-
+            MaybeT $ getValBy $ UniqueStemComponentGestureLocalActivity itemID
+        _originID <- MaybeT $ getKeyBy $ UniqueStemOriginAdd stemID
+        return stemID
+    tryAddComp (Right remoteActivityID) = do
+        StemComponentGestureRemote stemID _ _ <-
+            MaybeT $ getValBy $
+                UniqueStemComponentGestureRemoteActivity remoteActivityID
+        _originID <- MaybeT $ getKeyBy $ UniqueStemOriginAdd stemID
+        return stemID
+
+    prepareChain role = do
+        encodeRouteHome <- getEncodeRouteHome
+
+        audProject <- makeAudSenderWithFollowers authorIdMsig
+        audMe <-
+            AudLocal [] . pure . localActorFollowers .
+            grantResourceLocalActor . topicResource <$>
+                encodeKeyHashid recipKey
+        uProject <- lift $ getActorURI authorIdMsig
+        uGrant <- lift $ getActivityURI authorIdMsig
+        recipHash <- encodeKeyHashid recipKey
+        let topicByHash = grantResourceLocalActor $ topicResource recipHash
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audProject, audMe]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Just uGrant
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = [uGrant]
+                , AP.actionSpecific   = AP.GrantActivity AP.Grant
+                    { AP.grantObject    = AP.RXRole role
+                    , AP.grantContext   =
+                        encodeRouteHome $ renderLocalActor topicByHash
+                    , AP.grantTarget    = uProject
+                    , AP.grantResult    = Nothing
+                    , AP.grantStart     = Just now
+                    , AP.grantEnd       = Nothing
+                    , AP.grantAllows    = AP.GatherAndConvey
+                    , AP.grantDelegates = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)

src/Vervis/Actor/Deck.hs

@@ -495,6 +495,38 @@ deckJoin =
         deckActor GrantResourceDeck
         CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
 
+-- Meaning: An actor is granting access-to-some-resource to another actor
+-- Behavior:
+--      * If I approved an Add-to-project where I'm the component, and the
+--        project is now giving me the delegator-Grant:
+--          * Record this in the Stem record in DB
+--          * Forward to my followers
+--          * Start a delegation chain giving access-to-me, send this new Grant
+--            to the project to distribute further, and use the delegator-Grant
+--            as the capability
+--              * To: Project
+--              * CC: My followers, project followers
+--      * If I approved an Invite-to-project where I'm the component, and the
+--        project is now giving me the delegator-Grant:
+--          * Record this in the Stem record in DB
+--          * Forward to my followers
+--          * Start a delegation chain giving access-to-me, send this new Grant
+--            to the project to distribute further, and use the delegator-Grant
+--            as the capability
+--              * To: Project
+--              * CC: My followers, project followers
+--      * If the Grant is for an Add/Invite that hasn't had the full approval
+--        chain, or I already got the delegator-Grant, raise an error
+--      * Otherwise, if I've already seen this Grant or it's simply not related
+--        to me, ignore it
+deckGrant
+    :: UTCTime
+    -> DeckId
+    -> Verse
+    -> AP.Grant URIMode
+    -> ActE (Text, Act (), Next)
+deckGrant = componentGrant deckActor GrantResourceDeck ComponentDeck
+
 ------------------------------------------------------------------------------
 -- Ambiguous: Following/Resolving
 ------------------------------------------------------------------------------
@@ -711,6 +743,7 @@ deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
         AP.AddActivity add       -> deckAdd now deckID verse add
         AP.CreateActivity create -> deckCreate now deckID verse create
         AP.FollowActivity follow -> deckFollow now deckID verse follow
+        AP.GrantActivity grant   -> deckGrant now deckID verse grant
         AP.InviteActivity invite -> deckInvite now deckID verse invite
         AP.JoinActivity join     -> deckJoin now deckID verse join
         AP.RejectActivity reject -> deckReject now deckID verse reject

src/Vervis/Data/Collab.hs

@@ -580,18 +580,21 @@ resourceToComponent = \case
 data GrantRecipBy' f
     = GrantRecipPerson' (f Person)
     | GrantRecipProject' (f Project)
+    | GrantRecipComponent' (ComponentBy f)
     deriving (Generic, FunctorB, TraversableB, ConstraintsB)
 
 deriving instance AllBF Eq f GrantRecipBy' => Eq (GrantRecipBy' f)
 
 parseGrantRecip' (PersonR p)  = Just $ GrantRecipPerson' p
 parseGrantRecip' (ProjectR j) = Just $ GrantRecipProject' j
-parseGrantRecip' _            = Nothing
+parseGrantRecip' r            = GrantRecipComponent' <$> parseComponent r
 
 hashGrantRecip' (GrantRecipPerson' k) =
     GrantRecipPerson' <$> WAP.encodeKeyHashid k
 hashGrantRecip' (GrantRecipProject' k) =
     GrantRecipProject' <$> WAP.encodeKeyHashid k
+hashGrantRecip' (GrantRecipComponent' byk) =
+    GrantRecipComponent' <$> hashComponent byk
 
 unhashGrantRecipPure' ctx = f
     where
@@ -599,6 +602,8 @@ unhashGrantRecipPure' ctx = f
         GrantRecipPerson' <$> decodeKeyHashidPure ctx p
     f (GrantRecipProject' p) =
         GrantRecipProject' <$> decodeKeyHashidPure ctx p
+    f (GrantRecipComponent' c) =
+        GrantRecipComponent' <$> unhashComponentPure ctx c
 
 unhashGrantRecip' resource = do
     ctx <- asksEnv WAP.stageHashidsContext