S2S: Component: Grant: Refactor, prepare for adding team-mode

src/Vervis/Actor/Common.hs

@@ -82,6 +82,8 @@ import Vervis.Data.Collab
 import Vervis.Data.Discussion
 import Vervis.FedURI
 
+import Vervis.Data.Actor
+import Vervis.Data.Collab
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Persist.Actor
@@ -92,6 +94,11 @@ import Vervis.RemoteActorStore
 import Vervis.Ticket
 import Vervis.Web.Collab
 
+data GrantKind
+    = GKDelegationStart AP.Role
+    | GKDelegationExtend AP.Role (Either (LocalActorBy Key) FedURI)
+    | GKDelegator
+
 actorFollow
     :: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r)
     => (Route App -> ActE a)
@@ -2163,6 +2170,7 @@ topicCreateMe grabResource topicResource now recipKey (Verse authorIdMsig body)
 --            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
@@ -2172,8 +2180,14 @@ topicCreateMe grabResource topicResource now recipKey (Verse authorIdMsig body)
 --            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
+--
+--      * Almost-Team sending me the delegator-Grant
+--          * Update the Squad record, enabling the team
+--          * Send a start-Grant giving access-to-me
+--
 --      * Otherwise, if I've already seen this Grant or it's simply not related
 --        to me, ignore it
 componentGrant
@@ -2188,47 +2202,45 @@ componentGrant
     -> ActE (Text, Act (), Next)
 componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body) grant = do
 
-    -- Check grant
+    grant' <- checkGrant grant
-    project <- checkDelegatorGrant grant
+    let adapt = maybe (Right Nothing) (either Left (Right . Just))
+    maybeMode <-
+        withDBExcept $ do
+            meResourceID <- lift $ grabResource <$> getJust recipKey
+            ExceptT $ fmap adapt $ runMaybeT $
+                runExceptT (id <$> tryStem grant')
+    mode <-
+        fromMaybeE
+            maybeMode
+            "Not a relevant Grant that I'm aware of"
+    case mode of
+        stem -> handleStem stem
 
-    -- Check the Add/Invite that it's related to
+    where
-    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
-        resourceID <- lift $ grabResource <$> getJust recipKey
-        Resource recipActorID <- lift $ getJust resourceID
-        recipActor <- lift $ getJust recipActorID
-
-        -- Find the fulfilled activity in our DB
-        fulfillsDB <- do
-            a <- getActivity fulfills
-            fromMaybeE a "Can't find fulfilled in DB"
 
+    tryStem (GKDelegationStart _)    = lift mzero
+    tryStem (GKDelegationExtend _ _) = lift mzero
+    tryStem 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)
         -- See if the fulfilled activity is an Invite or Add on a local
         -- component, grabbing the Stem record from our DB
-        stem <- do
+        stem <-
-            maybeStem <-
+            lift $
-                lift $ runMaybeT $
+                Left <$> tryInviteComp fulfillsDB <|>
-                    Left <$> tryInviteComp fulfillsDB <|>
+                Right <$> tryAddComp 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
+        ident <- lift $ lift $ getStemIdent stemID
-        unless (topicComponent recipKey == ident) $
+        lift $ guard $ 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 $
+            lift $ lift $
             requireEitherAlt
                 (getBy $ UniqueStemProjectLocal stemID)
                 (getBy $ UniqueStemProjectRemote stemID)
@@ -2242,89 +2254,98 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
                 | 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
+            mk <- lift $ lift $ getKeyBy $ UniqueStemComponentAccept stemID
             fromMaybeE mk "Getting a delegator-Grant but never approved this Invite/Add"
-        gl <- lift $ getBy $ UniqueStemProjectGrantLocal compAccept
+        gl <- lift $ lift $ getBy $ UniqueStemProjectGrantLocal compAccept
-        gr <- lift $ getBy $ UniqueStemProjectGrantRemote compAccept
+        gr <- lift $ lift $ getBy $ UniqueStemProjectGrantRemote compAccept
         unless (isNothing gl && isNothing gr) $
             throwE "I already received a delegator-Grant for this Invite/Add"
+        return (stemID, stemProject, compAccept)
 
-        maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
+    handleStem (stemID, stemProject, compAccept) = do
-        lift $ for maybeGrantDB $ \ (inboxItemID, grantDB) -> do
 
-            -- Prepare forwarding to my followers
+        maybeNew <- withDBExcept $ do
-            sieve <- do
-                recipHash <- encodeKeyHashid recipKey
-                let recipByHash = resourceToActor $ topicResource recipHash
-                return $ makeRecipientSet [] [localActorFollowers recipByHash]
 
-            -- Update the Stem record in DB
+            -- Grab me from DB
-            case (stemProject, grantDB) of
+            resourceID <- lift $ grabResource <$> getJust recipKey
-                (Left (Entity j _), Left (_, _, g)) -> insert_ $ StemProjectGrantLocal compAccept j g
+            Resource recipActorID <- lift $ getJust resourceID
-                (Right (Entity j _), Right (_, _, g)) -> insert_ $ StemProjectGrantRemote compAccept j g
+            recipActor <- lift $ getJust recipActorID
-                _ -> error "componentGrant impossible"
-            chainID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
-            insert_ $ StemDelegateLocal compAccept chainID
 
