automatically find and connect to master
This commit is contained in:
parent
b3581b5209
commit
f1fdc0f13b
2 changed files with 51 additions and 30 deletions
|
@ -28,7 +28,7 @@ module Database.MongoDB
|
||||||
-- * Connection
|
-- * Connection
|
||||||
Connection,
|
Connection,
|
||||||
connect, connectOnPort, conClose, disconnect, dropDatabase,
|
connect, connectOnPort, conClose, disconnect, dropDatabase,
|
||||||
connectCluster, connectClusterOnPort, setTarget,
|
connectCluster, connectClusterOnPort,
|
||||||
serverInfo, serverShutdown,
|
serverInfo, serverShutdown,
|
||||||
databasesInfo, databaseNames,
|
databasesInfo, databaseNames,
|
||||||
-- * Database
|
-- * Database
|
||||||
|
@ -84,9 +84,10 @@ import System.IO.Unsafe
|
||||||
import System.Random
|
import System.Random
|
||||||
|
|
||||||
-- | A list of handles to database connections
|
-- | A list of handles to database connections
|
||||||
data Connection = Connection { cHandles :: [Handle]
|
data Connection = Connection {
|
||||||
,cIndex :: IORef Int
|
cHandle :: IORef Handle,
|
||||||
,cRand :: IORef [Int] }
|
cRand :: IORef [Int]
|
||||||
|
}
|
||||||
|
|
||||||
-- | Establish a connection to a MongoDB server
|
-- | Establish a connection to a MongoDB server
|
||||||
connect :: HostName -> IO Connection
|
connect :: HostName -> IO Connection
|
||||||
|
@ -100,47 +101,44 @@ connectCluster xs =
|
||||||
-- | Establish connections to a list of MongoDB servers specifying each port.
|
-- | Establish connections to a list of MongoDB servers specifying each port.
|
||||||
connectClusterOnPort :: [(HostName, Network.PortID)] -> IO Connection
|
connectClusterOnPort :: [(HostName, Network.PortID)] -> IO Connection
|
||||||
connectClusterOnPort [] = throwOpFailure "No hostnames in list"
|
connectClusterOnPort [] = throwOpFailure "No hostnames in list"
|
||||||
connectClusterOnPort xs = newConnection >>= flip connectAll xs
|
connectClusterOnPort servers = newConnection servers
|
||||||
|
|
||||||
connectAll :: Connection -> [(HostName, Network.PortID)] -> IO Connection
|
|
||||||
connectAll c [] = return c
|
|
||||||
connectAll c ((host, port) : xs) = do
|
|
||||||
h <- Network.connectTo host port
|
|
||||||
hSetBuffering h NoBuffering
|
|
||||||
connectAll (c {cHandles = h : cHandles c}) xs
|
|
||||||
|
|
||||||
-- | Establish a connection to a MongoDB server on a non-standard port
|
-- | Establish a connection to a MongoDB server on a non-standard port
|
||||||
connectOnPort :: HostName -> Network.PortID -> IO Connection
|
connectOnPort :: HostName -> Network.PortID -> IO Connection
|
||||||
connectOnPort host port = do
|
connectOnPort host port = newConnection [(host, port)]
|
||||||
c <- newConnection
|
|
||||||
connectAll c [(host, port)]
|
|
||||||
|
|
||||||
newConnection :: IO Connection
|
newConnection :: [(HostName, Network.PortID)] -> IO Connection
|
||||||
newConnection = do
|
newConnection servers = do
|
||||||
r <- newStdGen
|
r <- newStdGen
|
||||||
let ns = randomRs (fromIntegral (minBound :: Int32),
|
let ns = randomRs (fromIntegral (minBound :: Int32),
|
||||||
fromIntegral (maxBound :: Int32)) r
|
fromIntegral (maxBound :: Int32)) r
|
||||||
nsRef <- newIORef ns
|
nsRef <- newIORef ns
|
||||||
nsIdx <- newIORef 0
|
hRef <- openHandle (head servers) >>= newIORef
|
||||||
return $ Connection [] nsIdx nsRef
|
let c = Connection hRef nsRef
|
||||||
|
res <- isMaster c
|
||||||
|
if fromBson (fromLookup $ BSON.lookup "ismaster" res) == (1::Int)
|
||||||
|
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 :: Connection -> IO Handle
|
||||||
getHandle c = do
|
getHandle c = readIORef $ cHandle c
|
||||||
i <- readIORef $ cIndex c
|
|
||||||
return $ cHandles c !! i
|
|
||||||
|
|
||||||
cPut :: Connection -> L.ByteString -> IO ()
|
cPut :: Connection -> L.ByteString -> IO ()
|
||||||
cPut c msg = getHandle c >>= flip L.hPut msg
|
cPut c msg = getHandle c >>= flip L.hPut msg
|
||||||
|
|
||||||
-- | Close database connection
|
-- | Close database connection
|
||||||
conClose :: Connection -> IO ()
|
conClose :: Connection -> IO ()
|
||||||
conClose c = mapM_ hClose $ cHandles c
|
conClose c = readIORef (cHandle c) >>= hClose
|
||||||
|
|
||||||
setTarget :: Connection -> Int -> IO ()
|
|
||||||
setTarget c i =
|
|
||||||
if i > length (cHandles c)
|
|
||||||
then throwOpFailure "Target index higher than length of list"
|
|
||||||
else writeIORef (cIndex c) i >> return ()
|
|
||||||
|
|
||||||
-- | Information about the databases on the server.
|
-- | Information about the databases on the server.
|
||||||
databasesInfo :: Connection -> IO BsonDoc
|
databasesInfo :: Connection -> IO BsonDoc
|
||||||
|
@ -165,6 +163,9 @@ dropDatabase c db = do
|
||||||
_ <- runCommand c db $ toBsonDoc [("dropDatabase", toBson (1::Int))]
|
_ <- runCommand c db $ toBsonDoc [("dropDatabase", toBson (1::Int))]
|
||||||
return ()
|
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.
|
-- | Get information about the MongoDB server we're connected to.
|
||||||
serverInfo :: Connection -> IO BsonDoc
|
serverInfo :: Connection -> IO BsonDoc
|
||||||
serverInfo c =
|
serverInfo c =
|
||||||
|
@ -266,6 +267,10 @@ splitFullCol :: FullCollection -> (Database, Collection)
|
||||||
splitFullCol col = (L.takeWhile (c2w '.' /=) col,
|
splitFullCol col = (L.takeWhile (c2w '.' /=) col,
|
||||||
L.tail $ L.dropWhile (c2w '.' /=) col)
|
L.tail $ L.dropWhile (c2w '.' /=) col)
|
||||||
|
|
||||||
|
splitHostPort :: String -> (HostName, Network.PortID)
|
||||||
|
splitHostPort hp = (List.takeWhile (':' /=) hp,
|
||||||
|
Network.Service $ List.tail $ List.dropWhile (':' /=) hp)
|
||||||
|
|
||||||
-- | Run a database command. Usually this is unneeded as driver wraps
|
-- | Run a database command. Usually this is unneeded as driver wraps
|
||||||
-- all of the commands for you (eg 'createCollection',
|
-- all of the commands for you (eg 'createCollection',
|
||||||
-- 'dropCollection', etc).
|
-- 'dropCollection', etc).
|
||||||
|
@ -341,6 +346,20 @@ instance Exception MongoDBOperationFailure
|
||||||
throwOpFailure :: String -> a
|
throwOpFailure :: String -> a
|
||||||
throwOpFailure = throw . MongoDBOperationFailure
|
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 :: Opcode -> Int32
|
||||||
fromOpcode OPReply = 1
|
fromOpcode OPReply = 1
|
||||||
fromOpcode OPMsg = 1000
|
fromOpcode OPMsg = 1000
|
||||||
|
|
4
TODO
4
TODO
|
@ -19,6 +19,9 @@ MongoDB
|
||||||
- hint, explain, $where
|
- hint, explain, $where
|
||||||
- database profiling: set/get profiling level, get profiling info
|
- database profiling: set/get profiling level, get profiling info
|
||||||
- pair mode connection
|
- pair mode connection
|
||||||
|
- allow connecting only to slave
|
||||||
|
- handle defunct servers
|
||||||
|
- connection fail over
|
||||||
- operations on database objects
|
- operations on database objects
|
||||||
* getName
|
* getName
|
||||||
* getCollection
|
* getCollection
|
||||||
|
@ -27,7 +30,6 @@ MongoDB
|
||||||
* error
|
* error
|
||||||
* eval
|
* eval
|
||||||
* last_status
|
* last_status
|
||||||
* logout
|
|
||||||
* reset_error_history
|
* reset_error_history
|
||||||
- database admin
|
- database admin
|
||||||
* getAdmin
|
* getAdmin
|
||||||
|
|
Loading…
Reference in a new issue