compile with -Wall and -Werror, fix all ensuing breaks

This commit is contained in:
Scott R. Parish 2010-01-16 21:40:22 -06:00
parent a5ab7cdb64
commit 7f777c8fb4
4 changed files with 79 additions and 32 deletions

View file

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

View file

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

View file

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

View file

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