mongoDB 0.2 → 0.3
raw patch · 4 files changed
+203/−51 lines, 4 filesdep +nano-md5
Dependencies added: nano-md5
Files
- Database/MongoDB.hs +185/−45
- Database/MongoDB/BSON.hs +11/−3
- Database/MongoDB/Util.hs +4/−1
- mongoDB.cabal +3/−2
Database/MongoDB.hs view
@@ -26,23 +26,28 @@ module Database.MongoDB ( -- * Connection- Connection,+ Connection, ConnectOpt(..), connect, connectOnPort, conClose, disconnect, dropDatabase,- serverInfo,+ connectCluster, connectClusterOnPort,+ serverInfo, serverShutdown, databasesInfo, databaseNames, -- * Database- Database, MongoDBCollectionInvalid,+ Database, MongoDBCollectionInvalid, Password, Username, ColCreateOpt(..), collectionNames, createCollection, dropCollection, renameCollection, runCommand, validateCollection,+ auth, addUser, login, logout, -- * Collection Collection, FieldSelector, FullCollection, NumToSkip, NumToReturn, Selector, QueryOpt(..), UpdateFlag(..), count, countMatching, delete, insert, insertMany, query, remove, update,- -- * Convience collection operations+ save,+ -- * Convenience collection operations find, findOne, quickFind, quickFind',+ -- * Query Helpers+ whereClause, -- * Cursor Cursor, allDocs, allDocs', finish, nextDoc,@@ -54,10 +59,11 @@ where import Control.Exception import Control.Monad-import Data.Binary+import Data.Binary() import Data.Binary.Get import Data.Binary.Put import Data.Bits+import Data.ByteString.Char8 (pack) import Data.ByteString.Internal (c2w) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.UTF8 as L8@@ -67,6 +73,7 @@ import qualified Data.Map as Map import Data.Maybe import Data.Typeable+import Data.Digest.OpenSSL.MD5 import Database.MongoDB.BSON as BSON import Database.MongoDB.Util import qualified Network@@ -76,27 +83,68 @@ import System.IO.Unsafe import System.Random --- | A handle to a database connection-data Connection = Connection { cHandle :: Handle, cRand :: IORef [Int] }+-- | A list of handles to database connections+data Connection = Connection {+ cHandle :: IORef Handle,+ cRand :: IORef [Int]+ } --- | Estabilish a connection to a MongoDB server-connect :: HostName -> IO Connection-connect = flip connectOnPort $ Network.PortNumber 27017+data ConnectOpt+ = SlaveOK -- ^ It's fine to connect to the slave+ deriving (Show, Eq) --- | Estabilish a connection to a MongoDB server on a non-standard port-connectOnPort :: HostName -> Network.PortID -> IO Connection-connectOnPort host port = do- h <- Network.connectTo host port- hSetBuffering h NoBuffering+-- | Establish a connection to a MongoDB server+connect :: HostName -> [ConnectOpt] -> IO Connection+connect = flip connectOnPort (Network.PortNumber 27017)++-- | Establish connections to a list of MongoDB servers+connectCluster :: [HostName] -> [ConnectOpt] -> IO Connection+connectCluster xs =+ connectClusterOnPort (fmap (flip (,) $ Network.PortNumber 27017) xs)++-- | Establish connections to a list of MongoDB servers specifying each port.+connectClusterOnPort :: [(HostName, Network.PortID)] -> [ConnectOpt]+ -> IO Connection+connectClusterOnPort [] _ = throwOpFailure "No hostnames in list"+connectClusterOnPort servers opts = newConnection servers opts++-- | Establish a connection to a MongoDB server on a non-standard port+connectOnPort :: HostName -> Network.PortID -> [ConnectOpt] -> IO Connection+connectOnPort host port = newConnection [(host, port)]++newConnection :: [(HostName, Network.PortID)] -> [ConnectOpt] -> IO Connection+newConnection servers opts = do r <- newStdGen let ns = randomRs (fromIntegral (minBound :: Int32), fromIntegral (maxBound :: Int32)) r nsRef <- newIORef ns- return Connection { cHandle = h, cRand = nsRef }+ hRef <- openHandle (head servers) >>= newIORef+ let c = Connection hRef nsRef+ res <- isMaster c+ if fromBson (fromLookup $ BSON.lookup "ismaster" res) == (1::Int) ||+ isJust (List.elemIndex SlaveOK opts)+ then return c+ else case BSON.lookup "remote" res of+ Nothing -> throwConFailure "Couldn't find master to connect to"+ Just server -> do+ hRef' <- openHandle (splitHostPort $ fromBson server) >>= newIORef+ return $ c {cHandle = hRef'} +openHandle :: (HostName, Network.PortID) -> IO Handle+openHandle (host, port) = do+ h <- Network.connectTo host port+ hSetBuffering h NoBuffering+ return h++getHandle :: Connection -> IO Handle+getHandle c = readIORef $ cHandle c++cPut :: Connection -> L.ByteString -> IO ()+cPut c msg = getHandle c >>= flip L.hPut msg+ -- | Close database connection conClose :: Connection -> IO ()-conClose = hClose . cHandle+conClose c = readIORef (cHandle c) >>= hClose -- | Information about the databases on the server. databasesInfo :: Connection -> IO BsonDoc@@ -107,7 +155,7 @@ databaseNames :: Connection -> IO [Database] databaseNames c = do info <- databasesInfo c- let (BsonArray dbs) = fromJust $ Map.lookup (s2L "databases") info+ let (BsonArray dbs) = fromLookup $ Map.lookup (s2L "databases") info names = mapMaybe (Map.lookup (s2L "name") . fromBson) dbs return $ List.map fromBson (names::[BsonValue]) @@ -121,16 +169,27 @@ _ <- runCommand c db $ toBsonDoc [("dropDatabase", toBson (1::Int))] return () +isMaster :: Connection -> IO BsonDoc+isMaster c = runCommand c (s2L "admin") $ toBsonDoc [("ismaster", BsonInt32 1)]+ -- | 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))] +-- | Shut down the MongoDB server.+--+-- Force a clean exit, flushing and closing all data files.+-- Note that it will wait until all ongoing operations are complete.+serverShutdown :: Connection -> IO BsonDoc+serverShutdown c =+ runCommand c (s2L "admin") $ toBsonDoc [("shutdown", 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 $ fromBson . fromJust . BSON.lookup "name"+ let names = flip List.map docs $ fromBson . fromLookup . BSON.lookup "name" return $ List.filter (L.notElem $ c2w '$') names data ColCreateOpt = CCOSize Int64 -- ^ Desired initial size for the@@ -208,25 +267,32 @@ validateCollection c col = do let (db, col') = splitFullCol col res <- runCommand c db $ toBsonDoc [("validate", toBson col')]- return $ fromBson $ fromJust $ BSON.lookup "result" res+ return $ fromBson $ fromLookup $ BSON.lookup "result" res splitFullCol :: FullCollection -> (Database, Collection) splitFullCol col = (L.takeWhile (c2w '.' /=) col, L.tail $ L.dropWhile (c2w '.' /=) col) +splitHostPort :: String -> (HostName, Network.PortID)+splitHostPort hp = (host, port)+ where host = List.takeWhile (':' /=) hp+ port = case List.dropWhile (':' /=) hp of+ "" -> Network.PortNumber 27017+ pstr -> Network.Service $ List.tail pstr+ -- | 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- when (1 /= (fromBson $ fromJust $ BSON.lookup "ok" res :: Int)) $+ let res = fromLookup mres+ when (1 /= (fromBson $ fromLookup $ BSON.lookup "ok" res :: Int)) $ throwOpFailure $ "command \"" ++ show cmd ++ "\" failed: " ++- fromBson (fromJust $ BSON.lookup "errmsg" res)+ fromBson (fromLookup $ BSON.lookup "errmsg" res) return res --- | An Itertaor over the results of a query. Use 'nextDoc' to get each+-- | An Iterator over the results of a query. Use 'nextDoc' to get each -- successive result document, or 'allDocs' or 'allDocs'' to get lazy or -- strict lists of results. data Cursor = Cursor {@@ -289,6 +355,20 @@ throwOpFailure :: String -> a throwOpFailure = throw . MongoDBOperationFailure +data MongoDBConnectionFailure = MongoDBConnectionFailure String+ deriving (Eq, Show, Read)++mongoDBConnectionFailure :: TyCon+mongoDBConnectionFailure = mkTyCon "Database.MongoDB.MongoDBconnectionFailure"++instance Typeable MongoDBConnectionFailure where+ typeOf _ = mkTyConApp mongoDBConnectionFailure []++instance Exception MongoDBConnectionFailure++throwConFailure :: String -> a+throwConFailure = throw . MongoDBConnectionFailure+ fromOpcode :: Opcode -> Int32 fromOpcode OPReply = 1 fromOpcode OPMsg = 1000@@ -327,16 +407,20 @@ -- | A 'BsonDoc' representing restrictions for a query much like the -- /where/ part of an SQL query. type Selector = BsonDoc+ -- | A list of field names that limits the fields in the returned -- documents. The list can contains zero or more elements, each of -- which is the name of a field that should be returned. An empty list -- means that no limiting is done and all fields are returned. type FieldSelector = [L8.ByteString]+ type RequestID = Int32+ -- | Sets the number of documents to omit - starting from the first -- document in the resulting dataset - when returning the result of -- the query. type NumToSkip = Int32+ -- | This controls how many documents are returned at a time. The -- cursor works by requesting /NumToReturn/ documents, which are then -- immediately all transfered over the network; these are held locally@@ -350,6 +434,9 @@ -- and the way the cursor is being used. type NumToReturn = Int32 +type Username = String+type Password = String+ -- | Options that control the behavior of a 'query' operation. data QueryOpt = QOTailableCursor | QOSlaveOK@@ -383,7 +470,7 @@ let (db, col') = splitFullCol col res <- runCommand c db $ toBsonDoc [("count", toBson col'), ("query", toBson sel)]- return $ fromBson $ fromJust $ BSON.lookup "n" res+ return $ fromBson $ fromLookup $ BSON.lookup "n" res -- | Delete documents matching /Selector/ from the given /FullCollection/. delete :: Connection -> FullCollection -> Selector -> IO RequestID@@ -394,7 +481,7 @@ putI32 0 putBsonDoc sel (reqID, msg) <- packMsg c OPDelete body- L.hPut (cHandle c) msg+ cPut c msg return reqID -- | An alias for 'delete'.@@ -409,7 +496,7 @@ putCol col putBsonDoc doc (reqID, msg) <- packMsg c OPInsert body- L.hPut (cHandle c) msg+ cPut c msg return reqID -- | Insert a list of documents into /FullCollection/.@@ -420,7 +507,7 @@ putCol col forM_ docs putBsonDoc (reqID, msg) <- packMsg c OPInsert body- L.hPut (cHandle c) msg+ cPut c msg return reqID -- | Open a cursor to find documents. If you need full functionality,@@ -430,11 +517,7 @@ -- | Query, but only return the first result, if any. findOne :: Connection -> FullCollection -> Selector -> IO (Maybe BsonDoc)-findOne c col sel = do- cur <- query c col [] 0 (-1) sel []- el <- nextDoc cur- finish cur- return el+findOne c col sel = query c col [] 0 (-1) sel [] >>= nextDoc -- | Perform a query and return the result as a lazy list. Be sure to -- understand the comments about using the lazy list given for@@ -452,7 +535,7 @@ query :: Connection -> FullCollection -> [QueryOpt] -> NumToSkip -> NumToReturn -> Selector -> FieldSelector -> IO Cursor query c col opts nskip ret sel fsel = do- let h = cHandle c+ h <- getHandle c let body = runPut $ do putI32 $ fromQueryOpts opts@@ -495,9 +578,61 @@ putBsonDoc sel putBsonDoc obj (reqID, msg) <- packMsg c OPUpdate body- L.hPut (cHandle c) msg+ cPut c msg return reqID +-- | log into the mongodb /Database/ attached to the /Connection/+login :: Connection -> Database -> Username -> Password -> IO BsonDoc+login c db user pass = do+ doc <- runCommand c db (toBsonDoc [("getnonce", toBson (1 :: Int))])+ let nonce = fromBson $ fromLookup $ BSON.lookup "nonce" doc :: String+ digest = md5sum $ pack $ nonce ++ user +++ md5sum (pack (user ++ ":mongo:" ++ pass))+ request = toBsonDoc [("authenticate", toBson (1 :: Int)),+ ("user", toBson user),+ ("nonce", toBson nonce),+ ("key", toBson digest)]+ in runCommand c db request++auth :: Connection -> Database -> Username -> Password -> IO BsonDoc+auth = login++logout :: Connection -> Database -> IO ()+logout c db =+ runCommand c db (toBsonDoc [(s2L "logout", BsonInt32 1)]) >> return ()++-- | create a new user in the current /Database/+addUser :: Connection -> Database -> Username -> Password -> IO BsonDoc+addUser c db user pass = do+ let userDoc = toBsonDoc [(s2L "user", toBson user)]+ fdb = L.append db (s2L ".system.users")+ doc <- findOne c fdb userDoc+ let pwd = md5sum $ pack (user ++ ":mongo:" ++ pass)+ doc' = Map.insert (s2L "pwd") (toBson pwd) (fromMaybe userDoc doc)+ _ <- save c fdb doc'+ return doc'++-- | Conveniently stores the /BsonDoc/ to the /FullCollection/+-- if there is an _id present in the /BsonDoc/ then it already has+-- a place in the DB, so we update it using the _id, otherwise+-- we insert it+save :: Connection -> FullCollection -> BsonDoc -> IO RequestID+save c fc doc =+ case Map.lookup (s2L "_id") doc of+ Nothing -> insert c fc doc+ Just obj -> update c fc [UFUpsert] (toBsonDoc [("_id", obj)]) doc++-- | Use this in the place of the query portion of a select type query+-- This uses javascript and a scope supplied by a /BsonDoc/ to evaluate+-- documents in the database for retrieval.+--+-- Example:+--+-- > findOne conn mycoll $ whereClause "this.name == (name1 + name2)"+-- > (toBsonDoc [("name1", toBson "mar"), ("name2", toBson "tha")])+whereClause :: String -> BsonDoc -> BsonDoc+whereClause qry scope = toBsonDoc [("$where", BsonCodeWScope (s2L qry) scope)]+ data Hdr = Hdr { hMsgLen :: Int32, -- hReqID :: Int32,@@ -534,7 +669,7 @@ -- | Return one document or Nothing if there are no more.--- Automatically closes the curosr when last document is read+-- Automatically closes the cursor when last document is read nextDoc :: Cursor -> IO (Maybe BsonDoc) nextDoc cur = do closed <- readIORef $ curClosed cur@@ -588,7 +723,7 @@ getMore :: Cursor -> IO (Maybe BsonDoc) getMore cur = do- let h = cHandle $ curCon cur+ h <- getHandle $ curCon cur cid <- readIORef $ curID cur let body = runPut $ do@@ -619,15 +754,16 @@ -- 'allDocs', 'allDocs'', or 'nextDoc'. finish :: Cursor -> IO () finish cur = do- let h = cHandle $ curCon cur+ h <- getHandle $ curCon cur cid <- readIORef $ curID cur- let body = runPut $ do- putI32 0- putI32 1- putI64 cid- (_reqID, msg) <- packMsg (curCon cur) OPKillCursors body- L.hPut h msg- writeIORef (curClosed cur) True+ unless (cid == 0) $ do+ let body = runPut $ do+ putI32 0+ putI32 1+ putI64 cid+ (_reqID, msg) <- packMsg (curCon cur) OPKillCursors body+ L.hPut h msg+ writeIORef (curClosed cur) True return () -- | The field key to index on.@@ -736,3 +872,7 @@ when (L.head col == c2w '.' || L.last col == c2w '.') $ throwColInvalid $ "Collection can't start or end with '.': " ++ show col return (db, col')++fromLookup :: Maybe a -> a+fromLookup (Just m) = m+fromLookup Nothing = throwColInvalid "cannot find key"
Database/MongoDB/BSON.hs view
@@ -73,6 +73,7 @@ | BsonSymbol L8.ByteString | BsonInt32 Int32 | BsonInt64 Int64+ | BsonCodeWScope L8.ByteString BsonDoc | BsonMinKey | BsonMaxKey deriving (Show, Eq, Ord)@@ -195,7 +196,11 @@ sLen1 <- getI32 (_sLen2, s) <- getS return (fromIntegral $ 4 + sLen1, BsonString s)-getVal DataCodeWScope = fail "DataCodeWScope not yet supported" -- TODO+getVal DataCodeWScope = do+ sLen1 <- getI32+ (_, qry) <- getS+ (_, scope) <- getDoc+ return (fromIntegral sLen1, BsonCodeWScope qry scope) getVal DataInt = liftM ((,) 4 . BsonInt32 . fromIntegral) getI32 getVal DataTimestamp = fail "DataTimestamp not yet supported" -- TODO @@ -240,7 +245,7 @@ -- putType = putDataType DataRef -- putType = putDataType DataCode putType BsonSymbol{} = putDataType DataSymbol--- putType = putDataType DataCodeWScope+putType BsonCodeWScope{} = putDataType DataCodeWScope putType BsonInt32 {} = putDataType DataInt putType BsonInt64 {} = putDataType DataLong -- putType = putDataType DataTimestamp@@ -249,7 +254,7 @@ putVal :: BsonValue -> Put putVal (BsonDouble d) = putFloat64le d-putVal (BsonString s) = putI32 (fromIntegral $ 1 + L8.length s) >> putS s+putVal (BsonString s) = putStrSz s putVal (BsonObject o) = putObj o putVal (BsonArray es) = putOutterObj bs where bs = runPut $ forM_ (List.zip [(0::Int) .. ] es) $ \(i, e) ->@@ -270,6 +275,9 @@ putVal (BsonSymbol s) = putI32 (fromIntegral $ 1 + L8.length s) >> putS s putVal (BsonInt32 i) = putI32 i putVal (BsonInt64 i) = putI64 i+putVal (BsonCodeWScope q s) =+ let bytes = runPut (putStrSz q >> putObj s)+ in putI32 ((+4) $ fromIntegral $ L.length bytes) >> putLazyByteString bytes putVal BsonMinKey = putNothing putVal BsonMaxKey = putNothing
Database/MongoDB/Util.hs view
@@ -26,7 +26,7 @@ module Database.MongoDB.Util ( putI8, putI32, putI64, putNothing, putNull, putS,- getI8, getI32, getI64, getC, getS, getNull,+ getI8, getI32, getI64, getC, getS, getNull, putStrSz, ) where import Control.Exception (assert)@@ -75,3 +75,6 @@ putS :: L8.ByteString -> Put putS s = putLazyByteString s >> putNull++putStrSz :: L.ByteString -> Put+putStrSz s = putI32 (fromIntegral $ 1 + L8.length s) >> putS s
mongoDB.cabal view
@@ -1,5 +1,5 @@ Name: mongoDB-Version: 0.2+Version: 0.3 License: MIT Maintainer: Scott Parish <srp@srparish.net> Author: Scott Parish <srp@srparish.net>@@ -21,7 +21,8 @@ network, random, time,- utf8-string+ utf8-string,+ nano-md5 Build-Type: Simple Exposed-modules: Database.MongoDB, Database.MongoDB.BSON