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