diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/persistent-test.cabal b/persistent-test.cabal new file mode 100644 --- /dev/null +++ b/persistent-test.cabal @@ -0,0 +1,208 @@ +name: persistent-test +version: 2.0.0.3 +license: MIT +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +synopsis: Tests for Persistent +description: Tests for Persistent +category: Database, Yesod +stability: Stable +cabal-version: >= 1.10 +build-type: Simple +homepage: http://www.yesodweb.com/book/persistent +bug-reports: https://github.com/yesodweb/persistent/issues + +extra-source-files: + test/main.hs + +Flag sqlite + Description: use sqlite. This is just present for consistency, and is not used + Default: False + manual: True + +Flag zookeeper + Description: test only Zookeeper. default is to test just sqlite. + Default: False + manual: True + +Flag mongodb + Description: test only MongoDB. default is to test just sqlite. + Default: False + manual: True + +Flag postgresql + Description: test postgresql. default is to test just sqlite. + Default: False + manual: True + +Flag mysql + Description: test MySQL. default is to test just sqlite. + Default: False + manual: True + +Flag high_precision_date + Description: for MongoDB use a time storage with nano second precision. + Default: False + manual: True + +flag nooverlap + default: False + description: test out our assumption that OverlappingInstances is just for String + manual: True + +library + exposed-modules: PersistentTest + PersistTestPetType + PersistTestPetCollarType + RenameTest + DataTypeTest + EmptyEntityTest + HtmlTest + EmbedTest + EmbedOrderTest + EntityEmbedTest + LargeNumberTest + UniqueTest + MaxLenTest + Recursive + SumTypeTest + MigrationOnlyTest + MigrationTest + MigrationIdempotencyTest + PersistUniqueTest + CompositeTest + Init + PrimaryTest + CustomPersistField + CustomPersistFieldTest + CustomPrimaryKeyReferenceTest + InsertDuplicateUpdate + MigrationColumnLengthTest + EquivalentTypeTest + + hs-source-dirs: src, test + + ghc-options: -Wall + if impl(ghc >= 7.8) + ghc-options: -Wall -j + + build-depends: base >= 4.6 && < 5 + , persistent + , persistent-template + , HUnit + , hspec >= 1.12.1 + , hspec-expectations + , template-haskell + , aeson >= 0.7 + , aeson-compat >= 0.3.2.0 && < 0.4 + , lifted-base >= 0.1 + , network + , path-pieces >= 0.1 + , http-api-data >= 0.2 + , text >= 0.8 + , transformers >= 0.2.1 + , unliftio-core + , unliftio + , containers >= 0.2 + , bytestring >= 0.9 + , base64-bytestring + , conduit >= 1.0 + , resourcet >= 0.4 + , exceptions >= 0.6 + , time >= 1.1.4 + , random >= 1.0 + , QuickCheck >= 2.7 + , blaze-html >= 0.5 + , blaze-markup >= 0.5.1 + , quickcheck-instances >= 0.3 + , transformers-base + , attoparsec + , vector + , unordered-containers + , monad-logger >= 0.3 + , hashable + -- actually just a mongoDB dependency + -- fixes build warning on current build server + , cereal + , silently + , blaze-builder + , mtl + , fast-logger + , semigroups + , scientific + , resource-pool + , exceptions + , tagged + , old-locale + + if flag(nooverlap) + cpp-options: -DNO_OVERLAP + + if !flag(postgresql) && !flag(mysql) && !flag(mongodb) && !flag(zookeeper) + build-depends: persistent-sqlite >= 2.6.1.1 + cpp-options: -DWITH_SQLITE -DDEBUG + + if flag(postgresql) + build-depends: persistent-postgresql + , postgresql-simple + , postgresql-libpq + cpp-options: -DWITH_POSTGRESQL -DDEBUG + + if flag(mysql) + build-depends: persistent-mysql + , mysql-simple >= 0.4.3 && < 0.5 + , mysql >= 0.1.1.3 && < 0.2 + cpp-options: -DWITH_MYSQL + + if flag(mongodb) + build-depends: persistent-mongoDB + , mongoDB >= 2.0.4 && < 3.0 + , cereal + , bson >= 0.3.1 + , process + cpp-options: -DWITH_NOSQL -DWITH_MONGODB -DDEBUG + + if flag(zookeeper) + build-depends: persistent-zookeeper + , hzk >= 2.1.0 + , binary + , utf8-string >= 0.3.7 && < 0.4.0 + , process + cpp-options: -DWITH_NOSQL -DWITH_ZOOKEEPER -DDEBUG + + if flag(high_precision_date) + cpp-options: -DHIGH_PRECISION_DATE + + default-language: Haskell2010 + + +executable persistent-test + main-is: main.hs + hs-source-dirs: test + default-language: Haskell2010 + + build-depends: base >= 4.6 && < 5 + , persistent-test + , persistent + , hspec + , system-filepath + , system-fileio + , resourcet + , scientific + + if !flag(postgresql) && !flag(mysql) && !flag(mongodb) && !flag(zookeeper) + cpp-options: -DWITH_SQLITE -DDEBUG + if flag(zookeeper) + cpp-options: -DWITH_NOSQL -DWITH_ZOOKEEPER -DDEBUG + if flag(mongodb) + cpp-options: -DWITH_NOSQL -DWITH_MONGODB -DDEBUG + if flag(postgresql) + cpp-options: -DWITH_POSTGRESQL + if flag(mysql) + cpp-options: -DWITH_MYSQL + + +source-repository head + type: git + location: git://github.com/yesodweb/persistent.git diff --git a/src/CompositeTest.hs b/src/CompositeTest.hs new file mode 100644 --- /dev/null +++ b/src/CompositeTest.hs @@ -0,0 +1,311 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} -- FIXME +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +module CompositeTest where + +import Test.Hspec.Expectations () +import Init + +#ifndef WITH_NOSQL +import Data.Maybe (isJust) +import Database.Persist.TH (mkDeleteCascade) +#endif + + +-- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs +#if WITH_NOSQL +mkPersist persistSettings { mpsGeneric = False } [persistUpperCase| +#else +share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate", mkDeleteCascade persistSettings { mpsGeneric = False }] [persistLowerCase| +#endif + TestParent + name String maxlen=20 + name2 String maxlen=20 + age Int + extra44 String + Primary name name2 age + deriving Show Eq + TestChild + name String maxlen=20 + name2 String maxlen=20 + age Int + extra4 String + Foreign TestParent fkparent name name2 age + deriving Show Eq +#ifndef WITH_MYSQL + Tree + name Text + parent Text Maybe + Primary name + Foreign Tree fkparent parent +#endif + + Citizen + name String + age Int Maybe + deriving Eq Show + Address + address String + country String + deriving Eq Show + CitizenAddress + citizen CitizenId + address AddressId + Primary citizen address + deriving Eq Show + + PrimaryCompositeWithOtherNullableFields + foo String maxlen=20 + bar String maxlen=20 + baz String Maybe + Primary foo bar + deriving Eq Show +|] + + +#ifdef WITH_NOSQL +cleanDB :: (PersistQuery backend, PersistEntityBackend TestChild ~ backend, MonadIO m) => ReaderT backend m () +cleanDB = do + deleteWhere ([] :: [Filter TestChild]) + deleteWhere ([] :: [Filter TestParent]) + deleteWhere ([] :: [Filter CitizenAddress]) + deleteWhere ([] :: [Filter Citizen]) + deleteWhere ([] :: [Filter Address]) + +db :: Action IO () -> Assertion +db = db' cleanDB + +specs :: Spec +specs = return () +#else + +specs :: Spec +specs = describe "composite" $ + describe "primary keys" $ do + + let p1 = TestParent "a1" "b1" 11 "p1" + let p2 = TestParent "a2" "b2" 22 "p2" + let p3 = TestParent "a3" "b3" 33 "p3" + let p1' = TestParent "a1" "b1" 11 "p1'" + let c1 = TestChild "a1" "b1" 11 "c1" + let c1' = TestChild "a1" "b1" 11 "c1'" + + it "insertWithKey" $ db $ do + kp1 <- insert p1 + delete kp1 + insertKey kp1 p2 + + it "repsert" $ db $ do + kp1 <- insert p1 + repsert kp1 p2 + + it "Insert" $ db $ do + kp1 <- insert p1 + matchParentK kp1 @== Right ("a1","b1",11) + mp <- get kp1 + isJust mp @== True + let Just p11 = mp + p1 @== p11 + xs <- selectList [TestParentId ==. kp1] [] + length xs @== 1 + let [Entity newkp1 newp1] = xs + matchParentK kp1 @== matchParentK newkp1 + p1 @== newp1 + + it "Id field" $ db $ do + kp1 <- insert p1 + kp2 <- insert p2 + xs <- selectList [TestParentId <-. [kp1,kp2]] [] + length xs @== 2 + let [e1@(Entity newkp1 newp1),e2@(Entity newkp2 newp2)] = xs + matchParentK kp1 @== matchParentK newkp1 + matchParentK kp2 @== matchParentK newkp2 + p1 @== newp1 + p2 @== newp2 + + it "Filter by Id with 'not equal'" $ db $ do + kp1 <- insert p1 + kp2 <- insert p2 + xs <- selectList [TestParentId !=. kp1] [] + length xs @== 1 + let [Entity newkp2 newp2] = xs + matchParentK kp2 @== matchParentK newkp2 + + it "Filter by Id with 'in'" $ db $ do + kp1 <- insert p1 + kp2 <- insert p2 + xs <- selectList [TestParentId <-. [kp1,kp2]] [] + length xs @== 2 + let [Entity newkp1 newp1,Entity newkp2 newp2] = xs + matchParentK kp1 @== matchParentK newkp1 + matchParentK kp2 @== matchParentK newkp2 + + it "Filter by Id with 'not in'" $ db $ do + kp1 <- insert p1 + kp2 <- insert p2 + xs <- selectList [TestParentId /<-. [kp1]] [] + length xs @== 1 + let [Entity newkp2 newp2] = xs + matchParentK kp2 @== matchParentK newkp2 + + it "Filter by Id with 'not in' with no data" $ db $ do + kp1 <- insert p1 + kp2 <- insert p2 + xs <- selectList [TestParentId /<-. [kp1,kp2]] [] + length xs @== 0 + + it "Extract Parent Foreign Key from Child value" $ db $ do + kp1 <- insert p1 + _ <- insert p2 + kc1 <- insert c1 + mc <- get kc1 + isJust mc @== True + let Just c11 = mc + c1 @== c11 + testChildFkparent c11 @== kp1 + +#ifndef WITH_MYSQL + it "Tree relationships" $ db $ do + kgp@(TreeKey gpt) <- insert $ Tree "grandpa" Nothing + kdad@(TreeKey dadt) <- insert $ Tree "dad" $ Just gpt + kc <- insert $ Tree "child" $ Just dadt + c <- getJust kc + treeFkparent c @== Just kdad + dad <- getJust kdad + treeFkparent dad @== Just kgp + gp <- getJust kgp + treeFkparent gp @== Nothing +#endif + + it "Validate Key contents" $ db $ do + _ <- insert p1 + _ <- insert p2 + _ <- insert p3 + xs <- selectKeysList [] [Asc TestParentName] + length xs @== 3 + let [kps1,kps2,kps3] = xs + matchParentK kps1 @== Right ("a1","b1",11) + matchParentK kps2 @== Right ("a2","b2",22) + matchParentK kps3 @== Right ("a3","b3",33) + + it "Delete" $ db $ do + kp1 <- insert p1 + kp2 <- insert p2 + + _ <- delete kp1 + r <- get kp1 + r @== Nothing + r1 <- get kp2 + isJust r1 @== True + + it "Update" $ db $ do + kp1 <- insert p1 + _ <- update kp1 [TestParentExtra44 =. "q1"] + newkps1 <- get kp1 + newkps1 @== Just (TestParent "a1" "b1" 11 "q1") + + it "Replace Parent" $ db $ do + kp1 <- insert p1 + _ <- replace kp1 p1' + newp1 <- get kp1 + newp1 @== Just p1' + + it "Replace Child" $ db $ do + -- c1 FKs p1 + _ <- insert p1 + kc1 <- insert c1 + _ <- replace kc1 c1' + newc1 <- get kc1 + newc1 @== Just c1' + + it "Insert Many to Many" $ db $ do + let z1 = Citizen "mk" (Just 11) + let a1 = Address "abc" "usa" + let z2 = Citizen "gb" (Just 22) + let a2 = Address "def" "den" + + kc1 <- insert z1 + ka1 <- insert a1 + let ca1 = CitizenAddress kc1 ka1 + kca1 <- insert ca1 + matchCitizenAddressK kca1 @== matchK2 kc1 ka1 + + mca <- get kca1 + isJust mca @== True + let Just newca1 = mca + ca1 @== newca1 + + kc2 <- insert z2 + ka2 <- insert a2 + let ca2 = CitizenAddress kc2 ka2 + kca2 <- insert ca2 + matchCitizenAddressK kca2 @== matchK2 kc2 ka2 + + xs <- selectList [CitizenAddressId ==. kca1] [] + length xs @== 1 + let [Entity newkca1 newca2] = xs + matchCitizenAddressK kca1 @== matchCitizenAddressK newkca1 + ca1 @== newca2 + it "insertMany" $ db $ do + [kp1, kp2] <- insertMany [p1, p2] + newp1 <- get kp1 + newp1 @== Just p1 + + newp2 <- get kp2 + newp2 @== Just p2 + it "RawSql Key instance" $ db $ do + key <- insert p1 + keyFromRaw <- rawSql "SELECT name, name2, age FROM test_parent LIMIT 1" [] + [key] @== keyFromRaw + + it "RawSql Key instance with sqlQQ" $ db $ do + key <- insert p1 + keyFromRaw' <- [sqlQQ| + SELECT @{TestParentName}, @{TestParentName2}, @{TestParentAge} + FROM ^{TestParent} + LIMIT 1 + |] + [key] @== keyFromRaw' + + it "RawSql Entity instance" $ db $ do + key <- insert p1 + newp1 <- rawSql "SELECT ?? FROM test_parent LIMIT 1" [] + [Entity key p1] @== newp1 + + it "RawSql Entity instance with sqlQQ" $ db $ do + key <- insert p1 + newp1' <- [sqlQQ| SELECT ?? FROM ^{TestParent} |] + [Entity key p1] @== newp1' + +#endif + +matchK :: (PersistField a, PersistEntity record) => Key record -> Either Text a +matchK = (\(pv:[]) -> fromPersistValue pv) . keyToValues + +matchK2 :: (PersistField a1, PersistField a, PersistEntity record, PersistEntity record2) + => Key record -> Key record2 + -> Either Text (a1, a) +matchK2 k1 k2 = (,) <$> matchK k1 <*> matchK k2 + +matchParentK :: Key TestParent -> Either Text (String, String, Int64) +matchParentK = (\(a:b:c:[]) -> (,,) <$> fromPersistValue a <*> fromPersistValue b <*> fromPersistValue c) + . keyToValues + +matchCitizenAddressK :: Key CitizenAddress -> Either Text (Int64, Int64) +matchCitizenAddressK = (\(a:b:[]) -> (,) <$> fromPersistValue a <*> fromPersistValue b) + . keyToValues diff --git a/src/CustomPersistField.hs b/src/CustomPersistField.hs new file mode 100644 --- /dev/null +++ b/src/CustomPersistField.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, FlexibleInstances, EmptyDataDecls, MultiParamTypeClasses #-} + +-- This module is used for CustomPersistFieldTest; the TH GHC stage restriction requires it to be here. +-- The code is taken from the Yesod.Text.Markdown package; see https://github.com/yesodweb/persistent/issues/448 +module CustomPersistField where + +import Init +import Data.Text (pack) +import qualified Data.Text.Lazy as TL +import Data.Text.Lazy (toStrict, fromStrict) +import Data.String (IsString) + +newtype Markdown = Markdown TL.Text + deriving (Eq, Ord, IsString, Show) + +instance PersistField Markdown where + toPersistValue (Markdown t) = PersistText $ toStrict t + fromPersistValue (PersistText t) = Right $ Markdown $ fromStrict t + fromPersistValue wrongValue = Left $ pack $ "Received " ++ show wrongValue ++ " when a value of type PersistText was expected." + + +instance PersistFieldSql Markdown where + sqlType _ = SqlString diff --git a/src/CustomPersistFieldTest.hs b/src/CustomPersistFieldTest.hs new file mode 100644 --- /dev/null +++ b/src/CustomPersistFieldTest.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, FlexibleInstances, EmptyDataDecls, MultiParamTypeClasses #-} + +module CustomPersistFieldTest ( + specs +#ifndef WITH_NOSQL + , customFieldMigrate +#endif +) where + +import Init +import CustomPersistField + +#ifdef WITH_NOSQL +db :: Action IO () -> Assertion +db = db' (return ()) +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "customFieldMigrate"] [persistLowerCase| +#endif + BlogPost + article Markdown + deriving Show Eq +|] + +specs :: Spec +specs = describe "Custom persist field" $ do + it "should read what it wrote" $ db $ do + let originalBlogPost = BlogPost "article" + blogPostId <- insert originalBlogPost + Just newBlogPost <- get blogPostId + liftIO $ originalBlogPost @?= newBlogPost + diff --git a/src/CustomPrimaryKeyReferenceTest.hs b/src/CustomPrimaryKeyReferenceTest.hs new file mode 100644 --- /dev/null +++ b/src/CustomPrimaryKeyReferenceTest.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} + +-- This test is based on this issue: https://github.com/yesodweb/persistent/issues/421 +-- The primary thing this is testing is the migration, thus the test code itself being mostly negligible. +module CustomPrimaryKeyReferenceTest where + +import Init + +-- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs +#if WITH_NOSQL +mkPersist persistSettings { mpsGeneric = False } [persistUpperCase| +#else +share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase| +#endif + Tweet + tweetId Int + statusText Text sqltype=varchar(170) + Primary tweetId + UniqueTweetId tweetId + deriving Show + TweetUrl + tweetId TweetId + tweetUrl Text sqltype=varchar(255) + finalUrl Text Maybe sqltype=varchar(255) + UniqueTweetIdTweetUrl tweetId tweetUrl + deriving Show +|] +#ifdef WITH_NOSQL +cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Tweet ~ backend) => ReaderT backend m () +cleanDB = do + deleteWhere ([] :: [Filter Tweet]) + deleteWhere ([] :: [Filter TweetUrl]) + +db :: Action IO () -> Assertion +db = db' cleanDB +#endif + +specs :: Spec +specs = describe "custom primary key reference" $ do +#ifdef WITH_NOSQL + return () +#else + + let tweet = Tweet {tweetTweetId = 1, tweetStatusText = "Hello!"} + + it "can insert a Tweet" $ db $ do + tweetId <- insert tweet + let url = TweetUrl {tweetUrlTweetId = tweetId, tweetUrlTweetUrl = "http://google.com", tweetUrlFinalUrl = Just "http://example.com"} + insert_ url + + return () + +#endif diff --git a/src/DataTypeTest.hs b/src/DataTypeTest.hs new file mode 100644 --- /dev/null +++ b/src/DataTypeTest.hs @@ -0,0 +1,198 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +module DataTypeTest (specs) where + +import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) +import Test.QuickCheck.Gen (Gen(..)) +import Test.QuickCheck.Instances () +import Test.QuickCheck.Random (newQCGen) +import Database.Persist.TH +import Data.Char (generalCategory, GeneralCategory(..)) +import qualified Data.Text as T +import qualified Data.ByteString as BS +import Data.Time (Day, UTCTime (..), fromGregorian, picosecondsToDiffTime, + TimeOfDay (TimeOfDay), timeToTimeOfDay, timeOfDayToTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) +import Data.IntMap (IntMap) +import Data.Fixed (Pico,Micro) + +import Init + +type Tuple a b = (a, b) + +#ifdef WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +-- Test lower case names +share [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase| +#endif +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 +#ifndef WITH_NOSQL + pico Pico + time TimeOfDay +#endif + utc UTCTime +#if defined(WITH_MYSQL) && !(defined(OLD_MYSQL)) + -- For MySQL, provide extra tests for time fields with fractional seconds, + -- since the default (used above) is to have no fractional part. This + -- requires the server version to be at least 5.6.4, and should be switched + -- off for older servers by defining OLD_MYSQL. + timeFrac TimeOfDay sqltype=TIME(6) + utcFrac UTCTime sqltype=DATETIME(6) +#endif +|] + +cleanDB :: (MonadIO m, PersistQuery backend, backend ~ PersistEntityBackend DataTypeTable) => ReaderT backend m () +cleanDB = deleteWhere ([] :: [Filter DataTypeTable]) + +specs :: Spec +specs = describe "data type specs" $ + it "handles all types" $ asIO $ runConn $ do +#ifndef WITH_NOSQL + _ <- runMigrationSilent dataTypeMigrate + -- Ensure reading the data from the database works... + _ <- runMigrationSilent dataTypeMigrate +#endif + rvals <- liftIO randomValues + forM_ (take 1000 rvals) $ \x -> do + key <- insert x + Just y <- get key + liftIO $ do + let check :: (Eq a, Show a) => String -> (DataTypeTable -> a) -> IO () + check s f = (s, f x) @=? (s, f y) + -- Check floating-point near equality + let check' :: String -> (DataTypeTable -> Pico) -> IO () + check' s f + | abs (f x - f y) < 0.000001 = return () + | otherwise = (s, f x) @=? (s, f y) + -- Check individual fields for better error messages + check "text" dataTypeTableText + check "textMaxLen" dataTypeTableTextMaxLen + check "bytes" dataTypeTableBytes + check "bytesTextTuple" dataTypeTableBytesTextTuple + check "bytesMaxLen" dataTypeTableBytesMaxLen + check "int" dataTypeTableInt + check "intList" dataTypeTableIntList + check "intMap" dataTypeTableIntMap + check "bool" dataTypeTableBool + check "day" dataTypeTableDay +#ifndef WITH_NOSQL + check' "pico" dataTypeTablePico + check "time" (roundTime . dataTypeTableTime) +#endif +#if !(defined(WITH_NOSQL)) || (defined(WITH_NOSQL) && defined(HIGH_PRECISION_DATE)) + check "utc" (roundUTCTime . dataTypeTableUtc) +#endif +#if defined(WITH_MYSQL) && !(defined(OLD_MYSQL)) + check "timeFrac" (dataTypeTableTimeFrac) + check "utcFrac" (dataTypeTableUtcFrac) +#endif + + -- Do a special check for Double since it may + -- lose precision when serialized. + when (getDoubleDiff (dataTypeTableDouble x)(dataTypeTableDouble y) > 1e-14) $ + check "double" dataTypeTableDouble + where + normDouble :: Double -> Double + normDouble x | abs x > 1 = x / 10 ^ (truncate (logBase 10 (abs x)) :: Integer) + | otherwise = x + getDoubleDiff x y = abs (normDouble x - normDouble y) + +roundFn :: RealFrac a => a -> Integer +#ifdef OLD_MYSQL +-- At version 5.6.4, MySQL changed the method used to round values for +-- date/time types - this is the same version which added support for +-- fractional seconds in the storage type. +roundFn = truncate +#else +roundFn = round +#endif + +roundTime :: TimeOfDay -> TimeOfDay +#ifdef WITH_MYSQL +roundTime t = timeToTimeOfDay $ fromIntegral $ roundFn $ timeOfDayToTime t +#else +roundTime = id +#endif + +roundUTCTime :: UTCTime -> UTCTime +#ifdef WITH_MYSQL +roundUTCTime t = + posixSecondsToUTCTime $ fromIntegral $ roundFn $ utcTimeToPOSIXSeconds t +#else +roundUTCTime = id +#endif + +randomValues :: IO [DataTypeTable] +randomValues = do + g <- newQCGen + return $ map (unGen arbitrary g) [0..] + +instance Arbitrary DataTypeTable where + arbitrary = DataTypeTable + <$> arbText -- text + <*> (T.take 100 <$> arbText) -- textManLen + <*> arbitrary -- bytes + <*> arbTuple arbitrary arbText -- bytesTextTuple + <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen + <*> arbitrary -- int + <*> arbitrary -- intList + <*> arbitrary -- intMap + <*> arbitrary -- double + <*> arbitrary -- bool + <*> arbitrary -- day +#ifndef WITH_NOSQL + <*> arbitrary -- pico + <*> (truncateTimeOfDay =<< arbitrary) -- time +#endif + <*> (truncateUTCTime =<< arbitrary) -- utc +#if defined(WITH_MYSQL) && !(defined(OLD_MYSQL)) + <*> (truncateTimeOfDay =<< arbitrary) -- timeFrac + <*> (truncateUTCTime =<< arbitrary) -- utcFrac +#endif + +arbText :: Gen Text +arbText = + T.pack + . filter ((`notElem` forbidden) . generalCategory) + . filter (<= '\xFFFF') -- only BMP + . filter (/= '\0') -- no nulls + <$> arbitrary + where forbidden = [NotAssigned, PrivateUse] + +arbTuple :: Gen a -> Gen b -> Gen (a, b) +arbTuple x y = (,) <$> x <*> y + +-- truncate less significant digits +truncateToMicro :: Pico -> Pico +truncateToMicro p = let + p' = fromRational . toRational $ p :: Micro + in fromRational . toRational $ p' :: Pico + +truncateTimeOfDay :: TimeOfDay -> Gen TimeOfDay +truncateTimeOfDay (TimeOfDay h m s) = + return $ TimeOfDay h m $ truncateToMicro s + +truncateUTCTime :: UTCTime -> Gen UTCTime +truncateUTCTime (UTCTime d dift) = do + let pico = fromRational . toRational $ dift :: Pico + picoi= truncate . (*1000000000000) . toRational $ truncateToMicro pico :: Integer + -- https://github.com/lpsmith/postgresql-simple/issues/123 + d' = max d $ fromGregorian 1950 1 1 + return $ UTCTime d' $ picosecondsToDiffTime picoi + +asIO :: IO a -> IO a +asIO = id diff --git a/src/EmbedOrderTest.hs b/src/EmbedOrderTest.hs new file mode 100644 --- /dev/null +++ b/src/EmbedOrderTest.hs @@ -0,0 +1,72 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleInstances #-} +{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell, + OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls, MultiParamTypeClasses #-} +module EmbedOrderTest (specs, +#ifndef WITH_NOSQL +embedOrderMigrate +#endif +) where + +import Init +import Data.Map hiding (insert) + +import Debug.Trace (trace) +debug :: Show s => s -> s +debug x = trace (show x) x + +#if WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "embedOrderMigrate"] [persistUpperCase| +#endif +Foo sql=foo_embed_order + bars [Bar] + deriving Eq Show +Bar sql=bar_embed_order + b String + u String + g String + deriving Eq Show +|] + +#ifdef WITH_NOSQL +cleanDB :: (PersistQuery backend, PersistEntityBackend Foo ~ backend, MonadIO m) => ReaderT backend m () +cleanDB = do + deleteWhere ([] :: [Filter Foo]) + deleteWhere ([] :: [Filter Bar]) + +db :: Action IO () -> Assertion +db = db' cleanDB +#endif + +specs :: Spec +specs = describe "embedded entities" $ do + it "preserves ordering" $ db $ do + let foo = Foo [Bar "b" "u" "g"] + fooId <- insert foo + Just otherFoo <- get fooId + foo @== otherFoo + + it "PersistMap PersistValue serializaion" $ db $ do + let record = fromList [("b","b"),("u","u"),("g","g")] :: Map Text Text + record @== (fromRight . fromPersistValue . toPersistValue) record + + -- this demonstrates a change in ordering + -- that won't be a problem if the keys are properly tracked + {- + let precord = PersistMap [("b",PersistText "b"),("u",PersistText "u"),("g",PersistText "g")] + precord ==@ (debug . toPersistValue . debug . (fromRight . fromPersistValue :: PersistValue -> Map Text Text)) precord + + let precord = PersistMap [("b",PersistText "b"),("u",PersistText "u"),("g",PersistText "g")] + precord ==@ (fromSuccess . fromJSON . debug . (toJSON :: PersistValue -> Value)) precord + + +fromSuccess :: Result a -> a +fromSuccess (Success s) = s +fromSuccess (Error e) = error $ "expected Success, got Error " ++ e + -} + +fromRight :: Show a => Either a b -> b +fromRight (Left e) = error $ "expected Right, got Left " ++ show e +fromRight (Right x) = x diff --git a/src/EmbedTest.hs b/src/EmbedTest.hs new file mode 100644 --- /dev/null +++ b/src/EmbedTest.hs @@ -0,0 +1,443 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +module EmbedTest (specs, +#ifndef WITH_NOSQL +embedMigrate +#endif +) where + +import Init +import Control.Exception (Exception, throw) +import Data.Typeable (Typeable) + +import qualified Data.Text as T +import qualified Data.Set as S +import qualified Data.Map as M +#if WITH_NOSQL +#ifdef WITH_MONGODB +import Database.Persist.MongoDB +import Database.MongoDB (genObjectId) +import Database.MongoDB (Value(String)) +#endif +import EntityEmbedTest +import System.Process (readProcess) +#endif +import Data.List.NonEmpty hiding (insert, length) + +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 = case fromPersistValue pv of + Left e -> Left e + Right [] -> Left "PersistField: NonEmpty found unexpected Empty List" + Right (l:ls) -> Right (l:|ls) + + +#if WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +# ifdef WITH_MONGODB + 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 +# endif + +#else +share [mkPersist sqlSettings, mkMigrate "embedMigrate"] [persistUpperCase| +#endif + + 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 +|] +#ifdef WITH_NOSQL +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 +#endif + +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 + +#ifdef WITH_NOSQL +#ifdef WITH_MONGODB + 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\" } }" + -- liftIO $ putStrLn =<< readProcess "mongo" ["--eval", "printjson(db." ++ cname ++ ".find().toArray())", T.unpack dbName] "" + + lists <- selectList [] [] + fmap entityVal lists @== [ListEmbed [InList 1 2, InList 1 2] 1 2] +#endif +#endif diff --git a/src/EmptyEntityTest.hs b/src/EmptyEntityTest.hs new file mode 100644 --- /dev/null +++ b/src/EmptyEntityTest.hs @@ -0,0 +1,36 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +module EmptyEntityTest (specs) where + +import Database.Persist.Sql +import Database.Persist.TH +import Control.Monad.Trans.Resource (runResourceT) + +import Init + +#ifdef WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +-- Test lower case names +share [mkPersist sqlSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase| +#endif +EmptyEntity +|] + +#ifdef WITH_NOSQL +cleanDB :: MonadIO m => ReaderT Context m () +cleanDB = deleteWhere ([] :: [Filter EmptyEntity]) +#endif + +specs :: Spec +specs = describe "empty entity" $ + it "inserts" $ (id :: IO () -> IO ()) $ runResourceT $ runConn $ do +#ifndef WITH_NOSQL + _ <- runMigrationSilent dataTypeMigrate + -- Ensure reading the data from the database works... + _ <- runMigrationSilent dataTypeMigrate +#endif + x <- insert EmptyEntity + Just EmptyEntity <- get x + return () diff --git a/src/EntityEmbedTest.hs b/src/EntityEmbedTest.hs new file mode 100644 --- /dev/null +++ b/src/EntityEmbedTest.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} +module EntityEmbedTest where + +-- because we are using a type alias we need to declare in a separate module +-- this is used in EmbedTest +#if WITH_NOSQL +import Init + +mkPersist persistSettings [persistUpperCase| + ARecord + name Text + deriving Show Eq Read Ord +|] + +type AnEntity = Entity ARecord +#endif diff --git a/src/EquivalentTypeTest.hs b/src/EquivalentTypeTest.hs new file mode 100644 --- /dev/null +++ b/src/EquivalentTypeTest.hs @@ -0,0 +1,61 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module EquivalentTypeTest (specs) where + +import Database.Persist.TH +import Control.Monad.Trans.Resource (runResourceT) +#ifdef WITH_POSTGRESQL +import qualified Data.Text as T +#endif + +import Init + +#ifdef WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase| +#endif +EquivalentType sql=equivalent_types + field1 Int +#ifdef WITH_POSTGRESQL + field2 T.Text sqltype=text + field3 T.Text sqltype=us_postal_code +#endif + deriving Eq Show +|] + +#ifdef WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "migrateAll2"] [persistLowerCase| +#endif +EquivalentType2 sql=equivalent_types + field1 Int +#ifdef WITH_POSTGRESQL + field2 T.Text + field3 T.Text sqltype=us_postal_code +#endif + deriving Eq Show +|] + +specs :: Spec +specs = describe "doesn't migrate equivalent types" $ do + it "works" $ asIO $ runResourceT $ runConn $ do + +#ifdef WITH_POSTGRESQL + _ <- rawExecute "DROP DOMAIN IF EXISTS us_postal_code" [] + _ <- rawExecute "CREATE DOMAIN us_postal_code AS TEXT CHECK(VALUE ~ '^\\d{5}$')" [] +#endif + +#ifndef WITH_NOSQL + _ <- runMigrationSilent migrateAll1 + xs <- getMigration migrateAll2 + liftIO $ xs @?= [] +#else + return () +#endif + + +asIO :: IO a -> IO a +asIO = id diff --git a/src/HtmlTest.hs b/src/HtmlTest.hs new file mode 100644 --- /dev/null +++ b/src/HtmlTest.hs @@ -0,0 +1,58 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +module HtmlTest (specs) where + +import Database.Persist.TH +import Data.Char (generalCategory, GeneralCategory(..)) +import qualified Data.Text as T +import System.Random (randomIO, randomRIO, Random) +import Control.Monad.Trans.Resource (runResourceT) + +import Init +import Text.Blaze.Html +import Text.Blaze.Html.Renderer.Text + +-- Test lower case names +share [mkPersist persistSettings, mkMigrate "htmlMigrate"] [persistLowerCase| +HtmlTable + html Html + deriving +|] + +cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend HtmlTable ~ backend) => ReaderT backend m () +cleanDB = do + deleteWhere ([] :: [Filter HtmlTable]) + +specs :: Spec +specs = describe "html" $ do + it "works" $ asIO $ runResourceT $ runConn $ do +#ifndef WITH_NOSQL + _ <- runMigrationSilent htmlMigrate + -- Ensure reading the data from the database works... + _ <- runMigrationSilent htmlMigrate +#endif + + sequence_ $ replicate 1000 $ do + x <- liftIO randomValue + key <- insert $ HtmlTable x + Just (HtmlTable y) <- get key + liftIO $ do + renderHtml x @?= renderHtml y + +randomValue :: IO Html +randomValue = + preEscapedToMarkup + . T.pack + . filter ((`notElem` forbidden) . generalCategory) + . filter (<= '\xFFFF') -- only BMP + . filter (/= '\0') -- no nulls + <$> randomIOs + where forbidden = [NotAssigned, PrivateUse] + +asIO :: IO a -> IO a +asIO = id + +randomIOs :: Random a => IO [a] +randomIOs = do + len <- randomRIO (0, 20) + sequence $ replicate len randomIO diff --git a/src/Init.hs b/src/Init.hs new file mode 100644 --- /dev/null +++ b/src/Init.hs @@ -0,0 +1,343 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +module Init ( + (@/=), (@==), (==@) + , assertNotEqual + , assertNotEmpty + , assertEmpty + , isTravis + , BackendMonad + , runConn + + , MonadIO + , persistSettings + , MkPersistSettings (..) +#ifdef WITH_NOSQL + , dbName + , db' + , setup + , mkPersistSettings + , Action + , Context +#else + , db + , sqlite_database + , sqlite_database_file +#endif + , BackendKey(..) + , generateKey + + -- re-exports + , (A.<$>), (A.<*>) + , module Database.Persist + , module Test.Hspec + , module Test.HUnit + , liftIO + , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase + , Int32, Int64 + , Text + , module Control.Monad.Trans.Reader + , module Control.Monad +#ifndef WITH_NOSQL + , module Database.Persist.Sql +#else + , PersistFieldSql(..) +#endif + , BS.ByteString + , SomeException +) where + +-- re-exports +import Control.Applicative as A ((<$>), (<*>)) +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 Test.Hspec + +-- testing +import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) +import Test.QuickCheck + +import qualified Data.ByteString as BS +import Data.Text (Text, unpack) +import Database.Persist +import Database.Persist.TH () +import System.Environment (getEnvironment) + +#ifdef WITH_NOSQL +import Database.Persist.Sql (PersistFieldSql(..)) +import Database.Persist.TH (mkPersistSettings) +import Language.Haskell.TH.Syntax (Type(..)) + +# ifdef WITH_MONGODB +import qualified Database.MongoDB as MongoDB +import Database.Persist.MongoDB (Action, withMongoPool, runMongoDBPool, defaultMongoConf, applyDockerEnv, BackendKey(..)) +# endif + +# ifdef WITH_ZOOKEEPER +import Data.IORef (newIORef, IORef, writeIORef, readIORef) +import qualified Data.Text as T +import Database.Persist.Zookeeper (Action, withZookeeperPool, runZookeeperPool, ZookeeperConf(..), defaultZookeeperConf, BackendKey(..), deleteRecursive) +import qualified Database.Zookeeper as Z +import System.IO.Unsafe (unsafePerformIO) +# endif + +#else +import Control.Monad.Logger +import Control.Monad.Trans.Resource (ResourceT, runResourceT) +import Database.Persist.Sql +import System.Log.FastLogger (fromLogStr) + +# ifdef WITH_POSTGRESQL +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Database.Persist.Postgresql +# endif +# ifdef WITH_SQLITE +import Database.Persist.Sqlite +# endif +# ifdef WITH_MYSQL +import Database.Persist.MySQL +import qualified Database.MySQL.Base as MySQL +# endif +import Data.IORef (newIORef, IORef, writeIORef, readIORef) +import System.IO.Unsafe (unsafePerformIO) +#endif + +import Control.Monad (unless, (>=>)) +import Control.Monad.IO.Unlift (MonadUnliftIO) + +-- Data types +import Data.Int (Int32, Int64) + +import Control.Monad.IO.Class + + +#ifdef WITH_MONGODB +setup :: Action IO () +setup = setupMongo +type Context = MongoDB.MongoContext +#endif + +#ifdef WITH_ZOOKEEPER +setup :: Action IO () +setup = setupZookeeper +type Context = Z.Zookeeper +#endif + + + + +(@/=), (@==), (==@) :: (Eq a, Show a, MonadIO m) => a -> a -> m () +infix 1 @/= --, /=@ +actual @/= expected = liftIO $ assertNotEqual "" expected actual + +infix 1 @==, ==@ +actual @== expected = liftIO $ actual @?= expected +expected ==@ actual = liftIO $ expected @=? actual + +{- +expected /=@ actual = liftIO $ assertNotEqual "" expected actual +-} + + +assertNotEqual :: (Eq a, Show a) => String -> a -> a -> Assertion +assertNotEqual preface expected actual = + unless (actual /= expected) (assertFailure msg) + where msg = (if null preface then "" else preface ++ "\n") ++ + "expected: " ++ show expected ++ "\n to not equal: " ++ show actual + +assertEmpty :: (Monad m, MonadIO m) => [a] -> m () +assertEmpty xs = liftIO $ assertBool "" (null xs) + +assertNotEmpty :: (Monad m, MonadIO m) => [a] -> m () +assertNotEmpty xs = liftIO $ assertBool "" (not (null xs)) + +isTravis :: IO Bool +isTravis = do + env <- liftIO getEnvironment + return $ case lookup "TRAVIS" env of + Just "true" -> True + _ -> False + +_debugOn :: Bool +#ifdef DEBUG +_debugOn = True +#else +_debugOn = False +#endif + +#ifdef WITH_POSTGRESQL +dockerPg :: IO (Maybe BS.ByteString) +dockerPg = do + env <- liftIO getEnvironment + return $ case lookup "POSTGRES_NAME" env of + Just _name -> Just "postgres" -- /persistent/postgres + _ -> Nothing +#endif + +#ifdef WITH_NOSQL +persistSettings :: MkPersistSettings +persistSettings = (mkPersistSettings $ ConT ''Context) { mpsGeneric = True } + +dbName :: Text +dbName = "persistent" + +type BackendMonad = Context + +#ifdef WITH_MONGODB +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 +#endif + +#ifdef WITH_ZOOKEEPER +runConn :: MonadUnliftIO m => Action m backend -> m () +runConn f = do + let conf = defaultZookeeperConf {zCoord = "localhost:2181/" ++ T.unpack dbName} + void $ withZookeeperPool conf $ runZookeeperPool f + +setupZookeeper :: Action IO () +setupZookeeper = do + liftIO $ Z.setDebugLevel Z.ZLogError + deleteRecursive "/" +#endif + +db' :: Action IO () -> Action IO () -> Assertion +db' actions cleanDB = do + r <- runConn (actions >> cleanDB) + return r + +instance Arbitrary PersistValue where + arbitrary = PersistObjectId `fmap` BS.pack `fmap` replicateM 12 arbitrary +#else +persistSettings :: MkPersistSettings +persistSettings = sqlSettings { mpsGeneric = True } +type BackendMonad = SqlBackend +# ifdef WITH_SQLITE +sqlite_database_file :: Text +sqlite_database_file = "testdb.sqlite3" +sqlite_database :: SqliteConnectionInfo +sqlite_database = mkSqliteConnectionInfo sqlite_database_file +# else +sqlite_database_file :: Text +sqlite_database_file = error "Sqlite tests disabled" +sqlite_database :: () +sqlite_database = error "Sqlite tests disabled" +# endif +runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m () +runConn f = do + travis <- liftIO isTravis + let debugPrint = not travis && _debugOn + let printDebug = if debugPrint then print . fromLogStr else void . return + flip runLoggingT (\_ _ _ s -> printDebug s) $ do +# ifdef WITH_POSTGRESQL + _ <- if travis + then withPostgresqlPool "host=localhost port=5432 user=postgres dbname=persistent" 1 $ runSqlPool f + else do + host <- fromMaybe "localhost" A.<$> liftIO dockerPg + withPostgresqlPool ("host=" <> host <> " port=5432 user=postgres dbname=test") 1 $ runSqlPool f +# else +# ifdef WITH_MYSQL + -- Since version 5.7.5, MySQL adds a mode value `STRICT_TRANS_TABLES` + -- which can cause an exception in MaxLenTest, depending on the server + -- configuration. Persistent tests do not need any of the modes which are + -- set by default, so it is simplest to clear `sql_mode` for the session. + let baseConnectInfo = + defaultConnectInfo { + connectOptions = + connectOptions defaultConnectInfo + ++ [MySQL.InitCommand "SET SESSION sql_mode = '';\0"] + } + _ <- if not travis + then withMySQLPool baseConnectInfo + { connectHost = "localhost" + , connectUser = "test" + , connectPassword = "test" + , connectDatabase = "test" + } 1 $ runSqlPool f + else withMySQLPool baseConnectInfo + { connectHost = "localhost" + , connectUser = "travis" + , connectPassword = "" + , connectDatabase = "persistent" + } 1 $ runSqlPool f +# else + _<-withSqlitePoolInfo sqlite_database 1 $ runSqlPool f +# endif +# endif + return () + +db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion +db actions = do + runResourceT $ runConn $ actions >> transactionUndo + +#if !MIN_VERSION_random(1,0,1) +instance Random Int32 where + random g = + let ((i::Int), g') = random g in + (fromInteger $ toInteger i, g') + randomR (lo, hi) g = + let ((i::Int), g') = randomR (fromInteger $ toInteger lo, fromInteger $ toInteger hi) g in + (fromInteger $ toInteger i, g') + +instance Random Int64 where + random g = + let ((i0::Int32), g0) = random g + ((i1::Int32), g1) = random g0 in + (fromInteger (toInteger i0) + fromInteger (toInteger i1) * 2 ^ (32::Int), g1) + randomR (lo, hi) g = -- TODO : generate on the whole range, and not only on a part of it + let ((i::Int), g') = randomR (fromInteger $ toInteger lo, fromInteger $ toInteger hi) g in + (fromInteger $ toInteger i, g') +#endif + +instance Arbitrary PersistValue where + arbitrary = PersistInt64 `fmap` choose (0, maxBound) + +#endif + +instance PersistStore backend => Arbitrary (BackendKey backend) where + arbitrary = (errorLeft . fromPersistValue) `fmap` arbitrary + where + errorLeft x = case x of + Left e -> error $ unpack e + Right r -> r + +#ifdef WITH_NOSQL +#ifdef WITH_MONGODB +generateKey :: IO (BackendKey Context) +generateKey = MongoKey `liftM` MongoDB.genObjectId +#endif + +#ifdef WITH_ZOOKEEPER +keyCounter :: IORef Int64 +keyCounter = unsafePerformIO $ newIORef 1 +{-# NOINLINE keyCounter #-} + +generateKey :: IO (BackendKey Context) +generateKey = do + i <- readIORef keyCounter + writeIORef keyCounter (i + 1) + return $ ZooKey $ T.pack $ show i +#endif + +#else +keyCounter :: IORef Int64 +keyCounter = unsafePerformIO $ newIORef 1 +{-# NOINLINE keyCounter #-} + +generateKey :: IO (BackendKey SqlBackend) +generateKey = do + i <- readIORef keyCounter + writeIORef keyCounter (i + 1) + return $ SqlBackendKey $ i +#endif diff --git a/src/InsertDuplicateUpdate.hs b/src/InsertDuplicateUpdate.hs new file mode 100644 --- /dev/null +++ b/src/InsertDuplicateUpdate.hs @@ -0,0 +1,103 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module InsertDuplicateUpdate where + +import Init +#ifdef WITH_MYSQL +import Database.Persist.MySQL +import Data.List (sort) + +share [mkPersist sqlSettings, mkMigrate "duplicateMigrate"] [persistUpperCase| + Item + name Text sqltype=varchar(80) + description Text + price Double Maybe + quantity Int Maybe + + Primary name + deriving Eq Show Ord + +|] + +specs :: Spec +specs = describe "DuplicateKeyUpdate" $ do + let item1 = Item "item1" "" (Just 3) Nothing + item2 = Item "item2" "hello world" Nothing (Just 2) + items = [item1, item2] + describe "insertOnDuplicateKeyUpdate" $ do + it "inserts appropriately" $ db $ do + deleteWhere ([] :: [Filter Item]) + insertOnDuplicateKeyUpdate item1 [ItemDescription =. "i am item 1"] + Just item <- get (ItemKey "item1") + item @== item1 + + it "performs only updates given if record already exists" $ db $ do + deleteWhere ([] :: [Filter Item]) + let newDescription = "I am a new description" + _ <- insert item1 + insertOnDuplicateKeyUpdate + (Item "item1" "i am inserted description" (Just 1) (Just 2)) + [ItemDescription =. newDescription] + Just item <- get (ItemKey "item1") + item @== item1 { itemDescription = newDescription } + + describe "insertManyOnDuplicateKeyUpdate" $ do + it "inserts fresh records" $ db $ do + deleteWhere ([] :: [Filter Item]) + insertMany_ items + let newItem = Item "item3" "fresh" Nothing Nothing + insertManyOnDuplicateKeyUpdate + (newItem : items) + [copyField ItemDescription] + [] + dbItems <- map entityVal <$> selectList [] [] + sort dbItems @== sort (newItem : items) + it "updates existing records" $ db $ do + deleteWhere ([] :: [Filter Item]) + insertMany_ items + insertManyOnDuplicateKeyUpdate + items + [] + [ItemQuantity +=. Just 1] + it "only copies passing values" $ db $ do + deleteWhere ([] :: [Filter Item]) + insertMany_ items + let newItems = map (\i -> i { itemQuantity = Just 0, itemPrice = fmap (*2) (itemPrice i) }) items + postUpdate = map (\i -> i { itemPrice = fmap (*2) (itemPrice i) }) items + insertManyOnDuplicateKeyUpdate + newItems + [ copyUnlessEq ItemQuantity (Just 0) + , copyField ItemPrice + ] + [] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort postUpdate + it "inserts without modifying existing records if no updates specified" $ db $ do + let newItem = Item "item3" "hi friends!" Nothing Nothing + deleteWhere ([] :: [Filter Item]) + insertMany_ items + insertManyOnDuplicateKeyUpdate + (newItem : items) + [] + [] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : items) + +#else +specs :: Spec +specs = describe "DuplicateKeyUpdate" $ do + it "Is only supported on MySQL currently." $ do + True `shouldBe` True +#endif diff --git a/src/LargeNumberTest.hs b/src/LargeNumberTest.hs new file mode 100644 --- /dev/null +++ b/src/LargeNumberTest.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +module LargeNumberTest where + +import Init +import Data.Word + +#ifdef WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "numberMigrate"] [persistLowerCase| +#endif + Number + intx Int + int32 Int32 + word32 Word32 + int64 Int64 + word64 Word64 + deriving Show Eq +|] + +#ifdef WITH_NOSQL +cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Number ~ backend) => ReaderT backend m () +cleanDB = do + deleteWhere ([] :: [Filter Number]) +db :: Action IO () -> Assertion +db = db' cleanDB +#endif + +specs :: Spec +specs = describe "persistent" $ do + it "large numbers" $ db $ do + let go x = do + xid <- insert x + x' <- get xid + liftIO $ x' @?= Just x + + go $ Number maxBound 0 0 0 0 + go $ Number 0 maxBound 0 0 0 + go $ Number 0 0 maxBound 0 0 + go $ Number 0 0 0 maxBound 0 + go $ Number 0 0 0 0 maxBound + + go $ Number minBound 0 0 0 0 + go $ Number 0 minBound 0 0 0 + go $ Number 0 0 minBound 0 0 + go $ Number 0 0 0 minBound 0 + go $ Number 0 0 0 0 minBound diff --git a/src/MaxLenTest.hs b/src/MaxLenTest.hs new file mode 100644 --- /dev/null +++ b/src/MaxLenTest.hs @@ -0,0 +1,55 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, FlexibleInstances, EmptyDataDecls, MultiParamTypeClasses #-} + +module MaxLenTest ( + specs +#ifndef WITH_NOSQL + , maxlenMigrate +#endif +) where + +import Init +import Data.String (IsString) + +#ifdef WITH_NOSQL +db :: Action IO () -> Assertion +db = db' (return ()) +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "maxlenMigrate"] [persistLowerCase| +#endif + MaxLen + text1 Text + text2 Text maxlen=3 + bs1 ByteString + bs2 ByteString maxlen=3 + str1 String + str2 String maxlen=3 + MLText1 text1 + MLText2 text2 + MLBs1 bs1 + MLBs2 bs2 + MLStr1 str1 + MLStr2 str2 + deriving Show Eq +|] + +specs :: Spec +specs = describe "Maximum length attribute" $ do + it "" $ db $ do + let t1 = MaxLen a a a a a a + t2 = MaxLen b b b b b b + t2' = MaxLen b b' b b' b b' + a, b, b' :: IsString t => t + a = "a" + b = "12345" + b' = "123" + t1k <- insert t1 + t2k <- insert t2 + Just t1v <- get t1k + Just t2v <- get t2k + liftIO $ do t1v @?= t1 + if t2v == t2 + then t2v @?= t2 -- FIXME: why u no truncate? + else t2v @?= t2' + diff --git a/src/MigrationColumnLengthTest.hs b/src/MigrationColumnLengthTest.hs new file mode 100644 --- /dev/null +++ b/src/MigrationColumnLengthTest.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module MigrationColumnLengthTest where + +import Database.Persist.TH +import qualified Data.Text as T + +import Init + +#ifdef WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase| +#endif +VaryingLengths + field1 Int + field2 T.Text sqltype=varchar(5) +|] + + +specs :: Spec +specs = describe "Migration" $ do +#ifdef WITH_NOSQL + return () +#else + it "is idempotent" $ db $ do + again <- getMigration migration + liftIO $ again @?= [] +#endif + diff --git a/src/MigrationIdempotencyTest.hs b/src/MigrationIdempotencyTest.hs new file mode 100644 --- /dev/null +++ b/src/MigrationIdempotencyTest.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module MigrationIdempotencyTest where + +import Database.Persist.TH +import qualified Data.Text as T + +import Init + +#ifdef WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase| +#endif +Idempotency + field1 Int + field2 T.Text sqltype=varchar(5) + field3 T.Text sqltype=mediumtext + field4 T.Text sqltype=longtext + field5 T.Text sqltype=mediumblob + field6 T.Text sqltype=longblob + field7 Double sqltype=double(6,5) +|] + + +specs :: Spec +specs = describe "MySQL migration with backend-specific sqltypes" $ do +#ifdef WITH_NOSQL + return () +#else + it "is idempotent" $ db $ do + again <- getMigration migration + liftIO $ again @?= [] +#endif diff --git a/src/MigrationOnlyTest.hs b/src/MigrationOnlyTest.hs new file mode 100644 --- /dev/null +++ b/src/MigrationOnlyTest.hs @@ -0,0 +1,54 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module MigrationOnlyTest (specs) where + +import Database.Persist.TH +import Control.Monad.Trans.Resource (runResourceT) +import qualified Data.Text as T + +import Init + +#ifdef WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase| +#endif +TwoField1 sql=two_field + field1 Int + field2 T.Text + field3 Bool Maybe + deriving Eq Show +|] + +#ifdef WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "migrateAll2", mkDeleteCascade sqlSettings] [persistLowerCase| +#endif +TwoField + field1 Int + field2 T.Text + field3 Bool Maybe MigrationOnly + deriving Eq Show + +Referencing + field1 Int + field2 TwoFieldId MigrationOnly +|] + +specs :: Spec +specs = describe "migration only" $ do + it "works" $ asIO $ runResourceT $ runConn $ do +#ifndef WITH_NOSQL + _ <- runMigrationSilent migrateAll1 + _ <- runMigrationSilent migrateAll2 +#endif + let tf = TwoField 5 "hello" + tid <- insert tf + mtf <- get tid + liftIO $ mtf @?= Just tf + deleteWhere ([] :: [Filter TwoField]) + +asIO :: IO a -> IO a +asIO = id diff --git a/src/MigrationTest.hs b/src/MigrationTest.hs new file mode 100644 --- /dev/null +++ b/src/MigrationTest.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module MigrationTest where + +import Database.Persist.TH +import qualified Data.Text as T + +import Init + +#ifdef WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "migrationMigrate", mkDeleteCascade sqlSettings] [persistLowerCase| +#endif +Target + field1 Int + field2 T.Text + UniqueTarget field1 field2 + deriving Eq Show + +Source + field3 Int + field4 TargetId +|] + +#ifdef WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "migrationAddCol", mkDeleteCascade sqlSettings] [persistLowerCase| +#endif +Target1 sql=target + field1 Int + field2 T.Text + UniqueTarget1 field1 field2 + deriving Eq Show + +Source1 sql=source + field3 Int + extra Int + field4 Target1Id +|] + +#ifndef WITH_NOSQL +specs :: Spec +specs = describe "Migration" $ do + it "is idempotent" $ db $ do + again <- getMigration migrationMigrate + liftIO $ again @?= [] + it "really is idempotent" $ db $ do + runMigration migrationMigrate + again <- getMigration migrationMigrate + liftIO $ again @?= [] + it "can add an extra column" $ db $ do + -- Failing test case for #735. Foreign-key checking, switched on in + -- version 2.6.1, caused persistent-sqlite to generate a `references` + -- constraint in a *temporary* table during migration, which fails. + _ <- runMigration migrationAddCol + again <- getMigration migrationAddCol + liftIO $ again @?= [] +#endif diff --git a/src/PersistTestPetCollarType.hs b/src/PersistTestPetCollarType.hs new file mode 100644 --- /dev/null +++ b/src/PersistTestPetCollarType.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +module PersistTestPetCollarType where + +import GHC.Generics +import Data.Aeson +import Database.Persist.TH +import Data.Text (Text) + +data PetCollar = PetCollar {tag :: Text, bell :: Bool} + deriving (Generic, Eq, Show) +instance ToJSON PetCollar +instance FromJSON PetCollar + +derivePersistFieldJSON "PetCollar" diff --git a/src/PersistTestPetType.hs b/src/PersistTestPetType.hs new file mode 100644 --- /dev/null +++ b/src/PersistTestPetType.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module PersistTestPetType where + +import Database.Persist.TH + +data PetType = Cat | Dog + deriving (Show, Read, Eq) +derivePersistField "PetType" diff --git a/src/PersistUniqueTest.hs b/src/PersistUniqueTest.hs new file mode 100644 --- /dev/null +++ b/src/PersistUniqueTest.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +module PersistUniqueTest where + +import Init + +-- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs +#if WITH_NOSQL +mkPersist persistSettings { mpsGeneric = False } [persistUpperCase| +#else +share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase| +#endif + Fo + foo Int + bar Int + Primary foo + UniqueBar bar + deriving Eq Show +|] +#ifdef WITH_NOSQL +cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Fo ~ backend) => ReaderT backend m () +cleanDB = do + deleteWhere ([] :: [Filter Fo]) + +db :: Action IO () -> Assertion +db = db' cleanDB +#endif + +specs :: Spec +specs = describe "custom primary key" $ do +#ifdef WITH_NOSQL + return () +#else + it "getBy" $ db $ do + let b = 5 + k <- insert $ Fo 3 b + Just vk <- get k + Just vu <- getBy (UniqueBar b) + vu @== Entity k vk + it "insertUniqueEntity" $ db $ do + let fo = Fo 3 5 + Just (Entity _ insertedFoValue) <- insertUniqueEntity fo + Nothing <- insertUniqueEntity fo + fo @== insertedFoValue +#endif diff --git a/src/PersistentTest.hs b/src/PersistentTest.hs new file mode 100644 --- /dev/null +++ b/src/PersistentTest.hs @@ -0,0 +1,1208 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} -- FIXME +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +module PersistentTest where + +import Test.HUnit hiding (Test) +import Control.Monad.Trans.Resource (runResourceT) +import Test.Hspec.Expectations () +import Test.Hspec.QuickCheck(prop) +import UnliftIO (MonadUnliftIO, catch) + +import Database.Persist + +#ifdef WITH_NOSQL +#ifdef WITH_MONGODB +import qualified Database.MongoDB as MongoDB +import Database.Persist.MongoDB (toInsertDoc, docToEntityThrow, collectionName, recordToDocument) +#endif + +#else + +import Database.Persist.TH (mkDeleteCascade, mkSave) +import qualified Data.Text as T + +# ifdef WITH_POSTGRESQL +import Data.List (sort) +# endif +# if WITH_MYSQL +import Database.Persist.MySQL() +# endif + +#endif + +import Control.Monad.IO.Class + +import Web.PathPieces (PathPiece (..)) +import Data.Maybe (fromJust) +import qualified Data.HashMap.Lazy as M +import Init +import Data.Aeson + +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Function (on) +import Data.Functor.Identity +import Data.Functor.Constant +import PersistTestPetType +import PersistTestPetCollarType + +#ifdef WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist persistSettings, mkMigrate "testMigrate", mkDeleteCascade persistSettings, mkSave "_ignoredSave"] [persistUpperCase| +#endif + +-- Dedented comment + -- Header-level comment + -- Indented comment + Person json + name Text + age Int "some ignored -- \" attribute" + color Text Maybe -- this is a comment sql=foobarbaz + PersonNameKey name -- this is a comment sql=foobarbaz + deriving Show Eq + Person1 +-- Dedented comment + -- Header-level comment + -- Indented comment + name Text + age Int + PersonMaybeAge + name Text + age Int Maybe + PersonMay json + name Text Maybe + color Text Maybe + deriving Show Eq + Pet + ownerId PersonId + name Text + -- deriving Show Eq +-- Dedented comment + -- Header-level comment + -- Indented comment + type PetType + MaybeOwnedPet + ownerId PersonId Maybe + name Text + type PetType +-- Dedented comment + -- Header-level comment + -- Indented comment + NeedsPet + petKey PetId + OutdoorPet + ownerId PersonId + collar PetCollar + type PetType + + -- From the scaffold + UserPT + ident Text + password Text Maybe + UniqueUserPT ident + EmailPT + email Text + user UserPTId Maybe + verkey Text Maybe + UniqueEmailPT email + + Upsert + email Text + attr Text + extra Text + age Int + UniqueUpsert email + deriving Eq Show + + UpsertBy + email Text + city Text + attr Text + UniqueUpsertBy email + UniqueUpsertByCity city + deriving Eq Show + + Strict + !yes Int + ~no Int + def Int +|] + +deriving instance Show (BackendKey backend) => Show (PetGeneric backend) +deriving instance Eq (BackendKey backend) => Eq (PetGeneric backend) + +share [mkPersist persistSettings { mpsPrefixFields = False, mpsGeneric = False } +#ifdef WITH_NOSQL + ] [persistUpperCase| +#else + , mkMigrate "noPrefixMigrate" + ] [persistLowerCase| +#endif +NoPrefix1 + someFieldName Int + deriving Show Eq +NoPrefix2 + someOtherFieldName Int + unprefixedRef NoPrefix1Id + deriving Show Eq ++NoPrefixSum + unprefixedLeft Int + unprefixedRight String + deriving Show Eq +|] + +cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend EmailPT ~ backend) => ReaderT backend m () +cleanDB = do + deleteWhere ([] :: [Filter Person]) + deleteWhere ([] :: [Filter Person1]) + deleteWhere ([] :: [Filter Pet]) + deleteWhere ([] :: [Filter MaybeOwnedPet]) + deleteWhere ([] :: [Filter NeedsPet]) + deleteWhere ([] :: [Filter OutdoorPet]) + deleteWhere ([] :: [Filter UserPT]) + deleteWhere ([] :: [Filter EmailPT]) + +#ifdef WITH_NOSQL +db :: Action IO () -> Assertion +db = db' cleanDB +#endif + +catchPersistException :: MonadUnliftIO m => m a -> b -> m b +catchPersistException action errValue = do + Left res <- + (Right `fmap` action) `catch` + (\(_::PersistException) -> return $ Left errValue) + return res + + +specs :: Spec +specs = describe "persistent" $ do + it "fieldLens" $ do + let michael = Entity undefined $ Person "Michael" 28 Nothing :: Entity Person + michaelP1 = Person "Michael" 29 Nothing :: Person + view michael (fieldLens PersonAge) @?= 28 + entityVal (set (fieldLens PersonAge) 29 michael) @?= michaelP1 + + it "FilterOr []" $ db $ do + let p = Person "z" 1 Nothing + _ <- insert p +#ifdef WITH_MONGODB + ps <- catchPersistException (selectList [FilterOr []] [Desc PersonAge]) [] +#else + ps <- (selectList [FilterOr []] [Desc PersonAge]) +#endif + assertEmpty ps + + it "||. []" $ db $ do + let p = Person "z" 1 Nothing + _ <- insert p +#ifdef WITH_MONGODB + c <- catchPersistException (count $ [PersonName ==. "a"] ||. []) 1 +#else + c <- (count $ [PersonName ==. "a"] ||. []) +#endif + c @== (1::Int) + + it "FilterAnd []" $ db $ do + let p = Person "z" 1 Nothing + _ <- insert p + ps <- selectList [FilterAnd []] [Desc PersonAge] + assertNotEmpty ps + + it "order of opts is irrelevant" $ db $ do + let eq (a, b, _) (c, d) = (a, b) @== (c, d) + limitOffsetOrder' :: [SelectOpt Person] -> (Int, Int, [SelectOpt Person]) + limitOffsetOrder' = limitOffsetOrder + limitOffsetOrder' [Desc PersonAge] `eq` (0, 0) + limitOffsetOrder' [LimitTo 2, Desc PersonAge] `eq` (2, 0) + limitOffsetOrder' [Desc PersonAge, LimitTo 2] `eq` (2, 0) + limitOffsetOrder' [LimitTo 2, Desc PersonAge, OffsetBy 3] `eq` (2, 3) + + insertMany_ [ Person "z" 1 Nothing + , Person "y" 2 Nothing + , Person "x" 1 Nothing + , Person "w" 2 Nothing + , Person "v" 1 Nothing + , Person "u" 2 Nothing + ] + + a <- fmap (map $ personName . entityVal) $ selectList [] [Desc PersonAge, Asc PersonName, OffsetBy 2, LimitTo 3] + a @== ["y", "v", "x"] + + b <- fmap (map $ personName . entityVal) $ selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName] + b @== a + + c <- fmap (map $ personName . entityVal) $ selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName, LimitTo 1, OffsetBy 1] + c @== a + + + it "passes the general tests" $ db $ do + let mic26 = Person "Michael" 26 Nothing + micK <- insert mic26 + results <- selectList [PersonName ==. "Michael"] [] + results @== [Entity micK mic26] + + results' <- selectList [PersonAge <. 28] [] + results' @== [Entity micK mic26] + + p28 <- updateGet micK [PersonAge =. 28] + personAge p28 @== 28 + +#ifdef WITH_NOSQL + updateWhere [PersonName ==. "Michael"] [PersonAge =. 29] +#else + uc <- updateWhereCount [PersonName ==. "Michael"] [PersonAge =. 29] + uc @== 1 +#endif + Just mic29 <- get micK + personAge mic29 @== 29 + + let eli = Person "Eliezer" 2 $ Just "blue" + _ <- insert eli + pasc <- selectList [] [Asc PersonAge] + map entityVal pasc @== [eli, mic29] + + let abe30 = Person "Abe" 30 $ Just "black" + _ <- insert abe30 + -- pdesc <- selectList [PersonAge <. 30] [Desc PersonName] + map entityVal pasc @== [eli, mic29] + + abes <- selectList [PersonName ==. "Abe"] [] + map entityVal abes @== [abe30] + + Just (Entity _ p3) <- getBy $ PersonNameKey "Michael" + p3 @== mic29 + + ps <- selectList [PersonColor ==. Just "blue"] [] + map entityVal ps @== [eli] + + ps2 <- selectList [PersonColor ==. Nothing] [] + map entityVal ps2 @== [mic29] + + delete micK + Nothing <- get micK + return () +#ifdef WITH_ZOOKEEPER + -- zookeeper backend does not support idfield + -- zookeeper's key is node-name. + -- When uniq-key exists, zookeeper's key becomes encoded uniq-key. +#else + it "persistIdField" $ db $ do + let p = Person "foo" 100 (Just "blue") + q = Person "bar" 101 Nothing + pk <- insert p + qk <- insert q + + mp <- selectFirst [persistIdField ==. pk] [] + fmap entityVal mp @== Just p + + mq <- selectFirst [persistIdField ==. qk] [] + fmap entityVal mq @== Just q +#endif + + it "!=." $ db $ do + deleteWhere ([] :: [Filter Person]) + let mic = Person "Michael" 25 Nothing + _ <- insert mic + let eli = Person "Eliezer" 25 (Just "Red") + _ <- insert eli + + pne <- selectList [PersonName !=. "Michael"] [] + map entityVal pne @== [eli] + + ps <- selectList [PersonColor !=. Nothing] [] + map entityVal ps @== [eli] + + pnm <- selectList [PersonName !=. "Eliezer"] [] + map entityVal pnm @== [mic] + + it "Double Maybe" $ db $ do + deleteWhere ([] :: [Filter PersonMay]) + let mic = PersonMay (Just "Michael") Nothing + _ <- insert mic + let eli = PersonMay (Just "Eliezer") (Just "Red") + _ <- insert eli + pe <- selectList [PersonMayName ==. Nothing, PersonMayColor ==. Nothing] [] + map entityVal pe @== [] + pne <- selectList [PersonMayName !=. Nothing, PersonMayColor !=. Nothing] [] + map entityVal pne @== [eli] + + it "and/or" $ db $ do + deleteWhere ([] :: [Filter Person1]) + insertMany_ [ Person1 "Michael" 25 + , Person1 "Miriam" 25 + , Person1 "Michael" 30 + , Person1 "Michael" 35 + ] + + c10 <- count $ [Person1Name ==. "Michael"] ||. [Person1Name ==. "Miriam", Person1Age ==. 25] + c10 @== 4 + c12 <- count [FilterOr [FilterAnd [Person1Name ==. "Michael"], FilterAnd [Person1Name ==. "Miriam"]]] + c12 @== 4 + c14 <- count [FilterOr [FilterAnd [Person1Name ==. "Michael"], FilterAnd [Person1Name ==. "Miriam"], + FilterAnd [Person1Age >. 29, Person1Age <=. 30]]] + c14 @== 4 + + c20 <- count $ [Person1Name ==. "Miriam"] ||. [Person1Age >. 29, Person1Age <=. 30] + c20 @== 2 + c22 <- count $ [Person1Age <=. 30] ++ [Person1Age >. 29] + c22 @== 1 + c24 <- count $ [FilterAnd [Person1Age <=. 30, Person1Age >. 29]] + c24 @== 1 + c26 <- count $ [Person1Age <=. 30] ++ [Person1Age >. 29] + c26 @== 1 + + c34 <- count $ [Person1Name ==. "Michael"] ||. [Person1Name ==. "Mirieam"] ++ [Person1Age <.35] + c34 @== 3 + c30 <- count $ ([Person1Name ==. "Michael"] ||. [Person1Name ==. "Miriam"]) ++ [Person1Age <.35] + c30 @== 3 + c36 <- count $ [Person1Name ==. "Michael"] ||. ([Person1Name ==. "Miriam"] ++ [Person1Age <.35]) + c36 @== 4 + + c40 <- count $ ([Person1Name ==. "Michael"] ||. [Person1Name ==. "Miriam"] ||. [Person1Age <.35]) + c40 @== 4 + + + it "deleteWhere" $ db $ do + key2 <- insert $ Person "Michael2" 90 Nothing + _ <- insert $ Person "Michael3" 90 Nothing + let p91 = Person "Michael4" 91 Nothing + key91 <- insert $ p91 + + ps90 <- selectList [PersonAge ==. 90] [] + assertNotEmpty ps90 + deleteWhere [PersonAge ==. 90] + ps90' <- selectList [PersonAge ==. 90] [] + assertEmpty ps90' + Nothing <- get key2 + + Just p2_91 <- get key91 + p91 @== p2_91 + + + it "deleteBy" $ db $ do + _ <- insert $ Person "Michael2" 27 Nothing + let p3 = Person "Michael3" 27 Nothing + key3 <- insert $ p3 + + ps2 <- selectList [PersonName ==. "Michael2"] [] + assertNotEmpty ps2 + + deleteBy $ PersonNameKey "Michael2" + ps2' <- selectList [PersonName ==. "Michael2"] [] + assertEmpty ps2' + + Just p32 <- get key3 + p3 @== p32 + + + it "delete" $ db $ do + key2 <- insert $ Person "Michael2" 27 Nothing + let p3 = Person "Michael3" 27 Nothing + key3 <- insert $ p3 + + pm2 <- selectList [PersonName ==. "Michael2"] [] + assertNotEmpty pm2 + delete key2 + pm2' <- selectList [PersonName ==. "Michael2"] [] + assertEmpty pm2' + + Just p <- get key3 + p3 @== p + +#ifdef WITH_ZOOKEEPER + it "toPathPiece . fromPathPiece" $ do + -- Below quickcheck causes error of "Cannot convert PersistObjectId to Text." + -- Currently, ZooKey does not support PersistObjectId. + let key1 = ZooKey "hogehogekey" :: (BackendKey BackendMonad) + key2 = fromJust $ fromPathPiece $ toPathPiece key1 :: (BackendKey BackendMonad) + toPathPiece key1 `shouldBe` toPathPiece key2 +#else + prop "toPathPiece . fromPathPiece" $ \piece -> + let key1 = piece :: (BackendKey BackendMonad) + key2 = fromJust $ fromPathPiece $ toPathPiece key1 :: (BackendKey BackendMonad) + in toPathPiece key1 == toPathPiece key2 +#endif + + it "replace" $ db $ do + key2 <- insert $ Person "Michael2" 27 Nothing + let p3 = Person "Michael3" 27 Nothing + replace key2 p3 + Just p <- get key2 + p @== p3 + + -- test replace an empty key + delete key2 + Nothing <- get key2 + _ <- replace key2 p3 + Nothing <- get key2 + return () + + let mic = Person "Michael" 25 Nothing + micK <- insert mic + Just p1 <- get micK + p1 @== mic + + replace micK $ Person "Michael" 25 Nothing + Just p2 <- get micK + p2 @== mic + + replace micK $ Person "Michael" 26 Nothing + Just mic26 <- get micK + mic26 @/= mic + personAge mic26 @== personAge mic + 1 + + + + it "getBy" $ db $ do + let p2 = Person "Michael2" 27 Nothing + key2 <- insert p2 + Just (Entity k p) <- getBy $ PersonNameKey "Michael2" + p @== p2 + k @== key2 + Nothing <- getBy $ PersonNameKey "Michael9" + + Just (Entity k' p') <- getByValue p2 + k' @== k + p' @== p + return () + + + it "updateGet" $ db $ do + let p25 = Person "Michael" 25 Nothing + key25 <- insert p25 + pBlue28 <- updateGet key25 [PersonAge =. 28, PersonName =. "Updated"] + pBlue28 @== Person "Updated" 28 Nothing + pBlue30 <- updateGet key25 [PersonAge +=. 2] + pBlue30 @== Person "Updated" 30 Nothing + + describe "upsert" $ do + it "adds a new row with no updates" $ db $ do + Entity _ u <- upsert (Upsert "a" "new" "" 2) [UpsertAttr =. "update"] + c <- count ([] :: [Filter Upsert]) + c @== 1 + upsertAttr u @== "new" + it "keeps the existing row" $ db $ do +#ifdef WITH_MONGODB + initial <- insertEntity (Upsert "foo" "initial" "" 2) + update' <- upsert (Upsert "foo" "update" "" 3) [] + update' @== initial +#else + initial <- insertEntity (Upsert "a" "initial" "" 1) + update' <- upsert (Upsert "a" "update" "" 2) [] + update' @== initial +#endif + it "updates an existing row - assignment" $ db $ do +#ifdef WITH_MONGODB + initial <- insertEntity (Upsert "cow" "initial" "extra" 1) + update' <- + upsert (Upsert "cow" "wow" "such unused" 2) [UpsertAttr =. "update"] + ((==@) `on` entityKey) initial update' + upsertAttr (entityVal update') @== "update" + upsertExtra (entityVal update') @== "extra" +#else + initial <- insertEntity (Upsert "a" "initial" "extra" 1) + update' <- + upsert (Upsert "a" "wow" "such unused" 2) [UpsertAttr =. "update"] + ((==@) `on` entityKey) initial update' + upsertAttr (entityVal update') @== "update" + upsertExtra (entityVal update') @== "extra" +#endif + it "updates existing row - addition " $ db $ do +#ifdef WITH_MONGODB + initial <- insertEntity (Upsert "a1" "initial" "extra" 2) + update' <- + upsert (Upsert "a1" "wow" "such unused" 2) [UpsertAge +=. 3] + ((==@) `on` entityKey) initial update' + upsertAge (entityVal update') @== 5 + upsertExtra (entityVal update') @== "extra" +#else + initial <- insertEntity (Upsert "a" "initial" "extra" 2) + update' <- + upsert (Upsert "a" "wow" "such unused" 2) [UpsertAge +=. 3] + ((==@) `on` entityKey) initial update' + upsertAge (entityVal update') @== 5 + upsertExtra (entityVal update') @== "extra" +#endif + + describe "upsertBy" $ do + let uniqueEmail = UniqueUpsertBy "a" + uniqueCity = UniqueUpsertByCity "Boston" + it "adds a new row with no updates" $ db $ do + Entity _ u <- + upsertBy + uniqueEmail + (UpsertBy "a" "Boston" "new") + [UpsertByAttr =. "update"] + c <- count ([] :: [Filter UpsertBy]) + c @== 1 + upsertByAttr u @== "new" + it "keeps the existing row" $ db $ do +#ifdef WITH_MONGODB + initial <- insertEntity (UpsertBy "foo" "Chennai" "initial") + update' <- upsertBy (UniqueUpsertBy "foo") (UpsertBy "foo" "Chennai" "update") [] + update' @== initial +#else + initial <- insertEntity (UpsertBy "a" "Boston" "initial") + update' <- upsertBy uniqueEmail (UpsertBy "a" "Boston" "update") [] + update' @== initial +#endif + it "updates an existing row" $ db $ do +#ifdef WITH_MONGODB + initial <- insertEntity (UpsertBy "ko" "Kumbakonam" "initial") + update' <- + upsertBy + (UniqueUpsertBy "ko") + (UpsertBy "ko" "Bangalore" "such unused") + [UpsertByAttr =. "update"] + ((==@) `on` entityKey) initial update' + upsertByAttr (entityVal update') @== "update" + upsertByCity (entityVal update') @== "Kumbakonam" +#else + initial <- insertEntity (UpsertBy "a" "Boston" "initial") + update' <- + upsertBy + uniqueEmail + (UpsertBy "a" "wow" "such unused") + [UpsertByAttr =. "update"] + ((==@) `on` entityKey) initial update' + upsertByAttr (entityVal update') @== "update" + upsertByCity (entityVal update') @== "Boston" +#endif + it "updates by the appropriate constraint" $ db $ do + initBoston <- insertEntity (UpsertBy "bos" "Boston" "bos init") + initKrum <- insertEntity (UpsertBy "krum" "Krum" "krum init") + updBoston <- + upsertBy + (UniqueUpsertBy "bos") + (UpsertBy "bos" "Krum" "unused") + [UpsertByAttr =. "bos update"] + updKrum <- + upsertBy + (UniqueUpsertByCity "Krum") + (UpsertBy "bos" "Krum" "unused") + [UpsertByAttr =. "krum update"] + ((==@) `on` entityKey) initBoston updBoston + ((==@) `on` entityKey) initKrum updKrum + entityVal updBoston @== UpsertBy "bos" "Boston" "bos update" + entityVal updKrum @== UpsertBy "krum" "Krum" "krum update" + + it "maybe update" $ db $ do + let noAge = PersonMaybeAge "Michael" Nothing + keyNoAge <- insert noAge + noAge2 <- updateGet keyNoAge [PersonMaybeAgeAge +=. Just 2] + -- the correct answer is very debatable +#ifdef WITH_NOSQL + personMaybeAgeAge noAge2 @== Just 2 +#else + personMaybeAgeAge noAge2 @== Nothing +#endif + + + + it "updateWhere" $ db $ do + let p1 = Person "Michael" 25 Nothing + let p2 = Person "Michael2" 25 Nothing + key1 <- insert p1 + key2 <- insert p2 + updateWhere [PersonName ==. "Michael2"] + [PersonAge +=. 3, PersonName =. "Updated"] + Just pBlue28 <- get key2 + pBlue28 @== Person "Updated" 28 Nothing + Just p <- get key1 + p @== p1 + + + it "selectList" $ db $ do + let p25 = Person "Michael" 25 Nothing + let p26 = Person "Michael2" 26 Nothing + [key25, key26] <- insertMany [p25, p26] + ps1 <- selectList [] [Asc PersonAge] + ps1 @== [(Entity key25 p25), (Entity key26 p26)] + -- limit + ps2 <- selectList [] [Asc PersonAge, LimitTo 1] + ps2 @== [(Entity key25 p25)] + -- offset + ps3 <- selectList [] [Asc PersonAge, OffsetBy 1] + ps3 @== [(Entity key26 p26)] + -- limit & offset + ps4 <- selectList [] [Asc PersonAge, LimitTo 1, OffsetBy 1] + ps4 @== [(Entity key26 p26)] + + ps5 <- selectList [] [Desc PersonAge] + ps5 @== [(Entity key26 p26), (Entity key25 p25)] + ps6 <- selectList [PersonAge ==. 26] [] + ps6 @== [(Entity key26 p26)] + + it "selectSource" $ db $ do + let p1 = Person "selectSource1" 1 Nothing + p2 = Person "selectSource2" 2 Nothing + p3 = Person "selectSource3" 3 Nothing + [k1,k2,k3] <- insertMany [p1, p2, p3] + + ps1 <- runResourceT $ selectSource [] [Desc PersonAge] $$ await + ps1 @== Just (Entity k3 p3) + + ps2 <- runResourceT $ selectSource [PersonAge <. 3] [Asc PersonAge] $$ CL.consume + ps2 @== [Entity k1 p1, Entity k2 p2] + + runResourceT $ selectSource [] [Desc PersonAge] $$ do + e1 <- await + e1 @== Just (Entity k3 p3) + + e2 <- await + e2 @== Just (Entity k2 p2) + + e3 <- await + e3 @== Just (Entity k1 p1) + + e4 <- await + e4 @== Nothing + + it "selectFirst" $ db $ do + _ <- insert $ Person "Michael" 26 Nothing + let pOld = Person "Oldie" 75 Nothing + kOld <- insert pOld + + x <- selectFirst [] [Desc PersonAge] + x @== Just (Entity kOld pOld) + + + it "selectKeys" $ db $ do + let p1 = Person "selectKeys1" 1 Nothing + p2 = Person "selectKeys2" 2 Nothing + p3 = Person "selectKeys3" 3 Nothing + [k1,k2,k3] <- insertMany [p1, p2, p3] + + ps1 <- runResourceT $ selectKeys [] [Desc PersonAge] $$ await + ps1 @== Just k3 + + ps2 <- runResourceT $ selectKeys [PersonAge <. 3] [Asc PersonAge] $$ CL.consume + ps2 @== [k1, k2] + + runResourceT $ selectKeys [] [Desc PersonAge] $$ do + e1 <- await + e1 @== Just k3 + + e2 <- await + e2 @== Just k2 + + e3 <- await + e3 @== Just k1 + + e4 <- await + e4 @== Nothing + + it "insertMany_ with no arguments" $ db $ do + _ <- insertMany_ ([] :: [Person]) + rows <- count ([] :: [Filter Person]) + rows @== 0 + _ <- insertMany ([] :: [Person]) + rows2 <- count ([] :: [Filter Person]) + rows2 @== 0 + _ <- insertEntityMany ([] :: [Entity Person]) + rows3 <- count ([] :: [Filter Person]) + rows3 @== 0 + + it "insertEntityMany" $ db $ do + id1:id2:id3:id4:id5:[] <- liftIO $ replicateM 5 (PersonKey `fmap` generateKey) + let p1 = Entity id1 $ Person "insertEntityMany1" 1 Nothing + p2 = Entity id2 $ Person "insertEntityMany2" 2 Nothing + p3 = Entity id3 $ Person "insertEntityMany3" 3 Nothing + p4 = Entity id4 $ Person "insertEntityMany4" 3 Nothing + p5 = Entity id5 $ Person "insertEntityMany5" 3 Nothing + insertEntityMany [p1,p2,p3,p4,p5] + rows <- count ([] :: [Filter Person]) + rows @== 5 + + it "insertBy" $ db $ do + Right _ <- insertBy $ Person "name" 1 Nothing + Left _ <- insertBy $ Person "name" 1 Nothing + Right _ <- insertBy $ Person "name2" 1 Nothing + return () + + it "insertKey" $ db $ do + k <- liftIO (PersonKey `fmap` generateKey) + insertKey k $ Person "Key" 26 Nothing + Just (Entity k2 _) <- selectFirst [PersonName ==. "Key"] [] + k2 @== k + + it "insertEntity" $ db $ do + Entity k p <- insertEntity $ Person "name" 1 Nothing + Just p2 <- get k + p2 @== p + + it "insertRecord" $ db $ do + let record = Person "name" 1 Nothing + record' <- insertRecord record + record' @== record + + it "getEntity" $ db $ do + Entity k p <- insertEntity $ Person "name" 1 Nothing + Just (Entity k2 p2) <- getEntity k + p @== p2 + k @== k2 + + it "getJustEntity" $ db $ do + let p1 = Person "name" 1 Nothing + k1 <- insert p1 + Entity k2 p2 <- getJustEntity k1 + p1 @== p2 + k1 @== k2 + + it "repsert" $ db $ do + k <- liftIO (PersonKey `fmap` generateKey) + Nothing <- selectFirst [PersonName ==. "Repsert"] [] + repsert k $ Person "Repsert" 26 Nothing + Just (Entity k2 _) <- selectFirst [PersonName ==. "Repsert"] [] + k2 @== k + repsert k $ Person "Repsert" 27 Nothing + Just (Entity k3 p) <- selectFirst [PersonName ==. "Repsert"] [] + k3 @== k + 27 @== personAge p + + it "retrieves a belongsToJust association" $ db $ do + let p = Person "pet owner" 30 Nothing + person <- insert $ p + let cat = Pet person "Mittens" Cat + p2 <- getJust $ petOwnerId cat + p @== p2 + p3 <- belongsToJust petOwnerId $ cat + p @== p3 + + it "retrieves a belongsTo association" $ db $ do + let p = Person "pet owner" 30 Nothing + person <- insert p + let cat = MaybeOwnedPet (Just person) "Mittens" Cat + p2 <- getJust $ fromJust $ maybeOwnedPetOwnerId cat + p @== p2 + Just p4 <- belongsTo maybeOwnedPetOwnerId $ cat + p @== p4 + + it "derivePersistField" $ db $ do + person <- insert $ Person "pet owner" 30 Nothing + catKey <- insert $ Pet person "Mittens" Cat + Just cat' <- get catKey + liftIO $ petType cat' @?= Cat + dog <- insert $ Pet person "Spike" Dog + Just dog' <- get dog + liftIO $ petType dog' @?= Dog + + it "derivePersistFieldJSON" $ db $ do + let mittensCollar = PetCollar "Mittens\n1-714-668-9672" True + pkey <- insert $ Person "pet owner" 30 Nothing + catKey <- insert $ OutdoorPet pkey mittensCollar Cat + Just (OutdoorPet _ collar' _) <- get catKey + liftIO $ collar' @?= mittensCollar + +#ifdef WITH_ZOOKEEPER + -- zookeeper backend does not support idfield + -- zookeeper's key is node-name. + -- When uniq-key exists, zookeeper's key becomes encoded uniq-key. +#else + it "idIn" $ db $ do + let p1 = Person "D" 0 Nothing + p2 = Person "E" 1 Nothing + p3 = Person "F" 2 Nothing + pid1 <- insert p1 + _ <- insert p2 + pid3 <- insert p3 + x <- selectList [PersonId <-. [pid1, pid3]] [] + liftIO $ x @?= [Entity pid1 p1, Entity pid3 p3] +#endif + + it "In" $ db $ do + let p1 = Person "D" 0 Nothing + p2 = Person "E" 1 Nothing + p3 = Person "F" 2 (Just "blue") + insert_ p1 + insert_ p2 + insert_ p3 + x1 <- fmap entityVal `fmap` selectList [PersonName <-. ["D"]] [] + liftIO $ x1 @?= [p1] + x2 <- fmap entityVal `fmap` selectList [PersonName /<-. ["D"]] [] + liftIO $ x2 @?= [p2, p3] + + x3 <- fmap entityVal `fmap` selectList [PersonColor <-. [Just "blue"]] [] + liftIO $ x3 @?= [p3] + x4 <- fmap entityVal `fmap` selectList [PersonColor /<-. [Just "blue"]] [] + liftIO $ x4 @?= [p1, p2] + + x5 <- fmap entityVal `fmap` selectList [PersonColor <-. [Nothing, Just "blue"]] [] + liftIO $ x5 @?= [p1, p2, p3] + x6 <- fmap entityVal `fmap` selectList [PersonColor /<-. [Nothing]] [] + liftIO $ x6 @?= [p3] + + describe "toJSON" $ do + it "serializes" $ db $ do + let p = Person "D" 0 Nothing + k <- insert p + liftIO $ toJSON (Entity k p) @?= + Object (M.fromList [("id", toJSON k), ("color",Null),("name",String "D"),("age",Number 0)]) + +{- FIXME + prop "fromJSON . toJSON $ key" $ \(person :: Key Person) -> + case (fromJSON . toJSON) person of + Success p -> p == person + _ -> error "fromJSON" + -} + + +#ifdef WITH_NOSQL +#ifdef WITH_MONGODB + 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 +#endif +#else + it "rawSql/2+2" $ db $ do + ret <- rawSql "SELECT 2+2" [] + liftIO $ ret @?= [Single (4::Int)] + + it "sqlQQ/?-?" $ db $ do + ret <- [sqlQQ| SELECT #{2 :: Int}+#{2 :: Int} |] + liftIO $ ret @?= [Single (4::Int)] + + it "rawSql/?-?" $ db $ do + ret <- rawSql "SELECT ?-?" [PersistInt64 5, PersistInt64 3] + liftIO $ ret @?= [Single (2::Int)] + + it "sqlQQ/?-?" $ db $ do + ret <- [sqlQQ| SELECT #{5 :: Int}-#{3 :: Int} |] + liftIO $ ret @?= [Single (2::Int)] + + it "rawSql/NULL" $ db $ do + ret <- rawSql "SELECT NULL" [] + liftIO $ ret @?= [Nothing :: Maybe (Single Int)] + + it "sqlQQ/NULL" $ db $ do + ret <- [sqlQQ| SELECT NULL |] + liftIO $ ret @?= [Nothing :: Maybe (Single Int)] + + it "rawSql/entity" $ db $ do + let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m) + => val -> ReaderT backend m (Key val, val) + insert' v = insert v >>= \k -> return (k, v) + (p1k, p1) <- insert' $ Person "Mathias" 23 Nothing + (p2k, p2) <- insert' $ Person "Norbert" 44 Nothing + (p3k, _ ) <- insert' $ Person "Cassandra" 19 Nothing + (_ , _ ) <- insert' $ Person "Thiago" 19 Nothing + (a1k, a1) <- insert' $ Pet p1k "Rodolfo" Cat + (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat + (a3k, a3) <- insert' $ Pet p2k "Lhama" Dog + (_ , _ ) <- insert' $ Pet p3k "Abacate" Cat + escape <- ((. DBName) . connEscapeName) `fmap` ask + person <- getTableName (error "rawSql Person" :: Person) + name <- getFieldName PersonName + let query = T.concat [ "SELECT ??, ?? " + , "FROM ", person + , ", ", escape "Pet" + , " WHERE ", person, ".", escape "age", " >= ? " + , "AND ", escape "Pet", ".", escape "ownerId", " = " + , person, ".", escape "id" + , " ORDER BY ", person, ".", name + ] + ret <- rawSql query [PersistInt64 20] + liftIO $ ret @?= [ (Entity p1k p1, Entity a1k a1) + , (Entity p1k p1, Entity a2k a2) + , (Entity p2k p2, Entity a3k a3) ] + ret2 <- rawSql query [PersistInt64 20] + liftIO $ ret2 @?= [ (Just (Entity p1k p1), Just (Entity a1k a1)) + , (Just (Entity p1k p1), Just (Entity a2k a2)) + , (Just (Entity p2k p2), Just (Entity a3k a3)) ] + ret3 <- rawSql query [PersistInt64 20] + liftIO $ ret3 @?= [ Just (Entity p1k p1, Entity a1k a1) + , Just (Entity p1k p1, Entity a2k a2) + , Just (Entity p2k p2, Entity a3k a3) ] + + it "rawSql/order-proof" $ db $ do + let p1 = Person "Zacarias" 93 Nothing + p1k <- insert p1 + escape <- ((. DBName) . connEscapeName) `fmap` ask + let query = T.concat [ "SELECT ?? " + , "FROM ", escape "Person" + ] + ret1 <- rawSql query [] + ret2 <- rawSql query [] :: MonadIO m => SqlPersistT m [Entity (ReverseFieldOrder Person)] + liftIO $ ret1 @?= [Entity p1k p1] + liftIO $ ret2 @?= [Entity (RFOKey $ unPersonKey $ p1k) (RFO p1)] + + it "rawSql/OUTER JOIN" $ db $ do + let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m) + => val -> ReaderT backend m (Key val, val) + insert' v = insert v >>= \k -> return (k, v) + (p1k, p1) <- insert' $ Person "Mathias" 23 Nothing + (p2k, p2) <- insert' $ Person "Norbert" 44 Nothing + (a1k, a1) <- insert' $ Pet p1k "Rodolfo" Cat + (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat + escape <- ((. DBName) . connEscapeName) `fmap` ask + let query = T.concat [ "SELECT ??, ?? " + , "FROM ", person + , "LEFT OUTER JOIN ", pet + , " ON ", person, ".", escape "id" + , " = ", pet, ".", escape "ownerId" + , " ORDER BY ", person, ".", escape "name"] + person = escape "Person" + pet = escape "Pet" + ret <- rawSql query [] + liftIO $ ret @?= [ (Entity p1k p1, Just (Entity a1k a1)) + , (Entity p1k p1, Just (Entity a2k a2)) + , (Entity p2k p2, Nothing) ] + + it "sqlQQ/entity" $ db $ do + let insert' + :: PersistStore backend + => PersistEntity val + => PersistEntityBackend val ~ BaseBackend backend + => MonadIO m + => val + -> ReaderT backend m (Key val, val) + insert' v = insert v >>= \k -> return (k, v) + (p1k, p1) <- insert' $ Person "Mathias" 23 Nothing + (p2k, p2) <- insert' $ Person "Norbert" 44 Nothing + (p3k, _ ) <- insert' $ Person "Cassandra" 19 Nothing + (_ , _ ) <- insert' $ Person "Thiago" 19 Nothing + (a1k, a1) <- insert' $ Pet p1k "Rodolfo" Cat + (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat + (a3k, a3) <- insert' $ Pet p2k "Lhama" Dog + (_ , _ ) <- insert' $ Pet p3k "Abacate" Cat + + let runQuery + :: (RawSql a, Functor m, MonadIO m) + => Int + -> ReaderT SqlBackend m [a] + runQuery age = + [sqlQQ| + SELECT ??, ?? + FROM + ^{Person}, + ^{Pet} + WHERE ^{Person}.@{PersonAge} >= #{age} + AND ^{Pet}.@{PetOwnerId} = ^{Person}.@{PersonId} + ORDER BY ^{Person}.@{PersonName} + |] + + ret <- runQuery 20 + liftIO $ ret @?= [ (Entity p1k p1, Entity a1k a1) + , (Entity p1k p1, Entity a2k a2) + , (Entity p2k p2, Entity a3k a3) ] + ret2 <- runQuery 20 + liftIO $ ret2 @?= [ (Just (Entity p1k p1), Just (Entity a1k a1)) + , (Just (Entity p1k p1), Just (Entity a2k a2)) + , (Just (Entity p2k p2), Just (Entity a3k a3)) ] + ret3 <- runQuery 20 + liftIO $ ret3 @?= [ Just (Entity p1k p1, Entity a1k a1) + , Just (Entity p1k p1, Entity a2k a2) + , Just (Entity p2k p2, Entity a3k a3) ] + + it "sqlQQ/order-proof" $ db $ do + let p1 = Person "Zacarias" 93 Nothing + p1k <- insert p1 + + let runQuery + :: (RawSql a, Functor m, MonadIO m) + => ReaderT SqlBackend m [a] + runQuery = [sqlQQ| SELECT ?? FROM ^{Person} |] + ret1 <- runQuery + ret2 <- runQuery :: (MonadIO m, Functor m) => SqlPersistT m [Entity (ReverseFieldOrder Person)] + liftIO $ ret1 @?= [Entity p1k p1] + liftIO $ ret2 @?= [Entity (RFOKey $ unPersonKey $ p1k) (RFO p1)] + + it "sqlQQ/OUTER JOIN" $ db $ do + let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m) + => val -> ReaderT backend m (Key val, val) + insert' v = insert v >>= \k -> return (k, v) + (p1k, p1) <- insert' $ Person "Mathias" 23 Nothing + (p2k, p2) <- insert' $ Person "Norbert" 44 Nothing + (a1k, a1) <- insert' $ Pet p1k "Rodolfo" Cat + (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat + ret <- [sqlQQ| + SELECT ??, ?? + FROM ^{Person} + LEFT OUTER JOIN ^{Pet} + ON ^{Person}.@{PersonId} = ^{Pet}.@{PetOwnerId} + ORDER BY ^{Person}.@{PersonName} + |] + liftIO $ ret @?= [ (Entity p1k p1, Just (Entity a1k a1)) + , (Entity p1k p1, Just (Entity a2k a2)) + , (Entity p2k p2, Nothing) ] + + it "commit/rollback" (caseCommitRollback >> runResourceT (runConn cleanDB)) + +#ifndef WITH_MYSQL +# ifndef WITH_POSTGRESQL +# ifndef WITH_NOSQL + it "afterException" $ db $ do + let catcher :: Monad m => SomeException -> m () + catcher _ = return () + _ <- insert $ Person "A" 0 Nothing + _ <- (insert (Person "A" 1 Nothing) >> return ()) `catch` catcher + _ <- insert $ Person "B" 0 Nothing + return () +# endif +# endif +#endif + + +#ifndef WITH_NOSQL + it "mpsNoPrefix" $ db $ do + deleteWhere ([] :: [Filter NoPrefix2]) + deleteWhere ([] :: [Filter NoPrefix1]) + np1a <- insert $ NoPrefix1 1 + update np1a [SomeFieldName =. 2] + np1b <- insert $ NoPrefix1 3 + np2 <- insert $ NoPrefix2 4 np1a + update np2 [UnprefixedRef =. np1b, SomeOtherFieldName =. 5] + + mnp1a <- get np1a + liftIO $ mnp1a @?= Just (NoPrefix1 2) + liftIO $ fmap someFieldName mnp1a @?= Just 2 + mnp2 <- get np2 + liftIO $ fmap unprefixedRef mnp2 @?= Just np1b + liftIO $ fmap someOtherFieldName mnp2 @?= Just 5 + + insert_ $ UnprefixedLeftSum 5 + insert_ $ UnprefixedRightSum "Hello" + + it "IsSqlKey instance" $ db $ do + let p = Person "Alice" 30 Nothing + key@(PersonKey (SqlBackendKey i)) <- insert p + liftIO $ fromSqlKey key `shouldBe` (i :: Int64) + mp <- get $ toSqlKey i + liftIO $ mp `shouldBe` Just p +#endif + + describe "strictness" $ do + it "bang" $ (return $! Strict (error "foo") 5 5) `shouldThrow` anyErrorCall + it "tilde" $ void (return $! Strict 5 (error "foo") 5 :: IO Strict) + it "blank" $ (return $! Strict 5 5 (error "foo")) `shouldThrow` anyErrorCall + +#ifdef WITH_POSTGRESQL + describe "rawSql/array_agg" $ do + let runArrayAggTest dbField expected = db $ do + void $ insertMany + [ UserPT "a" $ Just "b" + , UserPT "c" $ Just "d" + , UserPT "e" Nothing + , UserPT "g" $ Just "h" ] + escape <- ((. DBName) . connEscapeName) `fmap` ask + let query = T.concat [ "SELECT array_agg(", escape dbField, ") " + , "FROM ", escape "UserPT" + ] + [Single xs] <- rawSql query [] + liftIO $ sort xs @?= expected + + it "works for [Text]" $ runArrayAggTest "ident" ["a", "c", "e", "g" :: Text] + it "works for [Maybe Text]" $ runArrayAggTest "password" [Nothing, Just "b", Just "d", Just "h" :: Maybe Text] +#endif + +-- | Reverses the order of the fields of an entity. Used to test +-- @??@ placeholders of 'rawSql'. +newtype ReverseFieldOrder a = RFO {unRFO :: a} deriving (Eq, Show) +instance ToJSON (Key (ReverseFieldOrder a)) where toJSON = error "ReverseFieldOrder" +instance FromJSON (Key (ReverseFieldOrder a)) where parseJSON = error "ReverseFieldOrder" +instance (PersistEntity a) => PersistEntity (ReverseFieldOrder a) where + type PersistEntityBackend (ReverseFieldOrder a) = PersistEntityBackend a + + newtype Key (ReverseFieldOrder a) = RFOKey { unRFOKey :: BackendKey SqlBackend } deriving (Show, Read, Eq, Ord, PersistField, PersistFieldSql) + keyFromValues = fmap RFOKey . fromPersistValue . head + keyToValues = (:[]) . toPersistValue . unRFOKey + + entityDef = revFields . entityDef . liftM unRFO + where + revFields ed = ed { entityFields = reverse (entityFields ed) } + + toPersistFields = reverse . toPersistFields . unRFO + newtype EntityField (ReverseFieldOrder a) b = EFRFO {unEFRFO :: EntityField a b} + persistFieldDef = persistFieldDef . unEFRFO + fromPersistValues = fmap RFO . fromPersistValues . reverse + + newtype Unique (ReverseFieldOrder a) = URFO {unURFO :: Unique a } + persistUniqueToFieldNames = reverse . persistUniqueToFieldNames . unURFO + persistUniqueToValues = reverse . persistUniqueToValues . unURFO + persistUniqueKeys = map URFO . reverse . persistUniqueKeys . unRFO + + persistIdField = error "ReverseFieldOrder.persistIdField" + fieldLens = error "ReverseFieldOrder.fieldLens" + +caseCommitRollback :: Assertion +caseCommitRollback = db $ do + let filt :: [Filter Person1] + filt = [] + + let p = Person1 "foo" 0 + + _ <- insert p + _ <- insert p + _ <- insert p + + c1 <- count filt + c1 @== 3 + + transactionSave + c2 <- count filt + c2 @== 3 + + _ <- insert p + transactionUndo + c3 <- count filt + c3 @== 3 + + _ <- insert p + transactionSave + _ <- insert p + _ <- insert p + transactionUndo + c4 <- count filt + c4 @== 4 + +#endif + +-- Test proper polymorphism +_polymorphic :: (MonadIO m, PersistQuery backend, BaseBackend backend ~ PersistEntityBackend Pet) => ReaderT backend m () +_polymorphic = do + ((Entity id' _):_) <- selectList [] [LimitTo 1] + _ <- selectList [PetOwnerId ==. id'] [] + _ <- insert $ Pet id' "foo" Cat + return () + +-- Some lens stuff +type ASetter s t a b = (a -> Identity b) -> s -> Identity t + +set :: ASetter s t a b -> b -> s -> t +set l b = runIdentity . (l (\_ -> Identity b)) + +type Getting r s t a b = (a -> Constant r b) -> s -> Constant r t + +view :: s -> Getting a s t a b -> a +view s l = getConstant (l Constant s) diff --git a/src/PrimaryTest.hs b/src/PrimaryTest.hs new file mode 100644 --- /dev/null +++ b/src/PrimaryTest.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +module PrimaryTest where + +import Init + +-- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs +#if WITH_NOSQL +mkPersist persistSettings { mpsGeneric = False } [persistUpperCase| +#else +share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase| +#endif + Foo + name String + Primary name + Bar + quux FooId + + Trees sql=trees + name String + parent String Maybe + Primary name + Foreign Trees fkparent parent +|] +#ifdef WITH_NOSQL +cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Foo ~ backend) => ReaderT backend m () +cleanDB = do + deleteWhere ([] :: [Filter Foo]) + deleteWhere ([] :: [Filter Bar]) + +db :: Action IO () -> Assertion +db = db' cleanDB +#endif + +specs :: Spec +specs = describe "primary key reference" $ do +#ifdef WITH_NOSQL + return () +#else +# ifdef WITH_MYSQL + return () +# else + it "insert a primary reference" $ db $ do + kf <- insert $ Foo "name" + _kb <- insert $ Bar kf + return () + it "uses RawSql for a Primary key" $ db $ do + key <- insert $ Foo "name" + keyFromRaw <- rawSql "SELECT name FROM foo LIMIT 1" [] + [key] @== keyFromRaw +# endif +#endif diff --git a/src/Recursive.hs b/src/Recursive.hs new file mode 100644 --- /dev/null +++ b/src/Recursive.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleInstances #-} +{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell, + OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls, MultiParamTypeClasses #-} +module Recursive (specs, +#ifndef WITH_NOSQL +recursiveMigrate +#endif +) where + +import Init + +#if WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "recursiveMigrate"] [persistLowerCase| +#endif +SubType + object [MenuObject] + deriving Show Eq +MenuObject + sub SubType Maybe + deriving Show Eq +|] +#if WITH_NOSQL +cleanDB :: ReaderT Context IO () +cleanDB = do + deleteWhere ([] :: [Filter MenuObject]) + deleteWhere ([] :: [Filter SubType]) +db :: Action IO () -> Assertion +db = db' cleanDB +#endif + +specs :: Spec +specs = describe "recursive definitions" $ do + it "mutually recursive" $ db $ do + let m1 = MenuObject $ Just $ SubType [] + let m2 = MenuObject $ Just $ SubType [m1] + let m3 = MenuObject $ Just $ SubType [m2] + k3 <- insert m3 + m3' <- get k3 + m3' @== Just m3 diff --git a/src/RenameTest.hs b/src/RenameTest.hs new file mode 100644 --- /dev/null +++ b/src/RenameTest.hs @@ -0,0 +1,108 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +module RenameTest where + +#ifndef WITH_NOSQL +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL +import Control.Monad.Trans.Resource (runResourceT) +#endif +import Data.Time (getCurrentTime, Day, UTCTime(..)) +import qualified Data.Map as Map +import qualified Data.Text as T +import Init + +-- persistent used to not allow types with an "Id" suffix +-- this verifies that the issue is fixed +type TextId = Text + +-- Test lower case names +#if WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase| +#endif +-- This just tests that a field can be named "key" +KeyTable + key Text + deriving Eq Show + +IdTable + Id Day default=CURRENT_DATE + name Text + -- This was added to test the ability to break a cycle + -- getting rid of the Maybe should be a compilation failure + keyTableEmbed IdTable Maybe + deriving Eq Show + +LowerCaseTable + Id sql=my_id + fullName Text + ExtraBlock + foo bar + baz + bin + ExtraBlock2 + something + +RefTable + someVal Int sql=something_else + lct LowerCaseTableId + text TextId + UniqueRefTable someVal + +-- Test a reference to a non-int Id +ForeignIdTable + idId IdTableId +|] +#if WITH_NOSQL +cleanDB :: ReaderT Context IO () +cleanDB = do + deleteWhere ([] :: [Filter IdTable]) + deleteWhere ([] :: [Filter LowerCaseTable]) + deleteWhere ([] :: [Filter RefTable]) +db :: Action IO () -> Assertion +db = db' cleanDB +#endif + +specs :: Spec +specs = describe "rename specs" $ do +#ifndef WITH_NOSQL + it "handles lower casing" $ asIO $ + runConn $ do + runResourceT $ rawQuery "SELECT full_name from lower_case_table WHERE my_id=5" [] C.$$ CL.sinkNull + runResourceT $ rawQuery "SELECT something_else from ref_table WHERE id=4" [] C.$$ CL.sinkNull +#endif + + it "user specified id, insertKey, no default=" $ db $ do + let rec2 = IdTable "Foo2" Nothing + let rec1 = IdTable "Foo1" $ Just rec2 + let rec = IdTable "Foo" $ Just rec1 + now <- liftIO getCurrentTime + let key = IdTableKey $ utctDay now + insertKey key rec + Just rec' <- get key + rec' @== rec + (Entity key' _):_ <- selectList ([] :: [Filter IdTable]) [] + key' @== key + +#ifndef WITH_MYSQL +# ifndef WITH_NOSQL + -- this uses default= + it "user specified id, default=" $ db $ do + let rec = IdTable "Foo" Nothing + k <- insert rec + Just rec' <- get k + rec' @== rec +# endif +#endif + + it "extra blocks" $ + entityExtra (entityDef (Nothing :: Maybe LowerCaseTable)) @?= + Map.fromList + [ ("ExtraBlock", map T.words ["foo bar", "baz", "bin"]) + , ("ExtraBlock2", map T.words ["something"]) + ] + +asIO :: IO a -> IO a +asIO = id diff --git a/src/SumTypeTest.hs b/src/SumTypeTest.hs new file mode 100644 --- /dev/null +++ b/src/SumTypeTest.hs @@ -0,0 +1,58 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +module SumTypeTest (specs) where + +import Database.Persist.TH +import Control.Monad.Trans.Resource (runResourceT) +import qualified Data.Text as T + +import Init + +#if WITH_NOSQL +mkPersist persistSettings [persistLowerCase| +#else +share [mkPersist persistSettings, mkMigrate "sumTypeMigrate"] [persistLowerCase| +#endif +Bicycle + brand T.Text +Car + make T.Text + model T.Text ++Vehicle + bicycle BicycleId + car CarId +|] + +-- This is needed for mpsGeneric = True +-- The typical persistent user sets mpsGeneric = False +-- https://ghc.haskell.org/trac/ghc/ticket/8100 +deriving instance Show (BackendKey backend) => Show (VehicleGeneric backend) +deriving instance Eq (BackendKey backend) => Eq (VehicleGeneric backend) + +specs :: Spec +specs = describe "sum types" $ + it "works" $ asIO $ runResourceT $ runConn $ do +#ifndef WITH_NOSQL + _ <- runMigrationSilent sumTypeMigrate +#endif + car1 <- insert $ Car "Ford" "Thunderbird" + car2 <- insert $ Car "Kia" "Rio" + bike1 <- insert $ Bicycle "Shwinn" + + vc1 <- insert $ VehicleCarSum car1 + vc2 <- insert $ VehicleCarSum car2 + vb1 <- insert $ VehicleBicycleSum bike1 + + x1 <- get vc1 + liftIO $ x1 @?= Just (VehicleCarSum car1) + + x2 <- get vc2 + liftIO $ x2 @?= Just (VehicleCarSum car2) + + x3 <- get vb1 + liftIO $ x3 @?= Just (VehicleBicycleSum bike1) + +asIO :: IO a -> IO a +asIO = id diff --git a/src/UniqueTest.hs b/src/UniqueTest.hs new file mode 100644 --- /dev/null +++ b/src/UniqueTest.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +module UniqueTest where + +import Init + +#ifdef WITH_NOSQL +mkPersist persistSettings [persistUpperCase| +#else +share [mkPersist sqlSettings, mkMigrate "uniqueMigrate"] [persistLowerCase| +#endif + TestNonNull + fieldA Int + UniqueTestNonNull fieldA + deriving Eq Show + TestNull + fieldA Int + fieldB Int Maybe + UniqueTestNull fieldA fieldB !force + deriving Eq Show +#ifndef WITH_NOSQL + TestCheckmark + name Text + value Text + active Checkmark nullable + UniqueTestCheckmark name active !force + deriving Eq Show +#endif +|] +#ifdef WITH_NOSQL +cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend TestNonNull ~ backend) => ReaderT backend m () +cleanDB = do + deleteWhere ([] :: [Filter TestNonNull]) + deleteWhere ([] :: [Filter TestNull]) + +db :: Action IO () -> Assertion +db = db' cleanDB +#endif + +specs :: Spec +specs = describe "uniqueness constraints" $ +#ifdef WITH_NOSQL + return () +#else + do + it "are respected for non-nullable Ints" $ do + let ins = insert . TestNonNull + (db $ void $ ins 1 >> ins 2) + (db $ void $ ins 1 >> ins 2 >> ins 1) `shouldThrow` anyException + (db $ void $ ins 1 >>= \k -> ins 2 >> delete k >> ins 1) + it "are respected for nullable Ints" $ do + let ins a b = insert $ TestNull a b + ctx = ins 1 Nothing >> ins 1 Nothing >> ins 1 Nothing >> + ins 1 (Just 3) >> ins 1 (Just 4) + (db $ void ctx) + (db $ void $ ctx >> ins 1 (Just 3)) `shouldThrow` anyException + (db $ void $ ctx >> ins 1 (Just 4)) `shouldThrow` anyException + (db $ void $ ctx >>= \k -> delete k >> ins 1 (Just 4)) + it "work for Checkmark" $ do + let ins k v a = insert $ TestCheckmark k v a + ctx = ins "name" "John" Inactive + >> ins "name" "Stewart" Inactive + >> ins "name" "Doroty" Active + >> ins "color" "blue" Inactive + (db $ void ctx) + (db $ void $ ctx >> ins "name" "Melissa" Active) `shouldThrow` anyException + (db $ void $ ctx >> ins "name" "Melissa" Inactive) + (db $ void $ ctx >>= flip update [TestCheckmarkActive =. Active]) + (db $ void $ do + void ctx + updateWhere [TestCheckmarkName ==. "name"] + [TestCheckmarkActive =. Inactive] + ins "name" "Melissa" Active) +#endif diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import qualified CompositeTest +import qualified CustomPersistFieldTest +import qualified CustomPrimaryKeyReferenceTest +import qualified DataTypeTest +import qualified EmbedOrderTest +import qualified EmbedTest +import qualified EmptyEntityTest +import qualified HtmlTest +import Init +import qualified LargeNumberTest +import qualified MaxLenTest +import qualified MigrationOnlyTest +import qualified PersistentTest +import qualified PersistUniqueTest +import qualified PrimaryTest +import qualified Recursive +import qualified RenameTest +import qualified SumTypeTest +import qualified InsertDuplicateUpdate +import qualified UniqueTest +import qualified MigrationColumnLengthTest +import qualified EquivalentTypeTest + +#ifndef WITH_NOSQL +# ifdef WITH_SQLITE +import Control.Exception (handle, IOException) +import Filesystem (removeFile) +import Filesystem.Path.CurrentOS (fromText) +import qualified MigrationTest +# endif +#endif + +#ifdef WITH_MYSQL +import qualified MigrationIdempotencyTest +#endif + + +#ifdef WITH_NOSQL +#else + +setup :: MonadIO m => Migration -> ReaderT SqlBackend m () +setup migration = do + printMigration migration + runMigrationUnsafe migration +#endif + +main :: IO () +main = do +#ifndef WITH_NOSQL +# ifdef WITH_SQLITE + handle (\(_ :: IOException) -> return ()) + $ removeFile $ fromText sqlite_database_file +# endif + + runConn $ do + mapM_ setup + [ PersistentTest.testMigrate + , PersistentTest.noPrefixMigrate + , EmbedTest.embedMigrate + , EmbedOrderTest.embedOrderMigrate + , LargeNumberTest.numberMigrate + , UniqueTest.uniqueMigrate + , MaxLenTest.maxlenMigrate + , Recursive.recursiveMigrate + , CompositeTest.compositeMigrate +# ifdef WITH_SQLITE + , MigrationTest.migrationMigrate +# endif + , PersistUniqueTest.migration + , RenameTest.migration + , CustomPersistFieldTest.customFieldMigrate +# ifndef WITH_MYSQL + , PrimaryTest.migration +# endif +# ifdef WITH_MYSQL + , InsertDuplicateUpdate.duplicateMigrate + , MigrationIdempotencyTest.migration +# endif + , CustomPrimaryKeyReferenceTest.migration + , MigrationColumnLengthTest.migration + ] + PersistentTest.cleanDB +#endif + + hspec $ do + RenameTest.specs + DataTypeTest.specs + HtmlTest.specs + EmbedTest.specs + EmbedOrderTest.specs + LargeNumberTest.specs + UniqueTest.specs + MaxLenTest.specs + Recursive.specs + SumTypeTest.specs + MigrationOnlyTest.specs + PersistentTest.specs + EmptyEntityTest.specs + CompositeTest.specs + PersistUniqueTest.specs + PrimaryTest.specs + CustomPersistFieldTest.specs + CustomPrimaryKeyReferenceTest.specs + InsertDuplicateUpdate.specs + MigrationColumnLengthTest.specs + EquivalentTypeTest.specs + +#ifdef WITH_SQLITE + MigrationTest.specs +#endif +#ifdef WITH_MYSQL + MigrationIdempotencyTest.specs +#endif