#if __GLASGOW_HASKELL__ >= 704
#endif
module Hails.Data.LBson.TCB (
module Data.UString
, Document, LabeledDocument
, look, lookup, valueAt, at, include, exclude, merge
, Field(..), (=:), (=?)
, Key
, hailsInternalKeyPrefix
, isUnsafeKey
, Value(..), Val(..), cast, typed
, PolicyLabeled(..), pu, pl
, Binary(..)
, Function(..)
, UUID(..)
, MD5(..)
, UserDefined(..)
, Regex(..)
, Javascript(..)
, Symbol(..)
, MongoStamp(..)
, MinMaxKey(..)
, ObjectId(..)
, timestamp
, genObjectId
, BsonValue
, safeToBsonValue, safeFromBsonValue
, BsonDocument, safeToBsonDoc, safeFromBsonDoc
, encodeDoc, decodeDoc
, toBsonDoc
, fromBsonDoc, fromBsonDocStrict
, sanitizeBsonValue
) where
import Prelude hiding (lookup,)
import Data.UString (UString, u, unpack)
import qualified Data.Bson as Bson
import Data.Bson ( Binary(..)
, Function(..)
, UUID(..)
, MD5(..)
, UserDefined(..)
, Regex(..)
, Javascript(..)
, Symbol(..)
, MongoStamp(..)
, MinMaxKey(..)
, ObjectId(..)
, timestamp
)
import Data.Bson.Binary (putDocument, getDocument)
import Data.Binary.Get (runGet)
import Data.Binary.Put (runPut)
import qualified Data.ByteString.Lazy as L
import Data.Maybe
import Data.List (find, findIndex)
import Data.Typeable hiding (cast)
import Data.CompactString.UTF8 (append, isPrefixOf)
import Data.Serialize (Serialize, encode, decode)
import Control.Monad
import Control.Monad.Identity (runIdentity)
import LIO
import LIO.TCB (labelTCB, unlabelTCB, rtioTCB)
#if DEBUG
import LIO.TCB (showTCB)
#endif
type Key = Bson.Label
type Document l = [Field l]
type LabeledDocument l = Labeled l (Document l)
look :: (Monad m, Label l) => Key -> Document l -> m (Value l)
look k doc = maybe notFound (return . value) (find ((k ==) . key) doc)
where notFound = fail $ "expected " ++ show k
lookup :: (Val l v, Monad m, Label l) => Key -> Document l -> m v
lookup k doc = cast =<< look k doc
valueAt :: Label l => Key -> [Field l] -> Value l
valueAt k = runIdentity . look k
at :: forall v l. (Val l v, Label l) => Key -> Document l -> v
at k doc = fromMaybe err (lookup k doc)
where err = error $ "expected (" ++ show k ++ " :: "
++ show (typeOf (undefined :: v)) ++ ") in " ++ show doc
include :: Label l => [Key] -> Document l -> Document l
include keys doc = mapMaybe (\k -> find ((k ==) . key) doc) keys
exclude :: Label l => [Key] -> Document l -> Document l
exclude keys = filter (\(k := _) -> notElem k keys)
merge :: Label l => Document l -> Document l -> Document l
merge es doc' = foldl f doc' es where
f doc (k := v) = case findIndex ((k ==) . key) doc of
Nothing -> doc ++ [k := v]
Just i -> let (x, _ : y) = splitAt i doc in x ++ [k := v] ++ y
infix 0 :=, =:, =?
data Field l = (:=) { key :: !Key
, value :: Value l }
deriving (Eq, Typeable)
instance Label l => Show (Field l) where
showsPrec d (k := v) = showParen (d > 0) $
showString (' ' : unpack k) . showString ": " . showsPrec 1 v
(=:) :: (Val l v, Label l) => Key -> v -> Field l
k =: v = k := val v
(=?) :: (Val l a, Label l) => Key -> Maybe a -> Document l
k =? ma = maybeToList (fmap (k =:) ma)
data Value l = BsonVal Bson.Value
| LabeledVal (Labeled l Bson.Value)
| PolicyLabeledVal (PolicyLabeled l Bson.Value)
deriving (Typeable)
instance Label l => Show (Value l) where
show (BsonVal v) = show v
#if DEBUG
show (LabeledVal lv) = showTCB lv
show (PolicyLabeledVal lv) = show lv
#else
show _ = "{- HIDING DATA -} "
#endif
instance Label l => Eq (Value l) where
(==) (BsonVal v1) (BsonVal v2) = v1 == v2
(==) _ _ = False
class (Typeable a, Show a, Eq a, Label l) => Val l a where
val :: a -> Value l
cast' :: Value l -> Maybe a
instance (Bson.Val a, Label l) => Val l a where
val = BsonVal . Bson.val
cast' (BsonVal v) = Bson.cast' v
cast' _ = Nothing
instance (Label l) => Val l (Value l) where
val = id
cast' = Just
instance (Bson.Val a, Label l) => Val l (Labeled l a) where
val lv = let l = labelOf lv
v = unlabelTCB lv
in LabeledVal $ labelTCB l (Bson.val v)
cast' (LabeledVal lv) = let l = labelOf lv
v = unlabelTCB lv
in Bson.cast' v >>= return . labelTCB l
cast' _ = Nothing
instance (Bson.Val a, Label l) => Val l (PolicyLabeled l a) where
val (PU x) = PolicyLabeledVal . PU . Bson.val $ x
val (PL lv) = let l = labelOf lv
v = unlabelTCB lv
in PolicyLabeledVal . PL $ labelTCB l (Bson.val v)
cast' (PolicyLabeledVal (PU v)) = Bson.cast' v >>= return . PU
cast' (PolicyLabeledVal (PL lv)) = let l = labelOf lv
v = unlabelTCB lv
in Bson.cast' v >>=
return . PL . labelTCB l
cast' _ = Nothing
cast :: forall m l a. (Label l, Val l a, Monad m) => Value l -> m a
cast v = maybe notType return (cast' v)
where notType = fail $ "expected " ++ show (typeOf (undefined :: a))
++ ": " ++ show v
typed :: (Val l a, Label l) => Value l -> a
typed = runIdentity . cast
instance (Show a, Label l) => Show (Labeled l a) where
#if DEBUG
show = showTCB
#else
show = error "Instance of show for Labeled not supported"
#endif
instance Label l => Eq (Labeled l a) where
(==) = error "Instance of Eq for Labeled not supported"
genObjectId :: LabelState l p s => LIO l p s ObjectId
genObjectId = rtioTCB $ Bson.genObjectId
data PolicyLabeled l a = PU a
| PL (Labeled l a)
deriving (Typeable)
pu :: (Label l, Bson.Val a) => a -> PolicyLabeled l a
pu = PU
pl :: (Label l, Bson.Val a) => Labeled l a -> PolicyLabeled l a
pl = PL
instance (Show a, Label l) => Show (PolicyLabeled l a) where
#if DEBUG
show (PU x) = show x
show (PL x) = showTCB x
#else
show = error "Instance of show for PolicyLabeled not supported"
#endif
instance Label l => Eq (PolicyLabeled l a) where
(==) = error "Instance of show for PolicyLabeled not supported"
type BsonValue = Bson.Value
safeToBsonValue :: (Label l) => Value l -> Maybe BsonValue
safeToBsonValue (BsonVal v) = Just v
safeToBsonValue _ = Nothing
safeFromBsonValue :: (Serialize l, Label l) => BsonValue -> Maybe (Value l)
safeFromBsonValue v' = case fromBsonValue v' of
mv@(Just (BsonVal _)) -> mv
_ -> Nothing
type BsonDocument = Bson.Document
safeToBsonDoc :: (Serialize l, Label l) => Document l -> Maybe BsonDocument
safeToBsonDoc = mapM (\(k := v) -> do v' <- safeToBsonValue v
return (k Bson.:= v')) . exceptInternal
safeFromBsonDoc :: (Serialize l, Label l) => BsonDocument -> Maybe (Document l)
safeFromBsonDoc d = do
d' <- forM d $ \(k Bson.:= v) -> do v' <- safeFromBsonValue v
return (k := v')
return $ exceptInternal d'
toBsonDoc :: (Serialize l, Label l) => Document l -> Bson.Document
toBsonDoc = map (\(k := v) -> (k Bson.:= toBsonValue v)) . exceptInternal
fromBsonDoc :: (Serialize l, Label l) => Bson.Document -> Document l
fromBsonDoc d =
let cs' = map (\(k Bson.:= v) -> (k, fromBsonValue v)) d
cs = map (\(k, Just v) -> k := v) $ filter (isJust . snd) cs'
in exceptInternal cs
fromBsonDocStrict :: (Serialize l, Label l)
=> Bson.Document -> Maybe (Document l)
fromBsonDocStrict d =
let cs' = map (\(k Bson.:= v) -> (k, fromBsonValue v)) d
cs = map (\(k, Just v) -> k := v) $ filter (isJust . snd) cs'
ok = all (isJust .snd) cs'
in if ok then Just . exceptInternal $ cs else Nothing
isUnsafeKey :: Key -> Bool
isUnsafeKey k = or
[ hailsInternalKeyPrefix `isPrefixOf` k
, (u "$") `isPrefixOf` k
]
sanitizeBsonValue :: Bson.Value -> Bson.Value
sanitizeBsonValue (Bson.Doc doc) = Bson.Doc $ doExcludes doc
where doExcludes [] = []
doExcludes (f@(k Bson.:= _):fs) =
let rest = doExcludes fs
in if isUnsafeKey k
then rest
else f:rest
sanitizeBsonValue v = v
exceptInternal :: Label l => Document l -> Document l
exceptInternal [] = []
exceptInternal (f@(k := _):fs) =
let rest = exceptInternal fs
in if isUnsafeKey k
then rest
else f:rest
hailsInternalKeyPrefix :: Key
hailsInternalKeyPrefix = u "__hails_internal_"
lBsonLabeledValKey :: Key
lBsonLabeledValKey = hailsInternalKeyPrefix `append` u "Labeled"
lBsonPolicyLabeledValKey :: Key
lBsonPolicyLabeledValKey = hailsInternalKeyPrefix `append` u "PolicyLabeled"
lBsonLabelKey :: Key
lBsonLabelKey = u "label"
lBsonValueKey :: Key
lBsonValueKey = u "value"
toBsonValue :: (Serialize l, Label l) => Value l -> Bson.Value
toBsonValue mV =
case mV of
(BsonVal v) -> v
(LabeledVal lv) -> Bson.val [ lBsonLabeledValKey Bson.=:
[ lBsonLabelKey Bson.=: Binary (encode (labelOf lv))
, lBsonValueKey Bson.:= unlabelTCB lv ] ]
(PolicyLabeledVal (PL lv)) -> Bson.val [ lBsonPolicyLabeledValKey Bson.=:
[ lBsonValueKey Bson.:= unlabelTCB lv ] ]
(PolicyLabeledVal (PU _)) -> error "toBsonValue: Invalid use (PU _)."
fromBsonValue :: (Serialize l, Label l) => Bson.Value -> Maybe (Value l)
fromBsonValue mV =
case mV of
x@(Bson.Doc d) ->
let haveL = isJust $ Bson.look lBsonLabeledValKey d
havePL = isJust $ Bson.look lBsonPolicyLabeledValKey d
in if haveL || havePL
then getLabeled d `orMaybe` getPolicyLabeled d
else Just (BsonVal x)
x -> Just (BsonVal x)
where getLabeled :: (Serialize l, Label l) => Bson.Document -> Maybe (Value l)
getLabeled d = do
(Bson.Doc lv) <- Bson.look lBsonLabeledValKey d
(Binary b) <- Bson.lookup lBsonLabelKey lv
l <- either (const Nothing) return (decode b)
v <- Bson.look lBsonValueKey lv
return . LabeledVal $ labelTCB l v
getPolicyLabeled :: (Serialize l, Label l)
=> Bson.Document -> Maybe (Value l)
getPolicyLabeled d = do
(Bson.Doc lv) <- Bson.look lBsonPolicyLabeledValKey d
v <- Bson.look lBsonValueKey lv
return . PolicyLabeledVal . PU $ v
orMaybe :: Maybe a -> Maybe a -> Maybe a
orMaybe x y = if isJust x then x else y
class BsonDocSerialize doc where
encodeDoc :: doc -> L.ByteString
decodeDoc :: L.ByteString -> doc
instance BsonDocSerialize BsonDocument where
encodeDoc doc' = let (Bson.Doc doc) = sanitizeBsonValue . Bson.Doc $ doc'
in runPut $ putDocument doc
decodeDoc bs = let (Bson.Doc doc) = sanitizeBsonValue
. Bson.Doc $ runGet getDocument bs
in doc
instance (Serialize l, Label l) => BsonDocSerialize (Document l) where
encodeDoc = encodeDoc . fromJust . safeToBsonDoc
decodeDoc = fromJust . safeFromBsonDoc . decodeDoc