S2S: Project: Grant: Fix capability check, do it in MaybeT, not ExceptT
This commit is contained in:
parent
f326b276c2
commit
719999242a
2 changed files with 13 additions and 8 deletions
|
@ -18,10 +18,12 @@ module Control.Monad.Trans.Except.Local
|
||||||
, verifyNothingE
|
, verifyNothingE
|
||||||
, nameExceptT
|
, nameExceptT
|
||||||
, verifySingleE
|
, verifySingleE
|
||||||
|
, hoistMaybe
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
|
import Control.Monad.Trans.Maybe
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
|
||||||
fromMaybeE :: Monad m => Maybe a -> e -> ExceptT e m a
|
fromMaybeE :: Monad m => Maybe a -> e -> ExceptT e m a
|
||||||
|
@ -40,3 +42,6 @@ verifySingleE list none several =
|
||||||
[] -> throwE none
|
[] -> throwE none
|
||||||
[x] -> pure x
|
[x] -> pure x
|
||||||
_ -> throwE several
|
_ -> throwE several
|
||||||
|
|
||||||
|
hoistMaybe :: Applicative m => Maybe b -> MaybeT m b
|
||||||
|
hoistMaybe = MaybeT . pure
|
||||||
|
|
|
@ -2276,20 +2276,20 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
|
|
||||||
checkCapability = do
|
checkCapability = do
|
||||||
-- Verify that a capability is provided
|
-- Verify that a capability is provided
|
||||||
uCap <- do
|
uCap <- lift $ hoistMaybe $ AP.activityCapability $ actbActivity body
|
||||||
let muCap = AP.activityCapability $ actbActivity body
|
|
||||||
fromMaybeE muCap "No capability provided"
|
|
||||||
|
|
||||||
-- Verify the capability URI is one of:
|
-- Verify the capability URI is one of:
|
||||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||||
-- * A remote URI
|
-- * A remote URI
|
||||||
cap <- nameExceptT "Grant capability" $ parseActivityURI' uCap
|
cap <-
|
||||||
|
ExceptT . lift . lift . runExceptT $
|
||||||
|
nameExceptT "Grant capability" $ parseActivityURI' uCap
|
||||||
|
|
||||||
-- Verify the capability is local
|
-- Verify the capability is local
|
||||||
case cap of
|
case cap of
|
||||||
Left (actorByKey, _, outboxItemID) ->
|
Left (actorByKey, _, outboxItemID) ->
|
||||||
return (actorByKey, outboxItemID)
|
return (actorByKey, outboxItemID)
|
||||||
_ -> throwE "Capability is remote i.e. definitely not by me"
|
_ -> lift mzero
|
||||||
|
|
||||||
checkGrant g = do
|
checkGrant g = do
|
||||||
(role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
|
(role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
|
||||||
|
@ -2320,7 +2320,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
tryComp (GKDelegationExtend _ _) = lift mzero
|
tryComp (GKDelegationExtend _ _) = lift mzero
|
||||||
tryComp GKDelegator = lift mzero
|
tryComp GKDelegator = lift mzero
|
||||||
tryComp (GKDelegationStart role) = do
|
tryComp (GKDelegationStart role) = do
|
||||||
capability <- ExceptT $ lift $ lift $ runExceptT checkCapability
|
capability <- checkCapability
|
||||||
-- Find the Component record from the capability
|
-- Find the Component record from the capability
|
||||||
Entity enableID (ComponentEnable componentID _) <- lift $ do
|
Entity enableID (ComponentEnable componentID _) <- lift $ do
|
||||||
-- Capability isn't mine
|
-- Capability isn't mine
|
||||||
|
@ -2622,7 +2622,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
tryCollab (GKDelegationStart _) = lift mzero
|
tryCollab (GKDelegationStart _) = lift mzero
|
||||||
tryCollab (GKDelegationExtend _ _) = lift mzero
|
tryCollab (GKDelegationExtend _ _) = lift mzero
|
||||||
tryCollab GKDelegator = do
|
tryCollab GKDelegator = do
|
||||||
capability <- ExceptT $ lift $ lift $ runExceptT checkCapability
|
capability <- checkCapability
|
||||||
-- Find the Collab record from the capability
|
-- Find the Collab record from the capability
|
||||||
Entity enableID (CollabEnable collabID _) <- lift $ do
|
Entity enableID (CollabEnable collabID _) <- lift $ do
|
||||||
-- Capability isn't mine
|
-- Capability isn't mine
|
||||||
|
@ -2904,7 +2904,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
tryChild gk = do
|
tryChild gk = do
|
||||||
capability <- ExceptT $ lift $ lift $ runExceptT checkCapability
|
capability <- checkCapability
|
||||||
role <-
|
role <-
|
||||||
case gk of
|
case gk of
|
||||||
GKDelegationStart role -> pure role
|
GKDelegationStart role -> pure role
|
||||||
|
|
Loading…
Reference in a new issue