module Hails.Database.Structured ( DCRecord(..)
, findAll, findAllP
, DCLabeledRecord(..)
, toLabeledDocument, fromLabeledDocument
, toLabeledDocumentP, fromLabeledDocumentP
) where
import Data.Monoid (mappend, mempty)
import Control.Monad (liftM)
import LIO
import LIO.DCLabel
import Hails.Data.Hson
import Hails.PolicyModule
import Hails.Database.Core
import Hails.Database.Query
import Hails.Database.TCB
class DCRecord a where
fromDocument :: Monad m => Document -> m a
toDocument :: a -> Document
recordCollection :: a -> CollectionName
findBy :: (BsonVal v, MonadDB m)
=> CollectionName -> FieldName -> v -> m (Maybe a)
findWhere :: MonadDB m => Query -> m (Maybe a)
insertRecord :: MonadDB m => a -> m ObjectId
saveRecord :: MonadDB m => a -> m ()
findByP :: (BsonVal v, MonadDB m)
=> DCPriv -> CollectionName -> FieldName -> v -> m (Maybe a)
findWhereP :: MonadDB m => DCPriv -> Query -> m (Maybe a)
insertRecordP :: MonadDB m => DCPriv -> a -> m ObjectId
saveRecordP :: MonadDB m => DCPriv -> a -> m ()
findBy = findByP mempty
findWhere = findWhereP mempty
insertRecord = insertRecordP mempty
saveRecord = saveRecordP mempty
insertRecordP p r = liftDB $ do
insertP p (recordCollection r) $ toDocument r
saveRecordP p r = liftDB $ do
saveP p (recordCollection r) $ toDocument r
findByP p cName k v =
findWhereP p (select [k -: v] cName)
findWhereP p query = liftDB $ do
mldoc <- findOneP p query
c <- liftLIO $ getClearance
case mldoc of
Just ldoc | canFlowToP p (labelOf ldoc) c ->
fromDocument `liftM` (liftLIO $ unlabelP p ldoc)
_ -> return Nothing
findAll :: (DCRecord a, MonadDB m) => Query -> m [a]
findAll = findAllP mempty
findAllP :: (DCRecord a, MonadDB m)
=> DCPriv -> Query -> m [a]
findAllP p query = liftDB $ do
cursor <- findP p query
cursorToRecords cursor []
where cursorToRecords cur docs = do
mldoc <- nextP p cur
case mldoc of
Just ldoc -> do
c <- liftLIO getClearance
if canFlowTo (labelOf ldoc) c
then do md <- fromDocument `liftM` (liftLIO $ unlabelP p ldoc)
cursorToRecords cur $ maybe docs (:docs) md
else cursorToRecords cur docs
_ -> return $ reverse docs
class (PolicyModule pm, DCRecord a) => DCLabeledRecord pm a | a -> pm where
insertLabeledRecord :: MonadDB m => DCLabeled a -> m ObjectId
saveLabeledRecord :: MonadDB m => DCLabeled a -> m ()
insertLabeledRecordP :: MonadDB m => DCPriv -> DCLabeled a -> m ObjectId
saveLabeledRecordP :: MonadDB m => DCPriv -> DCLabeled a -> m ()
endorseInstance :: DCLabeled a -> pm
insertLabeledRecord lrec = insertLabeledRecordP mempty lrec
saveLabeledRecord lrec = saveLabeledRecordP mempty lrec
insertLabeledRecordP p lrec = liftDB $ do
let cName = recordCollection (forceType lrec)
ldoc <- toLabeledDocumentP p lrec
insertP p cName ldoc
saveLabeledRecordP p lrec = liftDB $ do
let cName = recordCollection (forceType lrec)
ldoc <- toLabeledDocumentP p lrec
saveP p cName ldoc
toLabeledDocument :: (MonadDB m, DCLabeledRecord pm a)
=> DCLabeled a
-> m (DCLabeled Document)
toLabeledDocument = toLabeledDocumentP mempty
toLabeledDocumentP :: (MonadDB m, DCLabeledRecord pm a)
=> DCPriv
-> DCLabeled a
-> m (DCLabeled Document)
toLabeledDocumentP p' lr = liftDB $ do
pmPriv' <- dbActionPriv `liftM` getActionStateTCB
liftLIO $ do
pmPriv <- (evaluate . endorseInstance $ lr) >> return pmPriv'
`catch` (\(_ :: SomeException) -> return mempty)
let p = p' `mappend` pmPriv
scopeClearance $ do
clr <- getClearance
setClearanceP p $ clr `lub` (p %% True)
r <- unlabelP p lr
lcur <- getLabel
let lres = downgradeP p lcur `lub` (labelOf lr)
labelP p lres $ toDocument r
fromLabeledDocument :: forall m pm a. (MonadDB m, DCLabeledRecord pm a)
=> DCLabeled Document
-> m (DCLabeled a)
fromLabeledDocument = fromLabeledDocumentP mempty
fromLabeledDocumentP :: forall m pm a. (MonadDB m, DCLabeledRecord pm a)
=> DCPriv
-> DCLabeled Document
-> m (DCLabeled a)
fromLabeledDocumentP p' ldoc = liftDB $ do
pmPriv' <- dbActionPriv `liftM` getActionStateTCB
pmPriv <- liftLIO $ (evaluate . endorseInstance $ fake) >> return pmPriv'
`catch` (\(_ :: SomeException) -> return mempty)
let p = p' `mappend` pmPriv
liftLIO $ scopeClearance $ do
clr <- getClearance
setClearanceP p $ clr `lub` (p %% True)
doc <- liftLIO $ unlabelP p ldoc
lcur <- liftLIO $ getLabel
let lres = downgradeP p lcur `lub` (labelOf ldoc)
rec <- fromDocument doc
labelP p lres rec
where fake :: DCLabeled a
fake = undefined
forceType :: DCLabeled a -> a
forceType = undefined