#if __GLASGOW_HASKELL__ >= 704
#endif
module Hails.Database.MongoDB.TCB.Types (
CollectionName
, CollectionMap
, CollectionPolicy(..)
, Collection(..)
, collection, collectionP, collectionTCB
, DatabaseName
, Database(..)
, database, databaseP, databaseTCB
, assocCollection, assocCollectionP
, assocCollectionTCB
, RawPolicy(..)
, FieldPolicy(..)
, isSearchableField
, searchableFields
, PolicyError(..)
, NoSuchDatabaseError(..)
, UnsafeLIO(..)
, LIOAction(..)
, Action(..)
, liftAction
, getDatabase
, Cursor(..)
, Failure
) where
import LIO
import LIO.TCB ( LIO(..)
, LIOstate
, unlabelTCB
, labelTCB
, rtioTCB )
import qualified Database.MongoDB as M
import Database.MongoDB (Failure)
import Hails.Data.LBson.TCB
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Typeable
import Control.Applicative (Applicative)
import Control.Monad.Error hiding (liftIO)
import Control.Monad.Reader hiding (liftIO)
import Control.Monad.State hiding (liftIO)
import qualified Control.Monad.IO.Class as IO
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Trans.Control (MonadBaseControl(..))
import qualified Control.Exception as E
data Collection l = Collection { colIntern :: CollectionName
, colSec :: CollectionPolicy l
}
data CollectionPolicy l = CollectionPolicy { colLabel :: l
, colClear :: l
, colPolicy :: RawPolicy l
}
type CollectionName = M.Collection
collection :: LabelState l p s
=> CollectionName
-> l
-> l
-> RawPolicy l
-> LIO l p s (Collection l)
collection = collectionP noPrivs
collectionP :: LabelState l p s
=> p
-> CollectionName
-> l
-> l
-> RawPolicy l
-> LIO l p s (Collection l)
collectionP p' n l c pol = withCombinedPrivs p' $ \p -> do
aguardP p l
aguardP p c
collectionTCB n l c pol
collectionTCB :: LabelState l p s
=> CollectionName
-> l
-> l
-> RawPolicy l
-> LIO l p s (Collection l)
collectionTCB n l c pol =
return $ Collection { colIntern = n
, colSec = CollectionPolicy { colLabel = l
, colClear = c
, colPolicy = pol }
}
type DatabaseName = M.Database
type CollectionMap l = Labeled l (Map CollectionName (CollectionPolicy l))
data Database l = Database
{ dbIntern :: DatabaseName
, dbLabel :: l
, dbColPolicies :: CollectionMap l
}
databaseP :: LabelState l p s
=> p
-> DatabaseName
-> l
-> CollectionMap l
-> LIO l p s (Database l)
databaseP p' n l cs = withCombinedPrivs p' $ \p -> do
aguardP p l
databaseTCB n l cs
databaseTCB :: LabelState l p s
=> DatabaseName
-> l
-> CollectionMap l
-> LIO l p s (Database l)
databaseTCB n l cs = return $ Database { dbIntern = n
, dbLabel = l
, dbColPolicies = cs
}
database :: LabelState l p s
=> DatabaseName
-> l
-> CollectionMap l
-> LIO l p s (Database l)
database = databaseP noPrivs
assocCollectionP :: LabelState l p s
=> p
-> Collection l
-> Database l
-> LIO l p s (Database l)
assocCollectionP p' (Collection n cp) db = do
(l, colMap) <- liftLIO $ withCombinedPrivs p' $ \p -> do
let colMap = unlabelTCB $ dbColPolicies db
l = labelOf $ dbColPolicies db
wguardP p l
return (l, colMap)
let dCPs = Map.insert n cp colMap
return $ db { dbColPolicies = labelTCB l dCPs }
assocCollection :: LabelState l p s
=> Collection l
-> Database l
-> LIO l p s (Database l)
assocCollection = assocCollectionP noPrivs
assocCollectionTCB :: LabelState l p s
=> Collection l
-> Database l
-> LIO l p s (Database l)
assocCollectionTCB (Collection n cp) db = do
let colMap = unlabelTCB $ dbColPolicies db
l = labelOf $ dbColPolicies db
let dCPs = Map.insert n cp colMap
return $ db { dbColPolicies = labelTCB l dCPs }
data RawPolicy l = RawPolicy {
rawDocPolicy :: Document l -> l
, rawFieldPolicies :: [(Key, FieldPolicy l)]
}
data FieldPolicy l = SearchableField
| FieldPolicy (Document l -> l)
isSearchableField :: FieldPolicy l -> Bool
isSearchableField SearchableField = True
isSearchableField _ = False
searchableFields :: RawPolicy l -> [Key]
searchableFields policy = map fst $
filter (\(_, f) -> isSearchableField f) fields
where fields = rawFieldPolicies policy
data PolicyError = NoFieldPolicy
| InvalidPolicy
| NoColPolicy
| InvalidFieldPolicyType
| InvalidSearchableType
| PolicyViolation
deriving (Typeable)
instance Show PolicyError where
show NoFieldPolicy = "NoFieldPolicy: Field policy not found"
show NoColPolicy = "NoColPolicy: Collection policy not found"
show InvalidPolicy = "InvalidPolicy: Invalid policy application"
show PolicyViolation = "PolicyViolation: Policy has been violated"
show InvalidFieldPolicyType = "InvalidFieldPolicyType: " ++
"Expected \'PolicyLabeled\' type"
show InvalidSearchableType = "InvalidSearchableType: Searchable" ++
"fields cannot contain labeled values"
instance E.Exception PolicyError
data NoSuchDatabaseError = NoSuchDatabase
deriving (Typeable)
instance Show NoSuchDatabaseError where
show NoSuchDatabase = "NoSuchDatabase: No such database exists"
instance E.Exception (NoSuchDatabaseError)
newtype UnsafeLIO l p s a = UnsafeLIO { unUnsafeLIO :: LIO l p s a }
deriving (Functor, Applicative, Monad)
instance LabelState l p s => MonadIO (UnsafeLIO l p s) where
liftIO = UnsafeLIO . rtioTCB
instance LabelState l p s => MonadBase IO (UnsafeLIO l p s) where
liftBase = UnsafeLIO . rtioTCB
instance LabelState l p s => MonadBaseControl IO (UnsafeLIO l p s) where
newtype StM (UnsafeLIO l p s) a = StUnsafeLIO {
unStUnsafeLIO :: (StM (StateT (LIOstate l p s) IO) a) }
liftBaseWith f = UnsafeLIO . LIO $ liftBaseWith $ \runInIO ->
f $ liftM StUnsafeLIO . runInIO
. (\(LIO x) -> x) . unUnsafeLIO
restoreM = UnsafeLIO . LIO . restoreM . unStUnsafeLIO
newtype LIOAction l p s a =
LIOAction { unLIOAction :: M.Action (UnsafeLIO l p s) a }
deriving (Functor, Applicative, Monad)
newtype Action l p s a = Action (ReaderT (Database l) (LIOAction l p s) a)
deriving (Functor, Applicative, Monad)
instance LabelState l p s => MonadLIO (UnsafeLIO l p s) l p s where
liftLIO = UnsafeLIO
instance LabelState l p s => MonadLIO (LIOAction l p s) l p s where
liftLIO = LIOAction . liftLIO
instance LabelState l p s => MonadLIO (Action l p s) l p s where
liftLIO = Action . liftLIO
getDatabase :: Action l p s (Database l)
getDatabase = Action $ ask
liftAction :: LabelState l p s => M.Action (UnsafeLIO l p s) a -> Action l p s a
liftAction = Action . lift . LIOAction
data Cursor l = Cursor { curLabel :: l
, curIntern :: M.Cursor
, curProject :: M.Projector
, curPolicy :: CollectionPolicy l
}