diff --git a/Database/MongoDB.hs b/Database/MongoDB.hs --- a/Database/MongoDB.hs +++ b/Database/MongoDB.hs @@ -27,14 +27,17 @@ ( -- * Connection Connection, - connect, connectOnPort, conClose, disconnect, - dropDatabase, + connect, connectOnPort, conClose, disconnect, dropDatabase, + serverInfo, + databasesInfo, databaseNames, -- * Database Database, MongoDBCollectionInvalid, ColCreateOpt(..), - collectionNames, createCollection, dropCollection, validateCollection, + collectionNames, createCollection, dropCollection, + renameCollection, runCommand, validateCollection, -- * Collection - Collection, FieldSelector, NumToSkip, NumToReturn, Selector, + Collection, FieldSelector, FullCollection, + NumToSkip, NumToReturn, Selector, QueryOpt(..), UpdateFlag(..), count, countMatching, delete, insert, insertMany, query, remove, update, @@ -43,6 +46,10 @@ -- * Cursor Cursor, allDocs, allDocs', finish, nextDoc, + -- * Index + Key, Unique, + Direction(..), + createIndex, dropIndex, dropIndexes, indexInformation, ) where import Control.Exception @@ -51,12 +58,13 @@ import Data.Binary.Get import Data.Binary.Put import Data.Bits -import Data.ByteString.Char8 hiding (count, find) +import Data.ByteString.Internal (c2w) 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 qualified Data.Map as Map import Data.Maybe import Data.Typeable import Database.MongoDB.BSON as BSON @@ -84,12 +92,25 @@ 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 () conClose = hClose . cHandle +-- | Information about the databases on the server. +databasesInfo :: Connection -> IO BsonDoc +databasesInfo c = + runCommand c (s2L "admin") $ toBsonDoc [("listDatabases", toBson (1::Int))] + +-- | Return a list of database names on the server. +databaseNames :: Connection -> IO [Database] +databaseNames c = do + info <- databasesInfo c + let (BsonArray dbs) = fromJust $ Map.lookup (s2L "databases") info + names = mapMaybe (Map.lookup (s2L "name") . fromBson) dbs + return $ List.map fromBson (names::[BsonValue]) + -- | Alias for 'conClose' disconnect :: Connection -> IO () disconnect = conClose @@ -97,16 +118,20 @@ -- | Drop a database. dropDatabase :: Connection -> Database -> IO () dropDatabase c db = do - _ <- dbCmd c db $ toBsonDoc [("dropDatabase", toBson (1::Int))] + _ <- runCommand c db $ toBsonDoc [("dropDatabase", toBson (1::Int))] return () +-- | Get information about the MongoDB server we're connected to. +serverInfo :: Connection -> IO BsonDoc +serverInfo c = + runCommand c (s2L "admin") $ toBsonDoc [("buildinfo", toBson (1::Int))] + -- | Return a list of collections in /Database/. -collectionNames :: Connection -> Database -> IO [Collection] +collectionNames :: Connection -> Database -> IO [FullCollection] collectionNames c db = do - docs <- quickFind' c (db ++ ".system.namespaces") BSON.empty - let names = flip List.map docs $ \doc -> - fromBson $ fromJust $ BSON.lookup "name" doc - return $ List.filter (List.notElem '$') names + docs <- quickFind' c (L.append db $ s2L ".system.namespaces") empty + 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 -- collection (in bytes). must be @@ -129,38 +154,33 @@ -- only be needed if you want to specify 'ColCreateOpt's on creation. -- 'MongoDBCollectionInvalid' is thrown if the collection already -- exists. -createCollection :: Connection -> Collection -> [ColCreateOpt] -> IO () +createCollection :: Connection -> FullCollection -> [ColCreateOpt] -> IO () createCollection c col opts = do - let db = dbFromCol col - col' = colMinusDB col + (db, col') <- validateCollectionName col dbcols <- collectionNames c db - case col `List.elem` dbcols of - True -> throwColInvalid $ "Collection already exists: " ++ show col - False -> return () - case ".." `List.elem` (List.group col) of - True -> throwColInvalid $ "Collection can't contain \"..\": " ++ show col - False -> return () - case '$' `List.elem` col && - not ("oplog.$mail" `List.isPrefixOf` col' || - "$cmd" `List.isPrefixOf` col') of - True -> throwColInvalid $ "Collection can't contain '$': " ++ show col - False -> return () - case List.head col == '.' || List.last col == '.' of - True -> throwColInvalid $ - "Collection can't start or end with '.': " ++ show col - False -> return () + when (col `List.elem` dbcols) $ + throwColInvalid $ "Collection already exists: " ++ show col let cmd = ("create", toBson col') : List.map colCreateOptToBson opts - _ <- dbCmd c db $ toBsonDoc cmd + _ <- runCommand c db $ toBsonDoc cmd return () -- | Drop a collection. -dropCollection :: Connection -> Collection -> IO () +dropCollection :: Connection -> FullCollection -> IO () dropCollection c col = do - let db = dbFromCol col - col' = colMinusDB col - _ <- dbCmd c db $ toBsonDoc [("drop", toBson col')] + let (db, col') = splitFullCol col + _ <- runCommand c db $ toBsonDoc [("drop", toBson col')] return () +-- | Rename a collection--first /FullCollection/ argument is the +-- existing name, the second is the new name. At the moment this command +-- can also be used to move a collection between databases. +renameCollection :: Connection -> FullCollection -> FullCollection -> IO () +renameCollection c col newName = do + _ <- validateCollectionName col + _ <- runCommand c (s2L "admin") $ toBsonDoc [("renameCollection", toBson col), + ("to", toBson newName)] + return () + -- | Return a string of validation info about the collection. -- -- Example output (note this probably can/will change with different @@ -184,27 +204,26 @@ -- > deleted: n: 4 size: 588 -- > nIndexes:1 -- > test.foo.bar.$_id_ keys:5 -validateCollection :: Connection -> Collection -> IO String +validateCollection :: Connection -> FullCollection -> IO String validateCollection c col = do - let db = dbFromCol col - col' = colMinusDB col - res <- dbCmd c db $ toBsonDoc [("validate", toBson col')] + let (db, col') = splitFullCol col + res <- runCommand c db $ toBsonDoc [("validate", toBson col')] return $ fromBson $ fromJust $ BSON.lookup "result" res -dbFromCol :: Collection -> Database -dbFromCol = List.takeWhile (/= '.') - -colMinusDB :: Collection -> Collection -colMinusDB = List.tail . List.dropWhile (/= '.') +splitFullCol :: FullCollection -> (Database, Collection) +splitFullCol col = (L.takeWhile (c2w '.' /=) col, + L.tail $ L.dropWhile (c2w '.' /=) col) -dbCmd :: Connection -> Database -> BsonDoc -> IO BsonDoc -dbCmd c db cmd = do - mres <- findOne c (db ++ ".$cmd") cmd +-- | Run a database command. Usually this is unneeded as driver wraps +-- all of the commands for you (eg 'createCollection', +-- 'dropCollection', etc). +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 @@ -214,21 +233,21 @@ curCon :: Connection, curID :: IORef Int64, curNumToRet :: Int32, - curCol :: Collection, + curCol :: FullCollection, curDocBytes :: IORef L.ByteString, curClosed :: IORef Bool } 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 @@ -254,7 +273,7 @@ instance Exception MongoDBCollectionInvalid throwColInvalid :: String -> a -throwColInvalid s = throw $ MongoDBCollectionInvalid s +throwColInvalid = throw . MongoDBCollectionInvalid data MongoDBOperationFailure = MongoDBOperationFailure String deriving (Eq, Show, Read) @@ -268,40 +287,43 @@ 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. -type Database = String +type Database = L8.ByteString -- | The full collection name. The full collection name is the -- concatenation of the database name with the collection name, using -- a @.@ for the concatenation. For example, for the database @foo@ -- and the collection @bar@, the full collection name is @foo.bar@. -type Collection = String +type FullCollection = L8.ByteString +-- | The same as 'FullCollection' but without the 'Database' prefix. +type Collection = L8.ByteString + -- | A 'BsonDoc' representing restrictions for a query much like the -- /where/ part of an SQL query. type Selector = BsonDoc @@ -329,86 +351,85 @@ 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 fromUpdateFlags flags = List.foldl (.|.) 0 $ flip fmap flags $ (1 `shiftL`) . fromEnum --- | Return the number of documents in /Collection/. -count :: Connection -> Collection -> IO Int64 -count c col = countMatching c col BSON.empty +-- | Return the number of documents in /FullCollection/. +count :: Connection -> FullCollection -> IO Int64 +count c col = countMatching c col empty --- | Return the number of documents in /Collection/ matching /Selector/ -countMatching :: Connection -> Collection -> Selector -> IO Int64 +-- | Return the number of documents in /FullCollection/ matching /Selector/ +countMatching :: Connection -> FullCollection -> Selector -> IO Int64 countMatching c col sel = do - let db = dbFromCol col - col' = colMinusDB col - res <- dbCmd c db $ toBsonDoc [("count", toBson col'), - ("query", BsonObject sel)] + let (db, col') = splitFullCol col + res <- runCommand c db $ toBsonDoc [("count", toBson col'), + ("query", toBson sel)] return $ fromBson $ fromJust $ BSON.lookup "n" res --- | Delete documents matching /Selector/ from the given /Collection/. -delete :: Connection -> Collection -> Selector -> IO RequestID +-- | Delete documents matching /Selector/ from the given /FullCollection/. +delete :: Connection -> FullCollection -> Selector -> IO RequestID delete c col sel = do let body = runPut $ do putI32 0 putCol col putI32 0 - put sel - (reqID, msg) <- packMsg c OP_DELETE body + putBsonDoc sel + (reqID, msg) <- packMsg c OPDelete body L.hPut (cHandle c) msg return reqID -- | An alias for 'delete'. -remove :: Connection -> Collection -> Selector -> IO RequestID +remove :: Connection -> FullCollection -> Selector -> IO RequestID remove = delete --- | Insert a single document into /Collection/. -insert :: Connection -> Collection -> BsonDoc -> IO RequestID +-- | Insert a single document into /FullCollection/. +insert :: Connection -> FullCollection -> BsonDoc -> IO RequestID insert c col doc = do let body = runPut $ do putI32 0 putCol col - put doc - (reqID, msg) <- packMsg c OP_INSERT body + putBsonDoc doc + (reqID, msg) <- packMsg c OPInsert body L.hPut (cHandle c) msg return reqID --- | Insert a list of documents into /Collection/. -insertMany :: Connection -> Collection -> [BsonDoc] -> IO RequestID +-- | Insert a list of documents into /FullCollection/. +insertMany :: Connection -> FullCollection -> [BsonDoc] -> IO RequestID insertMany c col docs = do let body = runPut $ do putI32 0 putCol col - forM_ docs put - (reqID, msg) <- packMsg c OP_INSERT body + forM_ docs putBsonDoc + (reqID, msg) <- packMsg c OPInsert body L.hPut (cHandle c) msg return reqID -- | Open a cursor to find documents. If you need full functionality, -- see 'query' -find :: Connection -> Collection -> Selector -> IO Cursor +find :: Connection -> FullCollection -> Selector -> IO Cursor find c col sel = query c col [] 0 0 sel [] -- | Query, but only return the first result, if any. -findOne :: Connection -> Collection -> Selector -> IO (Maybe BsonDoc) +findOne :: Connection -> FullCollection -> Selector -> IO (Maybe BsonDoc) findOne c col sel = do cur <- query c col [] 0 (-1) sel [] el <- nextDoc cur @@ -418,18 +439,18 @@ -- | Perform a query and return the result as a lazy list. Be sure to -- understand the comments about using the lazy list given for -- 'allDocs'. -quickFind :: Connection -> Collection -> Selector -> IO [BsonDoc] +quickFind :: Connection -> FullCollection -> Selector -> IO [BsonDoc] quickFind c col sel = find c col sel >>= allDocs -- | Perform a query and return the result as a strict list. -quickFind' :: Connection -> Collection -> Selector -> IO [BsonDoc] +quickFind' :: Connection -> FullCollection -> Selector -> IO [BsonDoc] quickFind' c col sel = find c col sel >>= allDocs' --- | Open a cursor to find documents in /Collection/ that match +-- | Open a cursor to find documents in /FullCollection/ that match -- /Selector/. See the documentation for each argument's type for -- information about how it effects the query. -query :: Connection -> Collection -> [QueryOpt] -> NumToSkip -> NumToReturn -> - Selector -> FieldSelector -> IO Cursor +query :: Connection -> FullCollection -> [QueryOpt] -> + NumToSkip -> NumToReturn -> Selector -> FieldSelector -> IO Cursor query c col opts nskip ret sel fsel = do let h = cHandle c @@ -438,22 +459,23 @@ putCol col putI32 nskip putI32 ret - put sel + putBsonDoc sel case fsel of [] -> putNothing - _ -> put $ toBsonDoc $ List.zip fsel $ repeat $ BsonInt32 1 - (reqID, msg) <- packMsg c OP_QUERY body + _ -> putBsonDoc $ toBsonDoc $ List.zip fsel $ + repeat $ BsonInt32 1 + (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, @@ -462,17 +484,17 @@ curClosed = closed } --- | Update documents with /BsonDoc/ in /Collection/ that match /Selector/. -update :: Connection -> Collection -> +-- | Update documents with /BsonDoc/ in /FullCollection/ that match /Selector/. +update :: Connection -> FullCollection -> [UpdateFlag] -> Selector -> BsonDoc -> IO RequestID update c col flags sel obj = do let body = runPut $ do putI32 0 putCol col putI32 $ fromUpdateFlags flags - put sel - put obj - (reqID, msg) <- packMsg c OP_UPDATE body + putBsonDoc sel + putBsonDoc obj + (reqID, msg) <- packMsg c OPUpdate body L.hPut (cHandle c) msg return reqID @@ -508,7 +530,7 @@ 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. @@ -516,9 +538,9 @@ 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 @@ -546,7 +568,7 @@ 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 @@ -556,11 +578,11 @@ 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 - doc <- get + doc <- getBsonDoc docBytes' <- getRemainingLazyByteString return (doc, docBytes') @@ -574,11 +596,11 @@ 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 () @@ -603,13 +625,85 @@ 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 () +-- | The field key to index on. +type Key = L8.ByteString + +-- | Direction to index. +data Direction = Ascending + | Descending + deriving (Show, Eq) + +fromDirection :: Direction -> Int +fromDirection Ascending = 1 +fromDirection Descending = - 1 + +-- | Should this index guarantee uniqueness? +type Unique = Bool + +-- | Create a new index on /FullCollection/ on the list of /Key/ / +-- /Direction/ pairs. +createIndex :: Connection -> FullCollection -> + [(Key, Direction)] -> Unique -> IO L8.ByteString +createIndex c col keys uniq = do + let (db, _col') = splitFullCol col + name = indexName keys + keysDoc = flip fmap keys $ + \(k, d) -> (k, toBson $ fromDirection d :: BsonValue) + _ <- insert c (L.append db $ s2L ".system.indexes") $ + toBsonDoc [("name", toBson name), + ("ns", toBson col), + ("key", toBson keysDoc), + ("unique", toBson uniq)] + return name + +-- | Drop the specified index on the given /FullCollection/. +dropIndex :: Connection -> FullCollection -> [(Key, Direction)] -> IO () +dropIndex c col keys = do + let (db, col') = splitFullCol col + name = indexName keys + _ <- runCommand c db $ toBsonDoc [("deleteIndexes", toBson col'), + ("index", toBson name)] + return () + +-- | Drop all indexes on /FullCollection/. +dropIndexes :: Connection -> FullCollection -> IO () +dropIndexes c col = do + let (db, col') = splitFullCol col + _ <- runCommand c db $ toBsonDoc [("deleteIndexes", toBson col'), + ("index", toBson "*")] + return () + +-- | Return a BsonDoc describing the existing indexes on /FullCollection/. +-- +-- With the current server versions (1.2) this will return documents +-- such as: +-- +-- > {"key": {"lastname": -1, "firstname": 1}, +-- > "name": "lastname_-1_firstname_1", +-- > "ns": "mydb.people", +-- > "unique": true} +-- +-- Which is a single key that indexes on @lastname@ (descending) and +-- then @firstname@ (ascending) on the collection @people@ of the +-- database @mydb@ with a uniqueness requirement. +indexInformation :: Connection -> FullCollection -> IO [BsonDoc] +indexInformation c col = do + let (db, _col') = splitFullCol col + quickFind' c (L.append db $ s2L ".system.indexes") $ + toBsonDoc [("ns", toBson col)] + +indexName :: [(Key, Direction)] -> L8.ByteString +indexName = L.intercalate (s2L "_") . List.map partName + where partName (k, Ascending) = L.append k $ s2L "_1" + partName (k, Descending) = L.append k $ s2L "_-1" + putCol :: Collection -> Put -putCol col = putByteString (pack col) >> putNull +putCol col = putLazyByteString col >> putNull packMsg :: Connection -> Opcode -> L.ByteString -> IO (RequestID, L.ByteString) packMsg c op body = do @@ -626,3 +720,19 @@ randNum Connection { cRand = nsRef } = atomicModifyIORef nsRef $ \ns -> (List.tail ns, fromIntegral $ List.head ns) + +s2L :: String -> L8.ByteString +s2L = L8.fromString + +validateCollectionName :: FullCollection -> IO (Database, Collection) +validateCollectionName col = do + let (db, col') = splitFullCol col + 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 --- a/Database/MongoDB/BSON.hs +++ b/Database/MongoDB/BSON.hs @@ -27,13 +27,15 @@ ( -- * Types BsonValue(..), - BsonDoc(..), - toBsonDoc, + BsonDoc, BinarySubType(..), -- * BsonDoc Operations empty, lookup, - -- * Conversion - fromBson, toBson + -- * Type Conversion + fromBson, toBson, + fromBsonDoc, toBsonDoc, + -- * Binary encoding/decoding + getBsonDoc, putBsonDoc, ) where import Prelude hiding (lookup) @@ -83,72 +85,69 @@ -- strings ('Data.ByteString.Lazu.UTF8.ByteString') and 'BsonValue's. -- It can be constructed either from a 'Map' (eg @'BsonDoc' myMap@) or -- from a associative list (eg @'toBsonDoc' myAL@). -newtype BsonDoc = BsonDoc { - bdFromBsonDoc :: Map.Map L8.ByteString BsonValue - } - deriving (Eq, Ord, Show) +type BsonDoc = Map.Map L8.ByteString BsonValue class BsonDocOps a where -- | Construct a BsonDoc from an associative list toBsonDoc :: [(a, BsonValue)] -> BsonDoc -- | Unwrap BsonDoc to be a Map - fromBsonDoc :: BsonDoc -> Map.Map a BsonValue + fromBsonDoc :: BsonDoc -> [(a, BsonValue)] -- | Return the BsonValue for given key, if any. lookup :: a -> BsonDoc -> Maybe BsonValue -- | An empty BsonDoc empty :: BsonDoc -empty = BsonDoc Map.empty +empty = Map.empty instance BsonDocOps L8.ByteString where - toBsonDoc = BsonDoc . Map.fromList - fromBsonDoc = bdFromBsonDoc - lookup k = Map.lookup k . fromBsonDoc + toBsonDoc = Map.fromList + fromBsonDoc = Map.toList + lookup = Map.lookup instance BsonDocOps String where - toBsonDoc = BsonDoc . Map.mapKeys L8.fromString .Map.fromList - fromBsonDoc = Map.mapKeys L8.toString . bdFromBsonDoc - lookup k = Map.lookup (L8.fromString k) . fromBsonDoc + toBsonDoc = Map.mapKeys L8.fromString .Map.fromList + fromBsonDoc = Map.toList . Map.mapKeys L8.toString + 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) @@ -161,93 +160,92 @@ fromBinarySubType BSTUserDefined = 0x80 fromBinarySubType d = fromEnum d -instance Binary BsonDoc where - get = liftM snd getDoc - put = putObj +getBsonDoc :: Get BsonDoc +getBsonDoc = liftM snd getDoc +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 -> Get (Map.Map L8.ByteString BsonValue) - -> Get (Map.Map L8.ByteString BsonValue) -getInnerObj 1 obj = obj +getInnerObj :: Int32 -> BsonDoc -> Get BsonDoc +getInnerObj 1 obj = return obj getInnerObj bytesLeft obj = do typ <- getDataType (keySz, key) <- getS (valSz, val) <- getVal typ getInnerObj (bytesLeft - 1 - fromIntegral keySz - fromIntegral valSz) $ - liftM (Map.insert key val) obj + Map.insert key val obj -getRawObj :: Get (Integer, Map.Map L8.ByteString BsonValue) +getRawObj :: Get (Integer, BsonDoc) getRawObj = do bytes <- getI32 - obj <- getInnerObj (bytes - 4) $ return Map.empty + obj <- getInnerObj (bytes - 4) empty getNull return (fromIntegral bytes, obj) getDoc :: Get (Integer, BsonDoc) -getDoc = getRawObj >>= \(len, obj) -> return (len, BsonDoc obj) +getDoc = getRawObj 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 (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 @@ -277,7 +275,7 @@ putObj :: BsonDoc -> Put putObj obj = putOutterObj bs - where bs = runPut $ forM_ (Map.toList (fromBsonDoc obj)) $ \(k, v) -> + where bs = runPut $ forM_ (fromBsonDoc obj) $ \(k, v) -> putType v >> putS k >> putVal v putOutterObj :: L.ByteString -> Put @@ -338,6 +336,18 @@ instance Convertible [S8.ByteString] BsonValue where safeConvert bs = BsonArray `liftM` mapM safeConvert bs +instance Convertible BsonDoc BsonValue where + safeConvert = return . BsonObject + +instance Convertible (Map.Map String BsonValue) BsonValue where + safeConvert = return . BsonObject . Map.mapKeys L8.fromString + +instance Convertible [(L8.ByteString, BsonValue)] BsonValue where + safeConvert = return . BsonObject . toBsonDoc + +instance Convertible [(String, BsonValue)] BsonValue where + safeConvert = return . BsonObject . toBsonDoc + instance Convertible [Bool] BsonValue where safeConvert bs = BsonArray `liftM` mapM safeConvert bs @@ -363,22 +373,22 @@ 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 @@ -407,6 +417,22 @@ instance Convertible BsonValue S8.ByteString where safeConvert (BsonString bs) = return $ C8.concat $ L.toChunks bs + safeConvert v = unsupportedError v + +instance Convertible BsonValue BsonDoc where + safeConvert (BsonObject o) = return o + safeConvert v = unsupportedError v + +instance Convertible BsonValue (Map.Map String BsonValue) where + safeConvert (BsonObject o) = return $ Map.mapKeys L8.toString o + safeConvert v = unsupportedError v + +instance Convertible BsonValue [(String, BsonValue)] where + safeConvert (BsonObject o) = return $ fromBsonDoc o + safeConvert v = unsupportedError v + +instance Convertible BsonValue [(L8.ByteString, BsonValue)] where + safeConvert (BsonObject o) = return $ fromBsonDoc o safeConvert v = unsupportedError v instance Convertible BsonValue [Double] where diff --git a/mongoDB.cabal b/mongoDB.cabal --- a/mongoDB.cabal +++ b/mongoDB.cabal @@ -1,9 +1,10 @@ Name: mongoDB -Version: 0.1 +Version: 0.2 License: MIT Maintainer: Scott Parish Author: Scott Parish Copyright: Copyright (c) 2010-2010 Scott Parish +homepage: http://github.com/srp/mongoDB Category: Database Synopsis: A driver for MongoDB Description: This driver lets you connect to MongoDB, do inserts,