module Hails.PolicyModule.DSL (
setPolicy
, readers, secrecy
, writers, integrity
, unrestricted
, admins
, (==>), (<==)
, database
, collection
, access
, clearance
, document
, field, searchable, key, labeled
) where
import Data.Maybe
import Data.List (isPrefixOf)
import Data.Map (Map)
import Data.Traversable (forM)
import Data.Typeable
import qualified Data.Map as Map
import qualified Data.Text as T
import Control.Applicative
import Control.Monad hiding (forM)
import Control.Monad.Trans
import Control.Monad.Trans.Reader hiding (ask)
import Control.Monad.Trans.State hiding (put, get)
import Control.Monad.Trans.Error
import Control.Monad.State.Class
import Control.Monad.Reader.Class
import Control.Exception
import LIO
import LIO.DCLabel
import Hails.PolicyModule
import Hails.Database
data Readers = Readers
instance Show Readers where show _ = "readers"
readers, secrecy :: Readers
readers = Readers
secrecy = Readers
data Writers = Writers
instance Show Writers where show _ = "writers"
writers, integrity :: Writers
writers = Writers
integrity = Writers
data Admins = Admins
instance Show Admins where show _ = "admins"
admins :: Admins
admins = Admins
infixl 5 ==>, <==
class MonadState s m => Role r s m where
(==>) :: (ToCNF c) => r -> c -> m ()
(<==) :: (ToCNF c) => r -> c -> m ()
(<==) = (==>)
data DBExp = DBExp CNF CNF CNF
deriving Show
type DBExpS = Map String CNF
newtype DBExpM a = DBExpM (ErrorT String (State DBExpS) a)
deriving (Monad, MonadState DBExpS, Functor, Applicative)
instance Role Readers DBExpS DBExpM where
_ ==> c = DBExpM $ do
s <- get
case Map.lookup (show readers) s of
Just _ -> fail "Database readers already specified."
Nothing -> put $ Map.insert (show readers) (toCNF c) s
instance Role Writers DBExpS DBExpM where
_ ==> c = DBExpM $ do
s <- get
case Map.lookup (show writers) s of
Just _ -> fail "Database writers already specified."
Nothing -> put $ Map.insert (show writers) (toCNF c) s
instance Role Admins DBExpS DBExpM where
_ ==> c = DBExpM $ do
s <- get
case Map.lookup (show admins) s of
Just _ -> fail "Database admins already specified."
Nothing -> put $ Map.insert (show admins) (toCNF c) s
database :: DBExpM () -> PolicyExpM ()
database (DBExpM e) = do
s <- get
case Map.lookup "database" s of
Just _ -> fail "Database labels already set"
Nothing -> case evalState (runErrorT e') Map.empty of
Left err -> fail err
Right dbExp -> put $ Map.insert "database"
(PolicyDBExpT dbExp) s
where e' = do e
s <- get
r <- lookup' (show readers) s
w <- lookup' (show writers) s
a <- lookup' (show admins ) s
return $ DBExp r w a
lookup' k s = maybe (fail $ "Missing " ++ show k)
return $ Map.lookup k s
data ColAccExp = ColAccExp CNF CNF
deriving Show
type ColAccExpS = Map String CNF
newtype ColAccExpM a =
ColAccExpM (ErrorT String (StateT ColAccExpS (Reader CollectionName)) a)
deriving (Monad, MonadState ColAccExpS, MonadReader CollectionName, Functor, Applicative)
instance Role Readers ColAccExpS ColAccExpM where
_ ==> c = ColAccExpM $ do
s <- get
cName <- ask
case Map.lookup (show readers) s of
Just _ -> fail $ "Collection " ++ show cName
++ " access readers already specified."
Nothing -> put $ Map.insert (show readers) (toCNF c) s
instance Role Writers ColAccExpS ColAccExpM where
_ ==> c = ColAccExpM $ do
s <- get
cName <- ask
case Map.lookup (show writers) s of
Just _ -> fail $ "Collection " ++ show cName
++ " access writers already specified."
Nothing -> put $ Map.insert (show writers) (toCNF c) s
data ColClrExp = ColClrExp CNF CNF
deriving Show
type ColClrExpS = Map String CNF
newtype ColClrExpM a =
ColClrExpM (ErrorT String (StateT ColClrExpS (Reader CollectionName)) a)
deriving (Monad, MonadState ColClrExpS, MonadReader CollectionName, Functor, Applicative)
instance Role Readers ColClrExpS ColClrExpM where
_ ==> c = ColClrExpM $ do
s <- get
cName <- ask
case Map.lookup (show readers) s of
Just _ -> fail $ "Collection " ++ show cName
++ " clearance readers already specified."
Nothing -> lift . put $ Map.insert (show readers) (toCNF c) s
instance Role Writers ColClrExpS ColClrExpM where
_ ==> c = ColClrExpM $ do
s <- get
cName <- ask
case Map.lookup (show writers) s of
Just _ -> fail $ "Collection " ++ show cName
++ " clearance writers already specified."
Nothing -> put $ Map.insert (show writers) (toCNF c) s
data ColDocExp = ColDocExp (HsonDocument -> LabelExp)
instance Show ColDocExp where show _ = "ColDocExp {- function -}"
data LabelExp = LabelExp CNF CNF
type ColDocExpS = Map String CNF
newtype ColDocExpM a =
ColDocExpM (ErrorT String (StateT ColDocExpS (Reader CollectionName)) a)
deriving (Monad, MonadState ColDocExpS, MonadReader CollectionName, Functor, Applicative)
instance Role Readers ColDocExpS ColDocExpM where
_ ==> c = ColDocExpM $ do
s <- get
cName <- ask
case Map.lookup (show readers) s of
Just _ -> fail $ "Collection " ++ show cName
++ " document readers already specified."
Nothing -> lift . put $ Map.insert (show readers) (toCNF c) s
instance Role Writers ColDocExpS ColDocExpM where
_ ==> c = ColDocExpM $ do
s <- get
cName <- ask
case Map.lookup (show writers) s of
Just _ -> fail $ "Collection " ++ show cName
++ " document writers already specified."
Nothing -> put $ Map.insert (show writers) (toCNF c) s
data ColFieldExp = ColFieldSearchable
| ColLabFieldExp (HsonDocument -> LabelExp)
instance Show ColFieldExp where
show ColFieldSearchable = "ColFieldSearchable"
show (ColLabFieldExp _) = "ColLabFieldExp {- function -}"
type ColLabFieldExpS = Map String CNF
newtype ColLabFieldExpM a =
ColLabFieldExpM (ErrorT String (StateT ColLabFieldExpS (Reader (FieldName, CollectionName))) a)
deriving (Monad, MonadState ColLabFieldExpS, MonadReader (FieldName, CollectionName), Functor, Applicative)
instance Role Readers ColLabFieldExpS ColLabFieldExpM where
_ ==> c = ColLabFieldExpM $ do
s <- get
(fName, cName) <- ask
case Map.lookup (show readers) s of
Just _ -> fail $ "Collection " ++ show cName ++ " field " ++ show fName
++ " readers already specified."
Nothing -> lift . put $ Map.insert (show readers) (toCNF c) s
instance Role Writers ColLabFieldExpS ColLabFieldExpM where
_ ==> c = ColLabFieldExpM $ do
s <- get
(fName, cName) <- ask
case Map.lookup (show writers) s of
Just _ -> fail $ "Collection " ++ show cName ++ " field " ++ show fName
++ " writers already specified."
Nothing -> put $ Map.insert (show writers) (toCNF c) s
newtype ColFieldExpM a =
ColFieldExpM (ErrorT String (StateT (Maybe ColFieldExp) (Reader (FieldName, CollectionName))) a)
deriving (Monad, MonadState (Maybe ColFieldExp), MonadReader (FieldName, CollectionName), Functor, Applicative)
searchable :: ColFieldExpM ()
searchable = do
s <- get
(fName, cName) <- ask
when (isJust s) $ fail $ "Collection " ++ show cName ++ " field " ++
show fName ++ " policy already specified."
put (Just ColFieldSearchable)
key :: ColFieldExpM ()
key = searchable
labeled :: (HsonDocument -> ColLabFieldExpM ()) -> ColFieldExpM ()
labeled fpol = do
s <- get
(fN, cN) <- ask
when (isJust s) $ fail $ "Collection " ++ show cN ++ " field " ++
show fN ++ " policy already specified."
let labFieldE = ColLabFieldExp $ \doc ->
fromRight $ eval (fpol' doc fN cN) fN cN
put (Just labFieldE)
where eval (ColLabFieldExpM e) fN cN =
runReader (evalStateT (runErrorT e) Map.empty) (fN, cN)
fpol' doc fN cN = do fpol doc
s <- get
r <- lookup' fN cN (show readers) s
w <- lookup' fN cN (show writers) s
return $ LabelExp r w
lookup' fN cN k s = maybe (fail $ "Missing " ++ show k ++
" in field label " ++ show fN
++ " of collection " ++ show cN)
return $ Map.lookup k s
data ColExp = ColExp CollectionName ColAccExp
ColClrExp
ColDocExp
(Map FieldName ColFieldExp)
deriving Show
data ColExpT = ColAccT ColAccExp
| ColClrT ColClrExp
| ColDocT ColDocExp
| ColFldT ColFieldExp
deriving Show
type ColExpS = Map String ColExpT
newtype ColExpM a =
ColExpM (ErrorT String (StateT ColExpS (Reader CollectionName)) a)
deriving (Monad, MonadState ColExpS, MonadReader CollectionName, Functor, Applicative)
data PolicyExp = PolicyExp DBExp (Map CollectionName ColExp)
deriving Show
data PolicyExpT = PolicyDBExpT DBExp
| PolicyColExpT ColExp
deriving Show
type PolicyExpS = Map String PolicyExpT
newtype PolicyExpM a = PolicyExpM (ErrorT String (State PolicyExpS) a)
deriving (Monad, MonadState PolicyExpS, Functor, Applicative)
access :: ColAccExpM () -> ColExpM ()
access (ColAccExpM acc) = do
s <- get
cN <- ask
case Map.lookup "access" s of
Just _ -> fail $ "Collection " ++ show cN
++ " access label already specified."
_ -> let r = runReader (evalStateT (runErrorT (acc' cN)) Map.empty) cN
in case r of
Left e -> fail e
Right accT -> put (Map.insert "access" accT s)
where acc' cN= do
acc
s <- get
r <- lookup' cN (show readers) s
w <- lookup' cN (show writers) s
return . ColAccT $ ColAccExp r w
lookup' cN k s = maybe (fail $ "Missing " ++ show k ++
" in access of " ++ show cN)
return $ Map.lookup k s
clearance :: ColClrExpM () -> ColExpM ()
clearance (ColClrExpM acc) = do
s <- get
cN <- ask
case Map.lookup "clearance" s of
Just _ -> fail $ "Collection " ++ show cN
++ " clearance label already specified."
_ -> let r = runReader (evalStateT (runErrorT (acc' cN)) Map.empty) cN
in case r of
Left e -> fail e
Right accT -> put (Map.insert "clearance" accT s)
where acc' cN = do
acc
s <- get
r <- lookup' cN (show readers) s
w <- lookup' cN (show writers) s
return . ColClrT $ ColClrExp r w
lookup' cN k s = maybe (fail $ "Missing " ++ show k ++
" in clearance of " ++ show cN)
return $ Map.lookup k s
document :: (HsonDocument -> ColDocExpM ()) -> ColExpM ()
document fpol = do
s <- get
cN <- ask
case Map.lookup "document" s of
Just _ -> fail $ "Collection " ++ show cN
++ " document policy already specified."
_ -> let docT = ColDocT $ ColDocExp $ \doc ->
fromRight $ eval (fpol' doc cN) cN
in put (Map.insert "document" docT s)
where eval (ColDocExpM e) cN =
runReader (evalStateT (runErrorT e) Map.empty) cN
fpol' doc cN = do fpol doc
s <- get
r <- lookup' cN (show readers) s
w <- lookup' cN (show writers) s
return $ LabelExp r w
lookup' cN k s = maybe (fail $ "Missing " ++ show k ++
" in document label of collection "
++ show cN)
return $ Map.lookup k s
field :: FieldName -> ColFieldExpM () -> ColExpM ()
field fName (ColFieldExpM e) = do
s <- get
cN <- ask
let _fName = "field." ++ T.unpack fName
case Map.lookup _fName s of
Just _ -> fail $ "Collection " ++ show cN ++ " field " ++ show fName
++ " policy already specified."
_ -> case runReader (evalStateT (runErrorT e') Nothing) (fName, cN) of
Left er -> fail er
Right Nothing -> fail $ "Collection " ++ show cN ++ " field " ++
show fName ++ " policy not specified."
Right (Just fieldE) -> put (Map.insert _fName (ColFldT fieldE) s)
where e' = do e >> get
collection :: CollectionName -> ColExpM () -> PolicyExpM ()
collection cN (ColExpM e) = do
s <- get
let _cN = "collection." ++ T.unpack cN
case Map.lookup _cN s of
Just _ -> fail $ "Collection " ++ show cN ++ " policy already set"
Nothing -> case runReader (evalStateT (runErrorT e') Map.empty) cN of
Left err -> fail err
Right colExp -> put $ Map.insert _cN (PolicyColExpT colExp) s
where e' = do
e
s <- get
(ColAccT a) <- lookup' "access" s
(ColClrT c) <- lookup' "clearance" s
(ColDocT d) <- lookup' "document" s
let fs = Map.mapKeys (T.pack . (drop (length "field."))) $
Map.map (\(ColFldT f) -> f) $
Map.filterWithKey (\k _ -> "field." `isPrefixOf` k) s
return $ ColExp cN a c d fs
lookup' k s = maybe (fail $ "Missing " ++ show k ++
" for collection " ++ show cN)
return $ Map.lookup k s
runPolicy :: PolicyExpM () -> Either String PolicyExp
runPolicy (PolicyExpM e) = evalState (runErrorT e') Map.empty
where e' = do
e
s <- get
(PolicyDBExpT db) <- maybe (fail $ "Missing database policy")
return $ Map.lookup "database" s
let cs = Map.mapKeys (T.pack . (drop (length "collection."))) $
Map.map (\(PolicyColExpT f) -> f) $
Map.filterWithKey (\k _ -> "collection." `isPrefixOf` k) s
return $ PolicyExp db cs
setPolicy :: DCPriv -> PolicyExpM () -> PMAction ()
setPolicy priv pol =
case runPolicy pol of
Left err -> liftLIO $ throwLIO $ PolicyCompileError err
Right policy -> execPolicy policy
where execPolicy (PolicyExp db cs) = do
execPolicyDB db
void $ forM cs execPolicyCol
execPolicyDB (DBExp r w a) = do
setDatabaseLabelP priv (r %% w)
setCollectionSetLabelP priv (r %% a)
execPolicyCol (ColExp n (ColAccExp lr lw) (ColClrExp cr cw) doc fs) =
let cps = mkColPol doc fs
in createCollectionP priv n (lr %% lw) (cr %% cw) cps
mkColPol (ColDocExp fdocE) cs =
let fdoc = unDataPolicy fdocE
in CollectionPolicy { documentLabelPolicy = fdoc
, fieldLabelPolicies = Map.map unFieldExp cs }
unDataPolicy fpolE = \doc ->
let (LabelExp s i) = fpolE doc
in s %% i
unFieldExp ColFieldSearchable = SearchableField
unFieldExp (ColLabFieldExp f) = FieldPolicy (unDataPolicy f)
data PolicySpecificiationError = PolicyCompileError String
| PolicyRuntimeError String
deriving (Show, Typeable)
instance Exception PolicySpecificiationError
fromRight :: Either String b -> b
fromRight (Right x) = x
fromRight (Left e) = throw . PolicyRuntimeError $ e
unrestricted :: CNF
unrestricted = cTrue