diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,11 @@ +# Changelog for persistent-mongoDB + +## 2.9.0 + +* Removed deprecated `entityToDocument`. Please use `recordToDocument` instead. [#894](https://github.com/yesodweb/persistent/pull/894) +* Removed deprecated `multiBsonEq`. Please use `anyBsonEq` instead. [#894](https://github.com/yesodweb/persistent/pull/894) +* Use `portID` from `mongoDB` instead of `network`. [#946](https://github.com/yesodweb/persistent/pull/946) + ## 2.8.0 * Switch from `MonadBaseControl` to `MonadUnliftIO` diff --git a/Database/Persist/MongoDB.hs b/Database/Persist/MongoDB.hs --- a/Database/Persist/MongoDB.hs +++ b/Database/Persist/MongoDB.hs @@ -1,3 +1,12 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- | Use persistent-mongodb the same way you would use other persistent -- libraries and refer to the general persistent documentation. -- There are some new MongoDB specific filters under the filters section. @@ -13,21 +22,12 @@ -- The MongoDB Persistent backend does not help perform migrations. -- 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 DeriveDataTypeable, GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} -{-# LANGUAGE RankNTypes, TypeFamilies #-} -{-# LANGUAGE EmptyDataDecls #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE GADTs #-} module Database.Persist.MongoDB ( -- * Entity conversion collectionName , docToEntityEither , docToEntityThrow - , entityToDocument , recordToDocument , documentFromEntity , toInsertDoc @@ -42,7 +42,7 @@ -- ** Filters -- $filters , nestEq, nestNe, nestGe, nestLe, nestIn, nestNotIn - , anyEq, nestAnyEq, nestBsonEq, anyBsonEq, multiBsonEq + , anyEq, nestAnyEq, nestBsonEq, anyBsonEq , inList, ninList , (=~.) -- non-operator forms of filters @@ -95,7 +95,6 @@ -- * network type , HostName - , PortID -- * MongoDB driver types , Database @@ -106,73 +105,57 @@ , (DB.=:) , DB.ObjectId , DB.MongoContext + , DB.PortID -- * Database.Persist , module Database.Persist ) where -import Database.Persist -import qualified Database.Persist.Sql as Sql - -import qualified Control.Monad.IO.Class as Trans import Control.Exception (throw, throwIO) -import Data.Acquire (mkAcquire) -import qualified Data.Traversable as Traversable +import Control.Monad (liftM, (>=>), forM_, unless) +import Control.Monad.IO.Class (liftIO) +import qualified Control.Monad.IO.Class as Trans +import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) +import Control.Monad.Trans.Reader (ask, runReaderT) +import Data.Acquire (mkAcquire) +import Data.Aeson (Value (Number), (.:), (.:?), (.!=), FromJSON(..), ToJSON(..), withText, withObject) +import Data.Aeson.Types (modifyFailure) +import Data.Bits (shiftR) import Data.Bson (ObjectId(..)) -import qualified Database.MongoDB as DB -import Database.MongoDB.Query (Database) -import Control.Applicative as A (Applicative, (<$>)) -import Network (PortID (PortNumber)) -import Network.Socket (HostName) +import qualified Data.ByteString as BS +import Data.Conduit import Data.Maybe (mapMaybe, fromJust) -import qualified Data.Text as T +import Data.Monoid (mappend) +import qualified Data.Serialize as Serialize import Data.Text (Text) -import qualified Data.ByteString as BS +import qualified Data.Text as T import qualified Data.Text.Encoding as E -import qualified Data.Serialize as Serialize -import Web.PathPieces (PathPiece(..)) -import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..), parseUrlPieceMaybe, parseUrlPieceWithPrefix, readTextData) -import Data.Conduit -import Control.Monad.IO.Class (liftIO) -import Data.Aeson (Value (Number), (.:), (.:?), (.!=), FromJSON(..), ToJSON(..), withText, withObject) -import Data.Aeson.Types (modifyFailure) -import Control.Monad (liftM, (>=>), forM_, unless) +import qualified Data.Traversable as Traversable import qualified Data.Pool as Pool import Data.Time (NominalDiffTime) +import Data.Time.Calendar (Day(..)) #ifdef HIGH_PRECISION_DATE 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.Bits (shiftR) import Data.Word (Word16) -import Data.Monoid (mappend) -import Control.Monad.Trans.Reader (ask, runReaderT) -import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) +import Network.Socket (HostName) import Numeric (readHex) -import Unsafe.Coerce (unsafeCoerce) - -#if MIN_VERSION_base(4,6,0) import System.Environment (lookupEnv) -#else -import System.Environment (getEnvironment) -#endif +import Unsafe.Coerce (unsafeCoerce) +import Web.PathPieces (PathPiece(..)) +import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..), parseUrlPieceMaybe, parseUrlPieceWithPrefix, readTextData) #ifdef DEBUG import FileLocation (debug) #endif -#if !MIN_VERSION_base(4,6,0) -lookupEnv :: String -> IO (Maybe String) -lookupEnv key = do - env <- getEnvironment - return $ lookup key env -#endif +import qualified Database.MongoDB as DB +import Database.MongoDB.Query (Database) +import Database.Persist +import qualified Database.Persist.Sql as Sql + instance HasPersistBackend DB.MongoContext where type BaseBackend DB.MongoContext = DB.MongoContext persistBackend = id @@ -184,30 +167,16 @@ deriving (Show, Eq, Num) instance FromJSON NoOrphanNominalDiffTime where -#if MIN_VERSION_aeson(0, 7, 0) parseJSON (Number x) = (return . NoOrphanNominalDiffTime . fromRational . toRational) x - - -#else - parseJSON (Number (I x)) = (return . NoOrphanNominalDiffTime . fromInteger) x - parseJSON (Number (D x)) = (return . NoOrphanNominalDiffTime . fromRational . toRational) x - -#endif parseJSON _ = fail "couldn't parse diff time" -newtype NoOrphanPortID = NoOrphanPortID PortID deriving (Show, Eq) +newtype NoOrphanPortID = NoOrphanPortID DB.PortID deriving (Show, Eq) instance FromJSON NoOrphanPortID where -#if MIN_VERSION_aeson(0, 7, 0) - parseJSON (Number x) = (return . NoOrphanPortID . PortNumber . fromIntegral ) cnvX + parseJSON (Number x) = (return . NoOrphanPortID . DB.PortNumber . fromIntegral ) cnvX where cnvX :: Word16 cnvX = round x - -#else - parseJSON (Number (I x)) = (return . NoOrphanPortID . PortNumber . fromInteger) x - -#endif parseJSON _ = fail "couldn't parse port number" @@ -220,7 +189,7 @@ instance FromHttpApiData (BackendKey DB.MongoContext) where parseUrlPiece input = do s <- parseUrlPieceWithPrefix "o" input return input - MongoKey A.<$> readTextData s + MongoKey <$> readTextData s where infixl 3 Left _ y = y @@ -257,19 +226,19 @@ sqlType _ = Sql.SqlOther "doesn't make much sense for MongoDB" -withConnection :: (Trans.MonadIO m, A.Applicative m) +withConnection :: (Trans.MonadIO 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 +withMongoDBConn :: (Trans.MonadIO m) + => Database -> HostName -> DB.PortID -> Maybe MongoAuth -> NominalDiffTime -> (ConnectionPool -> m b) -> m b withMongoDBConn dbname hostname port mauth connectionIdleTime = withMongoDBPool dbname hostname port mauth 1 1 connectionIdleTime -createPipe :: HostName -> PortID -> IO DB.Pipe +createPipe :: HostName -> DB.PortID -> IO DB.Pipe createPipe hostname port = DB.connect (DB.Host hostname port) createReplicatSet :: (DB.ReplicaSetName, [DB.Host]) -> Database -> Maybe MongoAuth -> IO Connection @@ -278,7 +247,7 @@ testAccess pipe dbname mAuth return $ Connection pipe dbname -createRsPool :: (Trans.MonadIO m, Applicative m) => Database -> ReplicaSetConfig +createRsPool :: (Trans.MonadIO m) => Database -> ReplicaSetConfig -> Maybe MongoAuth -> Int -- ^ pool size (number of stripes) -> Int -- ^ stripe size (number of connections per stripe) @@ -299,13 +268,13 @@ Nothing -> return undefined return () -createConnection :: Database -> HostName -> PortID -> Maybe MongoAuth -> IO Connection +createConnection :: Database -> HostName -> DB.PortID -> Maybe MongoAuth -> IO Connection createConnection dbname hostname port mAuth = do pipe <- createPipe hostname port testAccess pipe dbname mAuth return $ Connection pipe dbname -createMongoDBPool :: (Trans.MonadIO m, Applicative m) => Database -> HostName -> PortID +createMongoDBPool :: (Trans.MonadIO m) => Database -> HostName -> DB.PortID -> Maybe MongoAuth -> Int -- ^ pool size (number of stripes) -> Int -- ^ stripe size (number of connections per stripe) @@ -320,7 +289,7 @@ stripeSize -createMongoPool :: (Trans.MonadIO m, Applicative m) => MongoConf -> m ConnectionPool +createMongoPool :: (Trans.MonadIO m) => MongoConf -> m ConnectionPool createMongoPool c@MongoConf{mgReplicaSetConfig = Just (ReplicaSetConfig rsName hosts)} = createRsPool (mgDatabase c) @@ -339,7 +308,7 @@ -- The database parameter has not yet been applied yet. -- This is useful for switching between databases (on the same host and port) -- Unlike the normal pool, no authentication is available -createMongoDBPipePool :: (Trans.MonadIO m, Applicative m) => HostName -> PortID +createMongoDBPipePool :: (Trans.MonadIO m) => HostName -> DB.PortID -> Int -- ^ pool size (number of stripes) -> Int -- ^ stripe size (number of connections per stripe) -> NominalDiffTime -- ^ time a connection is left idle before closing @@ -352,11 +321,11 @@ connectionIdleTime stripeSize -withMongoPool :: (Trans.MonadIO m, Applicative m) => MongoConf -> (ConnectionPool -> m b) -> m b +withMongoPool :: (Trans.MonadIO m) => MongoConf -> (ConnectionPool -> m b) -> m b withMongoPool conf connectionReader = createMongoPool conf >>= connectionReader -withMongoDBPool :: (Trans.MonadIO m, Applicative m) => - Database -> HostName -> PortID -> Maybe MongoAuth -> Int -> Int -> NominalDiffTime -> (ConnectionPool -> m b) -> m b +withMongoDBPool :: (Trans.MonadIO m) => + Database -> HostName -> DB.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 @@ -443,7 +412,7 @@ -- | convert a PersistEntity into document fields. -- for inserts only: nulls are ignored so they will be unset in the document. --- 'entityToDocument' includes nulls +-- 'recordToDocument' includes nulls toInsertDoc :: forall record. (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => record -> DB.Document toInsertDoc record = zipFilter (embeddedFields $ toEmbedEntityDef entDef) @@ -488,15 +457,10 @@ where entity = entityDef $ Just record -entityToDocument :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) - => record -> DB.Document -entityToDocument = recordToDocument -{-# DEPRECATED entityToDocument "use recordToDocument" #-} - documentFromEntity :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => Entity record -> DB.Document documentFromEntity (Entity key record) = - keyToMongoDoc key ++ entityToDocument record + keyToMongoDoc key ++ recordToDocument record zipToDoc :: PersistField a => [DBName] -> [a] -> [DB.Field] zipToDoc [] _ = [] @@ -638,7 +602,7 @@ upsertBy uniq newRecord upds = do let uniqueDoc = toUniquesDoc uniq :: [DB.Field] - let uniqKeys = map DB.label uniqueDoc :: [DB.Label] + let uniqKeys = map DB.label uniqueDoc :: [DB.Label] let insDoc = DB.exclude uniqKeys $ toInsertDoc newRecord :: DB.Document let selection = DB.select uniqueDoc $ collectionName newRecord :: DB.Selection mdoc <- getBy uniq @@ -844,7 +808,7 @@ filterToBSON :: forall a. ( PersistField a) => Text - -> Either a [a] + -> FilterValue a -> PersistFilter -> DB.Field filterToBSON fname v filt = case filt of @@ -918,11 +882,12 @@ nesFldName (nf1 `LastNestFld` nf2) = [fieldName nf1, fieldName nf2] nesFldName (nf1 `LastNestFldNullable` nf2) = [fieldName nf1, fieldName nf2] -toValue :: forall a. PersistField a => Either a [a] -> DB.Value +toValue :: forall a. PersistField a => FilterValue a -> DB.Value toValue val = case val of - Left v -> DB.val $ toPersistValue v - Right vs -> DB.val $ map toPersistValue vs + FilterValue v -> DB.val $ toPersistValue v + UnsafeValue v -> DB.val $ toPersistValue v + FilterValues vs -> DB.val $ map toPersistValue vs fieldName :: forall record typ. (PersistEntity record) => EntityField record typ -> DB.Label fieldName f | fieldHaskell fd == HaskellName "Id" = id_ @@ -1075,6 +1040,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 (PersistArray a) = DB.val $ PersistList a 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 @@ -1122,7 +1088,7 @@ data MongoConf = MongoConf { mgDatabase :: Text , mgHost :: Text - , mgPort :: PortID + , mgPort :: DB.PortID , mgAuth :: Maybe MongoAuth , mgAccessMode :: DB.AccessMode , mgPoolStripes :: Int @@ -1265,7 +1231,7 @@ (=~.) :: forall record searchable. (MongoRegexSearchable searchable, PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => EntityField record searchable -> MongoRegex -> Filter record fld =~. val = BackendFilter $ RegExpFilter fld val -data MongoFilterOperator typ = PersistFilterOperator (Either typ [typ]) PersistFilter +data MongoFilterOperator typ = PersistFilterOperator (FilterValue typ) PersistFilter | MongoFilterOperator DB.Value data UpdateValueOp typ = @@ -1366,7 +1332,6 @@ infixr 4 `anyEq` infixr 4 `nestAnyEq` infixr 4 `nestBsonEq` -infixr 4 `multiBsonEq` infixr 4 `anyBsonEq` infixr 4 `nestSet` @@ -1398,7 +1363,7 @@ , PersistEntityBackend record ~ DB.MongoContext ) => PersistFilter -> NestedField record typ -> typ -> Filter record nestedFilterOp op nf v = BackendFilter $ - NestedFilter nf $ PersistFilterOperator (Left v) op + NestedFilter nf $ PersistFilterOperator (FilterValue v) op -- | same as `nestEq`, but give a BSON Value nestBsonEq :: forall record typ. @@ -1421,7 +1386,7 @@ , PersistEntityBackend record ~ DB.MongoContext ) => EntityField record [typ] -> typ -> Filter record fld `anyEq` val = BackendFilter $ - ArrayFilter fld $ PersistFilterOperator (Left val) Eq + ArrayFilter fld $ PersistFilterOperator (FilterValue val) Eq -- | Like nestEq, but for an embedded list. -- Checks to see if the nested list contains an item. @@ -1430,14 +1395,7 @@ , PersistEntityBackend record ~ DB.MongoContext ) => NestedField record [typ] -> typ -> Filter record fld `nestAnyEq` val = BackendFilter $ - NestedArrayFilter fld $ PersistFilterOperator (Left val) Eq - -multiBsonEq :: forall record typ. - ( PersistField typ - , PersistEntityBackend record ~ DB.MongoContext - ) => EntityField record [typ] -> DB.Value -> Filter record -multiBsonEq = anyBsonEq -{-# DEPRECATED multiBsonEq "Please use anyBsonEq instead" #-} + NestedArrayFilter fld $ PersistFilterOperator (FilterValue val) Eq -- | same as `anyEq`, but give a BSON Value anyBsonEq :: forall record typ. @@ -1508,10 +1466,10 @@ -- | Intersection of lists: if any value in the field is found in the list. inList :: PersistField typ => EntityField v [typ] -> [typ] -> Filter v -f `inList` a = Filter (unsafeCoerce f) (Right a) In +f `inList` a = Filter (unsafeCoerce f) (FilterValues a) In infix 4 `inList` -- | No intersection of lists: if no value in the field is found in the list. ninList :: PersistField typ => EntityField v [typ] -> [typ] -> Filter v -f `ninList` a = Filter (unsafeCoerce f) (Right a) In +f `ninList` a = Filter (unsafeCoerce f) (FilterValues a) In infix 4 `ninList` 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: 2.8.0 +version: 2.9.0 license: MIT license-file: LICENSE author: Greg Weber @@ -7,7 +7,7 @@ synopsis: Backend for the persistent library using mongoDB. category: Database stability: Experimental -cabal-version: >= 1.8 +cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/book/persistent bug-reports: https://github.com/yesodweb/persistent/issues @@ -21,30 +21,62 @@ library build-depends: base >= 4.8 && < 5 , persistent >= 2.8 && < 3 - , text >= 0.8 - , transformers >= 0.2.1 - , containers >= 0.2 - , bytestring >= 0.9 - , conduit >= 0.5.3 - , resourcet >= 0.3 - , mongoDB >= 2.0.3 && (< 2.1 || >= 2.1.1) - , bson >= 0.3.1 && < 0.4 - , network >= 2.2.1.7 - , cereal >= 0.3.0.0 - , path-pieces >= 0.1 - , http-api-data >= 0.2 && < 0.4 - , aeson >= 0.6.2 - , attoparsec - , time + , aeson >= 1.0 + , bson >= 0.3.2 && < 0.4 , bytestring - , resource-pool < 0.3 + , cereal >= 0.5 + , conduit >= 1.2 + , http-api-data >= 0.3.7 && < 0.5 + , mongoDB >= 2.3 + , network >= 2.6 + , path-pieces >= 0.2 + , resource-pool >= 0.2 && < 0.3 + , resourcet >= 1.1 + , text >= 1.2 + , time + , transformers >= 0.5 , unliftio-core exposed-modules: Database.Persist.MongoDB ghc-options: -Wall + default-language: Haskell2010 if flag(high_precision_date) cpp-options: -DHIGH_PRECISION_DATE + +test-suite test + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: test + other-modules: MongoInit + EmbedTestMongo + EntityEmbedTestMongo + RawMongoHelpers + ghc-options: -Wall + + build-depends: base >= 4.6 && < 5 + , persistent + , persistent-mongoDB + , persistent-qq + , persistent-template + , persistent-test + , blaze-html + , bytestring + , containers + , hspec >= 2.4.0 + , HUnit + , mongoDB + , process + , QuickCheck + , template-haskell + , text + , time + , transformers + , unliftio-core + if impl(ghc < 8) + build-depends: + semigroups + default-language: Haskell2010 source-repository head type: git diff --git a/test/EmbedTestMongo.hs b/test/EmbedTestMongo.hs new file mode 100644 --- /dev/null +++ b/test/EmbedTestMongo.hs @@ -0,0 +1,432 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unused-top-binds -Wno-orphans -O0 #-} +module EmbedTestMongo (specs) where + +import MongoInit + +import Control.Exception (Exception, throw) +import Data.List.NonEmpty hiding (insert, length) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Typeable (Typeable) +import Database.MongoDB (genObjectId) +import Database.MongoDB (Value(String)) +import System.Process (readProcess) + +import EntityEmbedTestMongo +import Database.Persist.MongoDB + +data TestException = TestException + deriving (Show, Typeable, Eq) +instance Exception TestException + +instance PersistFieldSql a => PersistFieldSql (NonEmpty a) where + sqlType _ = SqlString + +instance PersistField a => PersistField (NonEmpty a) where + toPersistValue = toPersistValue . toList + fromPersistValue pv = do + list <- fromPersistValue pv + case list of + [] -> Left "PersistField: NonEmpty found unexpected Empty List" + (l:ls) -> Right (l:|ls) + + +mkPersist persistSettings [persistUpperCase| + HasObjectId + oid ObjectId + name Text + deriving Show Eq Read Ord + + HasArrayWithObjectIds + name Text + arrayWithObjectIds [HasObjectId] + deriving Show Eq Read Ord + + HasArrayWithEntities + hasEntity (Entity ARecord) + arrayWithEntities [AnEntity] + deriving Show Eq Read Ord + + OnlyName + name Text + deriving Show Eq Read Ord + + HasEmbed + name Text + embed OnlyName + deriving Show Eq Read Ord + + HasEmbeds + name Text + embed OnlyName + double HasEmbed + deriving Show Eq Read Ord + + HasListEmbed + name Text + list [HasEmbed] + deriving Show Eq Read Ord + + HasSetEmbed + name Text + set (S.Set HasEmbed) + deriving Show Eq Read Ord + + HasMap + name Text + map (M.Map T.Text T.Text) + deriving Show Eq Read Ord + + HasList + list [HasListId] + deriving Show Eq Read Ord + + EmbedsHasMap + name Text Maybe + embed HasMap + deriving Show Eq Read Ord + + InList + one Int + two Int + deriving Show Eq + + ListEmbed + nested [InList] + one Int + two Int + deriving Show Eq + + User + ident Text + password Text Maybe + profile Profile + deriving Show Eq Read Ord + + Profile + firstName Text + lastName Text + contact Contact Maybe + deriving Show Eq Read Ord + + Contact + phone Int + email T.Text + deriving Show Eq Read Ord + + Account + userIds (NonEmpty (Key User)) + name Text Maybe + customDomains [Text] -- we may want to allow multiple cust domains. use [] instead of maybe + + deriving Show Eq Read Ord + + HasNestedList + list [IntList] + deriving Show Eq + + IntList + ints [Int] + deriving Show Eq + + -- We would like to be able to use OnlyNameId + -- But (Key OnlyName) works + MapIdValue + map (M.Map T.Text (Key OnlyName)) + deriving Show Eq Read Ord + + + -- Self refrences are only allowed as a nullable type: + -- a Maybe or a List + SelfList + reference [SelfList] + + SelfMaybe + reference SelfMaybe Maybe + + -- This failes + -- SelfDirect + -- reference SelfDirect +|] + +cleanDB :: (PersistQuery backend, PersistEntityBackend HasMap ~ backend, MonadIO m) => ReaderT backend m () +cleanDB = do + deleteWhere ([] :: [Filter HasEmbed]) + deleteWhere ([] :: [Filter HasEmbeds]) + deleteWhere ([] :: [Filter HasListEmbed]) + deleteWhere ([] :: [Filter HasSetEmbed]) + deleteWhere ([] :: [Filter User]) + deleteWhere ([] :: [Filter HasMap]) + deleteWhere ([] :: [Filter HasList]) + deleteWhere ([] :: [Filter EmbedsHasMap]) + deleteWhere ([] :: [Filter ListEmbed]) + deleteWhere ([] :: [Filter ARecord]) + deleteWhere ([] :: [Filter Account]) + deleteWhere ([] :: [Filter HasNestedList]) + +db :: Action IO () -> Assertion +db = db' cleanDB + +unlessM :: MonadIO m => IO Bool -> m () -> m () +unlessM predicate body = do + b <- liftIO predicate + unless b body + +specs :: Spec +specs = describe "embedded entities" $ do + + it "simple entities" $ db $ do + let container = HasEmbeds "container" (OnlyName "2") + (HasEmbed "embed" (OnlyName "1")) + contK <- insert container + Just res <- selectFirst [HasEmbedsName ==. "container"] [] + res @== Entity contK container + + it "query for equality of embeded entity" $ db $ do + let container = HasEmbed "container" (OnlyName "2") + contK <- insert container + Just res <- selectFirst [HasEmbedEmbed ==. OnlyName "2"] [] + res @== Entity contK container + + it "Set" $ db $ do + let container = HasSetEmbed "set" $ S.fromList + [ HasEmbed "embed" (OnlyName "1") + , HasEmbed "embed" (OnlyName "2") + ] + contK <- insert container + Just res <- selectFirst [HasSetEmbedName ==. "set"] [] + res @== Entity contK container + + it "Set empty" $ db $ do + let container = HasSetEmbed "set empty" $ S.fromList [] + contK <- insert container + Just res <- selectFirst [HasSetEmbedName ==. "set empty"] [] + res @== Entity contK container + + it "exception" $ flip shouldThrow (== TestException) $ db $ do + let container = HasSetEmbed "set" $ S.fromList + [ HasEmbed "embed" (OnlyName "1") + , HasEmbed "embed" (OnlyName "2") + ] + contK <- insert container + Just res <- selectFirst [HasSetEmbedName ==. throw TestException] [] + res @== Entity contK container + + it "ListEmbed" $ db $ do + let container = HasListEmbed "list" + [ HasEmbed "embed" (OnlyName "1") + , HasEmbed "embed" (OnlyName "2") + ] + contK <- insert container + Just res <- selectFirst [HasListEmbedName ==. "list"] [] + res @== Entity contK container + + it "ListEmbed empty" $ db $ do + let container = HasListEmbed "list empty" [] + contK <- insert container + Just res <- selectFirst [HasListEmbedName ==. "list empty"] [] + res @== Entity contK container + + it "List empty" $ db $ do + let container = HasList [] + contK <- insert container + Just res <- selectFirst [] [] + res @== Entity contK container + + it "NonEmpty List wrapper" $ db $ do + let con = Contact 123456 "foo@bar.com" + let prof = Profile "fstN" "lstN" (Just con) + uid <- insert $ User "foo" (Just "pswd") prof + let container = Account (uid:|[]) (Just "Account") [] + contK <- insert container + Just res <- selectFirst [AccountUserIds ==. (uid:|[])] [] + res @== Entity contK container + + it "Map" $ db $ do + let container = HasMap "2 items" $ M.fromList [ + ("k1","v1") + , ("k2","v2") + ] + contK <- insert container + Just res <- selectFirst [HasMapName ==. "2 items"] [] + res @== Entity contK container + + it "Map empty" $ db $ do + let container = HasMap "empty" $ M.fromList [] + contK <- insert container + Just res <- selectFirst [HasMapName ==. "empty"] [] + res @== Entity contK container + + it "Embeds a Map" $ db $ do + let container = EmbedsHasMap (Just "non-empty map") $ HasMap "2 items" $ M.fromList [ + ("k1","v1") + , ("k2","v2") + ] + contK <- insert container + Just res <- selectFirst [EmbedsHasMapName ==. Just "non-empty map"] [] + res @== Entity contK container + + it "Embeds a Map empty" $ db $ do + let container = EmbedsHasMap (Just "empty map") $ HasMap "empty" $ M.fromList [] + contK <- insert container + Just res <- selectFirst [EmbedsHasMapName ==. Just "empty map"] [] + res @== Entity contK container + + it "Embeds a Map with ids as values" $ db $ do + onId <- insert $ OnlyName "nombre" + onId2 <- insert $ OnlyName "nombre2" + let midValue = MapIdValue $ M.fromList [("foo", onId),("bar",onId2)] + mK <- insert midValue + Just mv <- get mK + mv @== midValue + + it "List" $ db $ do + k1 <- insert $ HasList [] + k2 <- insert $ HasList [k1] + let container = HasList [k1, k2] + contK <- insert container + Just res <- selectFirst [HasListList `anyEq` k2] [] + res @== Entity contK container + + it "can embed an Entity" $ db $ do + let foo = ARecord "foo" + bar = ARecord "bar" + _ <- insertMany [foo, bar] + arecords <- selectList ([ARecordName ==. "foo"] ||. [ARecordName ==. "bar"]) [] + length arecords @== 2 + + kfoo <- insert foo + let hasEnts = HasArrayWithEntities (Entity kfoo foo) arecords + kEnts <- insert hasEnts + Just retrievedHasEnts <- get kEnts + retrievedHasEnts @== hasEnts + + it "can embed objects with ObjectIds" $ db $ do + oid <- liftIO $ genObjectId + let hoid = HasObjectId oid "oid" + hasArr = HasArrayWithObjectIds "array" [hoid] + + k <- insert hasArr + Just v <- get k + v @== hasArr + + describe "mongoDB filters" $ do + it "mongo single nesting filters" $ db $ do + let usr = User "foo" (Just "pswd") prof + prof = Profile "fstN" "lstN" (Just con) + con = Contact 123456 "foo@bar.com" + uId <- insert usr + Just r1 <- selectFirst [UserProfile &->. ProfileFirstName `nestEq` "fstN"] [] + r1 @== (Entity uId usr) + Just r2 <- selectFirst [UserProfile &~>. ProfileContact ?&->. ContactEmail `nestEq` "foo@bar.com", UserIdent ==. "foo"] [] + r2 @== (Entity uId usr) + + it "mongo embedded array filters" $ db $ do + let container = HasListEmbed "list" [ + (HasEmbed "embed" (OnlyName "1")) + , (HasEmbed "embed" (OnlyName "2")) + ] + contK <- insert container + let contEnt = Entity contK container + Just meq <- selectFirst [HasListEmbedList `anyEq` HasEmbed "embed" (OnlyName "1")] [] + meq @== contEnt + + Just neq1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestEq` "embed"] [] + neq1 @== contEnt + + Just nne1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestNe` "notEmbed"] [] + nne1 @== contEnt + + Just neq2 <- selectFirst [HasListEmbedList ~>. HasEmbedEmbed &->. OnlyNameName `nestEq` "1"] [] + neq2 @== contEnt + + Just nbq1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestBsonEq` String "embed"] [] + nbq1 @== contEnt + + Just nbq2 <- selectFirst [HasListEmbedList ~>. HasEmbedEmbed &->. OnlyNameName `nestBsonEq` String "1"] [] + nbq2 @== contEnt + + it "regexp match" $ db $ do + let container = HasListEmbed "list" [ + (HasEmbed "embed" (OnlyName "abcd")) + , (HasEmbed "embed" (OnlyName "efgh")) + ] + contK <- insert container + let mkReg t = (t, "ims") + Just res <- selectFirst [HasListEmbedName =~. mkReg "ist"] [] + res @== (Entity contK container) + + it "nested anyEq" $ db $ do + let top = HasNestedList [IntList [1,2]] + k <- insert top + Nothing <- selectFirst [HasNestedListList ->. IntListInts `nestEq` ([]::[Int])] [] + Nothing <- selectFirst [HasNestedListList ->. IntListInts `nestAnyEq` 3] [] + Just res <- selectFirst [HasNestedListList ->. IntListInts `nestAnyEq` 2] [] + res @== (Entity k top) + + describe "mongoDB updates" $ do + it "mongo single nesting updates" $ db $ do + let usr = User "foo" (Just "pswd") prof + prof = Profile "fstN" "lstN" (Just con) + con = Contact 123456 "foo@bar.com" + uid <- insert usr + let newName = "fstN2" + usr1 <- updateGet uid [UserProfile &->. ProfileFirstName `nestSet` newName] + (profileFirstName $ userProfile usr1) @== newName + + let newEmail = "foo@example.com" + let newIdent = "bar" + usr2 <- updateGet uid [UserProfile &~>. ProfileContact ?&->. ContactEmail `nestSet` newEmail, UserIdent =. newIdent] + (userIdent usr2) @== newIdent + (fmap contactEmail . profileContact . userProfile $ usr2) @== Just newEmail + + + it "mongo embedded array updates" $ db $ do + let container = HasListEmbed "list" [ + (HasEmbed "embed" (OnlyName "1")) + , (HasEmbed "embed" (OnlyName "2")) + ] + contk <- insert container + let _contEnt = Entity contk container + + pushed <- updateGet contk [HasListEmbedList `push` HasEmbed "embed" (OnlyName "3")] + (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList pushed) @== ["1","2","3"] + + -- same, don't add anything + addedToSet <- updateGet contk [HasListEmbedList `addToSet` HasEmbed "embed" (OnlyName "3")] + (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList addedToSet) @== ["1","2","3"] + pulled <- updateGet contk [HasListEmbedList `pull` HasEmbed "embed" (OnlyName "3")] + (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList pulled) @== ["1","2"] + + -- now it is new + addedToSet2 <- updateGet contk [HasListEmbedList `addToSet` HasEmbed "embed" (OnlyName "3")] + (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList addedToSet2) @== ["1","2","3"] + + allPulled <- updateGet contk [eachOp pull HasListEmbedList + [ HasEmbed "embed" (OnlyName "3") + , HasEmbed "embed" (OnlyName "2") + ] ] + (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList allPulled) @== ["1"] + allPushed <- updateGet contk [eachOp push HasListEmbedList + [ HasEmbed "embed" (OnlyName "4") + , HasEmbed "embed" (OnlyName "5") + ] ] + (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList allPushed) @== ["1","4","5"] + + + it "re-orders json inserted from another source" $ db $ do + let cname = T.unpack $ collectionName (error "ListEmbed" :: ListEmbed) + liftIO $ putStrLn =<< readProcess "mongoimport" ["-d", T.unpack dbName, "-c", cname] "{ \"nested\": [{ \"one\": 1, \"two\": 2 }, { \"two\": 2, \"one\": 1}], \"two\": 2, \"one\": 1, \"_id\" : { \"$oid\" : \"50184f5a92d7ae0000001e89\" } }" + + lists <- selectList [] [] + fmap entityVal lists @== [ListEmbed [InList 1 2, InList 1 2] 1 2] diff --git a/test/EntityEmbedTestMongo.hs b/test/EntityEmbedTestMongo.hs new file mode 100644 --- /dev/null +++ b/test/EntityEmbedTestMongo.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module EntityEmbedTestMongo where + +-- because we are using a type alias we need to declare in a separate module +-- this is used in EmbedTest +import MongoInit + +mkPersist persistSettings [persistUpperCase| + ARecord + name Text + deriving Show Eq Read Ord +|] + +type AnEntity = Entity ARecord diff --git a/test/MongoInit.hs b/test/MongoInit.hs new file mode 100644 --- /dev/null +++ b/test/MongoInit.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- We create an orphan instance for GenerateKey here to avoid a circular +-- dependency between: +-- +-- a) persistent-mongoDB:test depends on +-- b) persistent-test:lib depends on +-- c) persistent-mongODB:lib +-- +-- This kind of cycle is all kinds of bad news. + +module MongoInit ( + BackendMonad + , runConn + , MonadIO + , persistSettings + , MkPersistSettings (..) + , dbName + , db' + , setup + , mkPersistSettings + , Action + , Context + , BackendKey(MongoKey) + + -- re-exports + , module Database.Persist + , module Database.Persist.Sql.Raw.QQ + , module Test.Hspec + , module Test.HUnit + , liftIO + , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase + , Int32, Int64 + , Text + , module Control.Monad.Trans.Reader + , module Control.Monad + , PersistFieldSql(..) + , BS.ByteString + , SomeException + , module Init + ) where + +-- we have to be careful with this import becuase CPP is still a problem +import Init + ( TestFn(..), truncateTimeOfDay, truncateUTCTime + , truncateToMicro, arbText, liftA2, GenerateKey(..) + , (@/=), (@==), (==@) + , assertNotEqual, assertNotEmpty, assertEmpty, asIO + , isTravis + ) + +-- re-exports +import Control.Exception (SomeException) +import Control.Monad (void, replicateM, liftM, when, forM_) +import Control.Monad.Trans.Reader +import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..)) +import Database.Persist.Sql.Raw.QQ +import Test.Hspec + +-- testing +import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) + +import Control.Monad (unless, (>=>)) +import Control.Monad.IO.Class +import Control.Monad.IO.Unlift (MonadUnliftIO) +import qualified Data.ByteString as BS +import Data.Int (Int32, Int64) +import Data.Text (Text) +import qualified Database.MongoDB as MongoDB +import Database.Persist.MongoDB (Action, withMongoPool, runMongoDBPool, defaultMongoConf, applyDockerEnv, BackendKey(..)) +import Language.Haskell.TH.Syntax (Type(..)) + +import Database.Persist +import Database.Persist.Sql (PersistFieldSql(..)) +import Database.Persist.TH (mkPersistSettings) + +setup :: Action IO () +setup = setupMongo +type Context = MongoDB.MongoContext + +_debugOn :: Bool +_debugOn = True + +persistSettings :: MkPersistSettings +persistSettings = (mkPersistSettings $ ConT ''Context) { mpsGeneric = True } + +dbName :: Text +dbName = "persistent" + +type BackendMonad = Context + +runConn :: MonadUnliftIO m => Action m backend -> m () +runConn f = do + conf <- liftIO $ applyDockerEnv $ defaultMongoConf dbName -- { mgRsPrimary = Just "replicaset" } + void $ withMongoPool conf $ runMongoDBPool MongoDB.master f + +setupMongo :: Action IO () +setupMongo = void $ MongoDB.dropDatabase dbName + +db' :: Action IO () -> Action IO () -> Assertion +db' actions cleanDB = do + r <- runConn (actions >> cleanDB) + return r + +instance GenerateKey MongoDB.MongoContext where + generateKey = MongoKey `liftM` MongoDB.genObjectId diff --git a/test/RawMongoHelpers.hs b/test/RawMongoHelpers.hs new file mode 100644 --- /dev/null +++ b/test/RawMongoHelpers.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +module RawMongoHelpers where + +import qualified Database.MongoDB as MongoDB +import Database.Persist.MongoDB (toInsertDoc, docToEntityThrow, collectionName, recordToDocument) + +import MongoInit +import PersistentTest (cleanDB) +import PersistentTestModels + + +db :: ReaderT MongoDB.MongoContext IO () -> IO () +db = db' cleanDB + +specs :: Spec +specs = do + describe "raw MongoDB helpers" $ do + it "collectionName" $ do + collectionName (Person "Duder" 0 Nothing) @?= "Person" + + it "toInsertFields, entityFields, & docToEntityThrow" $ db $ do + let p1 = Person "Duder" 0 Nothing + let doc = toInsertDoc p1 + MongoDB.ObjId _id <- MongoDB.insert "Person" $ doc + let idSelector = "_id" MongoDB.=: _id + Entity _ ent1 <- docToEntityThrow $ idSelector:doc + liftIO $ p1 @?= ent1 + + let p2 = p1 {personColor = Just "blue"} + let doc2 = idSelector:recordToDocument p2 + MongoDB.save "Person" doc2 + Entity _ ent2 <- docToEntityThrow doc2 + liftIO $ p2 @?= ent2 diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +import qualified Data.ByteString as BS +import Data.IntMap (IntMap) +import qualified Data.Text as T +import Data.Time +import Database.MongoDB (runCommand1) +import Text.Blaze.Html +import Test.QuickCheck + +-- FIXME: should this be added? (RawMongoHelpers module wasn't used) +-- import qualified RawMongoHelpers +import MongoInit + +-- These tests are noops with the NoSQL flags set. +-- +-- import qualified CompositeTest +-- import qualified CustomPrimaryKeyReferenceTest +-- import qualified InsertDuplicateUpdate +-- import qualified PersistUniqueTest +-- import qualified PrimaryTest +-- import qualified UniqueTest +-- import qualified MigrationColumnLengthTest +-- import qualified EquivalentTypeTest + +-- These modules were quite complicated. Instead of fully extracting the +-- relevant common functionality, I just copied and de-CPPed manually. +import qualified EmbedTestMongo + +-- These are done. +import qualified CustomPersistFieldTest +import qualified DataTypeTest +import qualified EmbedOrderTest +import qualified EmptyEntityTest +import qualified HtmlTest +import qualified LargeNumberTest +import qualified MaxLenTest +import qualified MigrationOnlyTest +import qualified PersistentTest +import qualified Recursive +import qualified RenameTest +import qualified SumTypeTest +import qualified UpsertTest + +type Tuple = (,) + +dbNoCleanup :: Action IO () -> Assertion +dbNoCleanup = db' (pure ()) + +-- FIXME: This isn't actually used? +share [mkPersist persistSettings, mkMigrate "htmlMigrate"] [persistLowerCase| +HtmlTable + html Html + deriving +|] + +mkPersist persistSettings [persistUpperCase| +DataTypeTable no-json + text Text + textMaxLen Text maxlen=100 + bytes ByteString + bytesTextTuple (Tuple ByteString Text) + bytesMaxLen ByteString maxlen=100 + int Int + intList [Int] + intMap (IntMap Int) + double Double + bool Bool + day Day + utc UTCTime +|] + +instance Arbitrary DataTypeTable where + arbitrary = DataTypeTable + <$> arbText -- text + <*> (T.take 100 <$> arbText) -- textManLen + <*> arbitrary -- bytes + <*> liftA2 (,) arbitrary arbText -- bytesTextTuple + <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen + <*> arbitrary -- int + <*> arbitrary -- intList + <*> arbitrary -- intMap + <*> arbitrary -- double + <*> arbitrary -- bool + <*> arbitrary -- day + <*> (truncateUTCTime =<< arbitrary) -- utc + +mkPersist persistSettings [persistUpperCase| +EmptyEntity +|] + +main :: IO () +main = do + hspec $ afterAll dropDatabase $ do + xdescribe "This test is failing for Mongo by only embedding the first thing." $ do + RenameTest.specsWith (db' RenameTest.cleanDB) + DataTypeTest.specsWith + dbNoCleanup + Nothing + [ TestFn "Text" dataTypeTableText + , TestFn "Text" dataTypeTableTextMaxLen + , TestFn "Bytes" dataTypeTableBytes + , TestFn "Bytes" dataTypeTableBytesTextTuple + , TestFn "Bytes" dataTypeTableBytesMaxLen + , TestFn "Int" dataTypeTableInt + , TestFn "Int" dataTypeTableIntList + , TestFn "Int" dataTypeTableIntMap + , TestFn "Double" dataTypeTableDouble + , TestFn "Bool" dataTypeTableBool + , TestFn "Day" dataTypeTableDay + ] + [] + dataTypeTableDouble + HtmlTest.specsWith (db' HtmlTest.cleanDB) Nothing + EmbedTestMongo.specs + EmbedOrderTest.specsWith (db' EmbedOrderTest.cleanDB) + LargeNumberTest.specsWith + (db' (deleteWhere ([] :: [Filter (LargeNumberTest.NumberGeneric backend)]))) + MaxLenTest.specsWith dbNoCleanup + Recursive.specsWith (db' Recursive.cleanup) + + SumTypeTest.specsWith (dbNoCleanup) Nothing + MigrationOnlyTest.specsWith + dbNoCleanup + Nothing + PersistentTest.specsWith (db' PersistentTest.cleanDB) + -- TODO: The upsert tests are currently failing. Find out why and fix + -- them. + xdescribe "UpsertTest is currently failing for Mongo due to differing behavior" $ do + UpsertTest.specsWith + (db' PersistentTest.cleanDB) + UpsertTest.AssumeNullIsZero + UpsertTest.UpsertGenerateNewKey + EmptyEntityTest.specsWith + (db' EmptyEntityTest.cleanDB) + Nothing + CustomPersistFieldTest.specsWith + dbNoCleanup + -- FIXME: should this be added? (RawMongoHelpers module wasn't used) + -- RawMongoHelpers.specs + + where + dropDatabase () = dbNoCleanup (void (runCommand1 $ T.pack "dropDatabase()"))