Fix compile warnings

This commit is contained in:
Tony Hannan 2010-10-27 16:46:11 -04:00
parent de32b22b4f
commit 583f8330c7
8 changed files with 56 additions and 42 deletions

View file

@ -47,8 +47,8 @@ class (MonadIO m) => MonadMVar m where
modifyMVar_ :: (MonadMVar m) => MVar a -> (a -> m a) -> m ()
modifyMVar_ var act = modifyMVar var $ \a -> do
a <- act a
return (a, ())
a' <- act a
return (a', ())
withMVar :: (MonadMVar m) => MVar a -> (a -> m b) -> m b
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
modifyMVar var f = StateT $ \s -> modifyMVar var $ \a -> do
((a, b), s) <- runStateT (f a) s
return (a, (b, s))
((a', b), s') <- runStateT (f a) s
return (a', (b, s'))
addMVarFinalizer var (StateT act) = StateT $ \s ->
addMVarFinalizer var (act s >> return ()) >> return ((), s)

View file

@ -29,7 +29,7 @@ loop act = act >>= maybe (return []) (\a -> (a :) <$> loop act)
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.
untilJust f [] = return Nothing
untilJust _ [] = return Nothing
untilJust f (a:as) = f a >>= maybe (untilJust f as) (return . Just)
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
-- ^ 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)
mapError :: (Functor m) => (e' -> e) -> ErrorT e' m a -> ErrorT e m a

View file

@ -191,8 +191,9 @@ removeUser user = delete (select ["user" =: user] "system.users")
-- ** Database
admin = Database "admin"
admin :: Database
-- ^ \"admin\" database
admin = Database "admin"
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).

View file

