#if __GLASGOW_HASKELL__ >= 704
#endif
module Hails.Database.MongoDB.TCB.Query ( insert, insert_
, insertP, insertP_
, save, saveP
, deleteOne, deleteOneP
, find, findP
, findOne, findOneP
, next, nextP
, Query(..), Selection(..), Selector
, select
) where
import Hails.Database.MongoDB.TCB.Access
import Hails.Database.MongoDB.TCB.Types
import LIO
import LIO.TCB
import Data.Word
import Data.Functor ((<$>))
import Data.Serialize (Serialize)
import qualified Data.Map as Map
import Hails.Data.LBson.TCB hiding (lookup)
import qualified Database.MongoDB as M
import Control.Monad.Reader hiding (liftIO)
data Query l = Query { options :: [M.QueryOption]
, selection :: Selection l
, skip :: Word32
, limit :: M.Limit
, sort :: Order l
, batchSize :: M.BatchSize
, hint :: Order l
}
queryToMQuery :: (Serialize l, Label l) => Query l -> M.Query
queryToMQuery q = M.Query { M.options = options q
, M.selection = selectionToMSelection $ selection q
, M.project = []
, M.skip = skip q
, M.limit = limit q
, M.batchSize = batchSize q
, M.sort = toBsonDoc $ sort q
, M.snapshot = False
, M.hint = toBsonDoc $ hint q
}
type Selector l = Document l
data Selection l = Selection { selector :: Selector l
, coll :: CollectionName
}
selectionToMSelection :: (Serialize l, Label l) => Selection l -> M.Selection
selectionToMSelection s = M.Select { M.selector = toBsonDoc $ selector s
, M.coll = coll s }
class Select selectionOrQuery where
select :: Label l => Selector l -> CollectionName -> selectionOrQuery l
instance Select Selection where
select = Selection
instance Select Query where
select s c = Query { options = []
, selection = select s c
, skip = 0
, limit = 0
, sort = []
, batchSize = 0
, hint = []
}
type Order l = Document l
class (LabelState l p s, Serialize l) => Insert l p s doc where
insert :: CollectionName
-> doc
-> Action l p s (Value l)
insert = insertP noPrivs
insert_ :: CollectionName
-> doc
-> Action l p s ()
insert_ c d = void $ insert c d
insertP :: p
-> CollectionName
-> doc
-> Action l p s (Value l)
insertP p colName doc = do
db <- getDatabase
bsonDoc <- mkDocForInsertTCB p colName doc
liftAction $ liftM BsonVal $ M.useDb (dbIntern db) $ M.insert colName bsonDoc
insertP_ :: p
-> CollectionName
-> doc
-> Action l p s ()
insertP_ p c d = void $ insertP p c d
save :: CollectionName
-> doc
-> Action l p s ()
save = saveP noPrivs
saveP :: p
-> CollectionName
-> doc
-> Action l p s ()
mkDocForInsertTCB :: p
-> CollectionName
-> doc
-> Action l p s M.Document
doForCollectionP :: (LabelState l p s, Serialize l)
=> p
-> CollectionName
-> (p -> Database l
-> CollectionPolicy l -> LIO l p s a)
-> Action l p s a
doForCollectionP p' colName act = do
db <- getDatabase
liftLIO $ withCombinedPrivs p' $ \p -> do
colMap <- unlabelP p $ dbColPolicies db
col <- maybe (throwIO NoColPolicy) return $ Map.lookup colName colMap
act p db col
instance (LabelState l p s, Serialize l) => Insert l p s (Document l) where
saveP p colName doc = do
db <- getDatabase
bsonDoc <- mkDocForInsertTCB p colName doc
case M.look "_id" bsonDoc of
Nothing -> dbAct db $ M.insert colName bsonDoc
Just i -> do
mdoc <- findOneP p $ select ["_id" := BsonVal i] colName
maybe (return ()) (lioWGuard . labelOf) mdoc
dbAct db $ M.save colName bsonDoc
where lioWGuard l = liftLIO $ withCombinedPrivs p $ \p' -> wguardP p' l
dbAct db = void . liftAction . M.useDb (dbIntern db)
mkDocForInsertTCB p' colName doc = do
ldoc <- doForCollectionP p' colName $ \p _ col ->
withClearance (colClear col) $ applyRawPolicyP p col doc
mkDocForInsertTCB p' colName ldoc
instance (LabelState l p s, Serialize l, Insert l p s (Document l)) =>
Insert l p s (Labeled l (Document l)) where
saveP p colName ldoc = do
db <- getDatabase
bsonDoc <- mkDocForInsertTCB p colName ldoc
case M.look "_id" bsonDoc of
Nothing -> dbAct db $ M.insert colName bsonDoc
Just i -> do
mdoc <- findOneP p $ select ["_id" := BsonVal i] colName
maybe (return ()) (lioWGuard . labelOf) mdoc
dbAct db $ M.save colName bsonDoc
where lioWGuard l = liftLIO $ withCombinedPrivs p $ \p' ->
unless (leqp p' (labelOf ldoc) l) $ throwIO LerrHigh
dbAct db = void . liftAction . M.useDb (dbIntern db)
mkDocForInsertTCB p' colName ldoc =
doForCollectionP p' colName $ \p db col -> do
wguardP p (dbLabel db)
wguardP p (colLabel col)
let udoc = unlabelTCB ldoc
asIfLDoc <- applyRawPolicyTCB col udoc
unless (leqp p (labelOf ldoc) (labelOf asIfLDoc)) $ throwIO LerrHigh
guardLabeledVals udoc $ colClear col
guardSerachables udoc col
return $ toBsonDoc udoc
where guardLabeledVals ds c = forM_ ds $ \(_ := v) ->
case v of
(LabeledVal lv) -> unless (labelOf lv `leq` c) $
throwIO $ LerrClearance
_ -> return ()
guardSerachables ds col =
let srchbls = searchableFields . colPolicy $ col
in forM_ ds $ \(k := v) ->
case v of
(BsonVal _) -> return ()
_ -> when (k `elem` srchbls) $
throwIO InvalidSearchableType
validateSearchableClause :: M.Document -> CollectionPolicy l -> Bool
validateSearchableClause doc policy = and (map isSearchable doc)
where isSearchable ("_id" M.:= _) = True
isSearchable (k M.:= _) = maybe False isSearchableField $
lookup k fieldPolicies
fieldPolicies = rawFieldPolicies . colPolicy $ policy
find :: (Serialize l, LabelState l p s)
=> Query l -> Action l p s (Cursor l)
find = findP noPrivs
findP :: (Serialize l, LabelState l p s)
=> p -> Query l -> Action l p s (Cursor l)
findP p' q' = do
db <- getDatabase
let q = queryToMQuery q'
slct = M.selection q
colName = M.coll slct
col <- liftLIO $ withCombinedPrivs p' $ \p -> do
colMap <- unlabelP p $ dbColPolicies db
maybe (throwIO NoColPolicy) return $ Map.lookup colName colMap
liftLIO $ withCombinedPrivs p' $ \p -> do
taintP p $ (colLabel col) `lub` (dbLabel db)
unless (and $ map (validate col) [ M.selector slct, M.sort q, M.hint q]) $
liftIO $ throwIO InvalidFieldPolicyType
cur <- liftAction $ M.useDb (dbIntern db) $ M.find (q {M.project = []})
return $ Cursor { curLabel = (colLabel col) `lub` (dbLabel db)
, curIntern = cur
, curProject = M.project q
, curPolicy = col }
where validate = flip validateSearchableClause
findOne :: (LabelState l p s, Serialize l)
=> Query l -> Action l p s (Maybe (LabeledDocument l))
findOne = findOneP noPrivs
findOneP :: (LabelState l p s, Serialize l)
=> p -> Query l -> Action l p s (Maybe (LabeledDocument l))
findOneP p q = findP p q >>= nextP p
next :: (LabelState l p s, Serialize l)
=> Cursor l
-> Action l p s (Maybe (LabeledDocument l))
next = nextP noPrivs
nextP :: (LabelState l p s, Serialize l)
=> p
-> Cursor l
-> Action l p s (Maybe (LabeledDocument l))
nextP p' cur = do
liftLIO $ withCombinedPrivs p' $ \p -> taintP p (curLabel cur)
md <- fromBsonDoc' <$> (liftAction $ M.next (curIntern cur))
case md of
Nothing -> return Nothing
Just d -> Just <$> (liftLIO $ applyProjection `liftM`
applyRawPolicyTCB (curPolicy cur) d)
where fromBsonDoc' = maybe Nothing fromBsonDocStrict
applyProjection doc =
if null $ curProject cur
then doc
else let udoc = unlabelTCB doc
in labelTCB (labelOf doc) $ filter inProjection udoc
inProjection (k := _) = case M.look k $ curProject cur of
Just (M.Int32 1) -> True
_ -> False
deleteOne :: (LabelState l p s, Serialize l)
=> Selection l -> Action l p s ()
deleteOne = deleteOneP noPrivs
deleteOneP :: (LabelState l p s, Serialize l)
=> p -> Selection l -> Action l p s ()
deleteOneP p' sel = do
p <- liftLIO $ withCombinedPrivs p' return
let colName = coll sel
mobj <- findOneP p $ select (selector sel) colName
voidIfNothing mobj $ \ldoc -> do
doForCollectionP p' (coll sel) $ \_ db col -> do
wguardP p (dbLabel db)
wguardP p (colLabel col)
wguardP p $ labelOf ldoc
i <- look "_id" $ unlabelTCB ldoc
dbAct . M.deleteOne . selectionToMSelection $ select ["_id" := i] colName
where dbAct act = do
db <- getDatabase
void . liftAction . M.useDb (dbIntern db) $ act
voidIfNothing mv m = maybe (return ()) m mv