Hello.
I've been playing around trying to write a framework to support/enforce access
control to resources. So far my efforts have yielded little but bruised
forehead and compressed plaster-board.
What I'd like is a solution that:
(1) prevents access to resources except via a fine-grained permissions
checking gateway
(2) supports on-the-fly permissions eg Bob can see Fred's salary
(3) supports dynamic role constraints eg Bob can't be both appointor and
appointee of secret agent status
(4) allows lack of permission to optionally act as a filter rather than
cause an abort, eg Bob viewing all salaries returns Fred's but doesn't return
Tom's rather than aborting altogether because Bob lacks the permission over
Tom
(5) well defined behaviour when checking permissions for actions that change
permissions
(6) it must be pure, no need for IO.
(7) ideally required permissions would appear (and accumulate) in type
signatures via inference so application code knows which are required and
type checker can reject static/dynamic role constraint violations
I've attempted a solution using arrows based loosely upon ideas in [1] and
[2]. I can't figure out how to make it work, even if I did get it working I
now suspect it can be done far more simply, and I don't think it could ever
provide feature (7). For what it's worth it's attached.
Ideally you kind folk could help me come up with a type-level solution to
satisfy (7), so you could have something like:
deptAveSal :: (HasPerms subject? Read Salary [person]?, HasPerm subject? Read
Employees dept?, HasRole subject? Manager dept?) => Department -> Salary
Failing that how to do it in a more simple fashion? I now think that a
State-like monad exposing only functions taking values in a wrapper type that
carries required permissions may be sufficient, but still probably couldn't
satisfy (7).
Failing that my existing attempt has me stumped for a few reasons:
how do I get hold of the subject and resource so I can build the correct
permission in Test? eg the Person whose Salary is needed in salary, and
who's trying to get it
where do I get the System from in Test? eg fakeSystem in personByName
how to implement the filter functionality in RBAC? Parametric over
container types?
I think that perhaps the Validator would need to be a monad that holds the
initial state of the System to provide a stable set of permissions/roles and
that the subject and System should also be threaded through the arrows for
use/modification.
Any help you can offer for my aching cranium will be _much_ appreciated.
Thanks.
[1] Encoding Information Flow in Haskell - Peng Li, Steve Zdancewic.
http://www.seas.upenn.edu/~lipeng/homepage/flowarrow.html
[2] A Library for Secure Multi-threaded Information Flow in Haskell -
Alejandro Russo, Tsa-chung Tsai, John Hughes.
http://www.cs.chalmers.se/~russo/publications.html
{-# LANGUAGE
FunctionalDependencies,
MultiParamTypeClasses
#-}
module RBAC (
Arrow (),
Validator (..),
apply,
require,
applyRequire,
check
) where
import Control.Arrow (
first,
pure,
(>>>)
)
import qualified Control.Arrow as A
import Data.Set (
Set
)
import qualified Data.Set as S (
empty,
fromList,
singleton,
union
)
require :: (A.Arrow a) => p -> Arrow v p a b b
require p = Arr { computation = pure id
, permissions = S.singleton p
}
apply :: (A.Arrow a, Ord p) => (b -> c) -> Arrow v p a b c
apply = pure
applyRequire :: (A.Arrow a, Ord p) => (b -> c) -> p -> Arrow v p a b c
applyRequire f p = apply f >>> require p
-- filter and filter' use permissionHeld... perhaps permissionHeld is
-- implemented by knot-tying the set of permissions that get checked
-- in the process of executing the arrow back in as an input. Perhaps
-- there should be permissions and filterPermissions in the arrow so
-- only the filterPermissions are passed back in.
--filter :: (A.Arrow a) => p -> Arrow v p a b (Maybe b)
--filter p = Arr { computation = pure if permissionHeld p
-- then Just
-- else const Nothing
-- , permissions = S.singleton p
-- }
-- Filters out each element of the list for which the constructed
-- permission isn't held. Would be nice if this could be generalised
-- to any container, not just lists.
--filter' :: (A.Arrow a) => (b -> p) -> Arrow v p a [b] [b]
--filter' pf = error "filter': not implemented"
data Arrow v p a b c = Arr { computation :: a b c
, permissions :: Set p
}
instance (Ord p, A.Arrow a) => A.Arrow (Arrow v p a) where
pure f = Arr { computation = pure f
, permissions = S.empty
}
(Arr c1 ps1) >>> (Arr c2 ps2) = Arr { computation = c1 >>> c2
, permissions = S.union ps1 ps2
}
first (Arr c ps) = Arr { computation = first c
, permissions = ps
}
type Checked a b = Either a b
class (Ord p) => Validator v p e | v -> p, v -> e where
validate :: v -> Set p -> Checked e ()
check :: (A.Arrow a, Validator v p e) =>
v -> Arrow v p a b c -> a b (Checked e c)
check v (Arr c ps) = either (pure . const . Left) (const (c >>> pure Right))
(validate v ps)
{-# LANGUAGE
MultiParamTypeClasses,
TypeSynonymInstances
#-}
module Test (
System (),
Person (),
name,
personByName,
salary,
manager
) where
import Control.Arrow
import Data.Maybe
import qualified RBAC as RBAC
data System = Sys [Person]
data Person = Person { pName :: Name
, pSalary :: Salary
, pManager :: Name
, pSecretAgent :: Bool
, pCanAppointAgent :: Bool
}
type Name = String
type Salary = String
type Protected a b = RBAC.Arrow Validator Permission (->) a b
type Permission = String
type DynamicConstraintViolation = String
data Validator = Validator
instance RBAC.Validator Validator Permission DynamicConstraintViolation where
validate = error "validate not implemented"
findPerson (Sys ps) n = (lookup n . map (\p -> (pName p, p))) ps
name :: Protected a Person -> Protected a Name
name = (>>^ pName)
personByName :: Protected a Name -> Protected a (Maybe Person)
personByName = ar (findPerson fakeSystem) (fakeP "perm: s observe p")
salary :: Protected a Person -> Protected a Salary
salary = ar pSalary (fakeP "perm s read p.salary")
manager :: Protected a Person -> Protected a Person
manager = (>>^ fromJust) . personByName .
ar pManager (fakeP "perm s read p.manager")
ar f p = (>>> RBAC.applyRequire f p)
fakeP :: String -> Permission
fakeP = error
fakeSystem :: System
fakeSystem = error "where does the Sys come from?"
protect :: a -> Protected () a
protect x = pure (\() -> x)
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
