persistent-mongoDB 1.3.1.1 → 1.3.2
raw patch · 2 files changed
+71/−15 lines, 2 files
Files
- Database/Persist/MongoDB.hs +70/−14
- persistent-mongoDB.cabal +1/−1
Database/Persist/MongoDB.hs view
@@ -53,6 +53,7 @@ , fieldName -- * using connections+ , withConnection , withMongoDBConn , withMongoDBPool , createMongoDBPool@@ -60,9 +61,19 @@ , runMongoDBPoolDef , ConnectionPool , Connection- , MongoConf (..) , MongoBackend , MongoAuth (..)++ -- * Connection configuration+ , MongoConf (..)+ , defaultMongoConf+ , defaultHost+ , defaultAccessMode+ , defaultPoolStripes+ , defaultConnectionIdleTime+ , defaultStripeConnections+ , applyDockerEnv+ -- ** using raw MongoDB pipes , PipePool , createMongoDBPipePool@@ -112,13 +123,17 @@ import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) #endif import Data.Time.Calendar (Day(..))+#if MIN_VERSION_aeson(0, 7, 0)+#else import Data.Attoparsec.Number+#endif 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)+import System.Environment (lookupEnv) #ifdef DEBUG import FileLocation (debug)@@ -131,7 +146,7 @@ deriving (Show, Eq, Num) instance FromJSON NoOrphanNominalDiffTime where-#if MIN_VERSION_aeson(0, 7, 0) +#if MIN_VERSION_aeson(0, 7, 0) parseJSON (Number x) = (return . NoOrphanNominalDiffTime . fromRational . toRational) x @@ -206,6 +221,12 @@ sqlType _ = Sql.SqlOther "doesn't make much sense for MongoDB" +withConnection :: (Trans.MonadIO m, Applicative m)+ => MongoConf+ -> (ConnectionPool -> m b) -> m b+withConnection mc =+ withMongoDBPool (mgDatabase mc) (T.unpack $ mgHost mc) (mgPort mc) (mgAuth mc) (mgPoolStripes mc) (mgStripeConnections mc) (mgConnectionIdleTime mc)+ withMongoDBConn :: (Trans.MonadIO m, Applicative m) => Database -> HostName -> PortID -> Maybe MongoAuth -> NominalDiffTime@@ -299,14 +320,19 @@ updateToMongoField (Update field v up) = opName DB.:= DB.Doc [fieldName field DB.:= opValue] where + inc = "$inc"+ mul = "$mul" (opName, opValue) = case (up, toPersistValue v) of (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))+ (Add, a) -> (inc, DB.val a)+ (Subtract, PersistInt64 i) -> (inc, DB.Int64 (-i))+ (Multiply, PersistInt64 i) -> (mul, DB.Int64 i)+ (Multiply, PersistDouble d) -> (mul, DB.Float d) (Subtract, _) -> error "expected PersistInt64 for a subtraction"- (Multiply, _) -> throw $ PersistMongoDBUnsupported "multiply not supported"+ (Multiply, _) -> error "expected PersistInt64 or PersistDouble for a subtraction"+ -- Obviously this could be supported for floats by multiplying with 1/x (Divide, _) -> throw $ PersistMongoDBUnsupported "divide not supported" @@ -801,6 +827,28 @@ , mgConnectionIdleTime :: NominalDiffTime } deriving Show +defaultHost :: Text+defaultHost = "127.0.0.1"+defaultAccessMode :: DB.AccessMode+defaultAccessMode = DB.ConfirmWrites ["j" DB.=: True]+defaultPoolStripes, defaultStripeConnections :: Int+defaultPoolStripes = 1+defaultStripeConnections = 10+defaultConnectionIdleTime :: NominalDiffTime+defaultConnectionIdleTime = 20++defaultMongoConf :: Text -> MongoConf+defaultMongoConf dbName = MongoConf+ { mgDatabase = dbName+ , mgHost = defaultHost+ , mgPort = DB.defaultPort+ , mgAuth = Nothing+ , mgAccessMode = defaultAccessMode+ , mgPoolStripes = defaultPoolStripes+ , mgStripeConnections = defaultStripeConnections+ , mgConnectionIdleTime = defaultConnectionIdleTime+ }+ instance PersistConfig MongoConf where type PersistConfigBackend MongoConf = DB.Action type PersistConfigPool MongoConf = ConnectionPool@@ -814,14 +862,14 @@ runPool c = runMongoDBPool (mgAccessMode c) loadConfig (Object o) = do db <- o .: "database"- host <- o .:? "host" .!= "127.0.0.1"+ host <- o .:? "host" .!= defaultHost (NoOrphanPortID port) <- o .:? "port" .!= (NoOrphanPortID DB.defaultPort)- poolStripes <- o .:? "poolstripes" .!= 1- stripeConnections <- o .: "connections"- (NoOrphanNominalDiffTime connectionIdleTime) <- o .:? "connectionIdleTime" .!= 20+ poolStripes <- o .:? "poolstripes" .!= defaultPoolStripes+ stripeConnections <- o .:? "connections" .!= defaultStripeConnections+ (NoOrphanNominalDiffTime connectionIdleTime) <- o .:? "connectionIdleTime" .!= (NoOrphanNominalDiffTime defaultConnectionIdleTime) mUser <- o .:? "user" mPass <- o .:? "password"- accessString <- o .:? "accessMode" .!= "ConfirmWrites"+ accessString <- o .:? "accessMode" .!= T.pack (show defaultAccessMode) mPoolSize <- o .:? "poolsize" case mPoolSize of@@ -829,10 +877,10 @@ 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 ["j" DB.=: True]- badAccess -> fail $ "unknown accessMode: " ++ (T.unpack badAccess)+ "ReadStaleOk" -> return DB.ReadStaleOk+ "UnconfirmedWrites" -> return DB.UnconfirmedWrites+ "ConfirmWrites" -> return $ defaultAccessMode+ badAccess -> fail $ "unknown accessMode: " ++ (T.unpack badAccess) return $ MongoConf { mgDatabase = db@@ -858,6 +906,14 @@ s = T.unpack t -} loadConfig _ = mzero++-- | docker integration: change the host to the mongodb link+applyDockerEnv :: MongoConf -> IO MongoConf+applyDockerEnv mconf = do+ mHost <- lookupEnv "MONGODB_PORT_27017_TCP_ADDR"+ return $ case mHost of+ Nothing -> mconf+ Just h -> mconf { mgHost = T.pack h } -- ---------------------------
persistent-mongoDB.cabal view
@@ -1,5 +1,5 @@ name: persistent-mongoDB-version: 1.3.1.1+version: 1.3.2 license: MIT license-file: LICENSE author: Greg Weber <greg@gregweber.info>