mongodb/Database/MongoDB/BSON.hs

210 lines
6.5 KiB
Haskell
Raw Normal View History

2010-01-09 22:49:06 +00:00
module Database.MongoDB.BSON
(
BSValue(..),
2010-01-11 03:22:02 +00:00
BSONObject(..),
2010-01-09 22:49:06 +00:00
toBSONObject,
BinarySubType(..)
)
where
import Control.Monad
import Data.Binary
import Data.Binary.Get
import Data.Binary.IEEE754
import Data.Binary.Put
import Data.Bits
import Data.ByteString.Char8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LC
import qualified Data.ByteString.Lazy.UTF8 as L8
import Data.Int
2010-01-11 01:26:50 +00:00
import qualified Data.Map as Map
import qualified Data.List as List
import Data.Time.Clock.POSIX
import Database.MongoDB.Util
data BSValue
= BSDouble Double
| BSString L8.ByteString
| BSObject BSONObject
| BSArray [BSValue]
| BSUndefined
| BSBinary BinarySubType L.ByteString
| BSObjectId L.ByteString
| BSBool !Bool
| BSDate POSIXTime
| BSNull
| BSRegex L8.ByteString String
| BSSymbol L8.ByteString
| BSInt32 Int32
| BSInt64 Int64
| BSMinKey
| BSMaxKey
deriving (Show, Eq, Ord)
2010-01-11 03:22:02 +00:00
newtype BSONObject = BSONObject {
fromBSONObject :: Map.Map L8.ByteString BSValue
}
deriving (Eq, Ord, Show)
toBSONObject :: [(L8.ByteString, BSValue)] -> BSONObject
2010-01-11 01:26:50 +00:00
toBSONObject = BSONObject . Map.fromList
data DataType =
Data_min_key | -- -1
Data_number | -- 1
Data_string | -- 2
Data_object | -- 3
Data_array | -- 4
Data_binary | -- 5
Data_undefined | -- 6
Data_oid | -- 7
Data_boolean | -- 8
Data_date | -- 9
Data_null | -- 10
Data_regex | -- 11
Data_ref | -- 12
Data_code | -- 13
Data_symbol | -- 14
Data_code_w_scope | -- 15
Data_int | -- 16
Data_timestamp | -- 17
Data_long | -- 18
Data_max_key -- 127
deriving (Show, Read, Enum, Eq, Ord)
toDataType :: Int -> DataType
toDataType (-1) = Data_min_key
toDataType 127 = Data_max_key
toDataType d = toEnum d
fromDataType :: DataType -> Int
fromDataType Data_min_key = (-1)
fromDataType Data_max_key = 127
fromDataType d = fromEnum d
data BinarySubType =
BSTUNDEFINED_1 |
BSTFunction | -- 1
BSTByteArray | -- 2
BSTUUID | -- 3
BSTUNDEFINED_2 |
BSTMD5 | -- 5
BSTUserDefined
deriving (Show, Read, Enum, Eq, Ord)
toBinarySubType :: Int -> BinarySubType
toBinarySubType 0x80 = BSTUserDefined
toBinarySubType d = toEnum d
fromBinarySubType :: BinarySubType -> Int
fromBinarySubType BSTUserDefined = 0x80
fromBinarySubType d = fromEnum d
instance Binary BSONObject where
get = liftM snd getObj
put = putObj
getVal :: DataType -> Get (Integer, BSValue)
getVal Data_number = getFloat64le >>= return . (,) 8 . BSDouble
getVal Data_string = do
sLen1 <- getI32
(sLen2, s) <- getS
return (fromIntegral $ 4 + sLen1, BSString s)
getVal Data_object = getObj >>= \(len, obj) -> return (len, BSObject obj)
getVal Data_array = do
(len, arr) <- getRawObj
2010-01-11 01:26:50 +00:00
let arr2 = Map.fold (:) [] arr -- reverse and remove key
return (len, BSArray arr2)
getVal Data_binary = do
skip 4
st <- getI8
len2 <- getI32
bs <- getLazyByteString $ fromIntegral len2
return (4 + 1 + 4 + fromIntegral len2, BSBinary (toBinarySubType st) bs)
getVal Data_undefined = return (1, BSUndefined)
getVal Data_oid = getLazyByteString 12 >>= return . (,) 12 . BSObjectId
getVal Data_boolean = getI8 >>= return . (,) 1 . BSBool . (/= 0)
getVal Data_date =
getI64 >>= return . (,) 8 . BSDate . flip (/) 1000 . realToFrac
getVal Data_null = return (1, BSNull)
getVal Data_int = getI32 >>= return . (,) 4 . BSInt32 . fromIntegral
getVal Data_long = getI64 >>= return . (,) 8 . BSInt64
getInnerObj 1 obj = obj
getInnerObj bytesLeft obj = do
typ <- getDataType
(keySz, key) <- getS
(valSz, val) <- getVal typ
getInnerObj (bytesLeft - 1 - fromIntegral keySz - fromIntegral valSz) $
2010-01-11 01:26:50 +00:00
liftM (Map.insert key val) obj
getRawObj = do
bytes <- getI32
2010-01-11 01:26:50 +00:00
obj <- getInnerObj (bytes - 4) $ return Map.empty
getNull
return (fromIntegral bytes, obj)
2010-01-11 01:26:50 +00:00
getObj = getRawObj >>= \(len, obj) -> return (len, BSONObject obj)
getDataType = liftM toDataType getI8
putType BSDouble{} = putDataType Data_number
putType BSString{} = putDataType Data_string
putType BSObject{} = putDataType Data_object
putType BSArray{} = putDataType Data_array
putType BSBinary{} = putDataType Data_binary
putType BSUndefined = putDataType Data_undefined
putType BSObjectId{} = putDataType Data_oid
putType BSBool{} = putDataType Data_boolean
putType BSDate{} = putDataType Data_date
putType BSNull = putDataType Data_null
putType BSRegex{} = putDataType Data_regex
-- putType = putDataType Data_ref
-- putType = putDataType Data_code
putType BSSymbol{} = putDataType Data_symbol
-- putType = putDataType Data_code_w_scope
putType (BSInt32 i) = putDataType Data_int
putType (BSInt64 i) = putDataType Data_long
-- putType = putDataType Data_timestamp
putType BSMinKey = putDataType Data_min_key
putType BSMaxKey = putDataType Data_max_key
putVal (BSDouble d) = putFloat64le d
putVal (BSString s) = putI32 (fromIntegral $ 1 + L8.length s) >> putS s
putVal (BSObject o) = putObj o
putVal (BSArray es) = putOutterObj bs
where bs = runPut $ forM_ (List.zip [0..] es) $ \(i, e) ->
putType e >> (putS $ L8.fromString $ show i) >> putVal e
putVal (BSBinary t bs)= do putI32 $ fromIntegral $ 4 + L.length bs
putI8 $ fromBinarySubType t
putI32 $ fromIntegral $ L.length bs
putLazyByteString bs
putVal BSUndefined = flush
putVal (BSObjectId o) = putLazyByteString o
putVal (BSBool False) = putI8 0
putVal (BSBool True) = putI8 1
putVal (BSDate pt) = putI64 $ round $ 1000 * realToFrac pt
putVal BSNull = flush
putVal (BSRegex r opt)= do putS r
putByteString $ pack $ List.sort opt
putNull
putVal (BSSymbol s) = putI32 (fromIntegral $ 1 + L8.length s) >> putS s
putVal (BSInt32 i) = putI32 i
putVal (BSInt64 i) = putI64 i
putVal BSMinKey = flush
putVal BSMaxKey = flush
putObj obj = putOutterObj bs
2010-01-11 01:26:50 +00:00
where bs = runPut $ forM_ (Map.toList (fromBSONObject obj)) $ \(k, v) ->
putType v >> putS k >> putVal v
putOutterObj bytes = do
-- the length prefix and null term are included in the length
putI32 $ fromIntegral $ 4 + 1 + L.length bytes
putLazyByteString bytes
putNull
putDataType = putI8 . fromDataType