Merge branch 'master' of github.com:snapframework/snap

snap.cabal

@@ -47,6 +47,9 @@ Library
       Snap.Loader.Devel
 
   exposed-modules:
+    Data.RBAC.Checker,
+    Data.RBAC.Role,
+    Data.RBAC.Types,
     Snap,
     Snap.Loader.Prod
     Snap.Snaplet,
@@ -57,6 +60,10 @@ Library
     Snap.Snaplet.Session.Backends.CookieSession
 
   other-modules:
+    Data.RBAC.Internal.Role,
+    Data.RBAC.Internal.RoleMap,
+    Data.RBAC.Internal.Rule,
+    Data.RBAC.Internal.Types,
     Snap.Loader.Devel.Evaluator,
     Snap.Loader.Devel.Signal,
     Snap.Loader.Devel.TreeWatcher,
@@ -93,6 +100,7 @@ Library
     filepath                  >= 1.1     && < 1.3,
     hashable                  >= 1.1     && < 1.2,
     heist                     >= 0.6     && < 0.7,
+    logict                    >= 0.4.2   && < 0.5,
     mtl                       >  2.0     && < 2.1,
     mwc-random                >= 0.8     && < 0.11,
     old-time                  >= 1.0     && < 1.1,
@@ -108,6 +116,8 @@ Library
     transformers              >= 0.2     && < 0.3,
     unordered-containers      >= 0.1.4   && < 0.2,
     utf8-string               >= 0.3     && < 0.4,
+    vector                    >= 0.7.1   && < 0.10,
+    vector-algorithms         >= 0.4     && < 0.6,
     xmlhtml                   >= 0.1     && < 0.2
 
   if flag(hint)

src/Data/RBAC/Checker.hs

