module Hails.Database.Structured ( DCRecord(..)
, findAll, findAllP
, DCLabeledRecord(..)
, toLabeledDocument, fromLabeledDocument
, toLabeledDocumentP, fromLabeledDocumentP
) where
import Data.Monoid (mappend)
import Control.Monad (liftM)
import Control.Exception (SomeException)
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 noPriv
findWhere = findWhereP noPriv
insertRecord = insertRecordP noPriv
saveRecord = saveRecordP noPriv
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 <- 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 noPriv
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 <- 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 noPriv lrec
saveLabeledRecord lrec = saveLabeledRecordP noPriv 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 noPriv
toLabeledDocumentP :: (MonadDB m, DCLabeledRecord pm a)
=> DCPriv
-> DCLabeled a
-> m (DCLabeled Document)
toLabeledDocumentP p' lr = liftDB $ do
pmPriv' <- dbActionPriv `liftM` getActionStateTCB
pmPriv <- liftLIO $ (evaluate . endorseInstance $ lr) >> return pmPriv'
`catchLIO` (\(_ :: SomeException) -> return noPriv)
let p = p' `mappend` pmPriv
r <- unlabelP p lr
lcur <- getLabel
let lres = partDowngradeP p lcur (labelOf lr)
labelP p lres $ toDocument r
fromLabeledDocument :: forall m pm a. (MonadDB m, DCLabeledRecord pm a)
=> DCLabeled Document
-> m (DCLabeled a)
fromLabeledDocument = fromLabeledDocumentP noPriv
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'
`catchLIO` (\(_ :: SomeException) -> return noPriv)
let p = p' `mappend` pmPriv
doc <- unlabelP p ldoc
lcur <- getLabel
let lres = partDowngradeP p lcur (labelOf ldoc)
rec <- fromDocument doc
labelP p lres rec
where fake :: DCLabeled a
fake = undefined
forceType :: DCLabeled a -> a
forceType = undefined