diff --git a/Database/Persist/MongoDB.hs b/Database/Persist/MongoDB.hs --- a/Database/Persist/MongoDB.hs +++ b/Database/Persist/MongoDB.hs @@ -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 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.1 +version: 1.3.1.1 license: MIT license-file: LICENSE author: Greg Weber @@ -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