@@ -0,0 +1,223 @@
+{-# LANGUAGE BangPatterns      #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.RBAC.Checker where
+
+import           Control.Monad
+import           Control.Monad.Logic
+import           Control.Monad.Reader
+import           Control.Monad.State.Lazy
+import           Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as M
+import           Data.Maybe (fromMaybe, isJust)
+import           Data.Text (Text)
+
+import           Data.RBAC.Internal.RoleMap (RoleMap)
+import qualified Data.RBAC.Internal.RoleMap as RM
+import           Data.RBAC.Internal.Types
+import           Data.RBAC.Role
+
+
+------------------------------------------------------------------------------
+type RoleBuilder a = StateT RoleMap RoleMonad a
+
+
+------------------------------------------------------------------------------
+applyRule :: Role -> Rule -> [Role]
+applyRule r (Rule _ f) = f r
+
+
+------------------------------------------------------------------------------
+applyRuleSet :: Role -> RuleSet -> [Role]
+applyRuleSet r (RuleSet m) = f r
+  where
+    f = fromMaybe (const []) $ M.lookup (_roleName r) m
+
+
+------------------------------------------------------------------------------
+checkUnseen :: Role -> RoleBuilder ()
+checkUnseen role = do
+    m <- get
+    if isJust $ RM.lookup role m then mzero else return ()
+
+
+------------------------------------------------------------------------------
+checkSeen :: Role -> RoleBuilder ()
+checkSeen = lnot . checkUnseen
+
+
+------------------------------------------------------------------------------
+markSeen :: Role -> RoleBuilder ()
+markSeen role = modify $ RM.insert role
+
+
+------------------------------------------------------------------------------
+isum :: (MonadLogic m, MonadPlus m) => [m a] -> m a
+isum l = case l of
+            []     -> mzero
+            (x:xs) -> x `interleave` isum xs
+
+
+------------------------------------------------------------------------------
+-- | Given a set of roles to check, and a set of implication rules describing
+-- how a given role inherits from other roles, this function produces a stream
+-- of expanded Roles. If a Role is seen twice, expandRoles mzeros.
+expandRoles :: [Rule] -> [Role] -> RoleMonad Role
+expandRoles rules roles0 = evalStateT (go roles0) RM.empty
+  where
+    ruleSet = rulesToSet rules
+
+    go roles = isum $ map expandOne roles
+
+    expandOne role = do
+        checkUnseen role
+        markSeen role
+        return role `interleave` go newRoles
+
+      where
+        newRoles = applyRuleSet role ruleSet
+
+
+------------------------------------------------------------------------------
+hasRole :: Role -> RuleChecker ()
+hasRole r = RuleChecker $ do
+    ch <- ask
+    once $ go ch
+  where
+    go gen = do
+        r' <- lift gen
+        if r `matches` r' then return () else mzero
+
+
+------------------------------------------------------------------------------
+missingRole :: Role -> RuleChecker ()
+missingRole = lnot . hasRole
+
+
+------------------------------------------------------------------------------
+hasAllRoles :: [Role] -> RuleChecker ()
+hasAllRoles rs = RuleChecker $ do
+    ch <- ask
+    lift $ once $ go ch $ RM.fromList rs
+  where
+    go gen !st = do
+        mr <- msplit gen
+        maybe mzero
+              (\(r,gen') -> let st' = RM.delete r st
+                            in if RM.null st'
+                                 then return ()
+                                 else go gen' st')
+              mr
+
+
+------------------------------------------------------------------------------
+hasAnyRoles :: [Role] -> RuleChecker ()
+hasAnyRoles rs = RuleChecker $ do
+    ch <- ask
+    lift $ once $ go ch
+  where
+    st = RM.fromList rs
+    go gen = do
+        mr <- msplit gen
+        maybe mzero
+              (\(r,gen') -> if isJust $ RM.lookup r st
+                                 then return ()
+                                 else go gen')
+              mr
+
+
+------------------------------------------------------------------------------
+runRuleChecker :: [Rule]
+               -> [Role]
+               -> RuleChecker a
+               -> Bool
+runRuleChecker rules roles (RuleChecker f) =
+    case outs of
+      []    -> False
+      _     -> True
+  where
+    (RoleMonad st) = runReaderT f $ expandRoles rules roles
+    outs = observeMany 1 st
+
+
+------------------------------------------------------------------------------
+mkRule :: Text -> (Role -> [Role]) -> Rule
+mkRule = Rule
+
+
+------------------------------------------------------------------------------
+implies :: Role -> [Role] -> Rule
+implies src dest = Rule (_roleName src)
+                        (\role -> if role `matches` src then dest else [])
+
+
+------------------------------------------------------------------------------
+impliesWith :: Role -> (HashMap Text RoleValue -> [Role]) -> Rule
+impliesWith src f = Rule (_roleName src)
+                         (\role -> if src `matches` role
+                                     then f $ _roleData role
+                                     else [])
+
+
+------------------------------------------------------------------------------
+-- Testing code follows: TODO: move into test suite
+
+
+testRules :: [Rule]
+testRules = [ "user" `implies` ["guest", "can_post"]
+            , "superuser" `implies` [ "user"
+                                    , "can_moderate"
+                                    , "can_administrate"]
+            , "superuser" `implies` [ addRoleData "arg" "*" "with_arg" ]
+            , "with_arg" `impliesWith` \dat ->
+                maybe [] (\arg -> [addRoleData "arg" arg "dependent_arg"]) $
+                      M.lookup "arg" dat
+            , "superuser" `implies` [ addRoleData "arg1" "a" $
+                                      addRoleData "arg2" "b" "multi_args" ]
+            ]
+
+tX :: RuleChecker () -> Bool
+tX f = runRuleChecker testRules ["superuser"] f
+
+t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17 :: Bool
+t1 = tX $ hasAnyRoles ["guest","userz"]
+
+t2 = tX $ hasAllRoles ["guest","userz"]
+
+t3 = tX $ hasAllRoles ["guest","user"]
+
+t4 = tX $ hasRole "can_administrate"
+
+t5 = tX $ hasRole "lkfdhjkjfhds"
+
+t6 = tX $ do
+         hasRole "guest"
+         hasRole "superuser"
+
+t7 = tX $ do
+         hasRole "zzzzz"
+         hasRole "superuser"
+
+t8 = tX $ hasRole $ addRoleData "arg" "*" "dependent_arg"
+
+t9 = tX $ hasRole "multi_args"
+
+t10 = tX $ hasRole $ addRoleData "arg2" "b" "multi_args"
+
+t11 = tX $ hasRole $ addRoleData "arg2" "z" "multi_args"
+
+t12 = tX $ hasAllRoles [addRoleData "arg2" "b" "multi_args"]
+
+t13 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args"
+                       , addRoleData "arg2" "b" "multi_args" ]
+
+t14 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args"
+                       , addRoleData "arg2" "aaa" "multi_args" ]
+
+t15 = tX $ missingRole "jflsdkjf"
+
+t16 = tX $ do
+          missingRole "fdjlksjlf"
+          hasRole "multi_args"
+
+t17 = tX $ missingRole "multi_args"

src/Data/RBAC/Internal/Role.hs

@@ -0,0 +1,80 @@
+module Data.RBAC.Internal.Role where
+
+import           Control.Monad.ST
+import           Data.Hashable
+import           Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as M
+import           Data.String
+import           Data.Text (Text)
+import qualified Data.Vector as V
+import qualified Data.Vector.Algorithms.Merge as VA
+
+
+------------------------------------------------------------------------------
+data RoleValue = RoleBool Bool
+               | RoleText Text
+               | RoleInt Int
+               | RoleDouble Double
+  deriving (Ord, Eq, Show)
+
+
+instance IsString RoleValue where
+    fromString = RoleText . fromString
+
+
+instance Hashable RoleValue where
+    hashWithSalt salt (RoleBool e)   = hashWithSalt salt e `combine` 7
+    hashWithSalt salt (RoleText t)   = hashWithSalt salt t `combine` 196613
+    hashWithSalt salt (RoleInt i)    = hashWithSalt salt i `combine` 12582917
+    hashWithSalt salt (RoleDouble d) = hashWithSalt salt d `combine` 1610612741
+
+
+------------------------------------------------------------------------------
+data Role = Role {
+      _roleName :: Text
+    , _roleData :: HashMap Text RoleValue
+    }
+  deriving (Eq, Show)
+
+
+instance IsString Role where
+    fromString s = Role (fromString s) M.empty
+
+
+------------------------------------------------------------------------------
+toSortedList :: (Ord k, Ord v) => HashMap k v -> [(k,v)]
+toSortedList m = runST $ do
+    v <- V.unsafeThaw $ V.fromList $ M.toList m
+    VA.sort v
+    v' <- V.unsafeFreeze v
+    return $ V.toList v'
+
+
+
+instance Hashable Role where
+    hashWithSalt salt (Role nm dat) =
+        h $ hashWithSalt salt nm
+      where
+        h s = hashWithSalt s $ toSortedList dat
+
+
+------------------------------------------------------------------------------
+data RoleValueMeta = RoleBoolMeta
+                   | RoleTextMeta
+                   | RoleEnumMeta [Text]
+                   | RoleIntMeta
+                   | RoleDoubleMeta
+
+
+data RoleDataDefinition = RoleDataDefinition {
+      _roleDataName        :: Text
+    , _roleValueMeta       :: RoleValueMeta
+    , _roleDataDescription :: Text
+    }
+
+
+data RoleMetadata = RoleMetadata {
+      _roleMetadataName :: Text
+    , _roleDescription  :: Text
+    , _roleDataDefs     :: [RoleDataDefinition]
+    }