Fix compile warnings
This commit is contained in:
parent
de32b22b4f
commit
583f8330c7
8 changed files with 56 additions and 42 deletions
|
@ -47,8 +47,8 @@ class (MonadIO m) => MonadMVar m where
|
||||||
|
|
||||||
modifyMVar_ :: (MonadMVar m) => MVar a -> (a -> m a) -> m ()
|
modifyMVar_ :: (MonadMVar m) => MVar a -> (a -> m a) -> m ()
|
||||||
modifyMVar_ var act = modifyMVar var $ \a -> do
|
modifyMVar_ var act = modifyMVar var $ \a -> do
|
||||||
a <- act a
|
a' <- act a
|
||||||
return (a, ())
|
return (a', ())
|
||||||
|
|
||||||
withMVar :: (MonadMVar m) => MVar a -> (a -> m b) -> m b
|
withMVar :: (MonadMVar m) => MVar a -> (a -> m b) -> m b
|
||||||
withMVar var act = modifyMVar var $ \a -> do
|
withMVar var act = modifyMVar var $ \a -> do
|
||||||
|
@ -73,7 +73,7 @@ instance (MonadMVar m) => MonadMVar (ReaderT r m) where
|
||||||
|
|
||||||
instance (MonadMVar m) => MonadMVar (StateT s m) where
|
instance (MonadMVar m) => MonadMVar (StateT s m) where
|
||||||
modifyMVar var f = StateT $ \s -> modifyMVar var $ \a -> do
|
modifyMVar var f = StateT $ \s -> modifyMVar var $ \a -> do
|
||||||
((a, b), s) <- runStateT (f a) s
|
((a', b), s') <- runStateT (f a) s
|
||||||
return (a, (b, s))
|
return (a', (b, s'))
|
||||||
addMVarFinalizer var (StateT act) = StateT $ \s ->
|
addMVarFinalizer var (StateT act) = StateT $ \s ->
|
||||||
addMVarFinalizer var (act s >> return ()) >> return ((), s)
|
addMVarFinalizer var (act s >> return ()) >> return ((), s)
|
||||||
|
|
|
@ -29,7 +29,7 @@ loop act = act >>= maybe (return []) (\a -> (a :) <$> loop act)
|
||||||
|
|
||||||
untilJust :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
|
untilJust :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
|
||||||
-- ^ Apply action to elements one at a time until one returns Just. Return Nothing if all return Nothing.
|
-- ^ Apply action to elements one at a time until one returns Just. Return Nothing if all return Nothing.
|
||||||
untilJust f [] = return Nothing
|
untilJust _ [] = return Nothing
|
||||||
untilJust f (a:as) = f a >>= maybe (untilJust f as) (return . Just)
|
untilJust f (a:as) = f a >>= maybe (untilJust f as) (return . Just)
|
||||||
|
|
||||||
untilSuccess :: (MonadError e m, Error e) => (a -> m b) -> [a] -> m b
|
untilSuccess :: (MonadError e m, Error e) => (a -> m b) -> [a] -> m b
|
||||||
|
@ -38,7 +38,7 @@ untilSuccess = untilSuccess' (strMsg "empty untilSuccess")
|
||||||
|
|
||||||
untilSuccess' :: (MonadError e m) => e -> (a -> m b) -> [a] -> m b
|
untilSuccess' :: (MonadError e m) => e -> (a -> m b) -> [a] -> m b
|
||||||
-- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw given error if list is empty
|
-- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw given error if list is empty
|
||||||
untilSuccess' e f [] = throwError e
|
untilSuccess' e _ [] = throwError e
|
||||||
untilSuccess' _ f (x : xs) = catchError (f x) (\e -> untilSuccess' e f xs)
|
untilSuccess' _ f (x : xs) = catchError (f x) (\e -> untilSuccess' e f xs)
|
||||||
|
|
||||||
mapError :: (Functor m) => (e' -> e) -> ErrorT e' m a -> ErrorT e m a
|
mapError :: (Functor m) => (e' -> e) -> ErrorT e' m a -> ErrorT e m a
|
||||||
|
|
|
@ -191,8 +191,9 @@ removeUser user = delete (select ["user" =: user] "system.users")
|
||||||
|
|
||||||
-- ** Database
|
-- ** Database
|
||||||
|
|
||||||
admin = Database "admin"
|
admin :: Database
|
||||||
-- ^ \"admin\" database
|
-- ^ \"admin\" database
|
||||||
|
admin = Database "admin"
|
||||||
|
|
||||||
cloneDatabase :: (Access m) => Database -> Host -> m Document
|
cloneDatabase :: (Access m) => Database -> Host -> m Document
|
||||||
-- ^ Copy database from given host to the server I am connected to. Fails and returns @"ok" = 0@ if we don't have permission to read from given server (use copyDatabase in this case).
|
-- ^ Copy database from given host to the server I am connected to. Fails and returns @"ok" = 0@ if we don't have permission to read from given server (use copyDatabase in this case).
|
||||||
|
|
|
@ -10,25 +10,23 @@ module Database.MongoDB.Connection (
|
||||||
-- * MasterOrSlaveOk
|
-- * MasterOrSlaveOk
|
||||||
MasterOrSlaveOk(..),
|
MasterOrSlaveOk(..),
|
||||||
-- * Connection
|
-- * Connection
|
||||||
Server(..),
|
Server(..), replicaSet
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Database.MongoDB.Internal.Protocol
|
import Database.MongoDB.Internal.Protocol
|
||||||
import Data.Bson ((=:), at, UString)
|
import Data.Bson ((=:), at, UString)
|
||||||
import Control.Pipeline (Resource(..))
|
import Control.Pipeline (Resource(..))
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
import Control.Arrow ((+++), left)
|
|
||||||
import Control.Exception (assert)
|
import Control.Exception (assert)
|
||||||
import System.IO.Error as E (try, mkIOError, userErrorType)
|
import System.IO.Error as E (try)
|
||||||
import Control.Monad.Error
|
import Control.Monad.Error
|
||||||
import Control.Monad.Throw (throw, onException)
|
|
||||||
import Control.Monad.MVar
|
import Control.Monad.MVar
|
||||||
import Network (HostName, PortID(..), connectTo)
|
import Network (HostName, PortID(..), connectTo)
|
||||||
import Data.Bson (Document, look, typed)
|
import Data.Bson (Document, look)
|
||||||
import Text.ParserCombinators.Parsec as T (parse, many1, letter, digit, char, eof, spaces, try, (<|>))
|
import Text.ParserCombinators.Parsec as T (parse, many1, letter, digit, char, eof, spaces, try, (<|>))
|
||||||
import Control.Monad.Identity
|
import Control.Monad.Identity
|
||||||
import Control.Monad.Util (MonadIO', untilSuccess)
|
import Control.Monad.Util (MonadIO', untilSuccess)
|
||||||
import Database.MongoDB.Internal.Util (true1) -- PortID instances
|
import Database.MongoDB.Internal.Util () -- PortID instances
|
||||||
import Var.Pool
|
import Var.Pool
|
||||||
import System.Random (newStdGen, randomRs)
|
import System.Random (newStdGen, randomRs)
|
||||||
import Data.List (delete, find, nub)
|
import Data.List (delete, find, nub)
|
||||||
|
@ -100,20 +98,20 @@ getReplicaInfo :: Pipe -> ErrorT IOError IO ReplicaInfo
|
||||||
getReplicaInfo pipe = do
|
getReplicaInfo pipe = do
|
||||||
promise <- call pipe [] (adminCommand ["ismaster" =: (1 :: Int)])
|
promise <- call pipe [] (adminCommand ["ismaster" =: (1 :: Int)])
|
||||||
info <- commandReply "ismaster" <$> promise
|
info <- commandReply "ismaster" <$> promise
|
||||||
look "hosts" info
|
_ <- look "hosts" info
|
||||||
look "primary" info
|
_ <- look "primary" info
|
||||||
return info
|
return info
|
||||||
|
|
||||||
type ReplicaInfo = Document
|
type ReplicaInfo = Document
|
||||||
-- ^ Configuration info of a host in a replica set. Contains all the hosts in the replica set plus its role in that set (master, slave, or arbiter)
|
-- ^ Configuration info of a host in a replica set. Contains all the hosts in the replica set plus its role in that set (master, slave, or arbiter)
|
||||||
|
|
||||||
isPrimary :: ReplicaInfo -> Bool
|
{- isPrimary :: ReplicaInfo -> Bool
|
||||||
-- ^ Is the replica described by this info a master/primary (not slave or arbiter)?
|
-- ^ Is the replica described by this info a master/primary (not slave or arbiter)?
|
||||||
isPrimary = true1 "ismaster"
|
isPrimary = true1 "ismaster"
|
||||||
|
|
||||||
isSecondary :: ReplicaInfo -> Bool
|
isSecondary :: ReplicaInfo -> Bool
|
||||||
-- ^ Is the replica described by this info a slave/secondary (not master or arbiter)
|
-- ^ Is the replica described by this info a slave/secondary (not master or arbiter)
|
||||||
isSecondary = true1 "secondary"
|
isSecondary = true1 "secondary" -}
|
||||||
|
|
||||||
replicas :: ReplicaInfo -> [Host]
|
replicas :: ReplicaInfo -> [Host]
|
||||||
-- ^ All replicas in set according to this replica configuration info.
|
-- ^ All replicas in set according to this replica configuration info.
|
||||||
|
@ -136,10 +134,10 @@ data MasterOrSlaveOk =
|
||||||
| SlaveOk -- ^ connect to a slave, or master if no slave available
|
| SlaveOk -- ^ connect to a slave, or master if no slave available
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
isMS :: MasterOrSlaveOk -> ReplicaInfo -> Bool
|
{- isMS :: MasterOrSlaveOk -> ReplicaInfo -> Bool
|
||||||
-- ^ Does the host (as described by its replica-info) match the master/slave type
|
-- ^ Does the host (as described by its replica-info) match the master/slave type
|
||||||
isMS Master i = isPrimary i
|
isMS Master i = isPrimary i
|
||||||
isMS SlaveOk i = isSecondary i || isPrimary i
|
isMS SlaveOk i = isSecondary i || isPrimary i -}
|
||||||
|
|
||||||
-- * Connection
|
-- * Connection
|
||||||
|
|
||||||
|
@ -161,7 +159,7 @@ class Server t where
|
||||||
instance Server Host where
|
instance Server Host where
|
||||||
data Connection Host = HostConnection {connHost :: Host, connPool :: Pool' Pipe}
|
data Connection Host = HostConnection {connHost :: Host, connPool :: Pool' Pipe}
|
||||||
-- ^ A pool of TCP connections ('Pipe's) to a server, handed out in round-robin style.
|
-- ^ A pool of TCP connections ('Pipe's) to a server, handed out in round-robin style.
|
||||||
connect poolSize host = liftIO (connectHost poolSize host)
|
connect poolSize' host' = liftIO (connectHost poolSize' host')
|
||||||
-- ^ Create a Connection (pool of TCP connections) to server (host or replica set)
|
-- ^ Create a Connection (pool of TCP connections) to server (host or replica set)
|
||||||
getPipe _ = getHostPipe
|
getPipe _ = getHostPipe
|
||||||
-- ^ Return a TCP connection (Pipe). If SlaveOk, connect to a slave if available. Round-robin if multiple slaves are available. Throw IOError if failed to connect.
|
-- ^ Return a TCP connection (Pipe). If SlaveOk, connect to a slave if available. Round-robin if multiple slaves are available. Throw IOError if failed to connect.
|
||||||
|
@ -169,8 +167,8 @@ instance Server Host where
|
||||||
|
|
||||||
connectHost :: Int -> Host -> IO (Connection Host)
|
connectHost :: Int -> Host -> IO (Connection Host)
|
||||||
-- ^ Create a pool of N 'Pipe's (TCP connections) to server. 'getHostPipe' will return one of those pipes, round-robin style.
|
-- ^ Create a pool of N 'Pipe's (TCP connections) to server. 'getHostPipe' will return one of those pipes, round-robin style.
|
||||||
connectHost poolSize host = HostConnection host <$> newPool Factory{..} poolSize where
|
connectHost poolSize' host' = HostConnection host' <$> newPool Factory{..} poolSize' where
|
||||||
newResource = tcpConnect host
|
newResource = tcpConnect host'
|
||||||
killResource = close
|
killResource = close
|
||||||
isExpired = isClosed
|
isExpired = isClosed
|
||||||
|
|
||||||
|
@ -188,7 +186,7 @@ instance Server ReplicaSet where
|
||||||
data Connection ReplicaSet = ReplicaSetConnection {
|
data Connection ReplicaSet = ReplicaSetConnection {
|
||||||
repsetName :: Name,
|
repsetName :: Name,
|
||||||
currentMembers :: MVar [Connection Host] } -- master at head after a refresh
|
currentMembers :: MVar [Connection Host] } -- master at head after a refresh
|
||||||
connect poolSize repset = liftIO (connectSet poolSize repset)
|
connect poolSize' repset = liftIO (connectSet poolSize' repset)
|
||||||
getPipe = getSetPipe
|
getPipe = getSetPipe
|
||||||
killPipes ReplicaSetConnection{..} = withMVar currentMembers (mapM_ killPipes)
|
killPipes ReplicaSetConnection{..} = withMVar currentMembers (mapM_ killPipes)
|
||||||
|
|
||||||
|
@ -198,14 +196,14 @@ replicaSet ReplicaSetConnection{..} = ReplicaSet repsetName . map connHost <$> r
|
||||||
|
|
||||||
connectSet :: Int -> ReplicaSet -> IO (Connection ReplicaSet)
|
connectSet :: Int -> ReplicaSet -> IO (Connection ReplicaSet)
|
||||||
-- ^ Create a connection to each member of the replica set.
|
-- ^ Create a connection to each member of the replica set.
|
||||||
connectSet poolSize repset = assert (not . null $ seedHosts repset) $ do
|
connectSet poolSize' repset = assert (not . null $ seedHosts repset) $ do
|
||||||
currentMembers <- newMVar =<< mapM (connect poolSize) (seedHosts repset)
|
currentMembers <- newMVar =<< mapM (connect poolSize') (seedHosts repset)
|
||||||
return $ ReplicaSetConnection (setName repset) currentMembers
|
return $ ReplicaSetConnection (setName repset) currentMembers
|
||||||
|
|
||||||
getMembers :: Name -> [Connection Host] -> ErrorT IOError IO [Host]
|
getMembers :: Name -> [Connection Host] -> ErrorT IOError IO [Host]
|
||||||
-- ^ Get members of replica set, master first. Query supplied connections until config found.
|
-- ^ Get members of replica set, master first. Query supplied connections until config found.
|
||||||
-- TODO: Verify config for request replica set name and not some other replica set. ismaster config should include replica set name in result but currently does not.
|
-- TODO: Verify config for request replica set name and not some other replica set. ismaster config should include replica set name in result but currently does not.
|
||||||
getMembers repsetName connections = hosts <$> untilSuccess (getReplicaInfo <=< getHostPipe) connections
|
getMembers _repsetName connections = hosts <$> untilSuccess (getReplicaInfo <=< getHostPipe) connections
|
||||||
|
|
||||||
refreshMembers :: Name -> [Connection Host] -> ErrorT IOError IO [Connection Host]
|
refreshMembers :: Name -> [Connection Host] -> ErrorT IOError IO [Connection Host]
|
||||||
-- ^ Update current members with master at head. Reuse unchanged members. Throw IOError if can't connect to any and fetch config. Dropped connections are not closed in case they still have users; they will be closed when garbage collected.
|
-- ^ Update current members with master at head. Reuse unchanged members. Throw IOError if can't connect to any and fetch config. Dropped connections are not closed in case they still have users; they will be closed when garbage collected.
|
||||||
|
@ -213,12 +211,12 @@ refreshMembers repsetName connections = do
|
||||||
n <- liftIO . poolSize . connPool $ head connections
|
n <- liftIO . poolSize . connPool $ head connections
|
||||||
mapM (connection n) =<< getMembers repsetName connections
|
mapM (connection n) =<< getMembers repsetName connections
|
||||||
where
|
where
|
||||||
connection n host = maybe (connect n host) return $ find ((host ==) . connHost) connections
|
connection n host' = maybe (connect n host') return $ find ((host' ==) . connHost) connections
|
||||||
|
|
||||||
getSetPipe :: MasterOrSlaveOk -> Connection ReplicaSet -> ErrorT IOError IO Pipe
|
getSetPipe :: MasterOrSlaveOk -> Connection ReplicaSet -> ErrorT IOError IO Pipe
|
||||||
-- ^ Return a pipe to primary or a random secondary in replica set. Use primary for SlaveOk if and only if no secondaries. Note, refreshes members each time (makes ismaster call to primary).
|
-- ^ Return a pipe to primary or a random secondary in replica set. Use primary for SlaveOk if and only if no secondaries. Note, refreshes members each time (makes ismaster call to primary).
|
||||||
getSetPipe mos ReplicaSetConnection{..} = modifyMVar currentMembers $ \connections -> do
|
getSetPipe mos ReplicaSetConnection{..} = modifyMVar currentMembers $ \conns -> do
|
||||||
connections <- refreshMembers repsetName connections -- master at head after refresh
|
connections <- refreshMembers repsetName conns -- master at head after refresh
|
||||||
pipe <- case mos of
|
pipe <- case mos of
|
||||||
Master -> getHostPipe (head connections)
|
Master -> getHostPipe (head connections)
|
||||||
SlaveOk -> do
|
SlaveOk -> do
|
||||||
|
|
|
@ -22,7 +22,6 @@ module Database.MongoDB.Internal.Protocol (
|
||||||
|
|
||||||
import Prelude as X
|
import Prelude as X
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
import Control.Monad (unless, replicateM)
|
|
||||||
import System.IO (Handle)
|
import System.IO (Handle)
|
||||||
import Data.ByteString.Lazy (ByteString)
|
import Data.ByteString.Lazy (ByteString)
|
||||||
import qualified Control.Pipeline as P
|
import qualified Control.Pipeline as P
|
||||||
|
@ -39,7 +38,6 @@ import Data.Digest.OpenSSL.MD5 (md5sum)
|
||||||
import Data.UString as U (pack, append, toByteString)
|
import Data.UString as U (pack, append, toByteString)
|
||||||
import System.IO.Error as E (try)
|
import System.IO.Error as E (try)
|
||||||
import Control.Monad.Error
|
import Control.Monad.Error
|
||||||
import Control.Monad.Trans (MonadIO(..))
|
|
||||||
|
|
||||||
-- * Pipe
|
-- * Pipe
|
||||||
|
|
||||||
|
|
|
@ -46,7 +46,6 @@ import Control.Monad.Context
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Control.Monad.Error
|
import Control.Monad.Error
|
||||||
import Control.Monad.Throw
|
import Control.Monad.Throw
|
||||||
import System.IO.Error (try)
|
|
||||||
import Control.Concurrent.MVar
|
import Control.Concurrent.MVar
|
||||||
import Control.Pipeline (Resource(..))
|
import Control.Pipeline (Resource(..))
|
||||||
import qualified Database.MongoDB.Internal.Protocol as P
|
import qualified Database.MongoDB.Internal.Protocol as P
|
||||||
|
|
|
@ -4,7 +4,7 @@
|
||||||
|
|
||||||
module Var.Pool where
|
module Var.Pool where
|
||||||
|
|
||||||
import Control.Applicative ((<$>), (<*>))
|
import Control.Applicative ((<$>))
|
||||||
import Control.Monad.MVar
|
import Control.Monad.MVar
|
||||||
import Data.Array.IO
|
import Data.Array.IO
|
||||||
import Data.Maybe (catMaybes)
|
import Data.Maybe (catMaybes)
|
||||||
|
@ -52,8 +52,8 @@ resize :: Pool e r -> Int -> IO ()
|
||||||
-- ^ resize max size of pool. When shrinking some resource will be dropped without closing since they may still be in use. They are expected to close themselves when garbage collected.
|
-- ^ resize max size of pool. When shrinking some resource will be dropped without closing since they may still be in use. They are expected to close themselves when garbage collected.
|
||||||
resize Pool{resources} n = modifyMVar_ resources $ \array -> do
|
resize Pool{resources} n = modifyMVar_ resources $ \array -> do
|
||||||
rs <- take n <$> getElems array
|
rs <- take n <$> getElems array
|
||||||
array <- newListArray (0, n-1) (rs ++ repeat Nothing)
|
array' <- newListArray (0, n-1) (rs ++ repeat Nothing)
|
||||||
return array
|
return array'
|
||||||
|
|
||||||
killAll :: Pool e r -> IO ()
|
killAll :: Pool e r -> IO ()
|
||||||
-- ^ Kill all resources in pool so subsequent access creates new ones
|
-- ^ Kill all resources in pool so subsequent access creates new ones
|
||||||
|
|
|
@ -6,9 +6,18 @@ license: OtherLicense
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
copyright: Copyright (c) 2010-2010 Scott Parish & 10gen Inc.
|
copyright: Copyright (c) 2010-2010 Scott Parish & 10gen Inc.
|
||||||
maintainer: Tony Hannan <tony@10gen.com>
|
maintainer: Tony Hannan <tony@10gen.com>
|
||||||
build-depends: array -any, base <5, binary -any, bson -any,
|
build-depends:
|
||||||
bytestring -any, containers -any, mtl -any, nano-md5 -any,
|
array -any,
|
||||||
network -any, parsec -any
|
base <5,
|
||||||
|
binary -any,
|
||||||
|
bson -any,
|
||||||
|
bytestring -any,
|
||||||
|
containers -any,
|
||||||
|
mtl -any,
|
||||||
|
nano-md5 -any,
|
||||||
|
network -any,
|
||||||
|
parsec -any,
|
||||||
|
random -any
|
||||||
stability: alpha
|
stability: alpha
|
||||||
homepage: http://github.com/TonyGen/mongoDB-haskell
|
homepage: http://github.com/TonyGen/mongoDB-haskell
|
||||||
package-url:
|
package-url:
|
||||||
|
@ -22,10 +31,19 @@ data-files:
|
||||||
data-dir: ""
|
data-dir: ""
|
||||||
extra-source-files:
|
extra-source-files:
|
||||||
extra-tmp-files:
|
extra-tmp-files:
|
||||||
exposed-modules: Control.Pipeline Control.Monad.Context
|
exposed-modules:
|
||||||
Control.Monad.Throw Database.MongoDB Database.MongoDB.Admin
|
Control.Monad.Context
|
||||||
Database.MongoDB.Connection Database.MongoDB.Query
|
Control.Monad.MVar
|
||||||
Database.MongoDB.Internal.Protocol Database.MongoDB.Internal.Util
|
Control.Monad.Throw
|
||||||
|
Control.Monad.Util
|
||||||
|
Control.Pipeline
|
||||||
|
Database.MongoDB
|
||||||
|
Database.MongoDB.Admin
|
||||||
|
Database.MongoDB.Connection
|
||||||
|
Database.MongoDB.Internal.Protocol
|
||||||
|
Database.MongoDB.Internal.Util
|
||||||
|
Database.MongoDB.Query
|
||||||
|
Var.Pool
|
||||||
exposed: True
|
exposed: True
|
||||||
buildable: True
|
buildable: True
|
||||||
build-tools:
|
build-tools:
|
||||||
|
|
Loading…
Reference in a new issue