module Hails.Data.Hson (
HsonDocument, Document, BsonDocument
, DocOps(..)
, DocValOps(..)
, include, exclude
, merge
, bsonDocToHsonDoc, bsonFieldToHsonField
, isBsonDoc
, hsonDocToBsonDoc
, hsonDocToBsonDocStrict
, labeledRequestToHson
, FieldName, HsonField(..), BsonField(..)
, IsField(..), Field(..), GenField(..)
, HsonValue(..), HsonVal(..)
, BsonValue(..), BsonVal(..)
, PolicyLabeled, needPolicy, hasPolicy, getPolicyLabeled
, Binary(..)
, ObjectId(..), genObjectId
) where
import Prelude hiding (lookup)
import Control.Monad (liftM)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Binary.Put
import Data.Bson.Binary
import Data.Maybe (mapMaybe, fromJust, fromMaybe)
import qualified Data.List as List
import Data.Text (Text)
import qualified Data.Text as T
import Data.Int (Int32, Int64)
import Data.Time.Clock (UTCTime)
import Data.Typeable
import Data.Functor.Identity (runIdentity)
import qualified Data.Bson as Bson
import Data.Conduit (runResourceT, ($$))
import Data.Conduit.Binary (sourceLbs)
import LIO
import LIO.DCLabel
import LIO.TCB
import Network.Wai.Parse ( FileInfo(..)
, sinkRequestBody
, lbsBackEnd)
import Hails.Data.Hson.TCB
import Hails.HttpServer.Types
infix 0 =:, -:
type Document = HsonDocument
instance Show BsonField where
show (BsonField n v) = T.unpack n ++ " -: " ++ show v
instance Show HsonField where
show (HsonField n v) = T.unpack n ++ " -: " ++ show v
class IsField f where
fieldName :: f -> FieldName
instance IsField BsonField where fieldName (BsonField n _) = n
instance IsField HsonField where fieldName (HsonField n _) = n
class (IsField f, Show v, Show f) => Field v f where
(=:) :: FieldName -> v -> f
fieldValue :: Monad m => f -> m v
instance Field BsonValue BsonField where
(=:) = BsonField
fieldValue (BsonField _ v) = return v
instance Field BsonValue HsonField where
n =: v = n =: HsonValue v
fieldValue (HsonField _ (HsonValue v)) = return v
fieldValue _ = fail "fieldValue: cannot extract PolicyLabled"
instance Field HsonValue HsonField where
(=:) = HsonField
fieldValue (HsonField _ v) = return v
instance Show BsonValue where
show (BsonFloat v) = show v
show (BsonString v) = show v
show (BsonDoc v) = show v
show (BsonArray v) = show v
show (BsonBlob v) = show v
show (BsonObjId v) = show v
show (BsonBool v) = show v
show (BsonUTC v) = show v
show BsonNull = "NULL"
show (BsonInt32 v) = show v
show (BsonInt64 v) = show v
instance Show HsonValue where
show (HsonValue h) = show h
show (HsonLabeled _) = "{- Hidden -} HsonLabeled"
instance ShowTCB HsonValue where
showTCB (HsonValue h) = show h
showTCB (HsonLabeled h) = showTCB h
instance ShowTCB PolicyLabeled where
showTCB (NeedPolicyTCB bv) = "NeedPolicyTCB " ++ show bv
showTCB (HasPolicyTCB lbv) = "HasPolicyTCB " ++ showTCB lbv
needPolicy :: BsonValue-> PolicyLabeled
needPolicy = NeedPolicyTCB
hasPolicy :: DCLabeled BsonValue -> PolicyLabeled
hasPolicy = HasPolicyTCB
getPolicyLabeled :: Monad m => PolicyLabeled -> m (DCLabeled BsonValue)
getPolicyLabeled (NeedPolicyTCB _) =
fail "Can only retrieve already labeldv policy values"
getPolicyLabeled (HasPolicyTCB lv) = return lv
class Field v f => DocOps v f | v -> f, f -> v where
look :: (Field v f, Monad m) => FieldName -> [f] -> m v
look n doc = case List.find ((==n) . fieldName) doc of
Just v -> fieldValue v
_ -> fail $ "look: Not found " ++ show n
valueAt :: Field v f => FieldName -> [f] -> v
valueAt n = runIdentity . look n
serialize :: [f] -> L8.ByteString
instance DocOps HsonValue HsonField where
serialize = serialize . hsonDocToBsonDoc
instance DocOps BsonValue BsonField where
serialize = runPut . putDocument . bsonDocToDataBsonDocTCB
include :: IsField f => [FieldName] -> [f] -> [f]
include ns doc = mapMaybe (\n -> List.find ((==n) . fieldName) doc) ns
exclude :: IsField f => [FieldName] -> [f] -> [f]
exclude ns doc = filter ((\n -> notElem n ns) . fieldName) doc
merge :: IsField f => [f] -> [f] -> [f]
merge doc1 doc2 =
let ns1 = map fieldName doc1
doc2' = List.filter ((\n -> n `notElem` ns1) . fieldName) doc2
in doc1 ++ doc2'
class DocValOps d v where
lookup :: (Monad m) => FieldName -> d -> m v
at :: FieldName -> d -> v
at n = runIdentity . lookup n
instance HsonVal v => DocValOps HsonDocument v where
lookup n doc = look n doc >>= fromHsonValue
instance BsonVal v => DocValOps BsonDocument v where
lookup n doc = look n doc >>= fromBsonValue
isBsonDoc :: HsonDocument -> Bool
isBsonDoc doc = all f doc
where f (HsonField _ (HsonLabeled _)) = False
f _ = True
bsonDocToHsonDoc :: BsonDocument -> HsonDocument
bsonDocToHsonDoc = map bsonFieldToHsonField
bsonFieldToHsonField :: BsonField -> HsonField
bsonFieldToHsonField (BsonField n v) = n =: v
hsonDocToBsonDoc :: HsonDocument -> BsonDocument
hsonDocToBsonDoc doc = mapMaybe hsonFieldToBsonField doc
hsonDocToBsonDocStrict :: Monad m => HsonDocument -> m BsonDocument
hsonDocToBsonDocStrict doc = mapM hsonFieldToBsonField doc
hsonFieldToBsonField :: Monad m => HsonField -> m BsonField
hsonFieldToBsonField (HsonField n (HsonValue v)) = return (n =: v)
hsonFieldToBsonField (HsonField n _) =
fail $ "hsonFieldToBsonField: field " ++ show n ++ " is PolicyLabeled"
labeledRequestToHson :: MonadLIO DCLabel m
=> DCLabeled Request -> m (DCLabeled HsonDocument)
labeledRequestToHson lreq = liftLIO $ do
let (LabeledTCB origLabel req) = lreq
btype = fromMaybe UrlEncoded $ getRequestBodyType req
(ps, fs) <- liftLIO . ioTCB $ runResourceT $
sourceLbs (requestBody req) $$ sinkRequestBody lbsBackEnd btype
let psDoc = map convertPS ps
fsDoc = map convertFS fs
return $ LabeledTCB origLabel $ arrayify $ psDoc ++ fsDoc
where convertPS (k,v) = HsonField
(T.pack . S8.unpack $ k)
(toHsonValue . S8.unpack $ v)
convertFS (k,v) = HsonField (T.pack . S8.unpack $ k)
(toHsonValue $ fsToDoc v)
fsToDoc f = [ "fileName" -: (T.pack . S8.unpack $ fileName f)
, "fileContentType" -:
(T.pack . S8.unpack $ fileContentType f)
, "fileContent" -: (S8.concat . L.toChunks $ fileContent f)
] :: BsonDocument
arrayify doc =
let pred0 = (T.isSuffixOf "[]" . fieldName)
(doc0, doc0_keep) = List.partition pred0 doc
gs = List.groupBy (\x y -> fieldName x == fieldName y)
. List.sortBy (\x y -> fieldName x `compare` fieldName y)
$ doc0
doc1 = concat $ map toArray gs
in doc0_keep ++ doc1
where toArray [] = []
toArray ds = let n = fromJust
. T.stripSuffix "[]"
. fieldName
. head $ ds
vs = map (fromJust . fieldValue) ds
in [ n -: BsonArray vs ]
class (Show v, Show f) => GenField v f where
(-:) :: FieldName -> v -> f
instance BsonVal v => GenField v BsonField where
n -: v = n =: toBsonValue v
instance HsonVal v => GenField v HsonField where
n -: v = n =: toHsonValue v
class (Typeable a, Show a) => BsonVal a where
toBsonValue :: a -> BsonValue
fromBsonValue :: Monad m => BsonValue -> m a
instance BsonVal Double where
toBsonValue = BsonFloat
fromBsonValue (BsonFloat x) = return x
fromBsonValue (BsonInt32 x) = return (fromIntegral x)
fromBsonValue (BsonInt64 x) = return (fromIntegral x)
fromBsonValue v = fail $ "fromBsonValue: no conversion to Double of " ++ (show v)
instance BsonVal Float where
toBsonValue = BsonFloat . realToFrac
fromBsonValue (BsonFloat x) = return (realToFrac x)
fromBsonValue (BsonInt32 x) = return (fromIntegral x)
fromBsonValue (BsonInt64 x) = return (fromIntegral x)
fromBsonValue v = fail $ "fromBsonValue: no conversion to Float of " ++ (show v)
instance BsonVal Text where
toBsonValue = BsonString
fromBsonValue (BsonString x) = return x
fromBsonValue v = fail $ "fromBsonValue: no conversion to Text of " ++ (show v)
instance BsonVal String where
toBsonValue = BsonString . T.pack
fromBsonValue (BsonString x) = return $ T.unpack x
fromBsonValue v = fail $ "fromBsonValue: no conversion to String of " ++ (show v)
instance BsonVal S8.ByteString where
toBsonValue = BsonString . T.pack . S8.unpack
fromBsonValue (BsonString x) = return $ S8.pack $ T.unpack x
fromBsonValue v = fail $ "fromBsonValue: no conversion to ByteString (Strict) of " ++ (show v)
instance BsonVal L8.ByteString where
toBsonValue = BsonString . T.pack . L8.unpack
fromBsonValue (BsonString x) = return $ L8.pack $ T.unpack x
fromBsonValue v = fail $ "fromBsonValue: no conversion to ByteString (Lazy) of " ++ (show v)
instance BsonVal BsonDocument where
toBsonValue = BsonDoc
fromBsonValue (BsonDoc x) = return x
fromBsonValue v = fail $ "fromBsonValue: no conversion to BsonDocument of " ++ (show v)
instance BsonVal [BsonValue] where
toBsonValue = BsonArray
fromBsonValue (BsonArray x) = return x
fromBsonValue v = fail $ "fromBsonValue: no conversion to [BsonValue] of " ++ (show v)
instance (BsonVal a) => BsonVal [a] where
toBsonValue = BsonArray . map toBsonValue
fromBsonValue (BsonArray x) = mapM fromBsonValue x
fromBsonValue v = fail $ "fromBsonValue: no conversion to [a] of " ++ (show v)
instance BsonVal Binary where
toBsonValue = BsonBlob
fromBsonValue (BsonBlob x) = return x
fromBsonValue (BsonString x) = return $ Binary $ S8.pack $ T.unpack x
fromBsonValue v = fail $ "fromBsonValue: no conversion to Binary of " ++ (show v)
instance BsonVal ObjectId where
toBsonValue = BsonObjId
fromBsonValue (BsonObjId x) = return x
fromBsonValue v = fail $ "fromBsonValue: no conversion to ObjectId of " ++ (show v)
instance BsonVal Bool where
toBsonValue = BsonBool
fromBsonValue (BsonBool x) = return x
fromBsonValue v = fail $ "fromBsonValue: no conversion to Bool of " ++ (show v)
instance BsonVal UTCTime where
toBsonValue = BsonUTC
fromBsonValue (BsonUTC x) = return x
fromBsonValue v = fail $ "fromBsonValue: no conversion to UTCTime of " ++ (show v)
instance BsonVal (Maybe BsonValue) where
toBsonValue Nothing = BsonNull
toBsonValue (Just v) = v
fromBsonValue BsonNull = return Nothing
fromBsonValue v = return (Just v)
instance (BsonVal a) => BsonVal (Maybe a) where
toBsonValue Nothing = BsonNull
toBsonValue (Just a) = toBsonValue a
fromBsonValue BsonNull = return Nothing
fromBsonValue v = Just `liftM` fromBsonValue v
instance BsonVal Int32 where
toBsonValue = BsonInt32
fromBsonValue (BsonInt32 x) = return x
fromBsonValue (BsonInt64 x) = fitInt x
fromBsonValue (BsonFloat x) = return (round x)
fromBsonValue v = fail $ "fromBsonValue: no conversion to Int32 of " ++ (show v)
instance BsonVal Int64 where
toBsonValue = BsonInt64
fromBsonValue (BsonInt64 x) = return x
fromBsonValue (BsonInt32 x) = return (fromIntegral x)
fromBsonValue (BsonFloat x) = return (round x)
fromBsonValue v = fail $ "fromBsonValue: no conversion to Int64 of " ++ (show v)
instance BsonVal Int where
toBsonValue n = maybe (BsonInt64 $ fromIntegral n) BsonInt32 (fitInt n)
fromBsonValue (BsonInt32 x) = return (fromIntegral x)
fromBsonValue (BsonInt64 x) = return (fromEnum x)
fromBsonValue (BsonFloat x) = return (round x)
fromBsonValue v = fail $ "fromBsonValue: no conversion to Int of " ++ (show v)
instance BsonVal Integer where
toBsonValue n = maybe (maybe err BsonInt64 $ fitInt n)
BsonInt32 (fitInt n)
where err = error $ show n ++ " is too large for BsonInt{32,64}"
fromBsonValue (BsonInt32 x) = return (fromIntegral x)
fromBsonValue (BsonInt64 x) = return (fromIntegral x)
fromBsonValue (BsonFloat x) = return (round x)
fromBsonValue v = fail $ "fromBsonValue: no conversion to Integer of " ++ (show v)
class (Typeable a, Show a) => HsonVal a where
toHsonValue :: a -> HsonValue
fromHsonValue :: Monad m => HsonValue -> m a
instance HsonVal HsonValue where
toHsonValue = id
fromHsonValue = return
instance HsonVal Double where
toHsonValue = HsonValue . BsonFloat
fromHsonValue (HsonValue (BsonFloat x)) = return x
fromHsonValue (HsonValue (BsonInt32 x)) = return (fromIntegral x)
fromHsonValue (HsonValue (BsonInt64 x)) = return (fromIntegral x)
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal Float where
toHsonValue = HsonValue . BsonFloat . realToFrac
fromHsonValue (HsonValue (BsonFloat x)) = return (realToFrac x)
fromHsonValue (HsonValue (BsonInt32 x)) = return (fromIntegral x)
fromHsonValue (HsonValue (BsonInt64 x)) = return (fromIntegral x)
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal Text where
toHsonValue = HsonValue . BsonString
fromHsonValue (HsonValue (BsonString x)) = return x
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal String where
toHsonValue = HsonValue . BsonString . T.pack
fromHsonValue (HsonValue (BsonString x)) = return $ T.unpack x
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal BsonDocument where
toHsonValue = HsonValue . BsonDoc
fromHsonValue (HsonValue (BsonDoc x)) = return x
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal [BsonValue] where
toHsonValue = HsonValue . BsonArray
fromHsonValue (HsonValue (BsonArray x)) = return x
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance (HsonVal a, BsonVal a) => HsonVal [a] where
toHsonValue = HsonValue . BsonArray . map toBsonValue
fromHsonValue (HsonValue (BsonArray x)) = mapM fromBsonValue x
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal Binary where
toHsonValue = HsonValue . BsonBlob
fromHsonValue (HsonValue (BsonBlob x)) = return x
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal ObjectId where
toHsonValue = HsonValue . BsonObjId
fromHsonValue (HsonValue (BsonObjId x)) = return x
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal Bool where
toHsonValue = HsonValue . BsonBool
fromHsonValue (HsonValue (BsonBool x)) = return x
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal UTCTime where
toHsonValue = HsonValue . BsonUTC
fromHsonValue (HsonValue (BsonUTC x)) = return x
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal (Maybe BsonValue) where
toHsonValue Nothing = HsonValue BsonNull
toHsonValue (Just v) = HsonValue v
fromHsonValue (HsonValue BsonNull) = return Nothing
fromHsonValue (HsonValue v) = return (Just v)
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance (HsonVal a, BsonVal a) => HsonVal (Maybe a) where
toHsonValue Nothing = HsonValue BsonNull
toHsonValue (Just a) = HsonValue $ toBsonValue a
fromHsonValue (HsonValue BsonNull) = return Nothing
fromHsonValue (HsonValue v) = fromBsonValue v
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal Int32 where
toHsonValue = HsonValue . BsonInt32
fromHsonValue (HsonValue (BsonInt32 x)) = return x
fromHsonValue (HsonValue (BsonInt64 x)) = fitInt x
fromHsonValue (HsonValue (BsonFloat x)) = return (round x)
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal Int64 where
toHsonValue = HsonValue . BsonInt64
fromHsonValue (HsonValue (BsonInt64 x)) = return x
fromHsonValue (HsonValue (BsonInt32 x)) = return (fromIntegral x)
fromHsonValue (HsonValue (BsonFloat x)) = return (round x)
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal Int where
toHsonValue n = HsonValue $ maybe (BsonInt64 $ fromIntegral n)
BsonInt32 (fitInt n)
fromHsonValue (HsonValue (BsonInt32 x)) = return (fromIntegral x)
fromHsonValue (HsonValue (BsonInt64 x)) = return (fromEnum x)
fromHsonValue (HsonValue (BsonFloat x)) = return (round x)
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal Integer where
toHsonValue n = HsonValue $ maybe (maybe err BsonInt64 $ fitInt n)
BsonInt32 (fitInt n)
where err = error $ show n ++ " is too large for HsonInt{32,64}"
fromHsonValue (HsonValue (BsonInt32 x)) = return (fromIntegral x)
fromHsonValue (HsonValue (BsonInt64 x)) = return (fromIntegral x)
fromHsonValue (HsonValue (BsonFloat x)) = return (round x)
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal BsonValue where
toHsonValue = HsonValue
fromHsonValue (HsonValue v) = return v
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance HsonVal PolicyLabeled where
toHsonValue = HsonLabeled
fromHsonValue (HsonLabeled v) = return v
fromHsonValue _ = fail "fromHsonValue: no conversion"
instance Show (DCLabeled BsonValue) where
show lv = " -UNKNOWN VALUE- {" ++ show (labelOf lv) ++ "}"
instance HsonVal (DCLabeled BsonValue) where
toHsonValue = HsonLabeled . hasPolicy
fromHsonValue (HsonLabeled v) = getPolicyLabeled v
fromHsonValue _ = fail "fromHsonValue: no conversion"
genObjectId :: MonadLIO DCLabel m => m ObjectId
genObjectId = liftLIO $ ioTCB Bson.genObjectId
fitInt :: forall a b m. (Integral a, Integral b, Bounded b, Monad m)
=> a -> m b
fitInt n = if fromIntegral (minBound :: b) <= n
&& n <= fromIntegral (maxBound :: b)
then return $ fromIntegral n
else fail "fitInt: number is too big"