Vergara_Tech/mongodb
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Fix compile warnings

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

8
Control/Monad/MVar.hs
View file

@ -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)

4
Control/Monad/Util.hs
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) 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

3
Database/MongoDB/Admin.hs
View file

@ -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).

42
Database/MongoDB/Connection.hs
View file

@ -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

2
Database/MongoDB/Internal/Protocol.hs
View file

@ -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

1
Database/MongoDB/Query.hs
View file

@ -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

6
Var/Pool.hs
View file

@ -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

32
mongoDB.cabal
View file

@ -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: