persistent-mongoDB 1.2.3 → 1.3.0
raw patch · 2 files changed
+161/−58 lines, 2 files
Files
- Database/Persist/MongoDB.hs +160/−57
- persistent-mongoDB.cabal +1/−1
Database/Persist/MongoDB.hs view
@@ -14,8 +14,8 @@ -- Unlike SQL backends, uniqueness constraints cannot be created for you. -- You must place a unique index on unique fields. {-# LANGUAGE CPP, PackageImports, OverloadedStrings, ScopedTypeVariables #-}-{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE RankNTypes, TypeFamilies #-} {-# LANGUAGE EmptyDataDecls #-} @@ -34,8 +34,11 @@ -- * MongoDB specific Filters -- $filters- , (->.), (~>.), (?->.), (?~>.)- , nestEq, multiEq+ , nestEq, multiEq, nestBsonEq, multiBsonEq+ , (=~.), (?=~.), MongoRegex+ , (->.), (~>.), (?&->.), (?&~>.), (&->.), (&~>.)+ -- non-operator forms of filters+ , NestedField(..) -- * MongoDB specific PersistFields , Objectid@@ -108,6 +111,7 @@ import Data.Attoparsec.Number import Data.Char (toUpper) import Data.Monoid (mappend)+import Data.Typeable #ifdef DEBUG import FileLocation (debug)@@ -156,8 +160,9 @@ -- | wrapper of 'ObjectId'--- * avoids an orphan instance--- * works around a Persistent naming issue+--+-- * avoids an orphan instance+-- * works around a Persistent naming issue newtype Objectid = Objectid { unObjectId :: DB.ObjectId } deriving (Show, Read, Eq, Ord) @@ -330,7 +335,7 @@ saveWithKey entToFields dbSave key record = dbSave (collectionName record) ((keyToMongoIdField key):(entToFields record)) -data MongoBackend+data MongoBackend deriving Typeable instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistStore (DB.Action m) where type PersistMonadBackend (DB.Action m) = MongoBackend@@ -499,15 +504,10 @@ #endif if null filts then [] else concatMap filterToDocument filts -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, PersistEntityBackend val ~ MongoBackend) => 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.=: [(showFilter filt) DB.:= toValue v]+ Filter field v filt -> return $ filterToBSON (fieldName field) v filt 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?@@ -518,6 +518,18 @@ FilterAnd fs -> multiFilter "$and" fs BackendFilter mf -> mongoFilterToDoc mf where+ 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)]++filterToBSON :: forall a. ( PersistField a)+ => Text+ -> Either a [a]+ -> PersistFilter+ -> DB.Field+filterToBSON fname v filt = case filt of+ Eq -> fname DB.:= toValue v+ _ -> fname DB.=: [(showFilter filt) DB.:= toValue v]+ where showFilter Ne = "$ne" showFilter Gt = "$gt" showFilter Lt = "$lt"@@ -528,6 +540,36 @@ showFilter Eq = error "EQ filter not expected" showFilter (BackendSpecificFilter bsf) = throw $ PersistMongoDBError $ T.pack $ "did not expect BackendSpecificFilter " ++ T.unpack bsf ++mongoFilterToBSON :: forall typ. ( PersistField typ )+ => Text+ -> MongoFilterOperator typ+ -> DB.Document+mongoFilterToBSON fname filt =+ case filt of+ (PersistOperator v op) -> [filterToBSON fname v op]+ (MongoFilterOperator bval) -> [fname DB.:= bval]++mongoFilterToDoc :: PersistEntity val => MongoFilter val -> DB.Document+mongoFilterToDoc (RegExpMaybeFilter fn (reg, opts)) = [ fieldName fn DB.:= DB.RegEx (DB.Regex reg opts)]+mongoFilterToDoc (RegExpFilter fn (reg, opts)) = [ fieldName fn DB.:= DB.RegEx (DB.Regex reg opts)]+mongoFilterToDoc (MultiKeyFilter fn filt) = mongoFilterToBSON (fieldName fn) filt+mongoFilterToDoc (NestedFilter fns filt) = mongoFilterToBSON (nesFldName fns) filt+ where+ nesFldName fns' = T.intercalate "." $ nesIdFix . reverse $ nesFldName' fns' []+ nesFldName' :: forall r1 r2. (PersistEntity r1) => NestedField r1 r2 -> [DB.Label] -> [DB.Label]+ nesFldName' (nf1 `LastEmbFld` nf2) lbls = fieldName nf2 : fieldName nf1 : lbls+ nesFldName' ( f1 `MidEmbFld` f2) lbls = nesFldName' f2 (fieldName f1 : lbls)+ nesFldName' ( f1 `MidNestFlds` f2) lbls = nesFldName' f2 (fieldName f1 : lbls)+ nesFldName' ( f1 `MidNestFldsNullable` f2) lbls = nesFldName' f2 (fieldName f1 : lbls)+ nesFldName' (nf1 `LastNestFld` nf2) lbls = fieldName nf2 : fieldName nf1:lbls+ nesFldName' (nf1 `LastNestFldNullable` 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'))+ toValue :: forall a. PersistField a => Either a [a] -> DB.Value toValue val = case val of@@ -680,6 +722,7 @@ val x@(PersistObjectId _) = DB.ObjId $ persistObjectIdToDbOid x val (PersistTimeOfDay _) = throw $ PersistMongoDBUnsupported "PersistTimeOfDay not implemented for the MongoDB backend. only PersistUTCTime currently implemented" val (PersistRational _) = throw $ PersistMongoDBUnsupported "PersistRational not implemented for the MongoDB backend"+ val (PersistDbSpecific _) = throw $ PersistMongoDBUnsupported "PersistDbSpecific not implemented for the MongoDB backend" cast' (DB.Float x) = Just (PersistDouble x) cast' (DB.Int32 x) = Just $ PersistInt64 $ fromIntegral x cast' (DB.Int64 x) = Just $ PersistInt64 x@@ -800,70 +843,130 @@ -- These filters create a query that reaches deeper into a document with -- nested fields. -type instance BackendSpecificFilter MongoBackend v = MongoFilter v+type instance BackendSpecificFilter MongoBackend record = MongoFilter record -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) =>+data NestedField record typ+ = forall emb. PersistEntity emb => EntityField record [emb] `LastEmbFld` EntityField emb typ+ | forall emb. PersistEntity emb => EntityField record [emb] `MidEmbFld` NestedField emb typ+ | forall nest. PersistEntity nest => EntityField record nest `MidNestFlds` NestedField nest typ+ | forall nest. PersistEntity nest => EntityField record (Maybe nest) `MidNestFldsNullable` NestedField nest typ+ | forall nest. PersistEntity nest => EntityField record nest `LastNestFld` EntityField nest typ+ | forall nest. PersistEntity nest => EntityField record (Maybe nest) `LastNestFldNullable` EntityField nest typ++-- | A MongoRegex represetns a Regular expression.+-- It is a tuple of the expression and the options for the regular expression, respectively+-- Options are listed here: <http://docs.mongodb.org/manual/reference/operator/query/regex/>+-- If you use the same options you may want to define a helper such as @r t = (t, "ims")@+type MongoRegex = (Text, Text)++-- | Filter using a Regular expression.+(=~.) :: forall record. (PersistEntity record, PersistEntityBackend record ~ MongoBackend) => EntityField record Text -> MongoRegex -> Filter record+fld =~. val = BackendFilter $ RegExpFilter fld val++-- | Filter using a Regular expression against a nullable field.+(?=~.) :: forall record. (PersistEntity record, PersistEntityBackend record ~ MongoBackend) => EntityField record (Maybe Text) -> MongoRegex -> Filter record+fld ?=~. val = BackendFilter $ RegExpMaybeFilter fld val++data MongoFilterOperator typ = PersistOperator (Either typ [typ]) PersistFilter+ | MongoFilterOperator DB.Value++data MongoFilter record = forall typ. (PersistField typ) => NestedFilter {- nestedField :: NestedField val typ- , fieldValue :: Either typ [typ]+ nestedField :: NestedField record typ+ , nestedValue :: MongoFilterOperator typ } | forall typ. PersistField typ => MultiKeyFilter {- mulFldKey :: EntityField val [typ]- , mulFldVal :: Either typ [typ]+ multiField :: EntityField record [typ]+ , multiValue :: MongoFilterOperator typ }+ | RegExpFilter (EntityField record Text) MongoRegex+ | RegExpMaybeFilter (EntityField record (Maybe Text)) MongoRegex --- | Point to a nested field to query. Used for the final level of nesting with `nestEq` or other operators.-(->.) :: forall val nes nes1. PersistEntity nes1 => EntityField val nes1 -> EntityField nes1 nes -> NestedField val nes-(->.) = LastFld+-- | Point to an array field with an embedded object and give a deeper query into the embedded object.+-- Use with 'nestEq'.+(->.) :: forall record emb typ. PersistEntity emb => EntityField record [emb] -> EntityField emb typ -> NestedField record typ+(->.) = LastEmbFld --- | Same as (->.), but Works against a Maybe type-(?->.) :: forall val nes nes1. PersistEntity nes1 => EntityField val (Maybe nes1) -> EntityField nes1 nes -> NestedField val nes-(?->.) = LastFldNullable+-- | Point to an array field with an embedded object and give a deeper query into the embedded object.+-- This level of nesting is not the final level.+-- Use '->.' or '&->.' to point to the final level.+(~>.) :: forall record typ emb. PersistEntity emb => EntityField record [emb] -> NestedField emb typ -> NestedField record typ+(~>.) = MidEmbFld --- | Point to a nested field to query.+-- | Point to a nested field to query. This field is not an array type.+-- Use with 'nestEq'.+(&->.) :: forall record typ nest. PersistEntity nest => EntityField record nest -> EntityField nest typ -> NestedField record typ+(&->.) = LastNestFld++-- | Same as '&->.', but Works against a Maybe type+(?&->.) :: forall record typ nest. PersistEntity nest => EntityField record (Maybe nest) -> EntityField nest typ -> NestedField record typ+(?&->.) = LastNestFldNullable+++-- | Point to a nested field to query. This field is not an array type. -- This level of nesting is not the final level.--- Use (->.) to point to the final level is -(~>.) :: forall val nes nes1. PersistEntity nes1 => EntityField val nes1 -> NestedField nes1 nes -> NestedField val nes-(~>.) = MidFlds+-- Use '->.' or '&>.' to point to the final level.+(&~>.) :: forall val nes nes1. PersistEntity nes1 => EntityField val nes1 -> NestedField nes1 nes -> NestedField val nes+(&~>.) = MidNestFlds --- | Same as (~>.), but Works against a Maybe type-(?~>.) :: forall val nes nes1. PersistEntity nes1 => EntityField val (Maybe nes1) -> NestedField nes1 nes -> NestedField val nes-(?~>.) = MidFldsNullable+-- | Same as '&~>.', but works against a Maybe type+(?&~>.) :: forall val nes nes1. PersistEntity nes1 => EntityField val (Maybe nes1) -> NestedField nes1 nes -> NestedField val nes+(?&~>.) = MidNestFldsNullable +infixr 4 ?=~.+infixr 4 =~. infixr 5 ~>.-infixr 5 ?~>.+infixr 5 &~>.+infixr 5 ?&~>.+infixr 6 &->.+infixr 6 ?&->. infixr 6 ->.-infixr 6 ?->. infixr 4 `nestEq`+infixr 4 `multiEq`+infixr 4 `nestBsonEq`+infixr 4 `multiBsonEq` -- | The normal Persistent equality test (==.) is not generic enough. -- Instead use this with the drill-down operaters (->.) or (?->.)-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)}+nestEq :: forall record typ.+ ( PersistField typ+ , PersistEntityBackend record ~ MongoBackend+ ) => NestedField record typ -> typ -> Filter record+nf `nestEq` v = BackendFilter $ NestedFilter+ { nestedField = nf+ , nestedValue = PersistOperator (Left v) Eq+ } +-- | same as `nestEq`, but give a BSON Value+nestBsonEq :: forall record typ.+ ( PersistField typ+ , PersistEntityBackend record ~ MongoBackend+ ) => NestedField record typ -> DB.Value -> Filter record+nf `nestBsonEq` val = BackendFilter $ NestedFilter+ { nestedField = nf+ , nestedValue = MongoFilterOperator val+ }+ -- | 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)}+multiEq :: forall record typ.+ ( PersistField typ+ , PersistEntityBackend record ~ MongoBackend+ ) => EntityField record [typ] -> typ -> Filter record+fld `multiEq` val = BackendFilter $ MultiKeyFilter+ { multiField = fld+ , multiValue = PersistOperator (Left val) Eq+ } -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'))+-- | same as `multiEq`, but give a BSON Value+multiBsonEq :: forall record typ.+ ( PersistField typ+ , PersistEntityBackend record ~ MongoBackend+ ) => EntityField record [typ] -> DB.Value -> Filter record+fld `multiBsonEq` val = BackendFilter $ MultiKeyFilter+ { multiField = fld+ , multiValue = MongoFilterOperator val+ }+
persistent-mongoDB.cabal view
@@ -1,5 +1,5 @@ name: persistent-mongoDB-version: 1.2.3+version: 1.3.0 license: MIT license-file: LICENSE author: Greg Weber <greg@gregweber.info>