diff --git a/Database/MongoDB.hs b/Database/MongoDB.hs index 4b5b89f..b69d24b 100644 --- a/Database/MongoDB.hs +++ b/Database/MongoDB.hs @@ -92,7 +92,7 @@ connectOnPort host port = do let ns = randomRs (fromIntegral (minBound :: Int32), fromIntegral (maxBound :: Int32)) r nsRef <- newIORef ns - return $ Connection { cHandle = h, cRand = nsRef } + return Connection { cHandle = h, cRand = nsRef } -- | Close database connection conClose :: Connection -> IO () @@ -100,7 +100,7 @@ conClose = hClose . cHandle -- | Information about the databases on the server. databasesInfo :: Connection -> IO BsonDoc -databasesInfo c = do +databasesInfo c = runCommand c (s2L "admin") $ toBsonDoc [("listDatabases", toBson (1::Int))] -- | Return a list of database names on the server. @@ -108,7 +108,7 @@ databaseNames :: Connection -> IO [Database] databaseNames c = do info <- databasesInfo c let (BsonArray dbs) = fromJust $ Map.lookup (s2L "databases") info - names = catMaybes $ List.map (Map.lookup (s2L "name") . fromBson) dbs + names = mapMaybe (Map.lookup (s2L "name") . fromBson) dbs return $ List.map fromBson (names::[BsonValue]) -- | Alias for 'conClose' @@ -123,15 +123,14 @@ dropDatabase c db = do -- | Get information about the MongoDB server we're connected to. serverInfo :: Connection -> IO BsonDoc -serverInfo c = do +serverInfo c = runCommand c (s2L "admin") $ toBsonDoc [("buildinfo", toBson (1::Int))] -- | Return a list of collections in /Database/. collectionNames :: Connection -> Database -> IO [FullCollection] collectionNames c db = do docs <- quickFind' c (L.append db $ s2L ".system.namespaces") empty - let names = flip List.map docs $ \doc -> - fromBson $ fromJust $ BSON.lookup "name" doc + let names = flip List.map docs $ fromBson . fromJust . BSON.lookup "name" return $ List.filter (L.notElem $ c2w '$') names data ColCreateOpt = CCOSize Int64 -- ^ Desired initial size for the @@ -159,9 +158,8 @@ createCollection :: Connection -> FullCollection -> [ColCreateOpt] -> IO () createCollection c col opts = do (db, col') <- validateCollectionName col dbcols <- collectionNames c db - case col `List.elem` dbcols of - True -> throwColInvalid $ "Collection already exists: " ++ show col - False -> return () + when (col `List.elem` dbcols) $ + throwColInvalid $ "Collection already exists: " ++ show col let cmd = ("create", toBson col') : List.map colCreateOptToBson opts _ <- runCommand c db $ toBsonDoc cmd return () @@ -223,10 +221,9 @@ runCommand :: Connection -> Database -> BsonDoc -> IO BsonDoc runCommand c db cmd = do mres <- findOne c (L.append db $ s2L ".$cmd") cmd let res = fromJust mres - case fromBson $ fromJust $ BSON.lookup "ok" res :: Int of - 1 -> return () - _ -> throwOpFailure $ "command \"" ++ show cmd ++ "\" failed: " ++ - (fromBson $ fromJust $ BSON.lookup "errmsg" res) + when (1 /= (fromBson $ fromJust $ BSON.lookup "ok" res :: Int)) $ + throwOpFailure $ "command \"" ++ show cmd ++ "\" failed: " ++ + fromBson (fromJust $ BSON.lookup "errmsg" res) return res -- | An Itertaor over the results of a query. Use 'nextDoc' to get each @@ -242,15 +239,15 @@ data Cursor = Cursor { } data Opcode - = OP_REPLY -- 1 Reply to a client request. responseTo is set - | OP_MSG -- 1000 generic msg command followed by a string - | OP_UPDATE -- 2001 update document - | OP_INSERT -- 2002 insert new document - | OP_GET_BY_OID -- 2003 is this used? - | OP_QUERY -- 2004 query a collection - | OP_GET_MORE -- 2005 Get more data from a query. See Cursors - | OP_DELETE -- 2006 Delete documents - | OP_KILL_CURSORS -- 2007 Tell database client is done with a cursor + = OPReply -- 1 Reply to a client request. responseTo is set + | OPMsg -- 1000 generic msg command followed by a string + | OPUpdate -- 2001 update document + | OPInsert -- 2002 insert new document + | OPGetByOid -- 2003 is this used? + | OPQuery -- 2004 query a collection + | OPGetMore -- 2005 Get more data from a query. See Cursors + | OPDelete -- 2006 Delete documents + | OPKillCursors -- 2007 Tell database client is done with a cursor deriving (Show, Eq) data MongoDBInternalError = MongoDBInternalError String @@ -276,7 +273,7 @@ instance Typeable MongoDBCollectionInvalid where instance Exception MongoDBCollectionInvalid throwColInvalid :: String -> a -throwColInvalid s = throw $ MongoDBCollectionInvalid s +throwColInvalid = throw . MongoDBCollectionInvalid data MongoDBOperationFailure = MongoDBOperationFailure String deriving (Eq, Show, Read) @@ -290,29 +287,29 @@ instance Typeable MongoDBOperationFailure where instance Exception MongoDBOperationFailure throwOpFailure :: String -> a -throwOpFailure s = throw $ MongoDBOperationFailure s +throwOpFailure = throw . MongoDBOperationFailure fromOpcode :: Opcode -> Int32 -fromOpcode OP_REPLY = 1 -fromOpcode OP_MSG = 1000 -fromOpcode OP_UPDATE = 2001 -fromOpcode OP_INSERT = 2002 -fromOpcode OP_GET_BY_OID = 2003 -fromOpcode OP_QUERY = 2004 -fromOpcode OP_GET_MORE = 2005 -fromOpcode OP_DELETE = 2006 -fromOpcode OP_KILL_CURSORS = 2007 +fromOpcode OPReply = 1 +fromOpcode OPMsg = 1000 +fromOpcode OPUpdate = 2001 +fromOpcode OPInsert = 2002 +fromOpcode OPGetByOid = 2003 +fromOpcode OPQuery = 2004 +fromOpcode OPGetMore = 2005 +fromOpcode OPDelete = 2006 +fromOpcode OPKillCursors = 2007 toOpcode :: Int32 -> Opcode -toOpcode 1 = OP_REPLY -toOpcode 1000 = OP_MSG -toOpcode 2001 = OP_UPDATE -toOpcode 2002 = OP_INSERT -toOpcode 2003 = OP_GET_BY_OID -toOpcode 2004 = OP_QUERY -toOpcode 2005 = OP_GET_MORE -toOpcode 2006 = OP_DELETE -toOpcode 2007 = OP_KILL_CURSORS +toOpcode 1 = OPReply +toOpcode 1000 = OPMsg +toOpcode 2001 = OPUpdate +toOpcode 2002 = OPInsert +toOpcode 2003 = OPGetByOid +toOpcode 2004 = OPQuery +toOpcode 2005 = OPGetMore +toOpcode 2006 = OPDelete +toOpcode 2007 = OPKillCursors toOpcode n = throw $ MongoDBInternalError $ "Got unexpected Opcode: " ++ show n -- | The name of a database. @@ -354,22 +351,22 @@ type NumToSkip = Int32 type NumToReturn = Int32 -- | Options that control the behavior of a 'query' operation. -data QueryOpt = QO_TailableCursor - | QO_SlaveOK - | QO_OpLogReplay - | QO_NoCursorTimeout - deriving (Show) +data QueryOpt = QOTailableCursor + | QOSlaveOK + | QOOpLogReplay + | QONoCursorTimeout + deriving (Show) fromQueryOpts :: [QueryOpt] -> Int32 fromQueryOpts opts = List.foldl (.|.) 0 $ fmap toVal opts - where toVal QO_TailableCursor = 2 - toVal QO_SlaveOK = 4 - toVal QO_OpLogReplay = 8 - toVal QO_NoCursorTimeout = 16 + where toVal QOTailableCursor = 2 + toVal QOSlaveOK = 4 + toVal QOOpLogReplay = 8 + toVal QONoCursorTimeout = 16 -- | Options that effect the behavior of a 'update' operation. -data UpdateFlag = UF_Upsert - | UF_Multiupdate +data UpdateFlag = UFUpsert + | UFMultiupdate deriving (Show, Enum) fromUpdateFlags :: [UpdateFlag] -> Int32 @@ -396,7 +393,7 @@ delete c col sel = do putCol col putI32 0 putBsonDoc sel - (reqID, msg) <- packMsg c OP_DELETE body + (reqID, msg) <- packMsg c OPDelete body L.hPut (cHandle c) msg return reqID @@ -411,7 +408,7 @@ insert c col doc = do putI32 0 putCol col putBsonDoc doc - (reqID, msg) <- packMsg c OP_INSERT body + (reqID, msg) <- packMsg c OPInsert body L.hPut (cHandle c) msg return reqID @@ -422,7 +419,7 @@ insertMany c col docs = do putI32 0 putCol col forM_ docs putBsonDoc - (reqID, msg) <- packMsg c OP_INSERT body + (reqID, msg) <- packMsg c OPInsert body L.hPut (cHandle c) msg return reqID @@ -467,18 +464,18 @@ query c col opts nskip ret sel fsel = do [] -> putNothing _ -> putBsonDoc $ toBsonDoc $ List.zip fsel $ repeat $ BsonInt32 1 - (reqID, msg) <- packMsg c OP_QUERY body + (reqID, msg) <- packMsg c OPQuery body L.hPut h msg hdr <- getHeader h - assert (OP_REPLY == hOp hdr) $ return () + assert (OPReply == hOp hdr) $ return () assert (hRespTo hdr == reqID) $ return () reply <- getReply h assert (rRespFlags reply == 0) $ return () - docBytes <- (L.hGet h $ fromIntegral $ hMsgLen hdr - 16 - 20) >>= newIORef + docBytes <- L.hGet h (fromIntegral $ hMsgLen hdr - 16 - 20) >>= newIORef closed <- newIORef False cid <- newIORef $ rCursorID reply - return $ Cursor { + return Cursor { curCon = c, curID = cid, curNumToRet = ret, @@ -497,7 +494,7 @@ update c col flags sel obj = do putI32 $ fromUpdateFlags flags putBsonDoc sel putBsonDoc obj - (reqID, msg) <- packMsg c OP_UPDATE body + (reqID, msg) <- packMsg c OPUpdate body L.hPut (cHandle c) msg return reqID @@ -533,7 +530,7 @@ getReply h = do cursorID <- getI64 skip 4 -- startFrom <- getI32 skip 4 -- numReturned <- getI32 - return $ (Reply respFlags cursorID) + return $ Reply respFlags cursorID -- | Return one document or Nothing if there are no more. @@ -541,9 +538,9 @@ getReply h = do nextDoc :: Cursor -> IO (Maybe BsonDoc) nextDoc cur = do closed <- readIORef $ curClosed cur - case closed of - True -> return Nothing - False -> do + if closed + then return Nothing + else do docBytes <- readIORef $ curDocBytes cur cid <- readIORef $ curID cur case L.length docBytes of @@ -571,7 +568,7 @@ allDocs cur = unsafeInterleaveIO $ do doc <- nextDoc cur case doc of Nothing -> return [] - Just d -> allDocs cur >>= return . (d :) + Just d -> liftM (d :) (allDocs cur) -- | Returns a strict list of all (of the rest) of the documents in -- the cursor. This means that all of the documents will immediately @@ -581,7 +578,7 @@ allDocs' cur = do doc <- nextDoc cur case doc of Nothing -> return [] - Just d -> allDocs' cur >>= return . (d :) + Just d -> liftM (d :) (allDocs' cur) getFirstDoc :: L.ByteString -> (BsonDoc, L.ByteString) getFirstDoc docBytes = flip runGet docBytes $ do @@ -599,11 +596,11 @@ getMore cur = do putCol $ curCol cur putI32 $ curNumToRet cur putI64 cid - (reqID, msg) <- packMsg (curCon cur) OP_GET_MORE body + (reqID, msg) <- packMsg (curCon cur) OPGetMore body L.hPut h msg hdr <- getHeader h - assert (OP_REPLY == hOp hdr) $ return () + assert (OPReply == hOp hdr) $ return () assert (hRespTo hdr == reqID) $ return () reply <- getReply h assert (rRespFlags reply == 0) $ return () @@ -628,7 +625,7 @@ finish cur = do putI32 0 putI32 1 putI64 cid - (_reqID, msg) <- packMsg (curCon cur) OP_KILL_CURSORS body + (_reqID, msg) <- packMsg (curCon cur) OPKillCursors body L.hPut h msg writeIORef (curClosed cur) True return () @@ -643,7 +640,7 @@ data Direction = Ascending fromDirection :: Direction -> Int fromDirection Ascending = 1 -fromDirection Descending = (-1) +fromDirection Descending = - 1 -- | Should this index guarantee uniqueness? type Unique = Bool @@ -730,16 +727,12 @@ s2L = L8.fromString validateCollectionName :: FullCollection -> IO (Database, Collection) validateCollectionName col = do let (db, col') = splitFullCol col - case s2L ".." `List.elem` (L.group col) of - True -> throwColInvalid $ "Collection can't contain \"..\": " ++ show col - False -> return () - case (c2w '$') `L.elem` col && - not (s2L "oplog.$mail" `L.isPrefixOf` col' || - s2L "$cmd" `L.isPrefixOf` col') of - True -> throwColInvalid $ "Collection can't contain '$': " ++ show col - False -> return () - case L.head col == (c2w '.') || L.last col == (c2w '.') of - True -> throwColInvalid $ - "Collection can't start or end with '.': " ++ show col - False -> return () + when (s2L ".." `List.elem` L.group col) $ + throwColInvalid $ "Collection can't contain \"..\": " ++ show col + when (c2w '$' `L.elem` col && + not (s2L "oplog.$mail" `L.isPrefixOf` col' || + s2L "$cmd" `L.isPrefixOf` col')) $ + throwColInvalid $ "Collection can't contain '$': " ++ show col + when (L.head col == c2w '.' || L.last col == c2w '.') $ + throwColInvalid $ "Collection can't start or end with '.': " ++ show col return (db, col') diff --git a/Database/MongoDB/BSON.hs b/Database/MongoDB/BSON.hs index 2520334..b8bfb5a 100644 --- a/Database/MongoDB/BSON.hs +++ b/Database/MongoDB/BSON.hs @@ -102,52 +102,52 @@ empty = Map.empty instance BsonDocOps L8.ByteString where toBsonDoc = Map.fromList fromBsonDoc = Map.toList - lookup k = Map.lookup k + lookup = Map.lookup instance BsonDocOps String where toBsonDoc = Map.mapKeys L8.fromString .Map.fromList fromBsonDoc = Map.toList . Map.mapKeys L8.toString - lookup k = Map.lookup (L8.fromString k) + lookup = Map.lookup . L8.fromString data DataType = - Data_min_key | -- -1 - Data_number | -- 1 - Data_string | -- 2 - Data_object | -- 3 - Data_array | -- 4 - Data_binary | -- 5 - Data_undefined | -- 6 - Data_oid | -- 7 - Data_boolean | -- 8 - Data_date | -- 9 - Data_null | -- 10 - Data_regex | -- 11 - Data_ref | -- 12 - Data_code | -- 13 - Data_symbol | -- 14 - Data_code_w_scope | -- 15 - Data_int | -- 16 - Data_timestamp | -- 17 - Data_long | -- 18 - Data_max_key -- 127 + DataMinKey | -- -1 + DataNumber | -- 1 + DataString | -- 2 + DataObject | -- 3 + DataArray | -- 4 + DataBinary | -- 5 + DataUndefined | -- 6 + DataOid | -- 7 + DataBoolean | -- 8 + DataDate | -- 9 + DataNull | -- 10 + DataRegex | -- 11 + DataRef | -- 12 + DataCode | -- 13 + DataSymbol | -- 14 + DataCodeWScope | -- 15 + DataInt | -- 16 + DataTimestamp | -- 17 + DataLong | -- 18 + DataMaxKey -- 127 deriving (Show, Read, Enum, Eq, Ord) toDataType :: Int -> DataType -toDataType (-1) = Data_min_key -toDataType 127 = Data_max_key +toDataType (-1) = DataMinKey +toDataType 127 = DataMaxKey toDataType d = toEnum d fromDataType :: DataType -> Int -fromDataType Data_min_key = (-1) -fromDataType Data_max_key = 127 +fromDataType DataMinKey = - 1 +fromDataType DataMaxKey = 127 fromDataType d = fromEnum d data BinarySubType = - BSTUNDEFINED_1 | + BSTUNDEFINED1 | BSTFunction | -- 1 BSTByteArray | -- 2 BSTUUID | -- 3 - BSTUNDEFINED_2 | + BSTUNDEFINED2 | BSTMD5 | -- 5 BSTUserDefined deriving (Show, Read, Enum, Eq, Ord) @@ -167,43 +167,41 @@ putBsonDoc :: BsonDoc -> Put putBsonDoc = putObj getVal :: DataType -> Get (Integer, BsonValue) -getVal Data_number = getFloat64le >>= return . (,) 8 . BsonDouble -getVal Data_string = do +getVal DataNumber = liftM ((,) 8 . BsonDouble) getFloat64le +getVal DataString = do sLen1 <- getI32 (_sLen2, s) <- getS return (fromIntegral $ 4 + sLen1, BsonString s) -getVal Data_object = getDoc >>= \(len, obj) -> return (len, BsonObject obj) -getVal Data_array = do +getVal DataObject = getDoc >>= \(len, obj) -> return (len, BsonObject obj) +getVal DataArray = do (len, arr) <- getRawObj let arr2 = Map.fold (:) [] arr -- reverse and remove key return (len, BsonArray arr2) -getVal Data_binary = do +getVal DataBinary = do skip 4 st <- getI8 len2 <- getI32 bs <- getLazyByteString $ fromIntegral len2 return (4 + 1 + 4 + fromIntegral len2, BsonBinary (toBinarySubType st) bs) -getVal Data_undefined = return (1, BsonUndefined) -getVal Data_oid = getLazyByteString 12 >>= return . (,) 12 . BsonObjectId -getVal Data_boolean = - getI8 >>= return . (,) (1::Integer) . BsonBool . (/= (0::Int)) -getVal Data_date = - getI64 >>= return . (,) 8 . BsonDate . flip (/) 1000 . realToFrac -getVal Data_null = return (1, BsonNull) -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 +getVal DataUndefined = return (1, BsonUndefined) +getVal DataOid = liftM ((,) 12 . BsonObjectId) $ getLazyByteString 12 +getVal DataBoolean = liftM ((,) (1::Integer) . BsonBool . (/= (0::Int))) getI8 +getVal DataDate = liftM ((,) 8 . BsonDate . flip (/) 1000 . realToFrac) getI64 +getVal DataNull = return (1, BsonNull) +getVal DataRegex = fail "DataCode not yet supported" -- TODO +getVal DataRef = fail "DataRef is deprecated" +getVal DataCode = fail "DataCode not yet supported" -- TODO +getVal DataSymbol = do sLen1 <- getI32 (_sLen2, s) <- getS return (fromIntegral $ 4 + sLen1, BsonString s) -getVal Data_code_w_scope = fail "Data_code_w_scope not yet supported" -- TODO -getVal Data_int = getI32 >>= return . (,) 4 . BsonInt32 . fromIntegral -getVal Data_timestamp = fail "Data_timestamp not yet supported" -- TODO +getVal DataCodeWScope = fail "DataCodeWScope not yet supported" -- TODO +getVal DataInt = liftM ((,) 4 . BsonInt32 . fromIntegral) getI32 +getVal DataTimestamp = fail "DataTimestamp not yet supported" -- TODO -getVal Data_long = getI64 >>= return . (,) 8 . BsonInt64 -getVal Data_min_key = return (0, BsonMinKey) -getVal Data_max_key = return (0, BsonMaxKey) +getVal DataLong = liftM ((,) 8 . BsonInt64) getI64 +getVal DataMinKey = return (0, BsonMinKey) +getVal DataMaxKey = return (0, BsonMaxKey) getInnerObj :: Int32 -> BsonDoc -> Get BsonDoc getInnerObj 1 obj = return obj @@ -212,7 +210,7 @@ getInnerObj bytesLeft obj = do (keySz, key) <- getS (valSz, val) <- getVal typ getInnerObj (bytesLeft - 1 - fromIntegral keySz - fromIntegral valSz) $ - (Map.insert key val) obj + Map.insert key val obj getRawObj :: Get (Integer, BsonDoc) getRawObj = do @@ -228,26 +226,26 @@ getDataType :: Get DataType getDataType = liftM toDataType getI8 putType :: BsonValue -> Put -putType BsonDouble{} = putDataType Data_number -putType BsonString{} = putDataType Data_string -putType BsonObject{} = putDataType Data_object -putType BsonArray{} = putDataType Data_array -putType BsonBinary{} = putDataType Data_binary -putType BsonUndefined = putDataType Data_undefined -putType BsonObjectId{} = putDataType Data_oid -putType BsonBool{} = putDataType Data_boolean -putType BsonDate{} = putDataType Data_date -putType BsonNull = putDataType Data_null -putType BsonRegex{} = putDataType Data_regex --- putType = putDataType Data_ref --- putType = putDataType Data_code -putType BsonSymbol{} = putDataType Data_symbol --- putType = putDataType Data_code_w_scope -putType BsonInt32 {} = putDataType Data_int -putType BsonInt64 {} = putDataType Data_long --- putType = putDataType Data_timestamp -putType BsonMinKey = putDataType Data_min_key -putType BsonMaxKey = putDataType Data_max_key +putType BsonDouble{} = putDataType DataNumber +putType BsonString{} = putDataType DataString +putType BsonObject{} = putDataType DataObject +putType BsonArray{} = putDataType DataArray +putType BsonBinary{} = putDataType DataBinary +putType BsonUndefined = putDataType DataUndefined +putType BsonObjectId{} = putDataType DataOid +putType BsonBool{} = putDataType DataBoolean +putType BsonDate{} = putDataType DataDate +putType BsonNull = putDataType DataNull +putType BsonRegex{} = putDataType DataRegex +-- putType = putDataType DataRef +-- putType = putDataType DataCode +putType BsonSymbol{} = putDataType DataSymbol +-- putType = putDataType DataCodeWScope +putType BsonInt32 {} = putDataType DataInt +putType BsonInt64 {} = putDataType DataLong +-- putType = putDataType DataTimestamp +putType BsonMinKey = putDataType DataMinKey +putType BsonMaxKey = putDataType DataMaxKey putVal :: BsonValue -> Put putVal (BsonDouble d) = putFloat64le d @@ -255,7 +253,7 @@ putVal (BsonString s) = putI32 (fromIntegral $ 1 + L8.length s) >> putS s putVal (BsonObject o) = putObj o putVal (BsonArray es) = putOutterObj bs 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 (BsonBinary t bs)= do putI32 $ fromIntegral $ 4 + L.length bs putI8 $ fromBinarySubType t putI32 $ fromIntegral $ L.length bs @@ -375,22 +373,22 @@ instance Convertible Bool BsonValue where safeConvert = return . BsonBool instance Convertible Int BsonValue where - safeConvert i = if i >= (fromIntegral (minBound::Int32)) && - i <= (fromIntegral (maxBound::Int32)) + safeConvert i = if i >= fromIntegral (minBound::Int32) && + i <= fromIntegral (maxBound::Int32) then return $ BsonInt32 $ fromIntegral i else return $ BsonInt64 $ fromIntegral i instance Convertible Integer BsonValue where - safeConvert i = if i >= (fromIntegral (minBound::Int32)) && - i <= (fromIntegral (maxBound::Int32)) + safeConvert i = if i >= fromIntegral (minBound::Int32) && + i <= fromIntegral (maxBound::Int32) then return $ BsonInt32 $ fromIntegral i else return $ BsonInt64 $ fromIntegral i instance Convertible Int32 BsonValue where - safeConvert i = return $ BsonInt32 i + safeConvert = return . BsonInt32 instance Convertible Int64 BsonValue where - safeConvert i = return $ BsonInt64 i + safeConvert = return . BsonInt64 instance (Convertible a BsonValue) => Convertible (Maybe a) BsonValue where