compile with -Wall and -Werror, fix all ensuing breaks
This commit is contained in:
parent
a5ab7cdb64
commit
7f777c8fb4
4 changed files with 79 additions and 32 deletions
|
@ -35,7 +35,7 @@ module Database.MongoDB
|
||||||
UpdateFlag(..),
|
UpdateFlag(..),
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
import Control.Exception (assert)
|
import Control.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Binary
|
import Data.Binary
|
||||||
import Data.Binary.Get
|
import Data.Binary.Get
|
||||||
|
@ -43,10 +43,10 @@ import Data.Binary.Put
|
||||||
import Data.Bits
|
import Data.Bits
|
||||||
import Data.ByteString.Char8 hiding (find)
|
import Data.ByteString.Char8 hiding (find)
|
||||||
import qualified Data.ByteString.Lazy as L
|
import qualified Data.ByteString.Lazy as L
|
||||||
import qualified Data.ByteString.Lazy.UTF8 as L8
|
|
||||||
import Data.Int
|
import Data.Int
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
import qualified Data.List as List
|
import qualified Data.List as List
|
||||||
|
import Data.Typeable
|
||||||
import Database.MongoDB.BSON
|
import Database.MongoDB.BSON
|
||||||
import Database.MongoDB.Util
|
import Database.MongoDB.Util
|
||||||
import qualified Network
|
import qualified Network
|
||||||
|
@ -95,6 +95,18 @@ data Opcode
|
||||||
| OP_KILL_CURSORS -- 2007 Tell database client is done with a cursor
|
| OP_KILL_CURSORS -- 2007 Tell database client is done with a cursor
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
data MongoDBInternalError = MongoDBInternalError String
|
||||||
|
deriving (Eq, Show, Read)
|
||||||
|
|
||||||
|
mongoDBInternalError :: TyCon
|
||||||
|
mongoDBInternalError = mkTyCon "Database.MongoDB.MongoDBInternalError"
|
||||||
|
|
||||||
|
instance Typeable MongoDBInternalError where
|
||||||
|
typeOf _ = mkTyConApp mongoDBInternalError []
|
||||||
|
|
||||||
|
instance Exception MongoDBInternalError
|
||||||
|
|
||||||
|
fromOpcode :: Opcode -> Int32
|
||||||
fromOpcode OP_REPLY = 1
|
fromOpcode OP_REPLY = 1
|
||||||
fromOpcode OP_MSG = 1000
|
fromOpcode OP_MSG = 1000
|
||||||
fromOpcode OP_UPDATE = 2001
|
fromOpcode OP_UPDATE = 2001
|
||||||
|
@ -105,6 +117,7 @@ fromOpcode OP_GET_MORE = 2005
|
||||||
fromOpcode OP_DELETE = 2006
|
fromOpcode OP_DELETE = 2006
|
||||||
fromOpcode OP_KILL_CURSORS = 2007
|
fromOpcode OP_KILL_CURSORS = 2007
|
||||||
|
|
||||||
|
toOpcode :: Int32 -> Opcode
|
||||||
toOpcode 1 = OP_REPLY
|
toOpcode 1 = OP_REPLY
|
||||||
toOpcode 1000 = OP_MSG
|
toOpcode 1000 = OP_MSG
|
||||||
toOpcode 2001 = OP_UPDATE
|
toOpcode 2001 = OP_UPDATE
|
||||||
|
@ -114,6 +127,7 @@ toOpcode 2004 = OP_QUERY
|
||||||
toOpcode 2005 = OP_GET_MORE
|
toOpcode 2005 = OP_GET_MORE
|
||||||
toOpcode 2006 = OP_DELETE
|
toOpcode 2006 = OP_DELETE
|
||||||
toOpcode 2007 = OP_KILL_CURSORS
|
toOpcode 2007 = OP_KILL_CURSORS
|
||||||
|
toOpcode n = throw $ MongoDBInternalError $ "Got unexpected Opcode: " ++ show n
|
||||||
|
|
||||||
type Collection = String
|
type Collection = String
|
||||||
type Selector = BSONObject
|
type Selector = BSONObject
|
||||||
|
@ -128,6 +142,7 @@ data QueryOpt = QO_TailableCursor
|
||||||
| QO_NoCursorTimeout
|
| QO_NoCursorTimeout
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
|
fromQueryOpts :: [QueryOpt] -> Int32
|
||||||
fromQueryOpts opts = List.foldl (.|.) 0 $ fmap toVal opts
|
fromQueryOpts opts = List.foldl (.|.) 0 $ fmap toVal opts
|
||||||
where toVal QO_TailableCursor = 2
|
where toVal QO_TailableCursor = 2
|
||||||
toVal QO_SlaveOK = 4
|
toVal QO_SlaveOK = 4
|
||||||
|
@ -138,6 +153,7 @@ data UpdateFlag = UF_Upsert
|
||||||
| UF_Multiupdate
|
| UF_Multiupdate
|
||||||
deriving (Show, Enum)
|
deriving (Show, Enum)
|
||||||
|
|
||||||
|
fromUpdateFlags :: [UpdateFlag] -> Int32
|
||||||
fromUpdateFlags flags = List.foldl (.|.) 0 $
|
fromUpdateFlags flags = List.foldl (.|.) 0 $
|
||||||
flip fmap flags $ (1 `shiftL`) . fromEnum
|
flip fmap flags $ (1 `shiftL`) . fromEnum
|
||||||
|
|
||||||
|
@ -152,6 +168,7 @@ delete c col sel = do
|
||||||
L.hPut (cHandle c) msg
|
L.hPut (cHandle c) msg
|
||||||
return reqID
|
return reqID
|
||||||
|
|
||||||
|
remove :: Connection -> Collection -> Selector -> IO RequestID
|
||||||
remove = delete
|
remove = delete
|
||||||
|
|
||||||
insert :: Connection -> Collection -> BSONObject -> IO RequestID
|
insert :: Connection -> Collection -> BSONObject -> IO RequestID
|
||||||
|
@ -190,18 +207,18 @@ quickFind' c col sel = find c col sel >>= allDocs'
|
||||||
|
|
||||||
query :: Connection -> Collection -> [QueryOpt] -> NumToSkip -> NumToReturn ->
|
query :: Connection -> Collection -> [QueryOpt] -> NumToSkip -> NumToReturn ->
|
||||||
Selector -> Maybe FieldSelector -> IO Cursor
|
Selector -> Maybe FieldSelector -> IO Cursor
|
||||||
query c col opts skip ret sel fsel = do
|
query c col opts nskip ret sel fsel = do
|
||||||
let h = cHandle c
|
let h = cHandle c
|
||||||
|
|
||||||
let body = runPut $ do
|
let body = runPut $ do
|
||||||
putI32 $ fromQueryOpts opts
|
putI32 $ fromQueryOpts opts
|
||||||
putCol col
|
putCol col
|
||||||
putI32 skip
|
putI32 nskip
|
||||||
putI32 ret
|
putI32 ret
|
||||||
put sel
|
put sel
|
||||||
case fsel of
|
case fsel of
|
||||||
Nothing -> putNothing
|
Nothing -> putNothing
|
||||||
Just fsel -> put fsel
|
Just _ -> put fsel
|
||||||
(reqID, msg) <- packMsg c OP_QUERY body
|
(reqID, msg) <- packMsg c OP_QUERY body
|
||||||
L.hPut h msg
|
L.hPut h msg
|
||||||
|
|
||||||
|
@ -238,35 +255,37 @@ update c col flags sel obj = do
|
||||||
|
|
||||||
data Hdr = Hdr {
|
data Hdr = Hdr {
|
||||||
hMsgLen :: Int32,
|
hMsgLen :: Int32,
|
||||||
hReqID :: Int32,
|
-- hReqID :: Int32,
|
||||||
hRespTo :: Int32,
|
hRespTo :: Int32,
|
||||||
hOp :: Opcode
|
hOp :: Opcode
|
||||||
} deriving (Show)
|
} deriving (Show)
|
||||||
|
|
||||||
data Reply = Reply {
|
data Reply = Reply {
|
||||||
rRespFlags :: Int32,
|
rRespFlags :: Int32,
|
||||||
rCursorID :: Int64,
|
rCursorID :: Int64
|
||||||
rStartFrom :: Int32,
|
-- rStartFrom :: Int32,
|
||||||
rNumReturned :: Int32
|
-- rNumReturned :: Int32
|
||||||
} deriving (Show)
|
} deriving (Show)
|
||||||
|
|
||||||
|
getHeader :: Handle -> IO Hdr
|
||||||
getHeader h = do
|
getHeader h = do
|
||||||
hdrBytes <- L.hGet h 16
|
hdrBytes <- L.hGet h 16
|
||||||
return $ flip runGet hdrBytes $ do
|
return $ flip runGet hdrBytes $ do
|
||||||
msgLen <- getI32
|
msgLen <- getI32
|
||||||
reqID <- getI32
|
skip 4 -- reqID <- getI32
|
||||||
respTo <- getI32
|
respTo <- getI32
|
||||||
op <- getI32
|
op <- getI32
|
||||||
return $ Hdr msgLen reqID respTo $ toOpcode op
|
return $ Hdr msgLen respTo $ toOpcode op
|
||||||
|
|
||||||
|
getReply :: Handle -> IO Reply
|
||||||
getReply h = do
|
getReply h = do
|
||||||
replyBytes <- L.hGet h 20
|
replyBytes <- L.hGet h 20
|
||||||
return $ flip runGet replyBytes $ do
|
return $ flip runGet replyBytes $ do
|
||||||
respFlags <- getI32
|
respFlags <- getI32
|
||||||
cursorID <- getI64
|
cursorID <- getI64
|
||||||
startFrom <- getI32
|
skip 4 -- startFrom <- getI32
|
||||||
numReturned <- getI32
|
skip 4 -- numReturned <- getI32
|
||||||
return $ (Reply respFlags cursorID startFrom numReturned)
|
return $ (Reply respFlags cursorID)
|
||||||
|
|
||||||
|
|
||||||
{- | Return one document or Nothing if there are no more.
|
{- | Return one document or Nothing if there are no more.
|
||||||
|
@ -317,6 +336,7 @@ allDocs' cur = do
|
||||||
Nothing -> return []
|
Nothing -> return []
|
||||||
Just d -> allDocs' cur >>= return . (d :)
|
Just d -> allDocs' cur >>= return . (d :)
|
||||||
|
|
||||||
|
getFirstDoc :: L.ByteString -> (BSONObject, L.ByteString)
|
||||||
getFirstDoc docBytes = flip runGet docBytes $ do
|
getFirstDoc docBytes = flip runGet docBytes $ do
|
||||||
doc <- get
|
doc <- get
|
||||||
docBytes' <- getRemainingLazyByteString
|
docBytes' <- getRemainingLazyByteString
|
||||||
|
@ -340,7 +360,6 @@ getMore cur = do
|
||||||
assert (hRespTo hdr == reqID) $ return ()
|
assert (hRespTo hdr == reqID) $ return ()
|
||||||
reply <- getReply h
|
reply <- getReply h
|
||||||
assert (rRespFlags reply == 0) $ return ()
|
assert (rRespFlags reply == 0) $ return ()
|
||||||
cid <- readIORef (curID cur)
|
|
||||||
case rCursorID reply of
|
case rCursorID reply of
|
||||||
0 -> writeIORef (curID cur) 0
|
0 -> writeIORef (curID cur) 0
|
||||||
ncid -> assert (ncid == cid) $ return ()
|
ncid -> assert (ncid == cid) $ return ()
|
||||||
|
@ -352,7 +371,6 @@ getMore cur = do
|
||||||
writeIORef (curDocBytes cur) docBytes'
|
writeIORef (curDocBytes cur) docBytes'
|
||||||
return $ Just doc
|
return $ Just doc
|
||||||
|
|
||||||
|
|
||||||
{- Manually close a cursor -- usually not needed. -}
|
{- Manually close a cursor -- usually not needed. -}
|
||||||
finish :: Cursor -> IO ()
|
finish :: Cursor -> IO ()
|
||||||
finish cur = do
|
finish cur = do
|
||||||
|
@ -362,11 +380,12 @@ finish cur = do
|
||||||
putI32 0
|
putI32 0
|
||||||
putI32 1
|
putI32 1
|
||||||
putI64 cid
|
putI64 cid
|
||||||
(reqID, msg) <- packMsg (curCon cur) OP_KILL_CURSORS body
|
(_reqID, msg) <- packMsg (curCon cur) OP_KILL_CURSORS body
|
||||||
L.hPut h msg
|
L.hPut h msg
|
||||||
writeIORef (curClosed cur) True
|
writeIORef (curClosed cur) True
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
|
putCol :: Collection -> Put
|
||||||
putCol col = putByteString (pack col) >> putNull
|
putCol col = putByteString (pack col) >> putNull
|
||||||
|
|
||||||
packMsg :: Connection -> Opcode -> L.ByteString -> IO (RequestID, L.ByteString)
|
packMsg :: Connection -> Opcode -> L.ByteString -> IO (RequestID, L.ByteString)
|
||||||
|
|
|
@ -36,10 +36,8 @@ import Data.Binary
|
||||||
import Data.Binary.Get
|
import Data.Binary.Get
|
||||||
import Data.Binary.IEEE754
|
import Data.Binary.IEEE754
|
||||||
import Data.Binary.Put
|
import Data.Binary.Put
|
||||||
import Data.Bits
|
|
||||||
import Data.ByteString.Char8
|
import Data.ByteString.Char8
|
||||||
import qualified Data.ByteString.Lazy as L
|
import qualified Data.ByteString.Lazy as L
|
||||||
import qualified Data.ByteString.Lazy.Char8 as LC
|
|
||||||
import qualified Data.ByteString.Lazy.UTF8 as L8
|
import qualified Data.ByteString.Lazy.UTF8 as L8
|
||||||
import Data.Int
|
import Data.Int
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
@ -134,7 +132,7 @@ getVal :: DataType -> Get (Integer, BSValue)
|
||||||
getVal Data_number = getFloat64le >>= return . (,) 8 . BSDouble
|
getVal Data_number = getFloat64le >>= return . (,) 8 . BSDouble
|
||||||
getVal Data_string = do
|
getVal Data_string = do
|
||||||
sLen1 <- getI32
|
sLen1 <- getI32
|
||||||
(sLen2, s) <- getS
|
(_sLen2, s) <- getS
|
||||||
return (fromIntegral $ 4 + sLen1, BSString s)
|
return (fromIntegral $ 4 + sLen1, BSString s)
|
||||||
getVal Data_object = getObj >>= \(len, obj) -> return (len, BSObject obj)
|
getVal Data_object = getObj >>= \(len, obj) -> return (len, BSObject obj)
|
||||||
getVal Data_array = do
|
getVal Data_array = do
|
||||||
|
@ -149,13 +147,28 @@ getVal Data_binary = do
|
||||||
return (4 + 1 + 4 + fromIntegral len2, BSBinary (toBinarySubType st) bs)
|
return (4 + 1 + 4 + fromIntegral len2, BSBinary (toBinarySubType st) bs)
|
||||||
getVal Data_undefined = return (1, BSUndefined)
|
getVal Data_undefined = return (1, BSUndefined)
|
||||||
getVal Data_oid = getLazyByteString 12 >>= return . (,) 12 . BSObjectId
|
getVal Data_oid = getLazyByteString 12 >>= return . (,) 12 . BSObjectId
|
||||||
getVal Data_boolean = getI8 >>= return . (,) 1 . BSBool . (/= 0)
|
getVal Data_boolean =
|
||||||
|
getI8 >>= return . (,) (1::Integer) . BSBool . (/= (0::Int))
|
||||||
getVal Data_date =
|
getVal Data_date =
|
||||||
getI64 >>= return . (,) 8 . BSDate . flip (/) 1000 . realToFrac
|
getI64 >>= return . (,) 8 . BSDate . flip (/) 1000 . realToFrac
|
||||||
getVal Data_null = return (1, BSNull)
|
getVal Data_null = return (1, BSNull)
|
||||||
|
getVal Data_regex = fail "Data_code not yet supported" -- TODO
|
||||||
|
getVal Data_ref = fail "Data_ref is deprecated"
|
||||||
|
getVal Data_code = fail "Data_code not yet supported" -- TODO
|
||||||
|
getVal Data_symbol = do
|
||||||
|
sLen1 <- getI32
|
||||||
|
(_sLen2, s) <- getS
|
||||||
|
return (fromIntegral $ 4 + sLen1, BSString s)
|
||||||
|
getVal Data_code_w_scope = fail "Data_code_w_scope not yet supported" -- TODO
|
||||||
getVal Data_int = getI32 >>= return . (,) 4 . BSInt32 . fromIntegral
|
getVal Data_int = getI32 >>= return . (,) 4 . BSInt32 . fromIntegral
|
||||||
getVal Data_long = getI64 >>= return . (,) 8 . BSInt64
|
getVal Data_timestamp = fail "Data_timestamp not yet supported" -- TODO
|
||||||
|
|
||||||
|
getVal Data_long = getI64 >>= return . (,) 8 . BSInt64
|
||||||
|
getVal Data_min_key = return (0, BSMinKey)
|
||||||
|
getVal Data_max_key = return (0, BSMaxKey)
|
||||||
|
|
||||||
|
getInnerObj :: Int32 -> Get (Map.Map L8.ByteString BSValue)
|
||||||
|
-> Get (Map.Map L8.ByteString BSValue)
|
||||||
getInnerObj 1 obj = obj
|
getInnerObj 1 obj = obj
|
||||||
getInnerObj bytesLeft obj = do
|
getInnerObj bytesLeft obj = do
|
||||||
typ <- getDataType
|
typ <- getDataType
|
||||||
|
@ -164,16 +177,20 @@ getInnerObj bytesLeft obj = do
|
||||||
getInnerObj (bytesLeft - 1 - fromIntegral keySz - fromIntegral valSz) $
|
getInnerObj (bytesLeft - 1 - fromIntegral keySz - fromIntegral valSz) $
|
||||||
liftM (Map.insert key val) obj
|
liftM (Map.insert key val) obj
|
||||||
|
|
||||||
|
getRawObj :: Get (Integer, Map.Map L8.ByteString BSValue)
|
||||||
getRawObj = do
|
getRawObj = do
|
||||||
bytes <- getI32
|
bytes <- getI32
|
||||||
obj <- getInnerObj (bytes - 4) $ return Map.empty
|
obj <- getInnerObj (bytes - 4) $ return Map.empty
|
||||||
getNull
|
getNull
|
||||||
return (fromIntegral bytes, obj)
|
return (fromIntegral bytes, obj)
|
||||||
|
|
||||||
|
getObj :: Get (Integer, BSONObject)
|
||||||
getObj = getRawObj >>= \(len, obj) -> return (len, BSONObject obj)
|
getObj = getRawObj >>= \(len, obj) -> return (len, BSONObject obj)
|
||||||
|
|
||||||
|
getDataType :: Get DataType
|
||||||
getDataType = liftM toDataType getI8
|
getDataType = liftM toDataType getI8
|
||||||
|
|
||||||
|
putType :: BSValue -> Put
|
||||||
putType BSDouble{} = putDataType Data_number
|
putType BSDouble{} = putDataType Data_number
|
||||||
putType BSString{} = putDataType Data_string
|
putType BSString{} = putDataType Data_string
|
||||||
putType BSObject{} = putDataType Data_object
|
putType BSObject{} = putDataType Data_object
|
||||||
|
@ -189,18 +206,18 @@ putType BSRegex{} = putDataType Data_regex
|
||||||
-- putType = putDataType Data_code
|
-- putType = putDataType Data_code
|
||||||
putType BSSymbol{} = putDataType Data_symbol
|
putType BSSymbol{} = putDataType Data_symbol
|
||||||
-- putType = putDataType Data_code_w_scope
|
-- putType = putDataType Data_code_w_scope
|
||||||
putType (BSInt32 i) = putDataType Data_int
|
putType BSInt32 {} = putDataType Data_int
|
||||||
putType (BSInt64 i) = putDataType Data_long
|
putType BSInt64 {} = putDataType Data_long
|
||||||
-- putType = putDataType Data_timestamp
|
-- putType = putDataType Data_timestamp
|
||||||
putType BSMinKey = putDataType Data_min_key
|
putType BSMinKey = putDataType Data_min_key
|
||||||
putType BSMaxKey = putDataType Data_max_key
|
putType BSMaxKey = putDataType Data_max_key
|
||||||
|
|
||||||
|
putVal :: BSValue -> Put
|
||||||
putVal (BSDouble d) = putFloat64le d
|
putVal (BSDouble d) = putFloat64le d
|
||||||
putVal (BSString s) = putI32 (fromIntegral $ 1 + L8.length s) >> putS s
|
putVal (BSString s) = putI32 (fromIntegral $ 1 + L8.length s) >> putS s
|
||||||
putVal (BSObject o) = putObj o
|
putVal (BSObject o) = putObj o
|
||||||
putVal (BSArray es) = putOutterObj bs
|
putVal (BSArray es) = putOutterObj bs
|
||||||
where bs = runPut $ forM_ (List.zip [0..] es) $ \(i, e) ->
|
where bs = runPut $ forM_ (List.zip [(0::Int) .. ] es) $ \(i, e) ->
|
||||||
putType e >> (putS $ L8.fromString $ show i) >> putVal e
|
putType e >> (putS $ L8.fromString $ show i) >> putVal e
|
||||||
putVal (BSBinary t bs)= do putI32 $ fromIntegral $ 4 + L.length bs
|
putVal (BSBinary t bs)= do putI32 $ fromIntegral $ 4 + L.length bs
|
||||||
putI8 $ fromBinarySubType t
|
putI8 $ fromBinarySubType t
|
||||||
|
@ -208,9 +225,9 @@ putVal (BSBinary t bs)= do putI32 $ fromIntegral $ 4 + L.length bs
|
||||||
putLazyByteString bs
|
putLazyByteString bs
|
||||||
putVal BSUndefined = putNothing
|
putVal BSUndefined = putNothing
|
||||||
putVal (BSObjectId o) = putLazyByteString o
|
putVal (BSObjectId o) = putLazyByteString o
|
||||||
putVal (BSBool False) = putI8 0
|
putVal (BSBool False) = putI8 (0::Int)
|
||||||
putVal (BSBool True) = putI8 1
|
putVal (BSBool True) = putI8 (1::Int)
|
||||||
putVal (BSDate pt) = putI64 $ round $ 1000 * realToFrac pt
|
putVal (BSDate pt) = putI64 $ round $ 1000 * (realToFrac pt :: Double)
|
||||||
putVal BSNull = putNothing
|
putVal BSNull = putNothing
|
||||||
putVal (BSRegex r opt)= do putS r
|
putVal (BSRegex r opt)= do putS r
|
||||||
putByteString $ pack $ List.sort opt
|
putByteString $ pack $ List.sort opt
|
||||||
|
@ -221,14 +238,17 @@ putVal (BSInt64 i) = putI64 i
|
||||||
putVal BSMinKey = putNothing
|
putVal BSMinKey = putNothing
|
||||||
putVal BSMaxKey = putNothing
|
putVal BSMaxKey = putNothing
|
||||||
|
|
||||||
|
putObj :: BSONObject -> Put
|
||||||
putObj obj = putOutterObj bs
|
putObj obj = putOutterObj bs
|
||||||
where bs = runPut $ forM_ (Map.toList (fromBSONObject obj)) $ \(k, v) ->
|
where bs = runPut $ forM_ (Map.toList (fromBSONObject obj)) $ \(k, v) ->
|
||||||
putType v >> putS k >> putVal v
|
putType v >> putS k >> putVal v
|
||||||
|
|
||||||
|
putOutterObj :: L.ByteString -> Put
|
||||||
putOutterObj bytes = do
|
putOutterObj bytes = do
|
||||||
-- the length prefix and null term are included in the length
|
-- the length prefix and null term are included in the length
|
||||||
putI32 $ fromIntegral $ 4 + 1 + L.length bytes
|
putI32 $ fromIntegral $ 4 + 1 + L.length bytes
|
||||||
putLazyByteString bytes
|
putLazyByteString bytes
|
||||||
putNull
|
putNull
|
||||||
|
|
||||||
|
putDataType :: DataType -> Put
|
||||||
putDataType = putI8 . fromDataType
|
putDataType = putI8 . fromDataType
|
||||||
|
|
|
@ -29,6 +29,7 @@ module Database.MongoDB.Util
|
||||||
getI8, getI32, getI64, getC, getS, getNull,
|
getI8, getI32, getI64, getC, getS, getNull,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
import Control.Exception (assert)
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Binary
|
import Data.Binary
|
||||||
import Data.Binary.Get
|
import Data.Binary.Get
|
||||||
|
@ -36,10 +37,13 @@ import Data.Binary.Put
|
||||||
import Data.ByteString.Char8
|
import Data.ByteString.Char8
|
||||||
import qualified Data.ByteString.Lazy as L
|
import qualified Data.ByteString.Lazy as L
|
||||||
import qualified Data.ByteString.Lazy.UTF8 as L8
|
import qualified Data.ByteString.Lazy.UTF8 as L8
|
||||||
import Data.Char (chr, ord)
|
import Data.Char (chr)
|
||||||
import Data.Int
|
import Data.Int
|
||||||
|
|
||||||
|
getC :: Get Char
|
||||||
getC = liftM chr getI8
|
getC = liftM chr getI8
|
||||||
|
|
||||||
|
getI8 :: (Integral a) => Get a
|
||||||
getI8 = liftM fromIntegral getWord8
|
getI8 = liftM fromIntegral getWord8
|
||||||
|
|
||||||
getI32 :: Get Int32
|
getI32 :: Get Int32
|
||||||
|
@ -51,7 +55,8 @@ getI64 = liftM fromIntegral getWord64le
|
||||||
getS :: Get (Integer, L8.ByteString)
|
getS :: Get (Integer, L8.ByteString)
|
||||||
getS = getLazyByteStringNul >>= \s -> return (fromIntegral $ L.length s + 1, s)
|
getS = getLazyByteStringNul >>= \s -> return (fromIntegral $ L.length s + 1, s)
|
||||||
|
|
||||||
getNull = do {'\0' <- getC; return ()}
|
getNull :: Get ()
|
||||||
|
getNull = do {c <- getC; assert (c == '\0') $ return ()}
|
||||||
|
|
||||||
putI8 :: (Integral i) => i -> Put
|
putI8 :: (Integral i) => i -> Put
|
||||||
putI8 = putWord8 . fromIntegral
|
putI8 = putWord8 . fromIntegral
|
||||||
|
@ -62,9 +67,11 @@ putI32 = putWord32le . fromIntegral
|
||||||
putI64 :: Int64 -> Put
|
putI64 :: Int64 -> Put
|
||||||
putI64 = putWord64le . fromIntegral
|
putI64 = putWord64le . fromIntegral
|
||||||
|
|
||||||
|
putNothing :: Put
|
||||||
putNothing = putByteString $ pack ""
|
putNothing = putByteString $ pack ""
|
||||||
|
|
||||||
putNull = putI8 0
|
putNull :: Put
|
||||||
|
putNull = putI8 (0::Int)
|
||||||
|
|
||||||
putS :: L8.ByteString -> Put
|
putS :: L8.ByteString -> Put
|
||||||
putS s = putLazyByteString s >> putNull
|
putS s = putLazyByteString s >> putNull
|
||||||
|
|
|
@ -14,3 +14,4 @@ Build-Type: Simple
|
||||||
Exposed-modules: Database.MongoDB,
|
Exposed-modules: Database.MongoDB,
|
||||||
Database.MongoDB.BSON
|
Database.MongoDB.BSON
|
||||||
Other-modules: Database.MongoDB.Util
|
Other-modules: Database.MongoDB.Util
|
||||||
|
ghc-options: -Wall -Werror
|
||||||
|
|
Loading…
Reference in a new issue