@ -10,25 +10,23 @@ module Database.MongoDB.Connection (
-- * MasterOrSlaveOk
MasterOrSlaveOk(..),
-- * Connection
Server(..),
Server(..), replicaSet
) where
import Database.MongoDB.Internal.Protocol
import Data.Bson ((=:), at, UString)
import Control.Pipeline (Resource(..))
import Control.Applicative ((<$>))
import Control.Arrow ((+++), left)
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.Throw (throw, onException)
import Control.Monad.MVar
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 Control.Monad.Identity
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 System.Random (newStdGen, randomRs)
import Data.List (delete, find, nub)
@ -100,20 +98,20 @@ getReplicaInfo :: Pipe -> ErrorT IOError IO ReplicaInfo
getReplicaInfo pipe = do
promise <- call pipe [] (adminCommand ["ismaster" =: (1 :: Int)])
info <- commandReply "ismaster" <$> promise
look "hosts" info
look "primary" info
_ <- look "hosts" info
_ <- look "primary" info
return info
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)
isPrimary :: ReplicaInfo -> Bool
{- isPrimary :: ReplicaInfo -> Bool
-- ^ Is the replica described by this info a master/primary (not slave or arbiter)?
isPrimary = true1 "ismaster"
isSecondary :: ReplicaInfo -> Bool
-- ^ Is the replica described by this info a slave/secondary (not master or arbiter)
isSecondary = true1 "secondary"
isSecondary = true1 "secondary" -}
replicas :: ReplicaInfo -> [Host]
-- ^ 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
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
isMS Master i = isPrimary i
isMS SlaveOk i = isSecondary i || isPrimary i
isMS SlaveOk i = isSecondary i || isPrimary i -}
-- * Connection
@ -161,7 +159,7 @@ class Server t where
instance Server Host where
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.
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)
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.
@ -169,8 +167,8 @@ instance Server Host where
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.
connectHost poolSize host = HostConnection host <$> newPool Factory{..} poolSize where
newResource = tcpConnect host
connectHost poolSize' host' = HostConnection host' <$> newPool Factory{..} poolSize' where
newResource = tcpConnect host'
killResource = close
isExpired = isClosed
@ -188,7 +186,7 @@ instance Server ReplicaSet where
data Connection ReplicaSet = ReplicaSetConnection {
repsetName :: Name,
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
killPipes ReplicaSetConnection{..} = withMVar currentMembers (mapM_ killPipes)
@ -198,14 +196,14 @@ replicaSet ReplicaSetConnection{..} = ReplicaSet repsetName . map connHost <$> r
connectSet :: Int -> ReplicaSet -> IO (Connection ReplicaSet)
-- ^ Create a connection to each member of the replica set.
connectSet poolSize repset = assert (not . null $ seedHosts repset) $ do
currentMembers <- newMVar =<< mapM (connect poolSize) (seedHosts repset)
connectSet poolSize' repset = assert (not . null $ seedHosts repset) $ do
currentMembers <- newMVar =<< mapM (connect poolSize') (seedHosts repset)
return $ ReplicaSetConnection (setName repset) currentMembers
getMembers :: Name -> [Connection Host] -> ErrorT IOError IO [Host]
-- ^ 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.
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]
-- ^ 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
mapM (connection n) =<< getMembers repsetName connections
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
-- ^ 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
connections <- refreshMembers repsetName connections -- master at head after refresh
getSetPipe mos ReplicaSetConnection{..} = modifyMVar currentMembers $ \conns -> do
connections <- refreshMembers repsetName conns -- master at head after refresh
pipe <- case mos of
Master -> getHostPipe (head connections)
SlaveOk -> do

View file

@ -22,7 +22,6 @@ module Database.MongoDB.Internal.Protocol (
import Prelude as X
import Control.Applicative ((<$>))
import Control.Monad (unless, replicateM)
import System.IO (Handle)
import Data.ByteString.Lazy (ByteString)
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 System.IO.Error as E (try)
import Control.Monad.Error
import Control.Monad.Trans (MonadIO(..))
-- * Pipe

View file

@ -46,7 +46,6 @@ import Control.Monad.Context
import Control.Monad.Reader
import Control.Monad.Error
import Control.Monad.Throw
import System.IO.Error (try)
import Control.Concurrent.MVar
import Control.Pipeline (Resource(..))
import qualified Database.MongoDB.Internal.Protocol as P

View file

@ -4,7 +4,7 @@
module Var.Pool where
import Control.Applicative ((<$>), (<*>))
import Control.Applicative ((<$>))
import Control.Monad.MVar
import Data.Array.IO
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 Pool{resources} n = modifyMVar_ resources $ \array -> do
rs <- take n <$> getElems array
array <- newListArray (0, n-1) (rs ++ repeat Nothing)
return array
array' <- newListArray (0, n-1) (rs ++ repeat Nothing)
return array'
killAll :: Pool e r -> IO ()
-- ^ Kill all resources in pool so subsequent access creates new ones

View file

@ -6,9 +6,18 @@ license: OtherLicense
license-file: LICENSE
copyright: Copyright (c) 2010-2010 Scott Parish & 10gen Inc.
maintainer: Tony Hannan <tony@10gen.com>
build-depends: array -any, base <5, binary -any, bson -any,
bytestring -any, containers -any, mtl -any, nano-md5 -any,
network -any, parsec -any
build-depends:
array -any,
base <5,
binary -any,
bson -any,
bytestring -any,
containers -any,
mtl -any,
nano-md5 -any,
network -any,
parsec -any,
random -any
stability: alpha
homepage: http://github.com/TonyGen/mongoDB-haskell
package-url:
@ -22,10 +31,19 @@ data-files:
data-dir: ""
extra-source-files:
extra-tmp-files:
exposed-modules: Control.Pipeline Control.Monad.Context
Control.Monad.Throw Database.MongoDB Database.MongoDB.Admin
Database.MongoDB.Connection Database.MongoDB.Query
Database.MongoDB.Internal.Protocol Database.MongoDB.Internal.Util
exposed-modules:
Control.Monad.Context
Control.Monad.MVar
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
buildable: True
build-tools: