persistent-mongoDB 1.0.1.0 → 1.1.0
raw patch · 2 files changed
+121/−43 lines, 2 filesdep ~persistent
Dependency ranges changed: persistent
Files
- Database/Persist/MongoDB.hs +119/−41
- persistent-mongoDB.cabal +2/−2
Database/Persist/MongoDB.hs view
@@ -2,9 +2,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE RankNTypes, TypeFamilies #-}+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE UndecidableInstances #-} -- FIXME {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE GADTs #-} module Database.Persist.MongoDB ( -- * using connections@@ -16,6 +18,7 @@ , ConnectionPool , Connection , MongoConf (..)+ , MongoBackend -- * Key conversion helpers , keyToOid , oidToKey@@ -26,6 +29,7 @@ , docToEntityThrow -- * network type , HostName+ , PortID -- * MongoDB driver types , DB.Action , DB.AccessMode(..)@@ -34,6 +38,9 @@ , (DB.=:) -- * Database.Persist , module Database.Persist+ -- * Mongo Filters+ , (~>.) ,(?~>.), (->.), (?->.)+ , nestEq, multiEq ) where import Database.Persist@@ -47,6 +54,7 @@ import qualified Database.MongoDB as DB import Database.MongoDB.Query (Database) import Control.Applicative (Applicative)+import Network (PortID (PortNumber)) import Network.Socket (HostName) import Data.Maybe (mapMaybe, fromJust) import qualified Data.Text as T@@ -59,10 +67,10 @@ import Control.Monad.IO.Class (liftIO) import Data.Aeson (Value (Object, Number), (.:), (.:?), (.!=), FromJSON(..)) import Control.Monad (mzero)-import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Conduit.Pool as Pool import Data.Time (NominalDiffTime) import Data.Attoparsec.Number+import Data.Char (toUpper) #ifdef DEBUG import FileLocation (debug)@@ -76,10 +84,14 @@ parseJSON (Number (D x)) = (return . NoOrphanNominalDiffTime . fromRational . toRational) x parseJSON _ = fail "couldn't parse diff time" +instance FromJSON PortID where+ parseJSON (Number (I x)) = (return . PortNumber . fromInteger) x+ parseJSON _ = fail "couldn't parse port number"+ data Connection = Connection DB.Pipe DB.Database type ConnectionPool = Pool.Pool Connection -instance PathPiece (Key DB.Action entity) where+instance PathPiece (KeyBackend MongoBackend entity) where toPathPiece (Key pOid@(PersistObjectId _)) = -- T.pack $ show $ Serialize.encode bsonId let oid = persistObjectIdToDbOid pOid in T.pack $ show oid@@ -92,35 +104,35 @@ withMongoDBConn :: (Trans.MonadIO m, Applicative m) =>- Database -> HostName -> Maybe MongoAuth -> NominalDiffTime -> (ConnectionPool -> m b) -> m b-withMongoDBConn dbname hostname mauth connectionIdleTime = withMongoDBPool dbname hostname mauth 1 1 connectionIdleTime+ Database -> HostName -> PortID -> Maybe MongoAuth -> NominalDiffTime -> (ConnectionPool -> m b) -> m b+withMongoDBConn dbname hostname port mauth connectionIdleTime = withMongoDBPool dbname hostname port mauth 1 1 connectionIdleTime -createConnection :: Database -> HostName -> Maybe MongoAuth -> IO Connection-createConnection dbname hostname mAuth = do- pipe <- DB.runIOE $ DB.connect (DB.host hostname)+createConnection :: Database -> HostName -> PortID -> Maybe MongoAuth -> IO Connection+createConnection dbname hostname port mAuth = do+ pipe <- DB.runIOE $ DB.connect (DB.Host hostname port) _ <- 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+createMongoDBPool :: (Trans.MonadIO m, Applicative m) => Database -> HostName -> PortID -> 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+createMongoDBPool dbname hostname port mAuth connectionPoolSize stripeSize connectionIdleTime = do Trans.liftIO $ Pool.createPool- (createConnection dbname hostname mAuth)+ (createConnection dbname hostname port mAuth) (\(Connection pipe _) -> DB.close pipe) connectionPoolSize connectionIdleTime stripeSize withMongoDBPool :: (Trans.MonadIO m, Applicative m) =>- 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+ Database -> HostName -> PortID -> Maybe MongoAuth -> Int -> Int -> NominalDiffTime -> (ConnectionPool -> m b) -> m b+withMongoDBPool dbname hostname port mauth poolStripes stripeConnections connectionIdleTime connectionReader = do+ pool <- createMongoDBPool dbname hostname port mauth poolStripes stripeConnections connectionIdleTime connectionReader pool runMongoDBPool :: (Trans.MonadIO m, MonadBaseControl IO m) => DB.AccessMode -> DB.Action m a -> ConnectionPool -> m a@@ -132,13 +144,13 @@ runMongoDBPoolDef :: (Trans.MonadIO m, MonadBaseControl IO m) => DB.Action m a -> ConnectionPool -> m a runMongoDBPoolDef = runMongoDBPool (DB.ConfirmWrites ["j" DB.=: True]) -filterByKey :: (PersistEntity val) => Key DB.Action val -> DB.Document+filterByKey :: (PersistEntity val) => KeyBackend MongoBackend val -> DB.Document filterByKey k = [_id DB.=: keyToOid k] -queryByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Query +queryByKey :: (PersistEntity val) => KeyBackend MongoBackend val -> EntityDef -> DB.Query queryByKey k entity = (DB.select (filterByKey k) (unDBName $ entityDB entity)) -selectByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Selection +selectByKey :: (PersistEntity val) => KeyBackend MongoBackend val -> EntityDef -> DB.Selection selectByKey k entity = (DB.select (filterByKey k) (unDBName $ entityDB entity)) updateFields :: (PersistEntity val) => [Update val] -> [DB.Field]@@ -159,7 +171,7 @@ (Divide, _) -> throw $ PersistMongoDBUnsupported "divide not supported" -uniqSelector :: forall record. (PersistEntity record) => Unique record DB.Action -> [DB.Field]+uniqSelector :: forall record. (PersistEntity record) => Unique record -> [DB.Field] uniqSelector uniq = zipWith (DB.:=) (map (unDBName . snd) $ persistUniqueToFieldNames uniq) (map DB.val (persistUniqueToValues uniq))@@ -196,7 +208,7 @@ (PersistEntity keyEntity, PersistEntity record) => (record -> [DB.Field]) -> (DB.Collection -> DB.Document -> DB.Action m () )- -> Key DB.Action keyEntity+ -> KeyBackend MongoBackend keyEntity -> record -> DB.Action m () saveWithKey entToFields dbSave key record =@@ -204,7 +216,11 @@ where entity = entityDef record -instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistStore DB.Action m where+data MongoBackend++instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistStore (DB.Action m) where+ type PersistMonadBackend (DB.Action m) = MongoBackend+ insert record = do DB.ObjId oid <- DB.insert (unDBName $ entityDB entity) (toInsertFields record) return $ oidToKey oid @@ -242,7 +258,7 @@ instance MonadThrow m => MonadThrow (DB.Action m) where monadThrow = lift . monadThrow -instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistUnique DB.Action m where+instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistUnique (DB.Action m) where getBy uniq = do mdoc <- DB.findOne $ (DB.select (uniqSelector uniq) (unDBName $ entityDB t))@@ -263,7 +279,7 @@ _id :: T.Text _id = "_id" -keyToMongoIdField :: PersistEntity val => Key DB.Action val -> DB.Field+keyToMongoIdField :: PersistEntity val => KeyBackend MongoBackend val -> DB.Field keyToMongoIdField k = _id DB.:= (DB.ObjId $ keyToOid k) @@ -285,7 +301,7 @@ 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+instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistQuery (DB.Action m) where update _ [] = return () update key upds = DB.modify @@ -332,11 +348,11 @@ t = entityDef $ dummyFromFilts filts selectSource filts opts = do- cursor <- lift $ lift $ DB.find $ makeQuery filts opts+ cursor <- lift $ DB.find $ makeQuery filts opts pull cursor where pull cursor = do- mdoc <- lift $ lift $ DB.next cursor+ mdoc <- lift $ DB.next cursor case mdoc of Nothing -> return () Just doc -> do@@ -354,13 +370,13 @@ t = entityDef $ dummyFromFilts filts selectKeys filts opts = do- cursor <- lift $ lift $ DB.find $ (makeQuery filts opts) {+ cursor <- lift $ DB.find $ (makeQuery filts opts) { DB.project = [_id DB.=: (1 :: Int)] } pull cursor where pull cursor = do- mdoc <- lift $ lift $ DB.next cursor+ mdoc <- lift $ DB.next cursor case mdoc of Nothing -> return () Just [_id DB.:= DB.ObjId oid] -> do@@ -375,7 +391,7 @@ _ -> error "orderClause: expected Asc or Desc" -makeQuery :: PersistEntity val => [Filter val] -> [SelectOpt val] -> DB.Query+makeQuery :: (PersistEntity val, PersistEntityBackend val ~ MongoBackend) => [Filter val] -> [SelectOpt val] -> DB.Query makeQuery filts opts = (DB.select (filtersToSelector filts) (unDBName $ entityDB t)) { DB.limit = fromIntegral limit@@ -387,17 +403,17 @@ (limit, offset, orders') = limitOffsetOrder opts orders = map orderClause orders' -filtersToSelector :: PersistEntity val => [Filter val] -> DB.Document+filtersToSelector :: (PersistEntity val, PersistEntityBackend val ~ MongoBackend) => [Filter val] -> DB.Document filtersToSelector filts = #ifdef DEBUG debug $ #endif if null filts then [] else concatMap filterToDocument filts -multiFilter :: forall record. PersistEntity record => String -> [Filter record] -> [DB.Field]+multiFilter :: forall record. (PersistEntity record, PersistEntityBackend record ~ MongoBackend) => String -> [Filter record] -> [DB.Field] multiFilter multi fs = [T.pack multi DB.:= DB.Array (map (DB.Doc . filterToDocument) fs)] -filterToDocument :: PersistEntity val => Filter val -> DB.Document+filterToDocument :: (PersistEntity val, PersistEntityBackend val ~ MongoBackend) => Filter val -> DB.Document filterToDocument f = case f of Filter field v filt -> return $ case filt of@@ -411,13 +427,8 @@ -- $and is usually unecessary but makes query construction easier in special cases FilterAnd [] -> [] FilterAnd fs -> multiFilter "$and" fs+ BackendFilter mf -> mongoFilterToDoc mf where- toValue :: forall a. PersistField a => Either a [a] -> DB.Value- toValue val =- case val of- Left v -> DB.val $ toPersistValue v- Right vs -> DB.val $ map toPersistValue vs- showFilter Ne = "$ne" showFilter Gt = "$gt" showFilter Lt = "$lt"@@ -428,6 +439,11 @@ showFilter Eq = error "EQ filter not expected" showFilter (BackendSpecificFilter bsf) = throw $ PersistMongoDBError $ T.pack $ "did not expect BackendSpecificFilter " ++ T.unpack bsf +toValue :: forall a. PersistField a => Either a [a] -> DB.Value+toValue val =+ case val of+ Left v -> DB.val $ toPersistValue v+ Right vs -> DB.val $ map toPersistValue vs fieldName :: forall record typ. (PersistEntity record) => EntityField record typ -> DB.Label fieldName = idfix . unDBName . fieldDB . persistFieldDef@@ -510,7 +526,7 @@ oidToPersistValue :: DB.ObjectId -> PersistValue oidToPersistValue = PersistObjectId . Serialize.encode -oidToKey :: (PersistEntity val) => DB.ObjectId -> Key DB.Action val+oidToKey :: (PersistEntity val) => DB.ObjectId -> KeyBackend MongoBackend val oidToKey = Key . oidToPersistValue persistObjectIdToDbOid :: PersistValue -> DB.ObjectId@@ -519,7 +535,7 @@ Right o -> o persistObjectIdToDbOid _ = throw $ PersistInvalidField "expected PersistObjectId" -keyToOid :: (PersistEntity val) => Key DB.Action val -> DB.ObjectId+keyToOid :: (PersistEntity val) => KeyBackend MongoBackend val -> DB.ObjectId keyToOid (Key k) = persistObjectIdToDbOid k instance DB.Val PersistValue where@@ -565,9 +581,9 @@ w2 <- Serialize.get return (DB.Oid w1 w2) -dummyFromKey :: Key DB.Action v -> v+dummyFromKey :: KeyBackend MongoBackend v -> v dummyFromKey _ = error "dummyFromKey"-dummyFromUnique :: Unique v DB.Action -> v+dummyFromUnique :: Unique v -> v dummyFromUnique _ = error "dummyFromUnique" dummyFromFilts :: [Filter v] -> v dummyFromFilts _ = error "dummyFromFilts"@@ -577,6 +593,7 @@ data MongoConf = MongoConf { mgDatabase :: Text , mgHost :: Text+ , mgPort :: PortID , mgAuth :: Maybe MongoAuth , mgAccessMode :: DB.AccessMode , mgPoolStripes :: Int@@ -590,7 +607,7 @@ createPoolConfig c = createMongoDBPool - (mgDatabase c) (T.unpack (mgHost c))+ (mgDatabase c) (T.unpack (mgHost c)) (mgPort c) (mgAuth c) (mgPoolStripes c) (mgStripeConnections c) (mgConnectionIdleTime c) @@ -598,6 +615,7 @@ loadConfig (Object o) = do db <- o .: "database" host <- o .:? "host" .!= "127.0.0.1"+ port <- o .:? "port" .!= (PortNumber 27017) poolStripes <- o .:? "poolstripes" .!= 1 stripeConnections <- o .: "connections" (NoOrphanNominalDiffTime connectionIdleTime) <- o .:? "connectionIdleTime" .!= 20@@ -619,6 +637,7 @@ return $ MongoConf { mgDatabase = db , mgHost = host+ , mgPort = port , mgAuth = (case (mUser, mPass) of (Just user, Just pass) -> Just (MongoAuth user pass)@@ -639,3 +658,62 @@ s = T.unpack t -} loadConfig _ = mzero++type instance BackendSpecificFilter MongoBackend v = MongoFilter v++data NestedField val nes = forall nes1. PersistEntity nes1 => EntityField val nes1 `MidFlds` NestedField nes1 nes+ | forall nes1. PersistEntity nes1 => EntityField val (Maybe nes1) `MidFldsNullable` NestedField nes1 nes+ | forall nes1. PersistEntity nes1 => EntityField val nes1 `LastFld` EntityField nes1 nes+ | forall nes1. PersistEntity nes1 => EntityField val (Maybe nes1) `LastFldNullable` EntityField nes1 nes+data MongoFilter val = forall typ. (PersistField typ) =>+ NestedFilter {+ nestedField :: NestedField val typ+ , fieldValue :: Either typ [typ]+ }+ | forall typ. PersistField typ =>+ MultiKeyFilter {+ mulFldKey :: EntityField val [typ]+ , mulFldVal :: Either typ [typ]+ }+(~>.) :: forall val nes nes1. PersistEntity nes1 => EntityField val nes1 -> NestedField nes1 nes -> NestedField val nes+(~>.) = MidFlds++(?~>.) :: forall val nes nes1. PersistEntity nes1 => EntityField val (Maybe nes1) -> NestedField nes1 nes -> NestedField val nes+(?~>.) = MidFldsNullable++(->.) :: forall val nes nes1. PersistEntity nes1 => EntityField val nes1 -> EntityField nes1 nes -> NestedField val nes+(->.) = LastFld++(?->.) :: forall val nes nes1. PersistEntity nes1 => EntityField val (Maybe nes1) -> EntityField nes1 nes -> NestedField val nes+(?->.) = LastFldNullable++infixr 5 ~>.+infixr 5 ?~>.+infixr 6 ->.+infixr 6 ?->.++infixr 4 `nestEq`++-- | use with drill-down operaters ~>, etc+nestEq :: forall v typ. (PersistField typ, PersistEntityBackend v ~ MongoBackend) => NestedField v typ -> typ -> Filter v+nf `nestEq` v = BackendFilter $ NestedFilter {nestedField = nf, fieldValue = (Left v)}++-- | use to see if an embedded list contains an item+multiEq :: forall v typ. (PersistField typ, PersistEntityBackend v ~ MongoBackend) => EntityField v [typ] -> typ -> Filter v+fld `multiEq` val = BackendFilter $ MultiKeyFilter {mulFldKey = fld, mulFldVal = (Left val)}++mongoFilterToDoc :: PersistEntity val => MongoFilter val -> DB.Document+mongoFilterToDoc (MultiKeyFilter fn v) = return (fieldName fn DB.:= toValue v)+mongoFilterToDoc (NestedFilter fns v) = return ( (nesFldName fns) DB.:= toValue v)+ where+ nesFldName fns' = T.intercalate "." $ nesIdFix . reverse $ nesFldName' fns' []+ nesFldName' :: forall r1 r2. (PersistEntity r1) => NestedField r1 r2 -> [DB.Label] -> [DB.Label]+ nesFldName' ( f1 `MidFlds` f2) lbls = nesFldName' f2 (fieldName f1 : lbls)+ nesFldName' ( f1 `MidFldsNullable` f2) lbls = nesFldName' f2 (fieldName f1:lbls)+ nesFldName' (nf1 `LastFld` nf2) lbls = fieldName nf2:fieldName nf1:lbls+ nesFldName' (nf1 `LastFldNullable` nf2) lbls = fieldName nf2:fieldName nf1:lbls+ nesIdFix [] = []+ nesIdFix (fst':rst') = fst': (map (joinFN . (T.splitOn "_")) rst')+ joinFN :: [Text] -> Text+ joinFN [] = ""+ joinFN (fst':rst') = fst' `T.append` (T.concat (map (\t -> (toUpper . T.head $ t) `T.cons` (T.tail t)) rst'))
persistent-mongoDB.cabal view
@@ -1,5 +1,5 @@ name: persistent-mongoDB-version: 1.0.1.0+version: 1.1.0 license: MIT license-file: LICENSE author: Greg Weber <greg@gregweber.info>@@ -14,7 +14,7 @@ library build-depends: base >= 4 && < 5- , persistent >= 1.0 && < 1.1+ , persistent >= 1.1 && < 1.2 , text >= 0.8 , transformers >= 0.2.1 , containers >= 0.2