persistent-mongoDB 0.9.0.3 → 1.0.0
raw patch · 2 files changed
+234/−146 lines, 2 filesdep +attoparsecdep +pool-conduitdep +timedep −compact-string-fixdep ~bsondep ~conduitdep ~mongoDB
Dependencies added: attoparsec, pool-conduit, time
Dependencies removed: compact-string-fix
Dependency ranges changed: bson, conduit, mongoDB, persistent
Files
- Database/Persist/MongoDB.hs +226/−140
- persistent-mongoDB.cabal +8/−6
Database/Persist/MongoDB.hs view
@@ -1,12 +1,8 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE PackageImports, RankNTypes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP, PackageImports, OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE RankNTypes, TypeFamilies #-}+ {-# LANGUAGE UndecidableInstances #-} -- FIXME {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.MongoDB@@ -15,26 +11,26 @@ withMongoDBConn , withMongoDBPool , createMongoDBPool- , runMongoDBConn + , runMongoDBPool+ , runMongoDBPoolDef , ConnectionPool+ , Connection , MongoConf (..) -- * Key conversion helpers , keyToOid , oidToKey- -- * CompactString helpers- , csToText- , textToCS+ -- * Entity conversion+ , entityToFields+ , toInsertFields -- * network type , HostName- -- * UString type- , u -- * MongoDB driver types , DB.Action , DB.AccessMode(..) , DB.master , DB.slaveOk , (DB.=:)- -- * Database.Persistent+ -- * Database.Persist , module Database.Persist ) where @@ -49,36 +45,38 @@ import qualified Database.MongoDB as DB import Database.MongoDB.Query (Database) import Control.Applicative (Applicative)-import Data.UString (u)-import qualified Data.CompactString.UTF8 as CS import Network.Socket (HostName) import Data.Maybe (mapMaybe, fromJust) import qualified Data.Text as T+import Data.Text (Text) import qualified Data.Text.Encoding as E import qualified Data.Serialize as Serialize-import qualified System.IO.Pool as Pool import Web.PathPieces (PathPiece (..))-import qualified Data.Conduit as C+import Data.Conduit import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO)-import Data.Aeson (Value (Object), (.:), (.:?), (.!=))+import Data.Aeson (Value (Object, Number), (.:), (.:?), (.!=), FromJSON(..)) import Control.Monad (mzero) import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Trans.Resource (MonadThrow (..))+import qualified Data.Conduit.Pool as Pool+import Data.Time (NominalDiffTime)+import Data.Attoparsec.Number #ifdef DEBUG import FileLocation (debug)-#else-{--debug :: forall a. a -> a-debug = id-debugMsg :: forall t a. t -> a -> a-debugMsg _ = id--} #endif -type ConnectionPool = (Pool.Pool IOError DB.Pipe, Database)+newtype NoOrphanNominalDiffTime = NoOrphanNominalDiffTime NominalDiffTime+ deriving (Show, Eq, Num) +instance FromJSON NoOrphanNominalDiffTime where+ parseJSON (Number (I x)) = (return . NoOrphanNominalDiffTime . fromInteger) x+ parseJSON (Number (D x)) = (return . NoOrphanNominalDiffTime . fromRational . toRational) x+ parseJSON _ = fail "couldn't parse diff time"++data Connection = Connection DB.Pipe DB.Database+type ConnectionPool = Pool.Pool Connection+ instance PathPiece (Key DB.Action entity) where toPathPiece (Key pOid@(PersistObjectId _)) = -- T.pack $ show $ Serialize.encode bsonId let oid = persistObjectIdToDbOid pOid@@ -92,32 +90,46 @@ withMongoDBConn :: (Trans.MonadIO m, Applicative m) =>- Database -> HostName -> (ConnectionPool -> m b) -> m b-withMongoDBConn dbname hostname = withMongoDBPool dbname hostname 1+ Database -> HostName -> Maybe MongoAuth -> NominalDiffTime -> (ConnectionPool -> m b) -> m b+withMongoDBConn dbname hostname mauth connectionIdleTime = withMongoDBPool dbname hostname mauth 1 1 connectionIdleTime -createMongoDBPool :: (Trans.MonadIO m, Applicative m) =>- Database -> HostName -> Int -> m ConnectionPool-createMongoDBPool dbname hostname connectionPoolSize = do- --pool <- runReaderT (DB.newConnPool connectionPoolSize $ DB.host hostname) $ ANetwork Internet- pool <- Trans.liftIO $ Pool.newPool Pool.Factory { Pool.newResource = DB.connect (DB.host hostname)- , Pool.killResource = DB.close- , Pool.isExpired = DB.isClosed- }- connectionPoolSize- return (pool, dbname)+createConnection :: Database -> HostName -> Maybe MongoAuth -> IO Connection+createConnection dbname hostname mAuth = do+ pipe <- DB.runIOE $ DB.connect (DB.host hostname)+ _ <- case mAuth of+ Just (MongoAuth user pass) -> DB.access pipe DB.UnconfirmedWrites dbname (DB.auth user pass)+ Nothing -> return undefined+ return $ Connection pipe dbname +createMongoDBPool :: (Trans.MonadIO m, Applicative m) => Database -> HostName+ -> 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+createMongoDBPool dbname hostname mAuth connectionPoolSize stripeSize connectionIdleTime = do+ Trans.liftIO $ Pool.createPool+ (createConnection dbname hostname mAuth)+ (\(Connection pipe _) -> DB.close pipe)+ connectionPoolSize+ connectionIdleTime+ stripeSize+ withMongoDBPool :: (Trans.MonadIO m, Applicative m) =>- Database -> HostName -> Int -> (ConnectionPool -> m b) -> m b-withMongoDBPool dbname hostname connectionPoolSize connectionReader = do- pool <- createMongoDBPool dbname hostname connectionPoolSize+ Database -> HostName -> Maybe MongoAuth -> Int -> Int -> NominalDiffTime -> (ConnectionPool -> m b) -> m b+withMongoDBPool dbname hostname mauth poolStripes stripeConnections connectionIdleTime connectionReader = do+ pool <- createMongoDBPool dbname hostname mauth poolStripes stripeConnections connectionIdleTime connectionReader pool -runMongoDBConn :: (Trans.MonadIO m) => DB.AccessMode -> DB.Action m b -> ConnectionPool -> m b-runMongoDBConn accessMode action (pool, databaseName) = do- pipe <- Trans.liftIO $ DB.runIOE $ Pool.aResource pool- res <- DB.access pipe accessMode databaseName action- either (Trans.liftIO . throwIO . PersistMongoDBError . T.pack . show) return res+runMongoDBPool :: (Trans.MonadIO m, MonadBaseControl IO m) => DB.AccessMode -> DB.Action m a -> ConnectionPool -> m a+runMongoDBPool accessMode action pool =+ Pool.withResource pool $ \(Connection pipe db) -> do+ res <- DB.access pipe accessMode db action+ either (Trans.liftIO . throwIO . PersistMongoDBError . T.pack . show) return res +runMongoDBPoolDef :: (Trans.MonadIO m, MonadBaseControl IO m) => DB.Action m a -> ConnectionPool -> m a+runMongoDBPoolDef = runMongoDBPool (DB.ConfirmWrites ["j" DB.=: True])+ value :: DB.Field -> DB.Value value (_ DB.:= val) = val @@ -127,27 +139,27 @@ Right v -> v filterByKey :: (PersistEntity val) => Key DB.Action val -> DB.Document-filterByKey k = [u"_id" DB.=: keyToOid k]+filterByKey k = [_id DB.=: keyToOid k] queryByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Query -queryByKey k entity = (DB.select (filterByKey k) (u $ T.unpack $ unDBName $ entityDB entity)) +queryByKey k entity = (DB.select (filterByKey k) (unDBName $ entityDB entity)) selectByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Selection -selectByKey k entity = (DB.select (filterByKey k) (u $ T.unpack $ unDBName $ entityDB entity))+selectByKey k entity = (DB.select (filterByKey k) (unDBName $ entityDB entity)) updateFields :: (PersistEntity val) => [Update val] -> [DB.Field] updateFields upds = map updateToMongoField upds updateToMongoField :: (PersistEntity val) => Update val -> DB.Field updateToMongoField (Update field v up) =- opName DB.:= DB.Doc [( (u $ T.unpack $ unDBName $ fieldDB $ persistFieldDef field) DB.:= opValue)]+ opName DB.:= DB.Doc [( (unDBName $ fieldDB $ persistFieldDef field) DB.:= opValue)] where (opName, opValue) = case (up, toPersistValue v) of- (Assign, PersistNull) -> (u"$unset", DB.Int64 1)- (Assign,a) -> (u"$set", DB.val a)- (Add, a) -> (u"$inc", DB.val a)- (Subtract, PersistInt64 i) -> (u "$inc", DB.Int64 (-i))+ (Assign, PersistNull) -> ("$unset", DB.Int64 1)+ (Assign,a) -> ("$set", DB.val a)+ (Add, a) -> ("$inc", DB.val a)+ (Subtract, PersistInt64 i) -> ("$inc", DB.Int64 (-i)) (Subtract, _) -> error "expected PersistInt64 for a subtraction" (Multiply, _) -> throw $ PersistMongoDBUnsupported "multiply not supported" (Divide, _) -> throw $ PersistMongoDBUnsupported "divide not supported"@@ -155,7 +167,7 @@ uniqSelector :: forall val. (PersistEntity val) => Unique val DB.Action -> [DB.Field] uniqSelector uniq = zipWith (DB.:=)- (map u (map (T.unpack . unDBName . snd) $ persistUniqueToFieldNames uniq))+ (map (unDBName . snd) $ persistUniqueToFieldNames uniq) (map DB.val (persistUniqueToValues uniq)) pairFromDocument :: (PersistEntity val, PersistEntityBackend val ~ DB.Action)@@ -170,45 +182,66 @@ Right xs' -> Right (Entity (oidToKey . fromJust . DB.cast' . value $ x) xs') pairFromPersistValues _ = Left "error in fromPersistValues'" -insertFields :: forall val. (PersistEntity val) => EntityDef -> val -> [DB.Field]-insertFields t record = zipFilter (entityFields t) (toPersistFields record)+-- | convert a PersistEntity into document fields.+-- for inserts only: nulls are ignored so they will be unset in the document.+-- 'entityToFields' includes nulls+toInsertFields :: forall val. (PersistEntity val) => val -> [DB.Field]+toInsertFields record = zipFilter (entityFields entity) (toPersistFields record) where zipFilter [] _ = [] zipFilter _ [] = [] zipFilter (e:efields) (p:pfields) = let pv = toPersistValue p in if pv == PersistNull then zipFilter efields pfields else (toLabel e DB.:= DB.val pv):zipFilter efields pfields+ entity = entityDef record - toLabel = u . T.unpack . unDBName . fieldDB+-- | convert a PersistEntity into document fields.+-- unlike 'toInsertFields', nulls are included.+entityToFields :: forall val. (PersistEntity val) => val -> [DB.Field]+entityToFields record = zipIt (entityFields entity) (toPersistFields record)+ where+ zipIt [] _ = []+ zipIt _ [] = []+ zipIt (e:efields) (p:pfields) =+ let pv = toPersistValue p+ in (toLabel e DB.:= DB.val pv):zipIt efields pfields+ entity = entityDef record -saveWithKey :: forall m ent record. (Applicative m, Functor m, MonadBaseControl IO m, PersistEntity ent, PersistEntity record)- => (DB.Collection -> DB.Document -> DB.Action m () )- -> Key DB.Action ent -> record -> DB.Action m ()-saveWithKey dbSave k record =- dbSave (u $ T.unpack $ unDBName $ entityDB t) ((persistKeyToMongoId k):(insertFields t record))+toLabel :: FieldDef -> Text+toLabel = unDBName . fieldDB++saveWithKey :: forall m record keyEntity. -- (Applicative m, Functor m, MonadBaseControl IO m,+ (PersistEntity keyEntity, PersistEntity record)+ => (record -> [DB.Field])+ -> (DB.Collection -> DB.Document -> DB.Action m () )+ -> Key DB.Action keyEntity+ -> record+ -> DB.Action m ()+saveWithKey entToFields dbSave key record =+ dbSave (unDBName $ entityDB entity) ((keyToMongoIdField key):(entToFields record)) where- t = entityDef record+ entity = entityDef record instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistStore DB.Action m where insert record = do- (DB.ObjId oid) <- DB.insert (u $ T.unpack $ unDBName $ entityDB t) (insertFields t record)+ DB.ObjId oid <- DB.insert (unDBName $ entityDB entity) (toInsertFields record) return $ oidToKey oid where- t = entityDef record+ entity = entityDef record - insertKey k record = saveWithKey DB.insert_ k record+ insertKey k record = saveWithKey toInsertFields DB.insert_ k record - repsert k record = saveWithKey DB.save k record+ repsert k record = saveWithKey entityToFields DB.save k record replace k record = do- DB.replace (selectByKey k t) (insertFields t record)+ DB.replace (selectByKey k t) (toInsertFields record) return () where t = entityDef record delete k = DB.deleteOne DB.Select {- DB.coll = (u $ T.unpack $ unDBName $ entityDB t)+ DB.coll = (unDBName $ entityDB t) , DB.selector = filterByKey k } where@@ -229,7 +262,7 @@ instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistUnique DB.Action m where getBy uniq = do mdocument <- DB.findOne $- (DB.select (uniqSelector uniq) (u $ T.unpack $ unDBName $ entityDB t))+ (DB.select (uniqSelector uniq) (unDBName $ entityDB t)) case mdocument of Nothing -> return Nothing Just document -> case pairFromDocument t document of@@ -240,28 +273,61 @@ deleteBy uniq = DB.delete DB.Select {- DB.coll = u $ T.unpack $ unDBName $ entityDB t+ DB.coll = unDBName $ entityDB t , DB.selector = uniqSelector uniq } where t = entityDef $ dummyFromUnique uniq -persistKeyToMongoId :: PersistEntity val => Key DB.Action val -> DB.Field-persistKeyToMongoId k = u"_id" DB.:= (DB.ObjId $ keyToOid k)+_id :: T.Text+_id = "_id" +keyToMongoIdField :: PersistEntity val => Key DB.Action val -> DB.Field+keyToMongoIdField k = _id DB.:= (DB.ObjId $ keyToOid k)+++findAndModifyOne :: (Applicative m, Trans.MonadIO m)+ => DB.Collection+ -> DB.ObjectId -- ^ _id for query+ -> [DB.Field] -- ^ updates+ -> DB.Action m (Either String DB.Document)+findAndModifyOne coll objectId updates = do+ result <- DB.runCommand [+ "findAndModify" DB.:= DB.String coll,+ "new" DB.:= DB.Bool True, -- return updated document, not original document+ "query" DB.:= DB.Doc [_id DB.:= DB.ObjId objectId],+ "update" DB.:= DB.Doc updates+ ]+ return $ case DB.lookup "err" (DB.at "lastErrorObject" result) result of+ Just e -> Left e+ Nothing -> case DB.lookup "value" result of+ Nothing -> Left "no value field"+ Just doc -> Right doc+ instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistQuery DB.Action m where update _ [] = return ()- update k upds =+ update key upds = DB.modify - (DB.Select [persistKeyToMongoId k] (u $ T.unpack $ unDBName $ entityDB t)) + (DB.Select [keyToMongoIdField key] (unDBName $ entityDB t)) $ updateFields upds where- t = entityDef $ dummyFromKey k+ t = entityDef $ dummyFromKey key + updateGet key upds = do+ result <- findAndModifyOne (unDBName $ entityDB t)+ (keyToOid key) (updateFields upds)+ case result of+ Left e -> err e+ Right doc -> return $ (rightPersistVals t) $ tail doc+ where+ err msg = Trans.liftIO $ throwIO $ KeyNotFound $ show key ++ msg+ t = entityDef $ dummyFromKey key++ updateWhere _ [] = return () updateWhere filts upds = DB.modify DB.Select {- DB.coll = (u $ T.unpack $ unDBName $ entityDB t)+ DB.coll = (unDBName $ entityDB t) , DB.selector = filtersToSelector filts } $ updateFields upds where@@ -269,7 +335,7 @@ deleteWhere filts = do DB.delete DB.Select {- DB.coll = (u $ T.unpack $ unDBName $ entityDB t)+ DB.coll = (unDBName $ entityDB t) , DB.selector = filtersToSelector filts } where@@ -279,24 +345,23 @@ i <- DB.count query return $ fromIntegral i where- query = DB.select (filtersToSelector filts) (u $ T.unpack $ unDBName $ entityDB t)+ query = DB.select (filtersToSelector filts) (unDBName $ entityDB t) t = entityDef $ dummyFromFilts filts - selectSource filts opts = C.PipeM- (do- cursor <- lift $ DB.find $ makeQuery filts opts- return $ mkSrc cursor)- (return ())+ selectSource filts opts = do+ cursor <- lift $ lift $ DB.find $ makeQuery filts opts+ pull cursor where- mkSrc cursor = C.PipeM (pull cursor) (return ())- pull cursor = lift $ do- mdoc <- DB.next cursor+ pull cursor = do+ mdoc <- lift $ lift $ DB.next cursor case mdoc of- Nothing -> return $ C.Done Nothing ()+ Nothing -> return () Just doc -> case pairFromDocument t doc of Left s -> liftIO $ throwIO $ PersistMarshalError $ T.pack s- Right row -> return $ C.HaveOutput (mkSrc cursor) (return ()) row+ Right row -> do+ yield row+ pull cursor t = entityDef $ dummyFromFilts filts selectFirst filts opts = do@@ -309,23 +374,20 @@ where t = entityDef $ dummyFromFilts filts - selectKeys filts = C.PipeM- (do- cursor <- lift $ DB.find query- return $ mkSrc cursor)- (return ())+ selectKeys filts opts = do+ cursor <- lift $ lift $ DB.find $ (makeQuery filts opts) {+ DB.project = [_id DB.=: (1 :: Int)]+ }+ pull cursor where- mkSrc cursor = C.PipeM (pull cursor) (return ())- pull cursor = lift $ do- mdoc <- DB.next cursor+ pull cursor = do+ mdoc <- lift $ lift $ DB.next cursor case mdoc of- Nothing -> return $ C.Done Nothing ()- Just [_ DB.:= DB.ObjId oid] -> return $ C.HaveOutput (mkSrc cursor) (return ()) $ oidToKey oid+ Nothing -> return ()+ Just [_ DB.:= DB.ObjId oid] -> do+ yield $ oidToKey oid+ pull cursor Just y -> liftIO $ throwIO $ PersistMarshalError $ T.pack $ "Unexpected in selectKeys: " ++ show y- query = (DB.select (filtersToSelector filts) (u $ T.unpack $ unDBName $ entityDB t)) {- DB.project = [u"_id" DB.=: (1 :: Int)]- }- t = entityDef $ dummyFromFilts filts orderClause :: PersistEntity val => SelectOpt val -> DB.Field orderClause o = case o of@@ -336,7 +398,7 @@ makeQuery :: PersistEntity val => [Filter val] -> [SelectOpt val] -> DB.Query makeQuery filts opts =- (DB.select (filtersToSelector filts) (u $ T.unpack $ unDBName $ entityDB t)) {+ (DB.select (filtersToSelector filts) (unDBName $ entityDB t)) { DB.limit = fromIntegral limit , DB.skip = fromIntegral offset , DB.sort = orders@@ -354,18 +416,18 @@ if null filts then [] else concatMap filterToDocument filts multiFilter :: forall val. PersistEntity val => String -> [Filter val] -> [DB.Field]-multiFilter multi fs = [u multi DB.:= DB.Array (map (DB.Doc . filterToDocument) fs)]+multiFilter multi fs = [T.pack multi DB.:= DB.Array (map (DB.Doc . filterToDocument) fs)] filterToDocument :: PersistEntity val => Filter val -> DB.Document filterToDocument f = case f of Filter field v filt -> return $ case filt of Eq -> fieldName field DB.:= toValue v- _ -> fieldName field DB.=: [u(showFilter filt) DB.:= toValue v]+ _ -> fieldName field DB.=: [(showFilter filt) DB.:= toValue v] FilterOr [] -> -- Michael decided to follow Haskell's semantics, which seems reasonable to me. -- in Haskell an empty or is a False -- Perhaps there is a less hacky way of creating a query that always returns false?- [u"$not" DB.=: [u"$exists" DB.=: u"_id"]]+ ["$not" DB.=: ["$exists" DB.=: _id]] FilterOr fs -> multiFilter "$or" fs -- $and is usually unecessary but makes query construction easier in special cases FilterAnd [] -> []@@ -387,9 +449,9 @@ showFilter Eq = error "EQ filter not expected" showFilter (BackendSpecificFilter bsf) = throw $ PersistMongoDBError $ T.pack $ "did not expect BackendSpecificFilter " ++ T.unpack bsf -fieldName :: forall v typ. (PersistEntity v) => EntityField v typ -> CS.CompactString-fieldName = u . idfix . T.unpack . unDBName . fieldDB . persistFieldDef- where idfix f = if f == "id" then "_id" else f+fieldName :: forall v typ. (PersistEntity v) => EntityField v typ -> DB.Label+fieldName = idfix . unDBName . fieldDB . persistFieldDef+ where idfix f = if f == "id" then _id else f wrapFromPersistValues :: (PersistEntity val) => EntityDef -> [DB.Field] -> Either T.Text val@@ -433,16 +495,8 @@ -- this keeps the document size down matchOne [] tried = ((c, PersistNull), tried) -mapFromDoc :: DB.Document -> [(T.Text, PersistValue)]-mapFromDoc = Prelude.map (\f -> ( ( csToText (DB.label f)), (fromJust . DB.cast') (DB.value f) ) )---- | CompactString is UTF8, Text is UTF16-csToText :: CS.CompactString -> T.Text-csToText = E.decodeUtf8 . CS.toByteString---- | CompactString is UTF8, Text is UTF16-textToCS :: T.Text -> CS.CompactString-textToCS = CS.fromByteString_ . E.encodeUtf8+mapFromDoc :: DB.Document -> [(Text, PersistValue)]+mapFromDoc = Prelude.map (\f -> ( (DB.label f), (fromJust . DB.cast') (DB.value f) ) ) oidToPersistValue :: DB.ObjectId -> PersistValue oidToPersistValue = PersistObjectId . Serialize.encode@@ -461,13 +515,14 @@ instance DB.Val PersistValue where val (PersistInt64 x) = DB.Int64 x- val (PersistText x) = DB.String (textToCS x)+ val (PersistText x) = DB.String x val (PersistDouble x) = DB.Float x val (PersistBool x) = DB.Bool x val (PersistUTCTime x) = DB.UTC x+ val (PersistZonedTime (ZT x)) = DB.String $ T.pack $ show x val (PersistNull) = DB.Null val (PersistList l) = DB.Array $ map DB.val l- val (PersistMap m) = DB.Doc $ map (\(k, v)-> (DB.=:) (textToCS k) v) m+ val (PersistMap m) = DB.Doc $ map (\(k, v)-> (DB.=:) k v) m val (PersistByteString x) = DB.Bin (DB.Binary x) val x@(PersistObjectId _) = DB.ObjId $ persistObjectIdToDbOid x val (PersistDay _) = throw $ PersistMongoDBUnsupported "only PersistUTCTime currently implemented"@@ -475,7 +530,7 @@ cast' (DB.Float x) = Just (PersistDouble x) cast' (DB.Int32 x) = Just $ PersistInt64 $ fromIntegral x cast' (DB.Int64 x) = Just $ PersistInt64 x- cast' (DB.String x) = Just $ PersistText (csToText x)+ cast' (DB.String x) = Just $ PersistText x cast' (DB.Bool x) = Just $ PersistBool x cast' (DB.UTC d) = Just $ PersistUTCTime d cast' DB.Null = Just $ PersistNull@@ -484,7 +539,7 @@ cast' (DB.Uuid (DB.UUID uid)) = Just $ PersistByteString uid cast' (DB.Md5 (DB.MD5 md5)) = Just $ PersistByteString md5 cast' (DB.UserDef (DB.UserDefined bs)) = Just $ PersistByteString bs- cast' (DB.RegEx (DB.Regex us1 us2)) = Just $ PersistByteString $ CS.toByteString $ CS.append us1 us2+ cast' (DB.RegEx (DB.Regex us1 us2)) = Just $ PersistByteString $ E.encodeUtf8 $ T.append us1 us2 cast' (DB.Doc doc) = Just $ PersistMap $ mapFromDoc doc cast' (DB.Array xs) = Just $ PersistList $ mapMaybe DB.cast' xs cast' (DB.ObjId x) = Just $ oidToPersistValue x @@ -508,32 +563,63 @@ dummyFromFilts :: [Filter v] -> v dummyFromFilts _ = error "dummyFromFilts" +data MongoAuth = MongoAuth DB.Username DB.Password -- | Information required to connect to a mongo database data MongoConf = MongoConf- { mgDatabase :: String- , mgHost :: String- , mgPoolSize :: Int+ { mgDatabase :: Text+ , mgHost :: Text+ , mgAuth :: Maybe MongoAuth , mgAccessMode :: DB.AccessMode+ , mgPoolStripes :: Int+ , mgStripeConnections :: Int+ , mgConnectionIdleTime :: NominalDiffTime } instance PersistConfig MongoConf where type PersistConfigBackend MongoConf = DB.Action type PersistConfigPool MongoConf = ConnectionPool- createPoolConfig (MongoConf db host poolsize _) = createMongoDBPool (u db) host poolsize- runPool (MongoConf _ _ _ accessMode) = runMongoDBConn accessMode++ createPoolConfig c =+ createMongoDBPool + (mgDatabase c) (T.unpack (mgHost c))+ (mgAuth c)+ (mgPoolStripes c) (mgStripeConnections c) (mgConnectionIdleTime c)++ runPool c = runMongoDBPool (mgAccessMode c) loadConfig (Object o) = do- db <- o .: "database"- host <- o .: "host"- pool <- o .: "poolsize"- accessString <- o .:? "accessMode" .!= "ConfirmWrites"+ db <- o .: "database"+ host <- o .:? "host" .!= "127.0.0.1"+ poolStripes <- o .:? "poolstripes" .!= 1+ stripeConnections <- o .: "connections"+ (NoOrphanNominalDiffTime connectionIdleTime) <- o .:? "connectionIdleTime" .!= 20+ mUser <- o .:? "user"+ mPass <- o .:? "password"+ accessString <- o .:? "accessMode" .!= "ConfirmWrites" + mPoolSize <- o .:? "poolsize"+ case mPoolSize of+ Nothing -> return ()+ Just (_::Int) -> fail "specified deprecated poolsize attribute. Please specify a connections. You can also specify a pools attribute which defaults to 1. Total connections opened to the db are connections * pools"+ accessMode <- case accessString of "ReadStaleOk" -> return DB.ReadStaleOk "UnconfirmedWrites" -> return DB.UnconfirmedWrites- "ConfirmWrites" -> return $ DB.ConfirmWrites [u"j" DB.=: True]+ "ConfirmWrites" -> return $ DB.ConfirmWrites ["j" DB.=: True] badAccess -> fail $ "unknown accessMode: " ++ (T.unpack badAccess) - return $ MongoConf (T.unpack db) (T.unpack host) pool accessMode+ return $ MongoConf {+ mgDatabase = db+ , mgHost = host+ , mgAuth =+ (case (mUser, mPass) of+ (Just user, Just pass) -> Just (MongoAuth user pass)+ _ -> Nothing+ )+ , mgPoolStripes = poolStripes+ , mgStripeConnections = stripeConnections+ , mgAccessMode = accessMode+ , mgConnectionIdleTime = connectionIdleTime+ } where {- safeRead :: String -> T.Text -> MEither String Int
persistent-mongoDB.cabal view
@@ -1,5 +1,5 @@ name: persistent-mongoDB-version: 0.9.0.3+version: 1.0.0 license: MIT license-file: LICENSE author: Greg Weber <greg@gregweber.info>@@ -14,21 +14,23 @@ library build-depends: base >= 4 && < 5- , persistent >= 0.9 && < 0.10+ , persistent >= 1.0 && < 1.1 , text >= 0.8 && < 1 , transformers >= 0.2.1 && < 0.4 , containers >= 0.2 && < 0.5 , bytestring >= 0.9- , conduit >= 0.4 && < 0.5+ , conduit >= 0.5 && < 0.6 , resourcet >= 0.3 && < 0.4- , mongoDB >= 1.2 && < 1.3- , bson >= 0.1.6 && < 0.1.8+ , mongoDB >= 1.3 && < 1.4+ , bson >= 0.2 && < 0.3 , network >= 2.2.1.7 && < 3- , compact-string-fix >= 0.3.1 && < 0.4 , cereal >= 0.3.0.0 , path-pieces >= 0.1 && < 0.2 , monad-control >= 0.3 && < 0.4 , aeson >= 0.5+ , attoparsec+ , pool-conduit >= 0.1 && < 0.2+ , time exposed-modules: Database.Persist.MongoDB ghc-options: -Wall