persistent-mongoDB 1.3.1 → 1.3.1.1
raw patch · 2 files changed
+60/−90 lines, 2 files
Files
- Database/Persist/MongoDB.hs +58/−89
- persistent-mongoDB.cabal +2/−1
Database/Persist/MongoDB.hs view
@@ -44,8 +44,15 @@ , Objectid , genObjectid + -- * Key conversion helpers+ , keyToOid+ , oidToKey+ , recordTypeFromKey++ -- * PersistField conversion+ , fieldName+ -- * using connections- , withMongoPool , withMongoDBConn , withMongoDBPool , createMongoDBPool@@ -53,7 +60,6 @@ , runMongoDBPoolDef , ConnectionPool , Connection- , defaultMongoConf , MongoConf (..) , MongoBackend , MongoAuth (..)@@ -62,10 +68,6 @@ , createMongoDBPipePool , runMongoDBPipePool - -- * Key conversion helpers- , keyToOid- , oidToKey- -- * network type , HostName , PortID@@ -112,25 +114,47 @@ 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) #endif +recordTypeFromKey :: KeyBackend MongoBackend v -> v+recordTypeFromKey _ = error "recordTypeFromKey"+ newtype NoOrphanNominalDiffTime = NoOrphanNominalDiffTime NominalDiffTime 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" @@ -188,40 +212,15 @@ -> (ConnectionPool -> m b) -> m b withMongoDBConn dbname hostname port mauth connectionIdleTime = withMongoDBPool dbname hostname port mauth 1 1 connectionIdleTime -mkPipe :: DB.Host -> IO DB.Pipe-mkPipe = DB.runIOE . DB.connect--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+createPipe :: HostName -> PortID -> IO DB.Pipe+createPipe hostname port = DB.runIOE $ DB.connect (DB.Host hostname port) -testAccess :: DB.Pipe -> Database -> Maybe MongoAuth -> IO ()-testAccess pipe dbname mAuth = do+createConnection :: Database -> HostName -> PortID -> Maybe MongoAuth -> IO Connection+createConnection dbname hostname port mAuth = do+ pipe <- createPipe hostname port _ <- 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@@ -238,19 +237,6 @@ 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.@@ -264,15 +250,12 @@ -> m PipePool createMongoDBPipePool hostname port connectionPoolSize stripeSize connectionIdleTime = do Trans.liftIO $ Pool.createPool- (mkPipe $ DB.Host hostname port)+ (createPipe 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@@ -314,7 +297,7 @@ updateToMongoField :: (PersistEntity entity) => Update entity -> DB.Field updateToMongoField (Update field v up) =- opName DB.:= DB.Doc [( (unDBName $ fieldDB $ persistFieldDef field) DB.:= opValue)]+ opName DB.:= DB.Doc [fieldName field DB.:= opValue] where (opName, opValue) = case (up, toPersistValue v) of@@ -403,7 +386,7 @@ delete k = DB.deleteOne DB.Select {- DB.coll = collectionName (dummyFromKey k)+ DB.coll = collectionName (recordTypeFromKey k) , DB.selector = filterByKey k } @@ -415,10 +398,14 @@ Entity _ ent <- fromPersistValuesThrow t doc return $ Just ent where- t = entityDef $ Just $ dummyFromKey k+ t = entityDef $ Just $ recordTypeFromKey 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@@ -448,7 +435,7 @@ update _ [] = return () update key upds = DB.modify - (DB.Select [keyToMongoIdField key] (collectionName $ dummyFromKey key))+ (DB.Select [keyToMongoIdField key] (collectionName $ recordTypeFromKey key)) $ updateFields upds updateGet key upds = do@@ -462,7 +449,7 @@ return ent where err msg = Trans.liftIO $ throwIO $ KeyNotFound $ show key ++ msg- t = entityDef $ Just $ dummyFromKey key+ t = entityDef $ Just $ recordTypeFromKey key updateWhere _ [] = return ()@@ -795,8 +782,6 @@ w2 <- Serialize.get return (DB.Oid w1 w2) -dummyFromKey :: KeyBackend MongoBackend v -> v-dummyFromKey _ = error "dummyFromKey" dummyFromUnique :: Unique v -> v dummyFromUnique _ = error "dummyFromUnique" dummyFromFilts :: [Filter v] -> v@@ -814,41 +799,29 @@ , 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 = createMongoPool+ createPoolConfig c =+ createMongoDBPool + (mgDatabase c) (T.unpack (mgHost c)) (mgPort c)+ (mgAuth c)+ (mgPoolStripes c) (mgStripeConnections c) (mgConnectionIdleTime c) runPool c = runMongoDBPool (mgAccessMode c) loadConfig (Object o) = do- let def = defaultMongoConf db <- o .: "database"- host <- o .:? "host" .!= (mgHost def)- (NoOrphanPortID port) <- o .:? "port" .!= NoOrphanPortID DB.defaultPort- poolStripes <- o .:? "poolstripes" .!= (mgPoolStripes def)+ host <- o .:? "host" .!= "127.0.0.1"+ (NoOrphanPortID port) <- o .:? "port" .!= (NoOrphanPortID DB.defaultPort)+ poolStripes <- o .:? "poolstripes" .!= 1 stripeConnections <- o .: "connections"- (NoOrphanNominalDiffTime connectionIdleTime) <- o .:? "connectionIdleTime" .!= (NoOrphanNominalDiffTime $ mgConnectionIdleTime def)+ (NoOrphanNominalDiffTime connectionIdleTime) <- o .:? "connectionIdleTime" .!= 20 mUser <- o .:? "user" mPass <- o .:? "password" accessString <- o .:? "accessMode" .!= "ConfirmWrites"- mRsPrimary <- o .:? "rsPrimary" mPoolSize <- o .:? "poolsize" case mPoolSize of@@ -859,27 +832,23 @@ "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.1+version: 1.3.1.1 license: MIT license-file: LICENSE author: Greg Weber <greg@gregweber.info>@@ -10,6 +10,7 @@ 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