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

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,
+      rCursorID :: Int64
-      rStartFrom :: Int32,
+      -- rStartFrom :: Int32,
-      rNumReturned :: 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
+               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.
@@ -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)

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 BSInt32 {}   = putDataType Data_int
-putType (BSInt64 i)  = putDataType Data_long
+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 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 (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

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

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