move the get/put* helpers to Util.hs so other modules can use them

This commit is contained in:
Scott R. Parish 2010-01-09 20:45:45 -06:00
parent 06391f5992
commit 61051bfc46
3 changed files with 54 additions and 36 deletions

View file

@ -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
View 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

View file

@ -9,3 +9,4 @@ Build-Depends: base,
utf8-string
Build-Type: Simple
Exposed-modules: Database.MongoDB.BSON
Other-modules: Database.MongoDB.Util