mongoDB 0.1 → 0.2
raw patch · 3 files changed
+385/−248 lines, 3 files
Files
- Database/MongoDB.hs +255/−145
- Database/MongoDB/BSON.hs +128/−102
- mongoDB.cabal +2/−1
Database/MongoDB.hs view
@@ -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')
Database/MongoDB/BSON.hs view
@@ -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
mongoDB.cabal view
@@ -1,9 +1,10 @@ Name: mongoDB-Version: 0.1+Version: 0.2 License: MIT Maintainer: Scott Parish <srp@srparish.net> Author: Scott Parish <srp@srparish.net> 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,