-            -- Prepare a Grant activity and insert to my outbox
+            maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
-            chain <- do
+            lift $ for maybeGrantDB $ \ (inboxItemID, grantDB) -> do
-                Stem role _ <- getJust stemID
-                chain@(actionChain, _, _, _) <- prepareChain role
-                let recipByKey = resourceToActor $ topicResource recipKey
-                _luChain <- updateOutboxItem' recipByKey chainID actionChain
-                return chain
 
-            return (recipActorID, sieve, chainID, chain, inboxItemID)
+                -- Prepare forwarding to my followers
+                sieve <- do
+                    recipHash <- encodeKeyHashid recipKey
+                    let recipByHash = resourceToActor $ topicResource recipHash
+                    return $ makeRecipientSet [] [localActorFollowers recipByHash]
 
-    case maybeNew of
+                -- Update the Stem record in DB
-        Nothing -> done "I already have this activity in my inbox"
+                case (stemProject, grantDB) of
-        Just (recipActorID, sieve, chainID, (actionChain, localRecipsChain, remoteRecipsChain, fwdHostsChain), inboxItemID) -> do
+                    (Left (Entity j _), Left (_, _, g)) -> insert_ $ StemProjectGrantLocal compAccept j g
-            let recipByID = resourceToActor $ topicResource recipKey
+                    (Right (Entity j _), Right (_, _, g)) -> insert_ $ StemProjectGrantRemote compAccept j g
-            forwardActivity authorIdMsig body recipByID recipActorID sieve
+                    _ -> error "componentGrant impossible"
-            lift $ sendActivity
+                chainID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
-                recipByID recipActorID localRecipsChain remoteRecipsChain
+                insert_ $ StemDelegateLocal compAccept chainID
-                fwdHostsChain chainID actionChain
-            doneDB inboxItemID "Recorded and forwarded the delegator-Grant, sent a delegation-starter Grant"
 
-    where
+                -- Prepare a Grant activity and insert to my outbox
+                chain <- do
+                    Stem role _ <- getJust stemID
+                    chain@(actionChain, _, _, _) <- prepareChain role
+                    let recipByKey = resourceToActor $ topicResource recipKey
+                    _luChain <- updateOutboxItem' recipByKey chainID actionChain
+                    return chain
+
+                return (recipActorID, sieve, chainID, chain, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (recipActorID, sieve, chainID, (actionChain, localRecipsChain, remoteRecipsChain, fwdHostsChain), inboxItemID) -> do
+                let recipByID = resourceToActor $ topicResource recipKey
+                forwardActivity authorIdMsig body recipByID recipActorID sieve
+                lift $ sendActivity
+                    recipByID recipActorID localRecipsChain remoteRecipsChain
+                    fwdHostsChain chainID actionChain
+                doneDB inboxItemID "Recorded and forwarded the delegator-Grant, sent a delegation-starter Grant"
+
+    meID = recipKey
+    toComponent = topicComponent
+
+    meComponent = toComponent recipKey
+    meResource = componentResource meComponent
+    meActor = resourceToActor meResource
 
     topicResource :: forall f. f topic -> LocalResourceBy f
     topicResource = componentResource . topicComponent
 
-    checkDelegatorGrant g = do
+    checkGrant 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
-                    LocalActorProject 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 la | resourceToActor (topicResource recipKey) == la -> pure ()
+            Left la | la == meActor -> pure ()
-            _ -> throwE "Grant recipient isn't me"
+            _ -> throwE "Target 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"
+        let resourceIsAuthor =
-        for_ mdeleg $ \ _ ->
+                case (resource, authorIdMsig) of
-            throwE "'delegates' is specified"
+                    (Left a, Left (a', _, _)) -> a == a'
-        return project
+                    (Right u, Right (ra, _, _)) -> remoteAuthorURI ra == u
+                    _ -> False
+
+        case (role, resourceIsAuthor, usage, mdeleg) of
+            (AP.RXRole r, True, AP.GatherAndConvey, Nothing) ->
+                pure $ GKDelegationStart r
+            (AP.RXRole r, False, AP.GatherAndConvey, Just _) ->
+                pure $ GKDelegationExtend r resource
+            (AP.RXDelegator, True, AP.Invoke, Nothing) ->
+                pure GKDelegator
+            _ -> throwE "A kind of Grant that I don't use"
 
     tryInviteComp (Left (_, _, itemID)) = do
         originInviteID <-

src/Vervis/Actor/Deck.hs

@@ -625,30 +625,6 @@ deckJoin
     -> ActE (Text, Act (), Next)
 deckJoin = topicJoin deckResource LocalResourceDeck
 
--- 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