move the get/put* helpers to Util.hs so other modules can use them
This commit is contained in:
parent
06391f5992
commit
61051bfc46
3 changed files with 54 additions and 36 deletions
|
@ -17,10 +17,10 @@ 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.Char (chr, ord)
|
||||
import Data.Int
|
||||
import qualified Data.List as List
|
||||
import Data.Time.Clock.POSIX
|
||||
import Database.MongoDB.Util
|
||||
|
||||
data BSValue
|
||||
= BSDouble Double
|
||||
|
@ -103,7 +103,7 @@ instance Binary BSONObject where
|
|||
get = liftM snd getObj
|
||||
put = putObj
|
||||
|
||||
getVal :: DataType -> Get (Int, BSValue)
|
||||
getVal :: DataType -> Get (Integer, BSValue)
|
||||
getVal Data_number = getFloat64le >>= return . (,) 8 . BSDouble
|
||||
getVal Data_string = do
|
||||
sLen1 <- getI32
|
||||
|
@ -119,7 +119,7 @@ getVal Data_binary = do
|
|||
st <- getI8
|
||||
len2 <- getI32
|
||||
bs <- getLazyByteString $ fromIntegral len2
|
||||
return (4 + 1 + 4 + len2, BSBinary (toBinarySubType st) bs)
|
||||
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)
|
||||
|
@ -134,28 +134,19 @@ getInnerObj bytesLeft obj = do
|
|||
typ <- getDataType
|
||||
(keySz, key) <- getS
|
||||
(valSz, val) <- getVal typ
|
||||
getInnerObj (bytesLeft - 1 - keySz - valSz) $ liftM ((key, val) :) obj
|
||||
getInnerObj (bytesLeft - 1 - fromIntegral keySz - fromIntegral valSz) $
|
||||
liftM ((key, val) :) obj
|
||||
|
||||
getRawObj = do
|
||||
bytes <- getI32
|
||||
obj <- getInnerObj (bytes - 4) $ return []
|
||||
getNull
|
||||
return (bytes, obj)
|
||||
return (fromIntegral bytes, obj)
|
||||
|
||||
getObj = getRawObj >>= \(len, obj) -> return (len, toBSONObject obj)
|
||||
|
||||
getS :: Get (Int, L8.ByteString)
|
||||
getS = getLazyByteStringNul >>= \s -> return (fromIntegral $ L.length s + 1, s)
|
||||
|
||||
getNull = do {'\0' <- getC; return ()}
|
||||
|
||||
getC = liftM chr getI8
|
||||
getI8 = liftM fromIntegral getWord8
|
||||
getI32 = liftM fromIntegral getWord32le
|
||||
getI64 = liftM fromIntegral getWord64le
|
||||
getDataType = liftM toDataType getI8
|
||||
|
||||
|
||||
putType BSDouble{} = putDataType Data_number
|
||||
putType BSString{} = putDataType Data_string
|
||||
putType BSObject{} = putDataType Data_object
|
||||
|
@ -179,14 +170,14 @@ putType BSMaxKey = putDataType Data_max_key
|
|||
|
||||
|
||||
putVal (BSDouble d) = putFloat64le d
|
||||
putVal (BSString s) = putI32 (1 + L8.length s) >> putS s
|
||||
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 $ 4 + L.length bs
|
||||
putVal (BSBinary t bs)= do putI32 $ fromIntegral $ 4 + L.length bs
|
||||
putI8 $ fromBinarySubType t
|
||||
putI32 $ L.length bs
|
||||
putI32 $ fromIntegral $ L.length bs
|
||||
putLazyByteString bs
|
||||
putVal BSUndefined = flush
|
||||
putVal (BSObjectId o) = putLazyByteString o
|
||||
|
@ -197,7 +188,7 @@ putVal BSNull = flush
|
|||
putVal (BSRegex r opt)= do putS r
|
||||
putByteString $ pack $ List.sort opt
|
||||
putNull
|
||||
putVal (BSSymbol s) = putI32 (1 + L8.length s) >> putS s
|
||||
putVal (BSSymbol s) = putI32 (fromIntegral $ 1 + L8.length s) >> putS s
|
||||
putVal (BSInt32 i) = putI32 i
|
||||
putVal (BSInt64 i) = putI64 i
|
||||
putVal BSMinKey = flush
|
||||
|
@ -209,24 +200,8 @@ putObj obj = putOutterObj bs
|
|||
|
||||
putOutterObj bytes = do
|
||||
-- the length prefix and null term are included in the length
|
||||
putI32 $ 4 + 1 + L.length bytes
|
||||
putI32 $ fromIntegral $ 4 + 1 + L.length bytes
|
||||
putLazyByteString bytes
|
||||
putNull
|
||||
|
||||
putNull = putI8 0
|
||||
putI8 :: (Integral i) => i -> Put
|
||||
putI8 = putWord8 . fromIntegral
|
||||
|
||||
putI32 :: (Integral i) => i -> Put
|
||||
putI32 = putWord32le . fromIntegral
|
||||
|
||||
putI64 :: (Integral i) => i -> Put
|
||||
putI64 = putWord64le . fromIntegral
|
||||
|
||||
putS :: L8.ByteString -> Put
|
||||
putS s = putLazyByteString s >> putNull
|
||||
|
||||
putDataType = putI8 . fromDataType
|
||||
|
||||
int32_min = -2147483648
|
||||
int32_max = -int32_min - 1
|
||||
|
|
42
Database/MongoDB/Util.hs
Normal file
42
Database/MongoDB/Util.hs
Normal file
|
@ -0,0 +1,42 @@
|
|||
module Database.MongoDB.Util
|
||||
(
|
||||
putI8, putI32, putI64, putNull, putS,
|
||||
getI8, getI32, getI64, getC, getS, getNull,
|
||||
)
|
||||
where
|
||||
import Control.Monad
|
||||
import Data.Binary
|
||||
import Data.Binary.Get
|
||||
import Data.Binary.Put
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.Lazy.UTF8 as L8
|
||||
import Data.Char (chr, ord)
|
||||
import Data.Int
|
||||
|
||||
getC = liftM chr getI8
|
||||
getI8 = liftM fromIntegral getWord8
|
||||
|
||||
getI32 :: Get Int32
|
||||
getI32 = liftM fromIntegral getWord32le
|
||||
|
||||
getI64 :: Get Int64
|
||||
getI64 = liftM fromIntegral getWord64le
|
||||
|
||||
getS :: Get (Integer, L8.ByteString)
|
||||
getS = getLazyByteStringNul >>= \s -> return (fromIntegral $ L.length s + 1, s)
|
||||
|
||||
getNull = do {'\0' <- getC; return ()}
|
||||
|
||||
putI8 :: (Integral i) => i -> Put
|
||||
putI8 = putWord8 . fromIntegral
|
||||
|
||||
putI32 :: Int32 -> Put
|
||||
putI32 = putWord32le . fromIntegral
|
||||
|
||||
putI64 :: Int64 -> Put
|
||||
putI64 = putWord64le . fromIntegral
|
||||
|
||||
putNull = putI8 0
|
||||
|
||||
putS :: L8.ByteString -> Put
|
||||
putS s = putLazyByteString s >> putNull
|
|
@ -9,3 +9,4 @@ Build-Depends: base,
|
|||
utf8-string
|
||||
Build-Type: Simple
|
||||
Exposed-modules: Database.MongoDB.BSON
|
||||
Other-modules: Database.MongoDB.Util
|
Loading…
Reference in a new issue