persistent-mongoDB 0.6.3 → 0.7.0
raw patch · 2 files changed
+222/−167 lines, 2 filesdep +aesondep +conduitdep −data-objectdep −enumeratordep −neitherdep ~monad-controldep ~mongoDBdep ~network
Dependencies added: aeson, conduit
Dependencies removed: data-object, enumerator, neither, template-haskell
Dependency ranges changed: monad-control, mongoDB, network, path-pieces, persistent, text
Files
- Database/Persist/MongoDB.hs +213/−156
- persistent-mongoDB.cabal +9/−11
Database/Persist/MongoDB.hs view
@@ -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
persistent-mongoDB.cabal view
@@ -1,5 +1,5 @@ name: persistent-mongoDB-version: 0.6.3+version: 0.7.0 license: BSD3 license-file: LICENSE author: Greg Weber <greg@gregweber.info>@@ -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