#if __GLASGOW_HASKELL__ >= 702
#endif
module Hails.Database.MongoDB.Structured ( DCRecord(..)
, DCLabeledRecord(..)
, MkToLabeledDocument(..)
, toDocumentP
) where
import LIO
import LIO.DCLabel
import Hails.Database
import Hails.Database.MongoDB
import Data.Monoid (mappend)
import Control.Monad (liftM)
class DCRecord a where
fromDocument :: Monad m => Document DCLabel -> m a
toDocument :: a -> Document DCLabel
collectionName :: a -> CollectionName
findBy :: (Val DCLabel v, DatabasePolicy p)
=> p -> CollectionName -> Key -> v -> DC (Maybe a)
findWhere :: (DatabasePolicy p)
=> p -> Query DCLabel -> DC (Maybe a)
insertRecord :: (DatabasePolicy p)
=> p -> a -> DC (Either Failure (Value DCLabel))
saveRecord :: (DatabasePolicy p)
=> p -> a -> DC (Either Failure ())
deleteBy :: (Val DCLabel v, DatabasePolicy p)
=> p -> CollectionName -> Key -> v -> DC (Maybe a)
deleteWhere :: (DatabasePolicy p)
=> p -> Selection DCLabel -> DC (Maybe a)
findByP :: (Val DCLabel v, DatabasePolicy p)
=> DCPrivTCB -> p -> CollectionName -> Key -> v -> DC (Maybe a)
findWhereP :: (DatabasePolicy p)
=> DCPrivTCB -> p -> Query DCLabel -> DC (Maybe a)
insertRecordP :: (DatabasePolicy p)
=> DCPrivTCB -> p -> a -> DC (Either Failure (Value DCLabel))
saveRecordP :: (DatabasePolicy p)
=> DCPrivTCB -> p -> a -> DC (Either Failure ())
deleteByP :: (Val DCLabel v, DatabasePolicy p)
=> DCPrivTCB -> p -> CollectionName -> Key -> v -> DC (Maybe a)
deleteWhereP :: (DatabasePolicy p)
=> DCPrivTCB -> p -> Selection DCLabel -> DC (Maybe a)
findBy = findByP noPrivs
findWhere = findWhereP noPrivs
insertRecord = insertRecordP noPrivs
saveRecord = saveRecordP noPrivs
deleteBy = deleteByP noPrivs
deleteWhere = deleteWhereP noPrivs
insertRecordP p policy record = do
let colName = collectionName record
p' <- getPrivileges
withDB policy $ insertP (p' `mappend` p) colName $ toDocument record
saveRecordP p policy record = do
let colName = collectionName record
p' <- getPrivileges
withDB policy $ saveP (p' `mappend` p) colName $ toDocument record
findByP p policy colName k v =
findWhereP p policy (select [k =: v] colName)
findWhereP p policy query = do
result <- withDB policy $ findOneP p query
c <- getClearance
case result of
Right (Just r) | leqp p (labelOf r) c -> fromDocument `liftM` unlabelP p r
_ -> return Nothing
deleteByP p policy colName k v =
deleteWhereP p policy (select [k =: v] colName)
deleteWhereP p policy sel = do
mdoc <- findWhereP p policy $ select (selector sel) (coll sel)
p' <- getPrivileges
res <- withDB policy $ deleteOneP (p' `mappend` p) sel
case res of
Right _ -> return mdoc
_ -> return Nothing
class DCRecord a => DCLabeledRecord a where
insertLabeledRecord :: (MkToLabeledDocument p)
=> p -> DCLabeled a -> DC (Either Failure (Value DCLabel))
saveLabeledRecord :: (MkToLabeledDocument p)
=> p -> DCLabeled a -> DC (Either Failure ())
insertLabeledRecordP :: (MkToLabeledDocument p)
=> DCPrivTCB -> p -> DCLabeled a -> DC (Either Failure (Value DCLabel))
saveLabeledRecordP :: (MkToLabeledDocument p)
=> DCPrivTCB -> p -> DCLabeled a -> DC (Either Failure ())
insertLabeledRecord = insertLabeledRecordP noPrivs
saveLabeledRecord = saveLabeledRecordP noPrivs
insertLabeledRecordP p policy lrecord = do
let colName = collectionName (forceType lrecord)
p' <- getPrivileges
ldoc <- mkToLabeledDocument policy lrecord
withDB policy $ insertP (p' `mappend` p) colName ldoc
saveLabeledRecordP p policy lrecord = do
let colName = collectionName (forceType lrecord)
p' <- getPrivileges
ldoc <- mkToLabeledDocument policy lrecord
withDB policy $ saveP (p' `mappend` p) colName ldoc
class DatabasePolicy p => MkToLabeledDocument p where
mkToLabeledDocument :: DCRecord a
=> p
-> DCLabeled a
-> DC (DCLabeled (Document DCLabel))
toDocumentP :: DCRecord a
=> DCPrivTCB -> DCLabeled a -> DC (DCLabeled (Document DCLabel))
toDocumentP privs lr = do
lcur <- getLabel
let lres = lostar privs lcur (labelOf lr)
r <- unlabelP privs lr
labelP privs lres $ toDocument r
forceType :: DCLabeled a -> a
forceType = undefined