diff --git a/Database/MongoDB/BSON.hs b/Database/MongoDB/BSON.hs index 8fbc1b4..73e9396 100644 --- a/Database/MongoDB/BSON.hs +++ b/Database/MongoDB/BSON.hs @@ -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 diff --git a/Database/MongoDB/Util.hs b/Database/MongoDB/Util.hs new file mode 100644 index 0000000..e9b64df --- /dev/null +++ b/Database/MongoDB/Util.hs @@ -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 diff --git a/mongoDB.cabal b/mongoDB.cabal index 0c087f2..e05fecb 100644 --- a/mongoDB.cabal +++ b/mongoDB.cabal @@ -9,3 +9,4 @@ Build-Depends: base, utf8-string Build-Type: Simple Exposed-modules: Database.MongoDB.BSON +Other-modules: Database.MongoDB.Util \ No newline at end of file