diff --git a/Database/Persist/MongoDB.hs b/Database/Persist/MongoDB.hs --- a/Database/Persist/MongoDB.hs +++ b/Database/Persist/MongoDB.hs @@ -45,6 +45,7 @@ , genObjectid -- * using connections + , withMongoPool , withMongoDBConn , withMongoDBPool , createMongoDBPool @@ -52,6 +53,7 @@ , runMongoDBPoolDef , ConnectionPool , Connection + , defaultMongoConf , MongoConf (..) , MongoBackend , MongoAuth (..) @@ -110,11 +112,8 @@ import Data.Time.Calendar (Day(..)) import Data.Attoparsec.Number import Data.Char (toUpper) -import Data.Word (Word16) import Data.Monoid (mappend) import Data.Typeable -import Control.Monad.Trans.Resource (MonadThrow (..)) -import Control.Monad.Trans.Control (MonadBaseControl) #ifdef DEBUG import FileLocation (debug) @@ -124,30 +123,14 @@ deriving (Show, Eq, Num) instance FromJSON NoOrphanNominalDiffTime where -#if MIN_VERSION_aeson(0, 7, 0) - parseJSON (Number x) = (return . NoOrphanNominalDiffTime . fromRational . toRational) x - - -#else parseJSON (Number (I x)) = (return . NoOrphanNominalDiffTime . fromInteger) x parseJSON (Number (D x)) = (return . NoOrphanNominalDiffTime . fromRational . toRational) x - -#endif parseJSON _ = fail "couldn't parse diff time" newtype NoOrphanPortID = NoOrphanPortID PortID deriving (Show, Eq) - instance FromJSON NoOrphanPortID where -#if MIN_VERSION_aeson(0, 7, 0) - parseJSON (Number x) = (return . NoOrphanPortID . PortNumber . fromIntegral ) cnvX - where cnvX :: Word16 - cnvX = round x - -#else parseJSON (Number (I x)) = (return . NoOrphanPortID . PortNumber . fromInteger) x - -#endif parseJSON _ = fail "couldn't parse port number" @@ -205,15 +188,40 @@ -> (ConnectionPool -> m b) -> m b withMongoDBConn dbname hostname port mauth connectionIdleTime = withMongoDBPool dbname hostname port mauth 1 1 connectionIdleTime -createPipe :: HostName -> PortID -> IO DB.Pipe -createPipe hostname port = DB.runIOE $ DB.connect (DB.Host hostname port) +mkPipe :: DB.Host -> IO DB.Pipe +mkPipe = DB.runIOE . DB.connect -createConnection :: Database -> HostName -> PortID -> Maybe MongoAuth -> IO Connection -createConnection dbname hostname port mAuth = do - pipe <- createPipe hostname port +createReplicatSet :: (DB.ReplicaSetName, [DB.Host]) -> Database -> Maybe MongoAuth -> IO Connection +createReplicatSet rsSeed dbname mAuth = do + pipe <- DB.runIOE $ DB.openReplicaSet rsSeed >>= DB.primary + testAccess pipe dbname mAuth + return $ Connection pipe dbname + +createRsPool :: (Trans.MonadIO m, Applicative m) => Database -> (DB.ReplicaSetName, [DB.Host]) + -> Maybe MongoAuth + -> Int -- ^ pool size (number of stripes) + -> Int -- ^ stripe size (number of connections per stripe) + -> NominalDiffTime -- ^ time a connection is left idle before closing + -> m ConnectionPool +createRsPool dbname rsSeed mAuth connectionPoolSize stripeSize connectionIdleTime = do + Trans.liftIO $ Pool.createPool + (createReplicatSet rsSeed dbname mAuth) + (\(Connection pipe _) -> DB.close pipe) + connectionPoolSize + connectionIdleTime + stripeSize + +testAccess :: DB.Pipe -> Database -> Maybe MongoAuth -> IO () +testAccess pipe dbname mAuth = do _ <- case mAuth of Just (MongoAuth user pass) -> DB.access pipe DB.UnconfirmedWrites dbname (DB.auth user pass) Nothing -> return undefined + return () + +createConnection :: Database -> HostName -> PortID -> Maybe MongoAuth -> IO Connection +createConnection dbname hostname port mAuth = do + pipe <- mkPipe $ DB.Host hostname port + testAccess pipe dbname mAuth return $ Connection pipe dbname createMongoDBPool :: (Trans.MonadIO m, Applicative m) => Database -> HostName -> PortID @@ -230,6 +238,19 @@ connectionIdleTime stripeSize + +createMongoPool :: (Trans.MonadIO m, Applicative m) => MongoConf -> m ConnectionPool +createMongoPool c@MongoConf{mgRsPrimary = Just rsName} = + createRsPool + (mgDatabase c) (rsName, [DB.Host (T.unpack $ mgHost c) (mgPort c)]) + (mgAuth c) + (mgPoolStripes c) (mgStripeConnections c) (mgConnectionIdleTime c) +createMongoPool c@MongoConf{mgRsPrimary = Nothing} = + createMongoDBPool + (mgDatabase c) (T.unpack (mgHost c)) (mgPort c) + (mgAuth c) + (mgPoolStripes c) (mgStripeConnections c) (mgConnectionIdleTime c) + type PipePool = Pool.Pool DB.Pipe -- | A pool of plain MongoDB pipes. @@ -243,12 +264,15 @@ -> m PipePool createMongoDBPipePool hostname port connectionPoolSize stripeSize connectionIdleTime = do Trans.liftIO $ Pool.createPool - (createPipe hostname port) + (mkPipe $ DB.Host hostname port) (\pipe -> DB.close pipe) connectionPoolSize connectionIdleTime stripeSize +withMongoPool :: (Trans.MonadIO m, Applicative m) => MongoConf -> (ConnectionPool -> m b) -> m b +withMongoPool conf connectionReader = createMongoPool conf >>= connectionReader + withMongoDBPool :: (Trans.MonadIO m, Applicative m) => Database -> HostName -> PortID -> Maybe MongoAuth -> Int -> Int -> NominalDiffTime -> (ConnectionPool -> m b) -> m b withMongoDBPool dbname hostname port mauth poolStripes stripeConnections connectionIdleTime connectionReader = do @@ -394,11 +418,7 @@ t = entityDef $ Just $ dummyFromKey k instance MonadThrow m => MonadThrow (DB.Action m) where -#if MIN_VERSION_resourcet(1,1,0) - throwM = lift . throwM -#else monadThrow = lift . monadThrow -#endif instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistUnique (DB.Action m) where getBy uniq = do @@ -794,29 +814,41 @@ , mgPoolStripes :: Int , mgStripeConnections :: Int , mgConnectionIdleTime :: NominalDiffTime + , mgRsPrimary :: Maybe DB.ReplicaSetName -- ^ useful to query just a replica set primary } deriving Show +defaultMongoConf :: MongoConf +defaultMongoConf = MongoConf + { mgDatabase = "test" + , mgHost = "127.0.0.1" + , mgPort = DB.defaultPort + , mgAuth = Nothing + , mgAccessMode = DB.ConfirmWrites ["j" DB.=: True] + , mgPoolStripes = 1 + , mgStripeConnections = 5 + , mgConnectionIdleTime = 20 + , mgRsPrimary = Nothing + } + instance PersistConfig MongoConf where type PersistConfigBackend MongoConf = DB.Action type PersistConfigPool MongoConf = ConnectionPool - createPoolConfig c = - createMongoDBPool - (mgDatabase c) (T.unpack (mgHost c)) (mgPort c) - (mgAuth c) - (mgPoolStripes c) (mgStripeConnections c) (mgConnectionIdleTime c) + createPoolConfig = createMongoPool runPool c = runMongoDBPool (mgAccessMode c) loadConfig (Object o) = do + let def = defaultMongoConf db <- o .: "database" - host <- o .:? "host" .!= "127.0.0.1" - (NoOrphanPortID port) <- o .:? "port" .!= (NoOrphanPortID DB.defaultPort) - poolStripes <- o .:? "poolstripes" .!= 1 + host <- o .:? "host" .!= (mgHost def) + (NoOrphanPortID port) <- o .:? "port" .!= NoOrphanPortID DB.defaultPort + poolStripes <- o .:? "poolstripes" .!= (mgPoolStripes def) stripeConnections <- o .: "connections" - (NoOrphanNominalDiffTime connectionIdleTime) <- o .:? "connectionIdleTime" .!= 20 + (NoOrphanNominalDiffTime connectionIdleTime) <- o .:? "connectionIdleTime" .!= (NoOrphanNominalDiffTime $ mgConnectionIdleTime def) mUser <- o .:? "user" mPass <- o .:? "password" accessString <- o .:? "accessMode" .!= "ConfirmWrites" + mRsPrimary <- o .:? "rsPrimary" mPoolSize <- o .:? "poolsize" case mPoolSize of @@ -827,23 +859,27 @@ "ReadStaleOk" -> return DB.ReadStaleOk "UnconfirmedWrites" -> return DB.UnconfirmedWrites "ConfirmWrites" -> return $ DB.ConfirmWrites ["j" DB.=: True] - badAccess -> fail $ "unknown accessMode: " ++ (T.unpack badAccess) + badAccess -> fail $ "unknown accessMode: " ++ T.unpack badAccess - return $ MongoConf { + return MongoConf { mgDatabase = db , mgHost = host , mgPort = port , mgAuth = - (case (mUser, mPass) of + case (mUser, mPass) of (Just user, Just pass) -> Just (MongoAuth user pass) _ -> Nothing - ) , mgPoolStripes = poolStripes , mgStripeConnections = stripeConnections , mgAccessMode = accessMode , mgConnectionIdleTime = connectionIdleTime + , mgRsPrimary = toRsPrimary mRsPrimary } where + toRsPrimary :: Maybe Text -> Maybe DB.ReplicaSetName + toRsPrimary Nothing = Nothing + toRsPrimary (Just "False") = Nothing + toRsPrimary rs = rs {- safeRead :: String -> T.Text -> MEither String Int safeRead name t = case reads s of diff --git a/persistent-mongoDB.cabal b/persistent-mongoDB.cabal --- a/persistent-mongoDB.cabal +++ b/persistent-mongoDB.cabal @@ -1,5 +1,5 @@ name: persistent-mongoDB -version: 1.3.0.4 +version: 1.3.1 license: MIT license-file: LICENSE author: Greg Weber @@ -10,7 +10,6 @@ cabal-version: >= 1.6 build-type: Simple homepage: http://www.yesodweb.com/book/persistent -bug-reports: https://github.com/yesodweb/persistent/issues description: MongoDB backend for the persistent library. Flag high_precision_date