module Hails.Data.Hson.TCB (
HsonDocument, BsonDocument
, FieldName, HsonField(..), BsonField(..)
, HsonValue(..), BsonValue(..)
, PolicyLabeled(..), ObjectId(..), Binary(..), S8
, hsonDocToDataBsonDocTCB
, dataBsonDocToHsonDocTCB
, bsonDocToDataBsonDocTCB
, dataBsonValueToHsonValueTCB
, add__hails_prefix
) where
import Data.Text (Text)
import qualified Data.Text as T
import Data.Int (Int32, Int64)
import Data.Time.Clock (UTCTime)
import Data.Typeable
import qualified Data.Bson as Bson
import qualified Data.Bson.Binary as Bson
import Data.Bson ( ObjectId(..) )
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.Binary.Put as Binary
import qualified Data.Binary.Get as Binary
import LIO.Labeled.TCB (unlabelTCB)
import LIO.DCLabel
type S8 = S8.ByteString
type HsonDocument = [HsonField]
type BsonDocument = [BsonField]
type FieldName = Text
data BsonField = BsonField !FieldName BsonValue
deriving (Typeable, Eq, Ord)
data HsonField = HsonField !FieldName HsonValue
deriving (Typeable, Eq, Ord)
data BsonValue = BsonFloat Double
| BsonString Text
| BsonDoc BsonDocument
| BsonArray [BsonValue]
| BsonBlob Binary
| BsonObjId ObjectId
| BsonBool Bool
| BsonUTC UTCTime
| BsonNull
| BsonInt32 Int32
| BsonInt64 Int64
deriving (Typeable, Eq, Ord)
data HsonValue = HsonValue BsonValue
| HsonLabeled PolicyLabeled
deriving (Typeable, Eq, Ord)
data PolicyLabeled = NeedPolicyTCB BsonValue
| HasPolicyTCB (DCLabeled BsonValue)
deriving (Typeable)
instance Eq PolicyLabeled where (==) _ _ = True
instance Ord PolicyLabeled where (<=) _ _ = False
instance Show PolicyLabeled where show _ = "PolicyLabeled"
newtype Binary = Binary { unBinary :: S8 }
deriving (Typeable, Show, Read, Eq, Ord)
hsonToDataBsonTCB :: HsonValue -> Bson.Value
hsonToDataBsonTCB (HsonValue b) = bsonToDataBsonTCB b
hsonToDataBsonTCB (HsonLabeled (HasPolicyTCB lv)) =
toUserDef . hsonDocToDataBsonDocTCB $
[ HsonField __hails_HsonLabeled_value $ HsonValue (unlabelTCB lv) ]
where toUserDef = Bson.UserDef
. Bson.UserDefined
. strictify
. Binary.runPut
. Bson.putDocument
strictify = S8.concat . L.toChunks
hsonToDataBsonTCB _ =
error $ "hsonToDataBsonTCB: all policy labeled values" ++
" must have labeled values"
bsonToDataBsonTCB :: BsonValue -> Bson.Value
bsonToDataBsonTCB bv = case bv of
(BsonFloat d) -> Bson.Float d
(BsonString t) -> Bson.String t
(BsonDoc d) -> Bson.Doc $ bsonDocToDataBsonDocTCB d
(BsonArray hs) -> Bson.Array $ bsonToDataBsonTCB `map` hs
(BsonBlob b) -> Bson.Bin . Bson.Binary . unBinary $ b
(BsonObjId oid) -> Bson.ObjId oid
(BsonBool b) -> Bson.Bool b
(BsonUTC t) -> Bson.UTC t
BsonNull -> Bson.Null
(BsonInt32 i) -> Bson.Int32 i
(BsonInt64 i) -> Bson.Int64 i
hsonFieldToDataBsonFieldTCB :: HsonField -> Bson.Field
hsonFieldToDataBsonFieldTCB (HsonField n v) =
(Bson.:=) n (hsonToDataBsonTCB v)
hsonDocToDataBsonDocTCB :: HsonDocument -> Bson.Document
hsonDocToDataBsonDocTCB = map hsonFieldToDataBsonFieldTCB
bsonFieldToDataBsonFieldTCB :: BsonField -> Bson.Field
bsonFieldToDataBsonFieldTCB (BsonField n v) =
(Bson.:=) n (bsonToDataBsonTCB v)
bsonDocToDataBsonDocTCB :: BsonDocument -> Bson.Document
bsonDocToDataBsonDocTCB = map bsonFieldToDataBsonFieldTCB
dataBsonFieldToBsonFieldTCB :: Bson.Field -> BsonField
dataBsonFieldToBsonFieldTCB ((Bson.:=) n v) = BsonField n (dataBsonToBsonTCB v)
dataBsonDocToBsonDocTCB :: Bson.Document -> BsonDocument
dataBsonDocToBsonDocTCB = map dataBsonFieldToBsonFieldTCB
dataBsonToBsonTCB :: Bson.Value -> BsonValue
dataBsonToBsonTCB bv = case bv of
(Bson.Float d) -> BsonFloat d
(Bson.String t) -> BsonString t
(Bson.Doc d) -> BsonDoc $ dataBsonDocToBsonDocTCB d
(Bson.Array hs) -> BsonArray $ dataBsonToBsonTCB `map` hs
(Bson.Bin (Bson.Binary b)) -> BsonBlob . Binary $ b
(Bson.ObjId oid) -> BsonObjId oid
(Bson.Bool b) -> BsonBool b
(Bson.UTC t) -> BsonUTC t
Bson.Null -> BsonNull
(Bson.Int32 i) -> BsonInt32 i
(Bson.Int64 i) -> BsonInt64 i
_ -> error "dataBsonToBsonTCB: only support subset of BSON"
dataBsonDocToHsonDocTCB :: Bson.Document -> HsonDocument
dataBsonDocToHsonDocTCB =
map (\((Bson.:=) n bv) -> HsonField n $ dataBsonValueToHsonValueTCB bv)
dataBsonValueToHsonValueTCB :: Bson.Value -> HsonValue
dataBsonValueToHsonValueTCB bv = case bv of
(Bson.UserDef (Bson.UserDefined b)) ->
let bdoc = Binary.runGet Bson.getDocument (lazyfy b)
in case maybePolicyLabeledTCB bdoc of
Nothing -> error $ "dataBsonValueToHsonValueTCB: "
++ "Expected PolicyLabeled"
Just lv -> HsonLabeled lv
v -> HsonValue $ dataBsonToBsonTCB v
where lazyfy x = L8.fromChunks [x]
__hails_HsonLabeled_value :: FieldName
__hails_HsonLabeled_value = add__hails_prefix $ T.pack "HsonLabeled_value"
add__hails_prefix :: FieldName -> FieldName
add__hails_prefix t = T.pack "__hails_" `T.append` t
maybePolicyLabeledTCB :: Bson.Document -> Maybe PolicyLabeled
maybePolicyLabeledTCB doc = do
v <- Bson.look __hails_HsonLabeled_value doc
return . NeedPolicyTCB $ dataBsonToBsonTCB v