{-# LANGUAGE Unsafe #-}
{-# LANGUAGE DeriveDataTypeable #-}

{- |


This module exports the type for a Hails BSON document, 'HsonDoc'.  A
Hails document is akin to "Data.Bson"\'s documents, but differs in two
ways. First, Hails restricts the number of types to a subset of BSON's
(see 'BsonVal'). This restriction is primarily due to the fact that
many of the BSON types are redundant and not used (at least within
Hails). Second, Hails allows for documents to contain policy-labeled
values.

Policy labeled values ('PolicyLabeled') are permitted only at the
\"top-level\" of a document. (This is primarily done to keep
policy-specification simple and may change in the future.)
Consequently to allow for nested documents and documents containing an
array of values we separate top-level fields ('HsonField'), that may
contain policy labeled values, from potentially-nested fields
('BsonField'). A top-level field 'HsonField' is thus either a
'BsonField' or a 'PolicyLabled' value.

To keep the TCB compact, this module does not export the combinators
used to create documents in a friendly fashion. See "Hails.Data.Hson"
for the safe external API.


/Credit:/ Much of this code is based on/reuses "Data.Bson".
-}

module Hails.Data.Hson.TCB (
  -- * Documents
    HsonDocument, BsonDocument
  -- * Fields
  , FieldName, HsonField(..), BsonField(..)
  -- * Values
  , HsonValue(..), BsonValue(..)
  , PolicyLabeled(..), ObjectId(..), Binary(..), S8
  -- * Marshall to/from "Data.Bson"
  , hsonDocToDataBsonDocTCB 
  , dataBsonDocToHsonDocTCB 
  , bsonDocToDataBsonDocTCB 
  , dataBsonValueToHsonValueTCB 
  -- * Internal
  , 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.DCLabel
import           LIO.TCB

-- | Strict ByeString
type S8 = S8.ByteString




--
-- Document
--

-- | A top-level document containing 'HsonField's.
type HsonDocument = [HsonField]

-- | A (possibly top-)level document containing 'BsonField's.
type BsonDocument = [BsonField]

--
-- Fields
--

-- | The name of a field.
type FieldName = Text

-- | A field containing a named 'BsonValue'
data BsonField = BsonField !FieldName BsonValue
  deriving (Typeable, Eq, Ord)

-- | A field containing a named 'HsonValue'
data HsonField = HsonField !FieldName HsonValue
  deriving (Typeable, Eq, Ord)

--
-- Values
--

-- | A @BsonValue@ is a subset of BSON ("Data.Bson") values.  Note that a
-- @BsonValue@ cannot contain any labeled values; all labeled values
-- occur in a document as 'HsonValue's.  Correspondingly, @BsonValue@s
-- may be arbitrarily nested.
data BsonValue = BsonFloat Double
               -- ^ Float value
               | BsonString Text
               -- ^ String value
               | BsonDoc BsonDocument
               -- ^ Inner document
               | BsonArray [BsonValue]
               -- ^ List of values
               | BsonBlob Binary
               -- ^ Binary blob value
               | BsonObjId ObjectId
               -- ^ Object Id value
               | BsonBool Bool
               -- ^ Boolean value
               | BsonUTC UTCTime
               -- ^ Time stamp value
               | BsonNull
               -- ^ The @NULL@ value
               | BsonInt32 Int32
               -- ^ 32-bit integer
               | BsonInt64 Int64
               -- ^ 64-bit integer
               deriving (Typeable, Eq, Ord)

-- | An @HsonValue@ is a top-level value that may either be a
-- 'BsonValue' or a policy labeled value. The separation of values
-- into 'BsonValue' and 'HsonValue' is solely due to the restriction
-- that policy-labeled values may only occur at the top level and
-- 'BsonValue's may be nested (e.g. using 'BsonArray' and 'BsonDoc').
data HsonValue = HsonValue BsonValue
                 -- ^ Bson value
               | HsonLabeled PolicyLabeled
                 -- ^ Policy labeled value
                 deriving (Typeable, Eq, Ord)

-- | A @PolicyLabeled@ value can be either an unlabeled value for which
-- the policy needs to be applied (@NeedPolicyTCB@), or an already
-- labeled value (@HasPolicyTCB@). @PolicyLabeled@ is a partially-opaque
-- type; code should not be able to inspect the value of an unlabeleda
-- value, but may inspect an already labeled value.
data PolicyLabeled = NeedPolicyTCB BsonValue
                     -- ^ Policy was not applied 
                   | HasPolicyTCB (DCLabeled BsonValue)
                     -- ^ Policy applied
                   deriving (Typeable)

instance Eq PolicyLabeled   where (==) _ _ = True
instance Ord PolicyLabeled  where (<=) _ _ = False
instance Show PolicyLabeled where show _   = "PolicyLabeled"


-- | Arbitrary binary blob
newtype Binary = Binary { unBinary :: S8 }
  deriving (Typeable, Show, Read, Eq, Ord)


--
-- Convert to "Data.Bson"
--

-- | Convert 'HsonValue' to a "Data.Bson" @Value@. Note that
-- 'PolicyLabeled' values are marshalled out as "Data.Bson" @UserDefined@
-- values. This means that the @UserDefined@ type is reserved and
-- exposing it as a type in 'BsonValue' would potentially lead to leaks.
-- Note that the label is /NOT/ serialized, only the value. Hence,
-- after marshalling such that back it is important that a policy is 
-- applied to label the field.
hsonToDataBsonTCB :: HsonValue -> Bson.Value
hsonToDataBsonTCB (HsonValue b) = bsonToDataBsonTCB b
hsonToDataBsonTCB (HsonLabeled (HasPolicyTCB (LabeledTCB _ lv))) =
  toUserDef . hsonDocToDataBsonDocTCB $ 
     [ HsonField __hails_HsonLabeled_value $
            HsonValue 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"

-- | Convert 'BsonValue' to a "Data.Bson" @Value@.
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


-- | Convert an 'HsonField' to a "Data.Bson" @Field@.
hsonFieldToDataBsonFieldTCB :: HsonField -> Bson.Field
hsonFieldToDataBsonFieldTCB (HsonField n v) =
  (Bson.:=) n (hsonToDataBsonTCB v)

-- | Convert a top-level document (i.e., 'HsonDocument') to a "Data.Bson"
-- @Document@. This is the primary marshall-out function.  All
-- 'PolicyLabeled' values are marshalled out as "Data.Bson" @UserDefined@
-- values. This means that the @UserDefined@ type is reserved and
-- exposing it as a type in 'BsonValue' would potentially lead to
-- vulnerabilities in which labeled values can be marshalled in from
-- well-crafted ByteStrings. Moreover, untrusted code should not have
-- access to this function; having such access would allow it to
-- inspect the serialized labeled values and thus violate IFC.
hsonDocToDataBsonDocTCB :: HsonDocument -> Bson.Document
hsonDocToDataBsonDocTCB = map hsonFieldToDataBsonFieldTCB

-- | Convert a 'BsonField' to a "Data.Bson" @Field@.
bsonFieldToDataBsonFieldTCB :: BsonField -> Bson.Field
bsonFieldToDataBsonFieldTCB (BsonField n v) =
  (Bson.:=) n (bsonToDataBsonTCB v)

-- | Convert a 'BsonDocument' to a "Data.Bson" @Document@.
bsonDocToDataBsonDocTCB :: BsonDocument -> Bson.Document
bsonDocToDataBsonDocTCB = map bsonFieldToDataBsonFieldTCB


--
-- Convert from "Data.Bson"
--

-- | Convert a "Data.Bson" @Field@ to 'BsonField'.
dataBsonFieldToBsonFieldTCB :: Bson.Field -> BsonField
dataBsonFieldToBsonFieldTCB ((Bson.:=) n v) = BsonField n (dataBsonToBsonTCB v)

-- | Convert a "Data.Bson" @Document@  to a 'BsonDocument'.
dataBsonDocToBsonDocTCB :: Bson.Document -> BsonDocument
dataBsonDocToBsonDocTCB = map dataBsonFieldToBsonFieldTCB

-- | Convert "Data.Bson" @Value@ to a 'BsonValue'.
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"


-- | Convert "Data.Bson" @Document@ to a 'HsonDocument'. This is the
-- top-level function that marshalls BSON documents to Hails
-- documents. This function assumes that all documents have been
-- marshalled out using 'hsonDocToDataBsonDocTCB'. Otherwise, the
-- 'PolicyLabled' values that are created from the document may be
-- forged.
dataBsonDocToHsonDocTCB :: Bson.Document -> HsonDocument
dataBsonDocToHsonDocTCB =
  map (\((Bson.:=) n bv) -> HsonField n $ dataBsonValueToHsonValueTCB bv)

-- |Convert a "Data.Bson" @Value@ to a 'HsonValue'. See
-- 'dataBsonDocToHsonDocTCB'.
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 internal field name for a policy labeled value (label part)
-- (name part).
__hails_HsonLabeled_value :: FieldName
__hails_HsonLabeled_value = add__hails_prefix $ T.pack "HsonLabeled_value"

-- | Hails internal prefix that is used to serialized labeled values.
add__hails_prefix :: FieldName -> FieldName
add__hails_prefix t = T.pack "__hails_" `T.append` t


-- | Convert a "Data.Bson" @Document@ to a policy labeled value.
maybePolicyLabeledTCB :: Bson.Document -> Maybe PolicyLabeled
maybePolicyLabeledTCB doc = do
  v <- Bson.look __hails_HsonLabeled_value doc
  return . NeedPolicyTCB $ dataBsonToBsonTCB v