module Control.SafeAccess
( ensureAccess
, Capability(..)
, Capabilities
, AccessDecision(..)
, SafeAccessT(..)
, AccessDescriptor(..)
, MonadSafeAccess(..)
, liftErrorT
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Error
import Data.List
ensureAccess :: MonadSafeAccess m d => d -> m ()
ensureAccess descr = do
caps <- getCapabilities
let decisions = map (\cap -> runCapability cap descr) caps
finalDecision = foldl' mergeDecisions AccessDeniedSoft decisions
case finalDecision of
AccessGranted -> return ()
_ -> denyAccess descr
newtype Capability d = MkCapability { runCapability :: d -> AccessDecision }
type Capabilities d = [Capability d]
data AccessDecision
= AccessDeniedSoft
| AccessGranted
| AccessDenied
deriving (Show, Eq)
mergeDecisions :: AccessDecision -> AccessDecision -> AccessDecision
mergeDecisions a b = case (a, b) of
(AccessDeniedSoft, _) -> b
(_, AccessDeniedSoft) -> a
(AccessGranted, _) -> b
(_, AccessGranted) -> a
_ -> AccessDenied
newtype SafeAccessT d m a
= SafeAccessT { runSafeAccessT :: Capabilities d -> m (Either d a) }
instance (AccessDescriptor d, Monad m) => Monad (SafeAccessT d m) where
return = SafeAccessT . const . return . Right
ma >>= f = SafeAccessT $ \caps -> do
ex <- runSafeAccessT ma caps
case ex of
Left d -> return $ Left d
Right x -> runSafeAccessT (f x) caps
fail = SafeAccessT . const . return . Left . descrMsg
instance MonadTrans (SafeAccessT d) where
lift = SafeAccessT . const . (Right `liftM`)
instance Functor f => Functor (SafeAccessT d f) where
fmap f sa = SafeAccessT $ \caps -> fmap (fmap f) $ runSafeAccessT sa caps
instance Applicative f => Applicative (SafeAccessT d f) where
pure = SafeAccessT . const . pure . Right
safef <*> safea = SafeAccessT $ \caps ->
let fef = runSafeAccessT safef caps
fea = runSafeAccessT safea caps
ff = flip fmap fef $ \ef -> case ef of
Left d -> const $ Left d
Right f -> fmap f
in ff <*> fea
instance (AccessDescriptor d, MonadIO m) => MonadIO (SafeAccessT d m) where
liftIO = SafeAccessT . const . (Right `liftM`) . liftIO
class AccessDescriptor d where
descrMsg :: String -> d
getCapabilities' :: Monad m => SafeAccessT d m (Capabilities d)
getCapabilities' = SafeAccessT $ return . Right
denyAccess' :: Monad m => d -> SafeAccessT d m ()
denyAccess' = SafeAccessT . const . return . Left
class (AccessDescriptor d, Monad m) => MonadSafeAccess m d where
getCapabilities :: m (Capabilities d)
denyAccess :: d -> m ()
instance (AccessDescriptor d, Monad m) => MonadSafeAccess (SafeAccessT d m) d where
getCapabilities = getCapabilities'
denyAccess = denyAccess'
liftErrorT :: ErrorT d m a -> SafeAccessT d m a
liftErrorT = SafeAccessT . const . runErrorT