From 7f777c8fb4e1585276fb2e0ef4204f0623a67cda Mon Sep 17 00:00:00 2001 From: "Scott R. Parish" Date: Sat, 16 Jan 2010 21:40:22 -0600 Subject: [PATCH] compile with -Wall and -Werror, fix all ensuing breaks --- Database/MongoDB.hs | 53 +++++++++++++++++++++++++++------------- Database/MongoDB/BSON.hs | 44 ++++++++++++++++++++++++--------- Database/MongoDB/Util.hs | 13 +++++++--- mongoDB.cabal | 1 + 4 files changed, 79 insertions(+), 32 deletions(-) diff --git a/Database/MongoDB.hs b/Database/MongoDB.hs index 7785f27..9ed038d 100644 --- a/Database/MongoDB.hs +++ b/Database/MongoDB.hs @@ -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) diff --git a/Database/MongoDB/BSON.hs b/Database/MongoDB/BSON.hs index 5f14247..62f8543 100644 --- a/Database/MongoDB/BSON.hs +++ b/Database/MongoDB/BSON.hs @@ -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 diff --git a/Database/MongoDB/Util.hs b/Database/MongoDB/Util.hs index bdd5825..a67c712 100644 --- a/Database/MongoDB/Util.hs +++ b/Database/MongoDB/Util.hs @@ -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 diff --git a/mongoDB.cabal b/mongoDB.cabal index e00a85d..bc1ebb4 100644 --- a/mongoDB.cabal +++ b/mongoDB.cabal @@ -14,3 +14,4 @@ Build-Type: Simple Exposed-modules: Database.MongoDB, Database.MongoDB.BSON Other-modules: Database.MongoDB.Util +ghc-options: -Wall -Werror