S2S: Project: Grant: Prepare for adding the child/parent modes

src/Vervis/Actor/Project.hs

@@ -1854,6 +1854,11 @@ projectFollow now recipProjectID verse follow = do
         (\ _ -> pure [])
         now recipProjectID verse follow
 
+data GrantKind
+    = GKDelegationStart AP.Role
+    | GKDelegationExtend AP.Role
+    | GKDelegator
+
 -- Meaning: An actor is granting access-to-some-resource to another actor
 -- Behavior:
 --      * Option 1 - Component sending me a delegation-start - Verify that:
@@ -1961,31 +1966,27 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
             _ -> throwE "Capability is remote i.e. definitely not by me"
 
     -- Check grant
-    grant' <-
+    grant' <- checkGrant grant
-        Left <$> checkDelegationStart grant <|>
+    let adapt = maybe (Right Nothing) (either Left (Right . Just))
-        Right <$> checkDelegator grant
+    maybeMode <-
-
+        withDBExcept $ ExceptT $ fmap adapt $ runMaybeT $
-    case grant' of
+            runExceptT (Left <$> tryComp capability grant') <|>
-        Left (role, component) -> handleComp capability role component
+            runExceptT (Right <$> tryCollab capability grant')
-        Right collab -> handleCollab capability collab
+    mode <-
+        fromMaybeE
+            maybeMode
+            "Not a relevant Grant that I'm aware of"
+    case mode of
+        Left (role, enableID, ident, identForCheck) ->
+            handleComp role enableID ident identForCheck
+        Right (enableID, role, recip) ->
+            handleCollab enableID role recip
 
     where
 
-    checkDelegationStart g = do
+    checkGrant g = do
         (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
             parseGrant' g
-        role' <-
-            case role of
-                AP.RXRole r -> pure r
-                AP.RXDelegator -> throwE "Role is delegator"
-        component <-
-            fromMaybeE
-                (bitraverse actorToComponent Just resource)
-                "Resource is a local project, therefore not a component of mine"
-        case (component, authorIdMsig) of
-            (Left c, Left (a, _, _)) | componentActor c == a -> pure ()
-            (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
-            _ -> throwE "Author and context aren't the same actor"
         case recipient of
             Left (LocalActorProject j) | j == projectID -> pure ()
             _ -> throwE "Target isn't me"
@@ -1993,44 +1994,48 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
             unless (start < now) $ throwE "Start time is in the future"
         for_ mend $ \ _ ->
             throwE "End time is specified"
-        unless (usage == AP.GatherAndConvey) $
-            throwE "Usage isn't GatherAndConvey"
-        for_ mdeleg $ \ _ ->
-            throwE "'delegates' is specified"
-        return (role', component)
 
-    checkDelegator g = do
+        let resourceIsAuthor =
-        (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
+                case (resource, authorIdMsig) of
-            parseGrant' g
+                    (Left a, Left (a', _, _)) -> a == a'
-        case role of
+                    (Right u, Right (ra, _, _)) -> remoteAuthorURI ra == u
-            AP.RXRole _ -> throwE "Role isn't delegator"
+                    _ -> False
-            AP.RXDelegator -> pure ()
+
-        collab <-
+        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
+            (AP.RXDelegator, True, AP.Invoke, Nothing) ->
+                pure GKDelegator
+            _ -> throwE "A kind of Grant that I don't use"
+
+    tryComp _          (GKDelegationExtend _)   = lift mzero
+    tryComp _          GKDelegator              = lift mzero
+    tryComp capability (GKDelegationStart role) = do
+        -- Find the Component record from the capability
+        Entity enableID (ComponentEnable componentID _) <- lift $ do
+            -- Capability isn't mine
+            guard $ fst capability == LocalActorProject projectID
+            -- I don't have a Component with this capability
+            MaybeT $ getBy $ UniqueComponentEnableGrant $ snd capability
+        Component j role' <- lift $ lift $ getJust componentID
+        -- Found a Component for this delegator-Grant but it's not mine
+        lift $ guard $ j == projectID
+        unless (role' == role) $
+            throwE "Grant role isn't the same as in the Invite/Add"
+        ident <- lift $ lift $ getComponentIdent componentID
+        identForCheck <-
+            lift $ lift $
             bitraverse
-                (\case
+                (pure . snd)
-                    LocalActorPerson p -> pure p
+                (\ (_, raID) -> getRemoteActorURI =<< getJust raID)
-                    _ -> throwE "Local resource isn't a Person, therefore not a collaborator of mine"
+                ident
-                )
+        unless (first componentActor identForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $
-                pure
+            throwE "Capability's component and Grant author aren't the same actor"
-                resource
+        return (role, enableID, ident, identForCheck)
-        case (collab, authorIdMsig) of
-            (Left c, Left (a, _, _)) | LocalActorPerson c == a -> pure ()
-            (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
-            _ -> throwE "Author and context aren't the same actor"
-        case recipient of
-            Left (LocalActorProject j) | j == projectID -> pure ()
-            _ -> 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"
-        for_ mdeleg $ \ _ ->
-            throwE "'delegates' is specified"
-        return collab
 
-    handleComp capability role component = do
+    handleComp role enableID ident identForCheck = do
 
         maybeNew <- withDBExcept $ do
 
@@ -2040,27 +2045,6 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
                 let actorID = projectActor recip
                 (actorID,) <$> getJust actorID
 
-            -- Find the Component record from the capability
-            Entity enableID (ComponentEnable componentID _) <- do
-                unless (fst capability == LocalActorProject projectID) $
-                    throwE "Capability isn't mine"
-                m <- lift $ getBy $ UniqueComponentEnableGrant $ snd capability
-                fromMaybeE m "I don't have a Component with this capability"
-            Component j role' <- lift $ getJust componentID
-            unless (j == projectID) $
-                throwE "Found a Component for this delegator-Grant but it's not mine"
-            unless (role' == role) $
-                throwE "Grant role isn't the same as in the Invite/Add"
-            ident <- lift $ getComponentIdent componentID
-            identForCheck <-
-                lift $
-                bitraverse
-                    (pure . snd)
-                    (\ (_, raID) -> getRemoteActorURI =<< getJust raID)
-                    ident
-            unless (identForCheck == component) $
-                throwE "Capability's component and Grant author aren't the same actor"
-
             -- Verify I don't yet have a delegation from the component
             maybeDeleg <-
                 lift $ case bimap fst fst ident of
@@ -2327,7 +2311,31 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
 
             return (action, recipientSet, remoteActors, fwdHosts)
 
-    handleCollab capability collab = do
+    tryCollab _          (GKDelegationStart _)  = lift mzero
+    tryCollab _          (GKDelegationExtend _) = lift mzero
+    tryCollab capability GKDelegator            = do
+        -- Find the Collab record from the capability
+        Entity enableID (CollabEnable collabID _) <- lift $ do
+            -- Capability isn't mine
+            guard $ fst capability == LocalActorProject projectID
+            -- I don't have a Collab with this capability
+            MaybeT $ getBy $ UniqueCollabEnableGrant $ snd capability
+        Collab role <- lift $ lift $ getJust collabID
+        topic <- lift $ lift $ getCollabTopic collabID
+        -- Found a Collab for this direct-Grant but it's not mine
+        lift $ guard $ topic == LocalActorProject projectID
+        recip <- lift $ lift $ getCollabRecip collabID
+        recipForCheck <-
+            lift $ lift $
+            bitraverse
+                (pure . collabRecipLocalPerson . entityVal)
+                (getRemoteActorURI <=< getJust . collabRecipRemoteActor . entityVal)
+                recip
+        unless (first LocalActorPerson recipForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $
+            throwE "Capability's collaborator and Grant author aren't the same actor"
+        return (enableID, role, recip)
+
+    handleCollab enableID role recip = do
 
         maybeNew <- withDBExcept $ do
 
@@ -2337,26 +2345,6 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
                 let actorID = projectActor recip
                 (actorID,) <$> getJust actorID
 
-            -- Find the Collab record from the capability
-            Entity enableID (CollabEnable collabID _) <- do
-                unless (fst capability == LocalActorProject projectID) $
-                    throwE "Capability isn't mine"
-                m <- lift $ getBy $ UniqueCollabEnableGrant $ snd capability
-                fromMaybeE m "I don't have a Collab with this capability"
-            Collab role <- lift $ getJust collabID
-            topic <- lift $ getCollabTopic collabID
-            unless (topic == LocalActorProject projectID) $
-                throwE "Found a Collab for this direct-Grant but it's not mine"
-            recip <- lift $ getCollabRecip collabID
-            recipForCheck <-
-                lift $
-                bitraverse
-                    (pure . collabRecipLocalPerson . entityVal)
-                    (getRemoteActorURI <=< getJust . collabRecipRemoteActor . entityVal)
-                    recip
-            unless (recipForCheck == collab) $
-                throwE "Capability's collaborator and Grant author aren't the same actor"
-
             -- Verify I don't yet have a delegator-Grant from the collaborator
             maybeDeleg <-
                 lift $ case bimap entityKey entityKey recip of