diff --git a/Database/Persist/MongoDB.hs b/Database/Persist/MongoDB.hs --- a/Database/Persist/MongoDB.hs +++ b/Database/Persist/MongoDB.hs @@ -6,46 +6,65 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.MongoDB - ( withMongoDBConn + ( + -- * using connections + withMongoDBConn , withMongoDBPool + , createMongoDBPool , runMongoDBConn + , ConnectionPool + , MongoConf (..) + -- * Key conversion helpers + , keyToOid + , oidToKey + -- * CompactString helpers + , csToText + , textToCS + -- * network type , HostName + -- * UString type , u + -- * MongoDB driver types , DB.Action - -- , DB.MasterOrSlaveOk(..) , DB.AccessMode(..) , DB.master , DB.slaveOk , (DB.=:) - , ConnectionPool + -- * Database.Persistent , module Database.Persist - , MongoConf (..) ) where import Database.Persist -import Database.Persist.Base +import Database.Persist.EntityDef +import Database.Persist.Store +import Database.Persist.Query.Internal import qualified Control.Monad.IO.Class as Trans -import Control.Exception (throw, toException, throwIO) +import Control.Exception (throw, throwIO) 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 Data.Enumerator hiding (map, length, concatMap, head, replicate) import Network.Socket (HostName) import Data.Maybe (mapMaybe, fromJust) import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.Serialize as Serialize import qualified System.IO.Pool as Pool -import Web.PathPieces (SinglePiece (..)) -import Control.Monad.IO.Control (MonadControlIO) -import Data.Object -import Data.Neither (MEither (..), meither) +import Web.PathPieces (PathPiece (..)) +import Data.Conduit (ResourceIO) +import qualified Data.Conduit as C +import Control.Monad.Trans.Resource (ResourceThrow (..)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value (Object), (.:), (.:?), (.!=)) +import Control.Monad (mzero) +import Control.Monad.Trans.Control (MonadBaseControl) #ifdef DEBUG import FileLocation (debug) @@ -60,13 +79,13 @@ type ConnectionPool = (Pool.Pool IOError DB.Pipe, Database) -instance SinglePiece (Key DB.Action entity) where - toSinglePiece (Key pOid@(PersistObjectId _)) = -- T.pack $ show $ Serialize.encode bsonId +instance PathPiece (Key DB.Action entity) where + toPathPiece (Key pOid@(PersistObjectId _)) = -- T.pack $ show $ Serialize.encode bsonId let oid = persistObjectIdToDbOid pOid in T.pack $ show oid - toSinglePiece k = throw $ PersistInvalidField $ "Invalid Key (expected PersistObjectId): " ++ show k + toPathPiece k = throw $ PersistInvalidField $ T.pack $ "Invalid Key (expected PersistObjectId): " ++ show k - fromSinglePiece str = + fromPathPiece str = case (reads $ (T.unpack str))::[(DB.ObjectId,String)] of (parsed,_):[] -> Just $ Key $ PersistObjectId $ Serialize.encode parsed _ -> Nothing @@ -76,52 +95,59 @@ Database -> HostName -> (ConnectionPool -> m b) -> m b withMongoDBConn dbname hostname = withMongoDBPool dbname hostname 1 -withMongoDBPool :: (Trans.MonadIO m, Applicative m) => - Database -> HostName -> Int -> (ConnectionPool -> m b) -> m b -withMongoDBPool dbname hostname connectionPoolSize connectionReader = do +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 - connectionReader (pool, dbname) + return (pool, dbname) +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 + 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 . show) return res + either (Trans.liftIO . throwIO . PersistMongoDBError . T.pack . show) return res value :: DB.Field -> DB.Value value (_ DB.:= val) = val rightPersistVals :: (PersistEntity val) => EntityDef -> [DB.Field] -> val rightPersistVals ent vals = case wrapFromPersistValues ent vals of - Left e -> error e + Left e -> error $ T.unpack e Right v -> v filterByKey :: (PersistEntity val) => Key DB.Action val -> DB.Document -filterByKey k = [u"_id" DB.=: keyToDbOid k] +filterByKey k = [u"_id" DB.=: keyToOid k] queryByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Query -queryByKey k entity = (DB.select (filterByKey k) (u $ entityName entity)) +queryByKey k entity = (DB.select (filterByKey k) (u $ T.unpack $ unDBName $ entityDB entity)) selectByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Selection -selectByKey k entity = (DB.select (filterByKey k) (u $ entityName entity)) +selectByKey k entity = (DB.select (filterByKey k) (u $ T.unpack $ unDBName $ entityDB entity)) updateFields :: (PersistEntity val) => [Update val] -> [DB.Field] updateFields upds = map updateToMongoField upds updateToMongoField :: (PersistEntity val) => Update val -> DB.Field -updateToMongoField upd@(Update _ v up) = opName DB.:= DB.Doc [( (u $ updateFieldName upd) DB.:= opValue)] +updateToMongoField (Update field v up) = + opName DB.:= DB.Doc [( (u $ T.unpack $ unDBName $ fieldDB $ persistFieldDef field) DB.:= opValue)] where opValue = DB.val . snd $ opNameValue opName = fst opNameValue opNameValue = case (up, toPersistValue v) of - (Assign,a) -> (u "$set", a) - (Add, a) -> (u "$inc", a) + (Assign,a) -> (u"$set", a) + (Add, a) -> (u"$inc", a) (Subtract, PersistInt64 i) -> (u "$inc", PersistInt64 (-i)) (Subtract, _) -> error "expected PersistInt64 for a subtraction" (Multiply, _) -> throw $ PersistMongoDBUnsupported "multiply not supported" @@ -130,78 +156,60 @@ uniqSelector :: forall val. (PersistEntity val) => Unique val DB.Action -> [DB.Field] uniqSelector uniq = zipWith (DB.:=) - (map u (persistUniqueToFieldNames uniq)) + (map u (map (T.unpack . unDBName . snd) $ persistUniqueToFieldNames uniq)) (map DB.val (persistUniqueToValues uniq)) -pairFromDocument :: forall val val1. (PersistEntity val, PersistEntity val1) => EntityDef -> [DB.Field] -> Either String (Key DB.Action val, val1) +pairFromDocument :: PersistEntity val + => EntityDef + -> [DB.Field] + -> Either String (Entity DB.Action val) pairFromDocument ent document = pairFromPersistValues document where pairFromPersistValues (x:xs) = case wrapFromPersistValues ent xs of - Left e -> Left e - Right xs' -> Right ((Key . dbOidToKey . fromJust . DB.cast' . value) x, xs') + Left e -> Left $ T.unpack e + 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 = zipWith (DB.:=) (toLabels) (toValues) where - toLabels = map (u . columnName) $ entityColumns t + toLabels = map (u . T.unpack . unDBName . fieldDB) $ entityFields t toValues = map (DB.val . toPersistValue) (toPersistFields record) -instance (Applicative m, Functor m, MonadControlIO m) => PersistBackend DB.Action m where +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)) + where + t = entityDef record + +instance (Applicative m, Functor m, ResourceIO m) => PersistStore DB.Action m where insert record = do - (DB.ObjId oid) <- DB.insert (u $ entityName t) (insertFields t record) - return $ Key $ dbOidToKey oid + (DB.ObjId oid) <- DB.insert (u $ T.unpack $ unDBName $ entityDB t) (insertFields t record) + return $ oidToKey oid where t = entityDef record + insertKey k record = saveWithKey DB.insert_ k record + + repsert k record = saveWithKey DB.save k record + replace k record = do DB.replace (selectByKey k t) (insertFields t record) return () where t = entityDef record - update _ [] = return () - update k upds = - DB.modify - (DB.Select [u"_id" DB.:= (DB.ObjId $ keyToDbOid k)] (u $ entityName t)) - $ updateFields upds - where - t = entityDef $ dummyFromKey k - - updateWhere _ [] = return () - updateWhere filts upds = - DB.modify DB.Select { - DB.coll = (u $ entityName t) - , DB.selector = filtersToSelector filts - } $ updateFields upds - where - t = entityDef $ dummyFromFilts filts - delete k = DB.deleteOne DB.Select { - DB.coll = (u $ entityName t) + DB.coll = (u $ T.unpack $ unDBName $ entityDB t) , DB.selector = filterByKey k } where t = entityDef $ dummyFromKey k - deleteWhere filts = do - DB.delete DB.Select { - DB.coll = (u $ entityName t) - , DB.selector = filtersToSelector filts - } - where - t = entityDef $ dummyFromFilts filts - - deleteBy uniq = - DB.delete DB.Select { - DB.coll = u $ entityName t - , DB.selector = uniqSelector uniq - } - where - t = entityDef $ dummyFromUnique uniq - get k = do d <- DB.findOne (queryByKey k t) case d of @@ -211,73 +219,104 @@ where t = entityDef $ dummyFromKey k +instance ResourceThrow m => ResourceThrow (DB.Action m) where + resourceThrow = lift . resourceThrow + +instance (Applicative m, Functor m, ResourceIO m) => PersistUnique DB.Action m where getBy uniq = do mdocument <- DB.findOne $ - (DB.select (uniqSelector uniq) (u $ entityName t)) + (DB.select (uniqSelector uniq) (u $ T.unpack $ unDBName $ entityDB t)) case mdocument of Nothing -> return Nothing Just document -> case pairFromDocument t document of - Left s -> Trans.liftIO . throwIO $ PersistMarshalError s - Right (k, x) -> return $ Just (k, x) + Left s -> Trans.liftIO . throwIO $ PersistMarshalError $ T.pack s + Right e -> return $ Just e where t = entityDef $ dummyFromUnique uniq + deleteBy uniq = + DB.delete DB.Select { + DB.coll = u $ T.unpack $ 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) + +instance (Applicative m, Functor m, ResourceIO m) => PersistQuery DB.Action m where + update _ [] = return () + update k upds = + DB.modify + (DB.Select [persistKeyToMongoId k] (u $ T.unpack $ unDBName $ entityDB t)) + $ updateFields upds + where + t = entityDef $ dummyFromKey k + + updateWhere _ [] = return () + updateWhere filts upds = + DB.modify DB.Select { + DB.coll = (u $ T.unpack $ unDBName $ entityDB t) + , DB.selector = filtersToSelector filts + } $ updateFields upds + where + t = entityDef $ dummyFromFilts filts + + deleteWhere filts = do + DB.delete DB.Select { + DB.coll = (u $ T.unpack $ unDBName $ entityDB t) + , DB.selector = filtersToSelector filts + } + where + t = entityDef $ dummyFromFilts filts + count filts = do i <- DB.count query return $ fromIntegral i where - query = DB.select (filtersToSelector filts) (u $ entityName t) + query = DB.select (filtersToSelector filts) (u $ T.unpack $ unDBName $ entityDB t) t = entityDef $ dummyFromFilts filts - selectEnum filts opts = Iteratee . start + selectSource filts opts = C.Source $ do + cursor <- lift $ DB.find $ makeQuery filts opts + return $ C.PreparedSource + { C.sourcePull = lift $ do + mdoc <- DB.next cursor + case mdoc of + Nothing -> return C.Closed + Just doc -> + case pairFromDocument t doc of + Left s -> liftIO $ throwIO $ PersistMarshalError $ T.pack s + Right row -> return $ C.Open row + , C.sourceClose = return () + } where - start x = do - cursor <- DB.find $ makeQuery filts opts - loop x cursor - t = entityDef $ dummyFromFilts filts - loop (Continue k) curs = do - doc <- DB.next curs - case doc of - Nothing -> return $ Continue k - Just document -> case pairFromDocument t document of - Left s -> return $ Error $ toException - $ PersistMarshalError s - Right row -> do - step <- runIteratee $ k $ Chunks [row] - loop step curs - loop step _ = return step - selectFirst filts opts = do doc <- DB.findOne $ makeQuery filts opts case doc of Nothing -> return Nothing Just document -> case pairFromDocument t document of - Left s -> Trans.liftIO . throwIO $ PersistMarshalError s + Left s -> Trans.liftIO . throwIO $ PersistMarshalError $ T.pack s Right row -> return $ Just row where t = entityDef $ dummyFromFilts filts - selectKeys filts = - Iteratee . start + selectKeys filts = C.Source $ do + cursor <- lift $ DB.find query + return $ C.PreparedSource + { C.sourcePull = lift $ do + mdoc <- DB.next cursor + case mdoc of + Nothing -> return C.Closed + Just [_ DB.:= DB.ObjId oid] -> return $ C.Open $ oidToKey oid + Just y -> liftIO $ throwIO $ PersistMarshalError $ T.pack $ "Unexpected in selectKeys: " ++ show y + , C.sourceClose = return () + } where - start x = do - cursor <- DB.find query - loop x cursor - - loop (Continue k) curs = do - doc <- DB.next curs - case doc of - Nothing -> return $ Continue k - Just [_ DB.:= (DB.ObjId oid)] -> do - step <- runIteratee $ k $ Chunks [Key $ dbOidToKey oid] - loop step curs - Just y -> return $ Error $ toException $ PersistMarshalError - $ "Unexpected in selectKeys: " ++ show y - loop step _ = return step - - query = (DB.select (filtersToSelector filts) (u $ entityName t)) { + query = (DB.select (filtersToSelector filts) (u $ T.unpack $ unDBName $ entityDB t)) { DB.project = [u"_id" DB.=: (1 :: Int)] } t = entityDef $ dummyFromFilts filts @@ -291,16 +330,15 @@ makeQuery :: PersistEntity val => [Filter val] -> [SelectOpt val] -> DB.Query makeQuery filts opts = - (DB.select (filtersToSelector filts) (u $ entityName t)) { + (DB.select (filtersToSelector filts) (u $ T.unpack $ unDBName $ entityDB t)) { DB.limit = fromIntegral limit , DB.skip = fromIntegral offset , DB.sort = orders } where t = entityDef $ dummyFromFilts filts - limit = fst3 $ limitOffsetOrder opts - offset = snd3 $ limitOffsetOrder opts - orders = map orderClause $ third3 $ limitOffsetOrder opts + (limit, offset, orders') = limitOffsetOrder opts + orders = map orderClause orders' filtersToSelector :: PersistEntity val => [Filter val] -> DB.Document filtersToSelector filts = @@ -318,10 +356,13 @@ Filter field v filt -> return $ case filt of Eq -> fieldName field DB.:= toValue v _ -> fieldName field DB.=: [u(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"]] FilterOr fs -> multiFilter "$or" fs - -- I didn't even know about the $and operator. - -- It is unecessary in 99% of cases. - -- However it makes query construction easier in special cases + -- $and is usually unecessary but makes query construction easier in special cases + FilterAnd [] -> [] FilterAnd fs -> multiFilter "$and" fs where toValue :: forall a. PersistField a => Either a [a] -> DB.Value @@ -338,18 +379,18 @@ showFilter In = "$in" showFilter NotIn = "$nin" showFilter Eq = error "EQ filter not expected" - showFilter (BackendSpecificFilter bsf) = throw $ PersistMongoDBError $ "did not expect BackendSpecificFilter " ++ bsf + 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 . columnName . persistColumnDef +fieldName = u . idfix . T.unpack . unDBName . fieldDB . persistFieldDef where idfix f = if f == "id" then "_id" else f -wrapFromPersistValues :: (PersistEntity val) => EntityDef -> [DB.Field] -> Either String val +wrapFromPersistValues :: (PersistEntity val) => EntityDef -> [DB.Field] -> Either T.Text val wrapFromPersistValues e doc = fromPersistValues reorder where castDoc = mapFromDoc doc - castColumns = map (T.pack . columnName) $ (entityColumns e) + castColumns = map (unDBName . fieldDB) $ (entityFields e) -- we have an alist of fields that need to be the same order as entityColumns -- -- this naive lookup is O(n^2) @@ -366,46 +407,57 @@ reorder = match castColumns castDoc [] where match :: [T.Text] -> [(T.Text, PersistValue)] -> [PersistValue] -> [PersistValue] - match [] [] values = values + -- when there are no more Persistent castColumns we are done + -- + -- allow extra mongoDB fields that persistent does not know about + -- another application may use fields we don't care about + -- our own application may set extra fields with the raw driver + -- TODO: instead use a projection to avoid network overhead + match [] _ values = values match (c:cs) fields values = let (found, unused) = matchOne fields [] in match cs unused (values ++ [snd found]) where matchOne (f:fs) tried = if c == fst f then (f, tried ++ fs) else matchOne fs (f:tried) - matchOne fs tried = throw $ PersistError $ "reorder error: field doesn't match" ++ (show c) ++ (show fs) ++ (show tried) - match cs fs values = throw $ PersistError $ "reorder error: fields don't match" ++ (show cs) ++ (show fs) ++ (show values) + matchOne fs tried = throw $ PersistError $ T.pack $ "reorder error: field doesn't match" ++ (show c) ++ (show fs) ++ (show tried) + -- match [] fs values = throw $ PersistError $ "reorder error: extra mongo fields" ++ (show fs) mapFromDoc :: DB.Document -> [(T.Text, PersistValue)] -mapFromDoc = Prelude.map (\f -> ( ( csToT (DB.label f)), (fromJust . DB.cast') (DB.value f) ) ) +mapFromDoc = Prelude.map (\f -> ( ( csToText (DB.label f)), (fromJust . DB.cast') (DB.value f) ) ) -csToT :: CS.CompactString -> T.Text -csToT = E.decodeUtf8 . CS.toByteString +-- | CompactString is UTF8, Text is UTF16 +csToText :: CS.CompactString -> T.Text +csToText = E.decodeUtf8 . CS.toByteString -tToCS :: T.Text -> CS.CompactString -tToCS = CS.fromByteString_ . E.encodeUtf8 +-- | CompactString is UTF8, Text is UTF16 +textToCS :: T.Text -> CS.CompactString +textToCS = CS.fromByteString_ . E.encodeUtf8 -dbOidToKey :: DB.ObjectId -> PersistValue -dbOidToKey = PersistObjectId . Serialize.encode +oidToPersistValue :: DB.ObjectId -> PersistValue +oidToPersistValue = PersistObjectId . Serialize.encode +oidToKey :: (PersistEntity val) => DB.ObjectId -> Key DB.Action val +oidToKey = Key . oidToPersistValue + persistObjectIdToDbOid :: PersistValue -> DB.ObjectId persistObjectIdToDbOid (PersistObjectId k) = case Serialize.decode k of - Left msg -> throw $ PersistError $ "error decoding " ++ (show k) ++ ": " ++ msg + Left msg -> throw $ PersistError $ T.pack $ "error decoding " ++ (show k) ++ ": " ++ msg Right o -> o persistObjectIdToDbOid _ = throw $ PersistInvalidField "expected PersistObjectId" -keyToDbOid :: (PersistEntity val) => Key DB.Action val -> DB.ObjectId -keyToDbOid (Key k) = persistObjectIdToDbOid k +keyToOid :: (PersistEntity val) => Key DB.Action val -> DB.ObjectId +keyToOid (Key k) = persistObjectIdToDbOid k instance DB.Val PersistValue where val (PersistInt64 x) = DB.Int64 x - val (PersistText x) = DB.String (tToCS x) + val (PersistText x) = DB.String (textToCS x) val (PersistDouble x) = DB.Float x val (PersistBool x) = DB.Bool x val (PersistUTCTime x) = DB.UTC x val (PersistNull) = DB.Null val (PersistList l) = DB.Array $ map DB.val l - val (PersistMap m) = DB.Doc $ map (\(k, v)-> (DB.=:) (tToCS k) v) m + val (PersistMap m) = DB.Doc $ map (\(k, v)-> (DB.=:) (textToCS k) v) m val (PersistByteString x) = DB.String $ CS.fromByteString_ x val x@(PersistObjectId _) = DB.ObjId $ persistObjectIdToDbOid x val (PersistDay _) = throw $ PersistMongoDBUnsupported "only PersistUTCTime currently implemented" @@ -413,7 +465,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 (csToT x) + cast' (DB.String x) = Just $ PersistText (csToText x) cast' (DB.Bool x) = Just $ PersistBool x cast' (DB.UTC d) = Just $ PersistUTCTime d cast' DB.Null = Just $ PersistNull @@ -425,7 +477,7 @@ cast' (DB.RegEx (DB.Regex us1 us2)) = Just $ PersistByteString $ CS.toByteString $ CS.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 $ dbOidToKey x + cast' (DB.ObjId x) = Just $ oidToPersistValue x cast' (DB.JavaScr _) = throw $ PersistMongoDBUnsupported "cast operation not supported for javascript" cast' (DB.Sym _) = throw $ PersistMongoDBUnsupported "cast operation not supported for sym" cast' (DB.Stamp _) = throw $ PersistMongoDBUnsupported "cast operation not supported for stamp" @@ -451,29 +503,34 @@ { mgDatabase :: String , mgHost :: String , mgPoolSize :: Int + , mgAccessMode :: DB.AccessMode } instance PersistConfig MongoConf where type PersistConfigBackend MongoConf = DB.Action type PersistConfigPool MongoConf = ConnectionPool - withPool (MongoConf db host poolsize) = withMongoDBPool (u db) host poolsize - runPool _ = runMongoDBConn (DB.ConfirmWrites [u"j" DB.=: True]) - loadConfig e' = meither Left Right $ do - e <- go $ fromMapping e' - db <- go $ lookupScalar "database" e - host <- go $ lookupScalar "host" e - pool' <- go $ lookupScalar "poolsize" e - pool <- safeRead "poolsize" pool' + createPoolConfig (MongoConf db host poolsize _) = createMongoDBPool (u db) host poolsize + runPool (MongoConf _ _ _ accessMode) = runMongoDBConn accessMode + loadConfig (Object o) = do + db <- o .: "database" + host <- o .: "host" + pool <- o .: "poolsize" + accessString <- o .:? "accessMode" .!= "ConfirmWrites" - return $ MongoConf (T.unpack db) (T.unpack host) pool - where - go :: MEither ObjectExtractError a -> MEither String a - go (MLeft e) = MLeft $ show e - go (MRight a) = MRight a + accessMode <- case accessString of + "ReadStaleOk" -> return DB.ReadStaleOk + "UnconfirmedWrites" -> return DB.UnconfirmedWrites + "ConfirmWrites" -> return $ DB.ConfirmWrites [u"j" DB.=: True] + badAccess -> fail $ "unknown accessMode: " ++ (T.unpack badAccess) -safeRead :: String -> T.Text -> MEither String Int -safeRead name t = case reads s of - (i, _):_ -> MRight i - [] -> MLeft $ concat ["Invalid value for ", name, ": ", s] - where - s = T.unpack t + return $ MongoConf (T.unpack db) (T.unpack host) pool accessMode + where + {- + safeRead :: String -> T.Text -> MEither String Int + safeRead name t = case reads s of + (i, _):_ -> MRight i + [] -> MLeft $ concat ["Invalid value for ", name, ": ", s] + where + s = T.unpack t + -} + loadConfig _ = mzero 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: 0.6.3 +version: 0.7.0 license: BSD3 license-file: LICENSE author: Greg Weber @@ -14,22 +14,20 @@ library build-depends: base >= 4 && < 5 - , persistent >= 0.6.3 && < 0.7.0 - , template-haskell >= 2.4 && < 2.7 - , text >= 0.8 && < 0.12 + , persistent >= 0.7 && < 0.8 + , text >= 0.8 && < 1 , transformers >= 0.2.1 && < 0.3 , containers >= 0.2 && < 0.5 , bytestring >= 0.9 && < 0.10 - , enumerator >= 0.4 && < 0.5 - , mongoDB >= 1.1 && < 1.2 + , conduit + , mongoDB >= 1.2 && < 1.3 , bson >= 0.1.6 - , network >= 2.2.1.7 + , network >= 2.2.1.7 && < 3 , compact-string-fix >= 0.3.1 && < 0.4 , cereal >= 0.3.0.0 - , path-pieces >= 0.0 && < 0.1 - , monad-control >= 0.2 && < 0.3 - , data-object >= 0.3 && < 0.4 - , neither >= 0.3 && < 0.4 + , path-pieces >= 0.1 && < 0.2 + , monad-control >= 0.3 && < 0.4 + , aeson >= 0.5 exposed-modules: Database.Persist.MongoDB ghc-options: -Wall