diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 5580289..6cb4110 100644 --- a/src/Vervis/Actor/Project.hs +++ b/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' <- - Left <$> checkDelegationStart grant <|> - Right <$> checkDelegator grant - - case grant' of - Left (role, component) -> handleComp capability role component - Right collab -> handleCollab capability collab + grant' <- checkGrant grant + let adapt = maybe (Right Nothing) (either Left (Right . Just)) + maybeMode <- + withDBExcept $ ExceptT $ fmap adapt $ runMaybeT $ + runExceptT (Left <$> tryComp capability grant') <|> + runExceptT (Right <$> tryCollab capability grant') + 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 - (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <- - parseGrant' g - case role of - AP.RXRole _ -> throwE "Role isn't delegator" - AP.RXDelegator -> pure () - collab <- + let resourceIsAuthor = + case (resource, authorIdMsig) of + (Left a, Left (a', _, _)) -> a == a' + (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 + (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 - LocalActorPerson p -> pure p - _ -> throwE "Local resource isn't a Person, therefore not a collaborator of mine" - ) - pure - resource - 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 + (pure . snd) + (\ (_, raID) -> getRemoteActorURI =<< getJust raID) + ident + unless (first componentActor identForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $ + throwE "Capability's component and Grant author aren't the same actor" + return (role, enableID, ident, identForCheck) - 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