persistent-mongoDB 1.3.0.4 → 1.3.1
raw patch · 2 files changed
+79/−44 lines, 2 files
Files
- Database/Persist/MongoDB.hs +78/−42
- persistent-mongoDB.cabal +1/−2
Database/Persist/MongoDB.hs view
@@ -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
persistent-mongoDB.cabal view
@@ -1,5 +1,5 @@ name: persistent-mongoDB-version: 1.3.0.4+version: 1.3.1 license: MIT license-file: LICENSE author: Greg Weber <greg@gregweber.info>@@ -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