persistent-test 2.13.2.0 → 2.13.2.1
raw patch · 41 files changed
+2267/−1782 lines, 41 filesdep ~persistent
Dependency ranges changed: persistent
Files
- ChangeLog.md +4/−0
- persistent-test.cabal +2/−2
- src/CompositeTest.hs +202/−172
- src/CustomPersistField.hs +11/−6
- src/CustomPersistFieldTest.hs +12/−8
- src/CustomPrimaryKeyReferenceTest.hs +21/−9
- src/DataTypeTest.hs +84/−69
- src/EmbedOrderTest.hs +14/−9
- src/EmbedTest.hs +147/−114
- src/EmptyEntityTest.hs +19/−15
- src/EntityEmbedTest.hs +5/−2
- src/EquivalentTypeTest.hs +7/−3
- src/ForeignKey.hs +43/−27
- src/GeneratedColumnTestSQL.hs +15/−9
- src/HtmlTest.hs +20/−15
- src/Init.hs +106/−89
- src/LargeNumberTest.hs +23/−20
- src/LongIdentifierTest.hs +9/−6
- src/MaxLenTest.hs +23/−20
- src/MaybeFieldDefsTest.hs +10/−8
- src/MigrationColumnLengthTest.hs +8/−5
- src/MigrationIdempotencyTest.hs +7/−4
- src/MigrationOnlyTest.hs +17/−7
- src/MigrationTest.hs +20/−15
- src/MpsCustomPrefixTest.hs +24/−23
- src/MpsNoPrefixTest.hs +24/−23
- src/PersistTestPetCollarType.hs +1/−0
- src/PersistUniqueTest.hs +52/−32
- src/PersistentTest.hs +759/−659
- src/PersistentTestModelsImports.hs +4/−2
- src/PrimaryTest.hs +30/−28
- src/RawSqlTest.hs +184/−79
- src/ReadWriteTest.hs +14/−11
- src/Recursive.hs +20/−17
- src/RenameTest.hs +33/−25
- src/SumTypeTest.hs +27/−22
- src/TransactionLevelTest.hs +13/−10
- src/TreeTest.hs +25/−21
- src/TypeLitFieldDefsTest.hs +6/−2
- src/UniqueTest.hs +49/−34
- src/UpsertTest.hs +173/−160
ChangeLog.md view
@@ -1,5 +1,9 @@ ## Unreleased changes +# 2.13.2.1+* [#1610](https://github.com/yesodweb/persistent/pull/1610)+ * Added `NoAction` as a `CascadeAction`+ # 2.13.2.0 * [#1601](https://github.com/yesodweb/persistent/pull/1601) * Adjust test data to avoid deprecated entity definition syntax
persistent-test.cabal view
@@ -1,5 +1,5 @@ name: persistent-test-version: 2.13.2.0+version: 2.13.2.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -77,7 +77,7 @@ , monad-logger >=0.3.25 , mtl , path-pieces >=0.2- , persistent >=2.16 && <2.18+ , persistent >=2.16 && <2.19 , QuickCheck >=2.9 , quickcheck-instances >=0.3 , random >=1.1
src/CompositeTest.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-} -- FIXME+-- FIXME+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module CompositeTest where import qualified Data.Map as Map@@ -10,9 +12,10 @@ import Init - -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs-share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate"] [persistLowerCase|+share+ [mkPersist persistSettings{mpsGeneric = False}, mkMigrate "compositeMigrate"]+ [persistLowerCase| TestParent name String maxlen=20 name2 String maxlen=20@@ -50,193 +53,215 @@ deriving Eq Show |] -cleanDB :: (PersistQuery backend, PersistEntityBackend TestChild ~ backend, MonadIO m) => ReaderT backend m ()+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])+ deleteWhere ([] :: [Filter TestChild])+ deleteWhere ([] :: [Filter TestParent])+ deleteWhere ([] :: [Filter CitizenAddress])+ deleteWhere ([] :: [Filter Citizen])+ deleteWhere ([] :: [Filter Address]) specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec specsWith runDb = 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'"+ 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" $ runDb $ do- kp1 <- insert p1- delete kp1- insertKey kp1 p2+ it "insertWithKey" $ runDb $ do+ kp1 <- insert p1+ delete kp1+ insertKey kp1 p2 - it "repsert" $ runDb $ do- kp1 <- insert p1- repsert kp1 p2+ it "repsert" $ runDb $ do+ kp1 <- insert p1+ repsert kp1 p2 - it "Insert" $ runDb $ 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 "Insert" $ runDb $ 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" $ runDb $ do- kp1 <- insert p1- kp2 <- insert p2- xs <- selectList [TestParentId <-. [kp1,kp2]] []- length xs @== 2- [(Entity newkp1 newp1),(Entity newkp2 newp2)] <- pure xs- matchParentK kp1 @== matchParentK newkp1- matchParentK kp2 @== matchParentK newkp2- p1 @== newp1- p2 @== newp2+ it "Id field" $ runDb $ do+ kp1 <- insert p1+ kp2 <- insert p2+ xs <- selectList [TestParentId <-. [kp1, kp2]] []+ length xs @== 2+ [(Entity newkp1 newp1), (Entity newkp2 newp2)] <- pure xs+ matchParentK kp1 @== matchParentK newkp1+ matchParentK kp2 @== matchParentK newkp2+ p1 @== newp1+ p2 @== newp2 - it "Filter by Id with 'not equal'" $ runDb $ 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 equal'" $ runDb $ 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'" $ runDb $ 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 'in'" $ runDb $ 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'" $ runDb $ 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'" $ runDb $ 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" $ runDb $ do- kp1 <- insert p1- kp2 <- insert p2- xs <- selectList [TestParentId /<-. [kp1,kp2]] []- length xs @== 0+ it "Filter by Id with 'not in' with no data" $ runDb $ do+ kp1 <- insert p1+ kp2 <- insert p2+ xs <- selectList [TestParentId /<-. [kp1, kp2]] []+ length xs @== 0 - it "Extract Parent Foreign Key from Child value" $ runDb $ do- kp1 <- insert p1- insert_ p2- kc1 <- insert c1- mc <- get kc1- isJust mc @== True- let Just c11 = mc- c1 @== c11- testChildFkparent c11 @== kp1+ it "Extract Parent Foreign Key from Child value" $ runDb $ do+ kp1 <- insert p1+ insert_ p2+ kc1 <- insert c1+ mc <- get kc1+ isJust mc @== True+ let+ Just c11 = mc+ c1 @== c11+ testChildFkparent c11 @== kp1 - it "Validate Key contents" $ runDb $ 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 "Validate Key contents" $ runDb $ 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" $ runDb $ do- kp1 <- insert p1- kp2 <- insert p2+ it "Delete" $ runDb $ do+ kp1 <- insert p1+ kp2 <- insert p2 - _ <- delete kp1- r <- get kp1- r @== Nothing- r1 <- get kp2- isJust r1 @== True+ _ <- delete kp1+ r <- get kp1+ r @== Nothing+ r1 <- get kp2+ isJust r1 @== True - it "Update" $ runDb $ do- kp1 <- insert p1- _ <- update kp1 [TestParentExtra44 =. "q1"]- newkps1 <- get kp1- newkps1 @== Just (TestParent "a1" "b1" 11 "q1")+ it "Update" $ runDb $ do+ kp1 <- insert p1+ _ <- update kp1 [TestParentExtra44 =. "q1"]+ newkps1 <- get kp1+ newkps1 @== Just (TestParent "a1" "b1" 11 "q1") - it "Replace Parent" $ runDb $ do- kp1 <- insert p1- _ <- replace kp1 p1'- newp1 <- get kp1- newp1 @== Just p1'+ it "Replace Parent" $ runDb $ do+ kp1 <- insert p1+ _ <- replace kp1 p1'+ newp1 <- get kp1+ newp1 @== Just p1' - it "Replace Child" $ runDb $ do- -- c1 FKs p1- insert_ p1- kc1 <- insert c1- _ <- replace kc1 c1'- newc1 <- get kc1- newc1 @== Just c1'+ it "Replace Child" $ runDb $ do+ -- c1 FKs p1+ insert_ p1+ kc1 <- insert c1+ _ <- replace kc1 c1'+ newc1 <- get kc1+ newc1 @== Just c1' - it "Insert Many to Many" $ runDb $ do- let z1 = Citizen "mk" (Just 11)- let a1 = Address "abc" "usa"- let z2 = Citizen "gb" (Just 22)- let a2 = Address "def" "den"+ it "Insert Many to Many" $ runDb $ 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+ 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+ 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+ 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" $ runDb $ do- [kp1, kp2] <- insertMany [p1, p2]- rs <- getMany [kp1, kp2]- rs @== Map.fromList [(kp1, p1), (kp2, p2)]- it "RawSql Key instance" $ runDb $ do- key <- insert p1- keyFromRaw <- rawSql "SELECT name, name2, age FROM test_parent LIMIT 1" []- [key] @== keyFromRaw+ xs <- selectList [CitizenAddressId ==. kca1] []+ length xs @== 1+ let+ [Entity newkca1 newca2] = xs+ matchCitizenAddressK kca1 @== matchCitizenAddressK newkca1+ ca1 @== newca2+ it "insertMany" $ runDb $ do+ [kp1, kp2] <- insertMany [p1, p2]+ rs <- getMany [kp1, kp2]+ rs @== Map.fromList [(kp1, p1), (kp2, p2)]+ it "RawSql Key instance" $ runDb $ do+ key <- insert p1+ keyFromRaw <- rawSql "SELECT name, name2, age FROM test_parent LIMIT 1" []+ [key] @== keyFromRaw --- TODO: push into persistent-qq test suite--- it "RawSql Key instance with sqlQQ" $ runDb $ do--- key <- insert p1--- keyFromRaw' <- [sqlQQ|--- SELECT @{TestParentName}, @{TestParentName2}, @{TestParentAge}--- FROM ^{TestParent}--- LIMIT 1--- |]--- [key] @== keyFromRaw'+ -- TODO: push into persistent-qq test suite+ -- it "RawSql Key instance with sqlQQ" $ runDb $ do+ -- key <- insert p1+ -- keyFromRaw' <- [sqlQQ|+ -- SELECT @{TestParentName}, @{TestParentName2}, @{TestParentAge}+ -- FROM ^{TestParent}+ -- LIMIT 1+ -- |]+ -- [key] @== keyFromRaw' - it "RawSql Entity instance" $ runDb $ do- key <- insert p1- Just x <- get key- x @== p1- newp1 <- rawSql "SELECT ?? FROM test_parent LIMIT 1" []- [Entity key p1] @== newp1+ it "RawSql Entity instance" $ runDb $ do+ key <- insert p1+ Just x <- get key+ x @== p1+ newp1 <- rawSql "SELECT ?? FROM test_parent LIMIT 1" []+ [Entity key p1] @== newp1 -- TODO: put into persistent-qq test suite -- it "RawSql Entity instance with sqlQQ" $ runDb $ do@@ -245,17 +270,22 @@ -- [Entity key p1] @== newp1' matchK :: (PersistField a, PersistEntity record) => Key record -> Either Text a-matchK = (\(pv:[]) -> fromPersistValue pv) . keyToValues+matchK = (\(pv : []) -> fromPersistValue pv) . keyToValues -matchK2 :: (PersistField a1, PersistField a, PersistEntity record, PersistEntity record2)- => Key record -> Key record2- -> Either Text (a1, a)+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+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+matchCitizenAddressK =+ (\(a : b : []) -> (,) <$> fromPersistValue a <*> fromPersistValue b)+ . keyToValues
src/CustomPersistField.hs view
@@ -1,23 +1,28 @@ -- 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 {-# LANGUAGE GeneralizedNewtypeDeriving #-}+ module CustomPersistField where import Data.String (IsString) import Data.Text (pack)-import Data.Text.Lazy (toStrict, fromStrict)+import Data.Text.Lazy (fromStrict, toStrict) import qualified Data.Text.Lazy as TL (Text) import Init newtype Markdown = Markdown TL.Text- deriving (Eq, Ord, IsString, Show)+ 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."-+ 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
src/CustomPersistFieldTest.hs view
@@ -1,21 +1,25 @@-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}+ module CustomPersistFieldTest (specsWith, customFieldMigrate) where import CustomPersistField import Init -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "customFieldMigrate"] [persistLowerCase|+share+ [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "customFieldMigrate"]+ [persistLowerCase| BlogPost article Markdown deriving Show Eq |] -specsWith :: Runner backend m => RunDb backend m -> Spec+specsWith :: (Runner backend m) => RunDb backend m -> Spec specsWith runDB = describe "Custom persist field" $ do- it "should read what it wrote" $ runDB $ do- let originalBlogPost = BlogPost "article"- blogPostId <- insert originalBlogPost- Just newBlogPost <- get blogPostId- liftIO $ originalBlogPost @?= newBlogPost+ it "should read what it wrote" $ runDB $ do+ let+ originalBlogPost = BlogPost "article"+ blogPostId <- insert originalBlogPost+ Just newBlogPost <- get blogPostId+ liftIO $ originalBlogPost @?= newBlogPost
src/CustomPrimaryKeyReferenceTest.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+ -- 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@@ -8,7 +9,9 @@ import Init -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs-share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase|+share+ [mkPersist persistSettings{mpsGeneric = False}, mkMigrate "migration"]+ [persistLowerCase| Tweet tweetId Int statusText Text sqltype=varchar(170)@@ -23,16 +26,25 @@ deriving Show |] -cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Tweet ~ backend) => ReaderT backend m ()+cleanDB+ :: (MonadIO m, PersistQuery backend, PersistEntityBackend Tweet ~ backend)+ => ReaderT backend m () cleanDB = do- deleteWhere ([] :: [Filter Tweet])- deleteWhere ([] :: [Filter TweetUrl])+ deleteWhere ([] :: [Filter Tweet])+ deleteWhere ([] :: [Filter TweetUrl]) specsWith :: (MonadFail m, MonadIO m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "custom primary key reference" $ do- let tweet = Tweet {tweetTweetId = 1, tweetStatusText = "Hello!"}+ let+ tweet = Tweet{tweetTweetId = 1, tweetStatusText = "Hello!"} - it "can insert a Tweet" $ runDb $ do- tweetId <- insert tweet- let url = TweetUrl {tweetUrlTweetId = tweetId, tweetUrlTweetUrl = "http://google.com", tweetUrlFinalUrl = Just "http://example.com"}- insert_ url+ it "can insert a Tweet" $ runDb $ do+ tweetId <- insert tweet+ let+ url =+ TweetUrl+ { tweetUrlTweetId = tweetId+ , tweetUrlTweetUrl = "http://google.com"+ , tweetUrlFinalUrl = Just "http://example.com"+ }+ insert_ url
src/DataTypeTest.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}+ module DataTypeTest ( specsWith , dataTypeMigrate@@ -15,13 +16,19 @@ import Data.Foldable (for_) import Data.IntMap (IntMap) import qualified Data.Text as T-import Data.Time (Day, UTCTime (..), TimeOfDay, timeToTimeOfDay, timeOfDayToTime)-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)+import Data.Time+ ( Day+ , TimeOfDay+ , UTCTime (..)+ , timeOfDayToTime+ , timeToTimeOfDay+ )+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)+import Database.Persist.Class.PersistEntity import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)-import Test.QuickCheck.Gen (Gen(..))+import Test.QuickCheck.Gen (Gen (..)) import Test.QuickCheck.Instances () import Test.QuickCheck.Random (newQCGen)-import Database.Persist.Class.PersistEntity import Database.Persist.TH import Init@@ -29,7 +36,9 @@ type Tuple a b = (a, b) -- Test lower case names-share [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase|+share+ [mkPersist persistSettings, mkMigrate "dataTypeMigrate"]+ [persistLowerCase| DataTypeTable no-json text Text textMaxLen Text maxlen=100@@ -46,11 +55,11 @@ |] cleanDB'- ::- ( MonadIO m, PersistStoreWrite (BaseBackend backend), PersistQuery backend) => ReaderT backend m ()+ :: (MonadIO m, PersistStoreWrite (BaseBackend backend), PersistQuery backend)+ => ReaderT backend m () cleanDB' = deleteWhere ([] :: [Filter (DataTypeTableGeneric backend)]) -roundFn :: RealFrac a => a -> Integer+roundFn :: (RealFrac a) => a -> Integer roundFn = truncate roundTime :: TimeOfDay -> TimeOfDay@@ -60,41 +69,42 @@ roundUTCTime t = posixSecondsToUTCTime $ fromIntegral $ roundFn $ utcTimeToPOSIXSeconds t -randomValues :: Arbitrary a => Int -> IO [a]+randomValues :: (Arbitrary a) => Int -> IO [a] randomValues i = do- gs <- replicateM i newQCGen- return $ zipWith (unGen arbitrary) gs [0..]+ gs <- replicateM i newQCGen+ return $ zipWith (unGen arbitrary) gs [0 ..] instance Arbitrary DataTypeTable where- arbitrary = DataTypeTable- <$> arbText -- text- <*> (T.take 100 <$> arbText) -- textManLen- <*> arbitrary -- bytes- <*> liftA2 (,) arbitrary arbText -- bytesTextTuple- <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen- <*> arbitrary -- int- <*> arbitrary -- intList- <*> arbitrary -- intMap- <*> arbitrary -- double- <*> arbitrary -- bool- <*> arbitrary -- day- <*> (truncateUTCTime =<< arbitrary) -- utc+ arbitrary =+ DataTypeTable+ <$> arbText -- text+ <*> (T.take 100 <$> arbText) -- textManLen+ <*> arbitrary -- bytes+ <*> liftA2 (,) arbitrary arbText -- bytesTextTuple+ <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen+ <*> arbitrary -- int+ <*> arbitrary -- intList+ <*> arbitrary -- intMap+ <*> arbitrary -- double+ <*> arbitrary -- bool+ <*> arbitrary -- day+ <*> (truncateUTCTime =<< arbitrary) -- utc specsWith- :: forall db backend m entity.- ( db ~ ReaderT backend m- , PersistStoreRead backend- , PersistEntity entity- , PersistEntityBackend entity ~ BaseBackend backend- , Arbitrary entity- , PersistStoreWrite backend- , PersistStoreWrite (BaseBackend backend)- , PersistQueryWrite (BaseBackend backend)- , PersistQueryWrite backend- , MonadFail m- , MonadIO m- , SafeToInsert entity- )+ :: forall db backend m entity+ . ( db ~ ReaderT backend m+ , PersistStoreRead backend+ , PersistEntity entity+ , PersistEntityBackend entity ~ BaseBackend backend+ , Arbitrary entity+ , PersistStoreWrite backend+ , PersistStoreWrite (BaseBackend backend)+ , PersistQueryWrite (BaseBackend backend)+ , PersistQueryWrite backend+ , MonadFail m+ , MonadIO m+ , SafeToInsert entity+ ) => (db () -> IO ()) -- ^ DB Runner -> Maybe (db [Text])@@ -106,34 +116,39 @@ -> (entity -> Double) -> Spec specsWith runDb mmigration checks apprxChecks doubleFn = describe "data type specs" $- it "handles all types" $ asIO $ runDb $ do-- _ <- sequence_ mmigration- -- Ensure reading the data from the database works...- _ <- sequence_ mmigration- cleanDB'- rvals <- liftIO $ randomValues 1000- for_ rvals $ \x -> do- key <- insert x- Just y <- get key- liftIO $ do- let check :: (Eq a, Show a, HasCallStack) => String -> (entity -> a) -> IO ()- check s f = (s, f x) @=? (s, f y)- -- Check floating-point near equality- let check' :: (Fractional p, Show p, Real p, HasCallStack) => String -> (entity -> p) -> 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- for_ checks $ \(TestFn msg f) -> check msg f- for_ apprxChecks $ \(msg, f) -> check' msg f+ it "handles all types" $+ asIO $+ runDb $ do+ _ <- sequence_ mmigration+ -- Ensure reading the data from the database works...+ _ <- sequence_ mmigration+ cleanDB'+ rvals <- liftIO $ randomValues 1000+ for_ rvals $ \x -> do+ key <- insert x+ Just y <- get key+ liftIO $ do+ let+ check :: (Eq a, Show a, HasCallStack) => String -> (entity -> a) -> IO ()+ check s f = (s, f x) @=? (s, f y)+ -- Check floating-point near equality+ let+ check'+ :: (Fractional p, Show p, Real p, HasCallStack) => String -> (entity -> p) -> 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+ for_ checks $ \(TestFn msg f) -> check msg f+ for_ apprxChecks $ \(msg, f) -> check' msg f - -- Do a special check for Double since it may- -- lose precision when serialized.- when (getDoubleDiff (doubleFn x) (doubleFn y) > 1e-14) $- check "double" doubleFn- 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)+ -- Do a special check for Double since it may+ -- lose precision when serialized.+ when (getDoubleDiff (doubleFn x) (doubleFn y) > 1e-14) $+ check "double" doubleFn+ 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)
src/EmbedOrderTest.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}+ module EmbedOrderTest (specsWith, embedOrderMigrate, cleanDB) where import qualified Data.Map as Map@@ -8,10 +9,12 @@ import Init -debug :: Show s => s -> s+debug :: (Show s) => s -> s debug x = trace (show x) x -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "embedOrderMigrate"] [persistUpperCase|+share+ [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "embedOrderMigrate"]+ [persistUpperCase| Foo sql=foo_embed_order bars [Bar] deriving Eq Show@@ -22,23 +25,25 @@ deriving Eq Show |] -cleanDB :: Runner backend m => ReaderT backend m ()+cleanDB :: (Runner backend m) => ReaderT backend m () cleanDB = do- deleteWhere ([] :: [Filter (FooGeneric backend)])- deleteWhere ([] :: [Filter (BarGeneric backend)])+ deleteWhere ([] :: [Filter (FooGeneric backend)])+ deleteWhere ([] :: [Filter (BarGeneric backend)]) -specsWith :: Runner backend m => RunDb backend m -> Spec+specsWith :: (Runner backend m) => RunDb backend m -> Spec specsWith db = describe "embedded entities" $ do it "preserves ordering" $ db $ do- let foo = Foo [Bar "b" "u" "g"]+ let+ foo = Foo [Bar "b" "u" "g"] fooId <- insert foo Just otherFoo <- get fooId foo @== otherFoo it "PersistMap PersistValue serializaion" $ db $ do- let record = Map.fromList [("b" :: Text,"b" :: Text),("u","u"),("g","g")]+ let+ record = Map.fromList [("b" :: Text, "b" :: Text), ("u", "u"), ("g", "g")] record @== (fromRight . fromPersistValue . toPersistValue) record -fromRight :: Show a => Either a b -> b+fromRight :: (Show a) => Either a b -> b fromRight (Left e) = error $ "expected Right, got Left " ++ show e fromRight (Right x) = x
src/EmbedTest.hs view
@@ -1,14 +1,15 @@-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans -O0 #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}+ module EmbedTest (specsWith, cleanDB, embedMigrate) where import Control.Exception (Exception, throw) import Data.List.NonEmpty hiding (insert, length) import qualified Data.Map as M-import qualified Data.Text as T import qualified Data.Set as S+import qualified Data.Text as T import EntityEmbedTest import Init@@ -17,19 +18,20 @@ deriving (Show, Eq) instance Exception TestException -instance PersistFieldSql a => PersistFieldSql (NonEmpty a) where+instance (PersistFieldSql a) => PersistFieldSql (NonEmpty a) where sqlType _ = SqlString -instance PersistField a => PersistField (NonEmpty a) where+instance (PersistField a) => PersistField (NonEmpty a) where toPersistValue = toPersistValue . toList fromPersistValue pv = do xs <- fromPersistValue pv case xs of [] -> Left "PersistField: NonEmpty found unexpected Empty List"- (l:ls) -> Right (l:|ls)-+ (l : ls) -> Right (l :| ls) -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "embedMigrate"] [persistUpperCase|+share+ [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "embedMigrate"]+ [persistUpperCase| OnlyName name Text@@ -136,130 +138,161 @@ -- SelfDirect -- reference SelfDirect |]-cleanDB :: (PersistQuery backend, PersistEntityBackend HasMap ~ backend, MonadIO m) => ReaderT backend m ()+cleanDB+ :: (PersistQuery backend, PersistEntityBackend HasMap ~ backend, MonadIO m)+ => ReaderT backend m () cleanDB = do- deleteWhere ([] :: [Filter (HasEmbedGeneric backend)])- deleteWhere ([] :: [Filter (HasEmbedsGeneric backend)])- deleteWhere ([] :: [Filter (HasListEmbedGeneric backend)])- deleteWhere ([] :: [Filter (HasSetEmbedGeneric backend)])- deleteWhere ([] :: [Filter (UserGeneric backend)])- deleteWhere ([] :: [Filter (HasMapGeneric backend)])- deleteWhere ([] :: [Filter (HasListGeneric backend)])- deleteWhere ([] :: [Filter (EmbedsHasMapGeneric backend)])- deleteWhere ([] :: [Filter (ListEmbedGeneric backend)])- deleteWhere ([] :: [Filter (ARecordGeneric backend)])- deleteWhere ([] :: [Filter (AccountGeneric backend)])- deleteWhere ([] :: [Filter (HasNestedListGeneric backend)])+ deleteWhere ([] :: [Filter (HasEmbedGeneric backend)])+ deleteWhere ([] :: [Filter (HasEmbedsGeneric backend)])+ deleteWhere ([] :: [Filter (HasListEmbedGeneric backend)])+ deleteWhere ([] :: [Filter (HasSetEmbedGeneric backend)])+ deleteWhere ([] :: [Filter (UserGeneric backend)])+ deleteWhere ([] :: [Filter (HasMapGeneric backend)])+ deleteWhere ([] :: [Filter (HasListGeneric backend)])+ deleteWhere ([] :: [Filter (EmbedsHasMapGeneric backend)])+ deleteWhere ([] :: [Filter (ListEmbedGeneric backend)])+ deleteWhere ([] :: [Filter (ARecordGeneric backend)])+ deleteWhere ([] :: [Filter (AccountGeneric backend)])+ deleteWhere ([] :: [Filter (HasNestedListGeneric backend)]) -_unlessM :: MonadIO m => IO Bool -> m () -> m ()+_unlessM :: (MonadIO m) => IO Bool -> m () -> m () _unlessM predicate body = do b <- liftIO predicate unless b body -specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec+specsWith :: (Runner SqlBackend m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "embedded entities" $ do-- it "simple entities" $ runDb $ do- let container = HasEmbeds "container" (OnlyName "2")- (HasEmbed "embed" (OnlyName "1"))- contK <- insert container- Just res <- selectFirst [HasEmbedsName ==. "container"] []- res @== Entity contK container+ it "simple entities" $ runDb $ 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" $ runDb $ do- let container = HasEmbed "container" (OnlyName "2")- contK <- insert container- Just res <- selectFirst [HasEmbedEmbed ==. OnlyName "2"] []- res @== Entity contK container+ it "query for equality of embeded entity" $ runDb $ do+ let+ container = HasEmbed "container" (OnlyName "2")+ contK <- insert container+ Just res <- selectFirst [HasEmbedEmbed ==. OnlyName "2"] []+ res @== Entity contK container - it "Set" $ runDb $ 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" $ runDb $ 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" $ runDb $ do- let container = HasSetEmbed "set empty" $ S.fromList []- contK <- insert container- Just res <- selectFirst [HasSetEmbedName ==. "set empty"] []- res @== Entity contK container+ it "Set empty" $ runDb $ 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) $ runDb $ 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 "exception" $ flip shouldThrow (== TestException) $ runDb $ 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" $ runDb $ 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" $ runDb $ 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" $ runDb $ do- let container = HasListEmbed "list empty" []- contK <- insert container- Just res <- selectFirst [HasListEmbedName ==. "list empty"] []- res @== Entity contK container+ it "ListEmbed empty" $ runDb $ do+ let+ container = HasListEmbed "list empty" []+ contK <- insert container+ Just res <- selectFirst [HasListEmbedName ==. "list empty"] []+ res @== Entity contK container - it "List empty" $ runDb $ do- let container = HasList []- contK <- insert container- Just res <- selectFirst [] []- res @== Entity contK container+ it "List empty" $ runDb $ do+ let+ container = HasList []+ contK <- insert container+ Just res <- selectFirst [] []+ res @== Entity contK container - it "NonEmpty List wrapper" $ runDb $ 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 "NonEmpty List wrapper" $ runDb $ 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" $ runDb $ 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" $ runDb $ 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" $ runDb $ do- let container = HasMap "empty" $ M.fromList []- contK <- insert container- Just res <- selectFirst [HasMapName ==. "empty"] []- res @== Entity contK container+ it "Map empty" $ runDb $ do+ let+ container = HasMap "empty" $ M.fromList []+ contK <- insert container+ Just res <- selectFirst [HasMapName ==. "empty"] []+ res @== Entity contK container - it "Embeds a Map" $ runDb $ 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" $ runDb $ 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" $ runDb $ 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 empty" $ runDb $ 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" $ runDb $ do- onId <- insert $ OnlyName "nombre"- onId2 <- insert $ OnlyName "nombre2"- let midValue = MapIdValue $ M.fromList [("foo", onId),("bar",onId2)]- mK <- insert midValue- Just mv <- get mK- mv @== midValue+ it "Embeds a Map with ids as values" $ runDb $ 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
src/EmptyEntityTest.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}+ module EmptyEntityTest (specsWith, migration, cleanDB) where import Database.Persist.Sql@@ -9,29 +10,32 @@ import Init -- Test lower case names-share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migration"] [persistLowerCase|+share+ [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "migration"]+ [persistLowerCase| EmptyEntity |] cleanDB- ::- ( PersistQueryWrite backend- , MonadIO m- , PersistStoreWrite (BaseBackend backend)- )+ :: ( PersistQueryWrite backend+ , MonadIO m+ , PersistStoreWrite (BaseBackend backend)+ ) => ReaderT backend m () cleanDB = deleteWhere ([] :: [Filter (EmptyEntityGeneric backend)]) specsWith- :: Runner backend m+ :: (Runner backend m) => RunDb backend m -> Maybe (ReaderT backend m a) -> Spec specsWith runConn mmigrate = describe "empty entity" $- it "inserts" $ asIO $ runConn $ do- _ <- sequence_ mmigrate- -- Ensure reading the data from the database works...- _ <- sequence_ mmigrate- x <- insert EmptyEntity- Just EmptyEntity <- get x- return ()+ it "inserts" $+ asIO $+ runConn $ do+ _ <- sequence_ mmigrate+ -- Ensure reading the data from the database works...+ _ <- sequence_ mmigrate+ x <- insert EmptyEntity+ Just EmptyEntity <- get x+ return ()
src/EntityEmbedTest.hs view
@@ -1,12 +1,15 @@-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+ module EntityEmbedTest where -- because we are using a type alias we need to declare in a separate module -- this is used in EmbedTest import Init -mkPersist persistSettings { mpsGeneric = True } [persistUpperCase|+mkPersist+ persistSettings{mpsGeneric = True}+ [persistUpperCase| ARecord name Text deriving Show Eq Read Ord
src/EquivalentTypeTest.hs view
@@ -10,19 +10,23 @@ import Database.Persist.TH import Init -share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase|+share+ [mkPersist sqlSettings, mkMigrate "migrateAll1"]+ [persistLowerCase| EquivalentType sql=equivalent_types field1 Int deriving Eq Show |] -share [mkPersist sqlSettings, mkMigrate "migrateAll2"] [persistLowerCase|+share+ [mkPersist sqlSettings, mkMigrate "migrateAll2"]+ [persistLowerCase| EquivalentType2 sql=equivalent_types field1 Int deriving Eq Show |] -specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec+specsWith :: (Runner SqlBackend m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "doesn't migrate equivalent types" $ do it "works" $ runDb $ do _ <- runMigrationSilent migrateAll1
src/ForeignKey.hs view
@@ -1,18 +1,23 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE AllowAmbiguousTypes, GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables, TypeApplications, UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module ForeignKey where -import Data.Proxy import qualified Data.List as List+import Data.Proxy import Init import Database.Persist.EntityDef.Internal (entityExtra) -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs-share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate"] [persistLowerCase|+share+ [mkPersist persistSettings{mpsGeneric = False}, mkMigrate "compositeMigrate"]+ [persistLowerCase| SimpleCascadeChild ref SimpleCascadeId OnDeleteCascade deriving Show Eq@@ -109,7 +114,8 @@ insert_ $ Child 1 delete kf cs <- selectList [] []- let expected = [] :: [Entity Child]+ let+ expected = [] :: [Entity Child] cs @== expected it "update cascades" $ runDb $ do kf <- insert $ Parent 1@@ -122,14 +128,16 @@ insert_ $ ChildComposite 1 2 delete kf cs <- selectList [] []- let expected = [] :: [Entity ChildComposite]+ let+ expected = [] :: [Entity ChildComposite] cs @== expected it "delete self referenced cascades" $ runDb $ do kf <- insert $ SelfReferenced 1 1 insert_ $ SelfReferenced 2 1 delete kf srs <- selectList [] []- let expected = [] :: [Entity SelfReferenced]+ let+ expected = [] :: [Entity SelfReferenced] srs @== expected it "delete cascade works on simple references" $ runDb $ do scId <- insert $ SimpleCascade 1@@ -147,7 +155,8 @@ delete kf return () cs <- selectList [] []- let expected = [] :: [Entity B]+ let+ expected = [] :: [Entity B] cs @== expected it "delete cascades with explicit Composite Reference" $ runDb $ do kf <- insert $ AComposite 1 20@@ -155,7 +164,8 @@ delete kf return () cs <- selectList [] []- let expected = [] :: [Entity B]+ let+ expected = [] :: [Entity B] cs @== expected it "delete cascades with explicit Composite Reference" $ runDb $ do kf <- insert $ AComposite 1 20@@ -163,7 +173,8 @@ delete kf return () cs <- selectList [] []- let expected = [] :: [Entity B]+ let+ expected = [] :: [Entity B] cs @== expected it "delete cascades with explicit Id field" $ runDb $ do kf <- insert $ A 1 20@@ -171,14 +182,16 @@ delete kf return () cs <- selectList [] []- let expected = [] :: [Entity B]+ let+ expected = [] :: [Entity B] cs @== expected it "deletes sets null with self reference" $ runDb $ do kf <- insert $ Chain 1 Nothing kf' <- insert $ Chain 2 (Just kf) delete kf cs <- selectList [] []- let expected = [Entity {entityKey = kf', entityVal = Chain 2 Nothing}]+ let+ expected = [Entity{entityKey = kf', entityVal = Chain 2 Nothing}] List.sort cs @== List.sort expected it "deletes cascades with self reference to the whole chain" $ runDb $ do k1 <- insert $ Chain2 1 Nothing@@ -186,7 +199,8 @@ insert_ $ Chain2 3 (Just k2) delete k1 cs <- selectList [] []- let expected = [] :: [Entity Chain2]+ let+ expected = [] :: [Entity Chain2] cs @== expected it "deletes cascades with field self reference to the whole chain" $ runDb $ do k1 <- insert $ Chain3 1 Nothing@@ -194,28 +208,30 @@ insert_ $ Chain3 3 (Just k2) delete k1 cs <- selectList [] []- let expected = [] :: [Entity Chain3]+ let+ expected = [] :: [Entity Chain3] cs @== expected describe "EntityDef" $ do- let ed =+ let+ ed = entityDef (Proxy @SimpleCascadeChild) isRefCol = (FieldNameHS "ref" ==) . fieldHaskell- expected = FieldCascade- { fcOnUpdate = Nothing- , fcOnDelete = Just Cascade- }+ expected =+ FieldCascade+ { fcOnUpdate = Nothing+ , fcOnDelete = Just Cascade+ } Just refField = List.find isRefCol (getEntityFields ed) - it "parses into fieldCascade" $ do+ it "parses into fieldCascade" $ do fieldCascade refField `shouldBe` expected it "shouldn't have cascade in extras" $ do entityExtra ed- `shouldBe`- mempty+ `shouldBe` mempty cleanDB :: (MonadIO m) => SqlPersistT m () cleanDB = do@@ -237,10 +253,10 @@ del @Chain2 del- :: forall a m.- ( PersistEntity a- , PersistEntityBackend a ~ SqlBackend- , MonadIO m- )+ :: forall a m+ . ( PersistEntity a+ , PersistEntityBackend a ~ SqlBackend+ , MonadIO m+ ) => SqlPersistT m () del = deleteWhere @_ @_ @a []
src/GeneratedColumnTestSQL.hs view
@@ -2,12 +2,15 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}+ module GeneratedColumnTestSQL (specsWith) where import Database.Persist.TH import Init -share [mkPersist sqlSettings, mkMigrate "migrate1"] [persistLowerCase|+share+ [mkPersist sqlSettings, mkMigrate "migrate1"]+ [persistLowerCase| GenTest sql=gen_test fieldOne Text Maybe fieldTwo Text Maybe@@ -19,31 +22,34 @@ cromulence Int generated=5 |] -share [mkPersist sqlSettings, mkMigrate "migrate2"] [persistLowerCase|+share+ [mkPersist sqlSettings, mkMigrate "migrate2"]+ [persistLowerCase| MigrateTestV2 sql=gen_migrate_test sickness Int generated=3 cromulence Int |] -specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec+specsWith :: (Runner SqlBackend m) => RunDb SqlBackend m -> Spec specsWith runDB = describe "PersistLiteral field" $ do it "should read a generated column" $ runDB $ do rawExecute "DROP TABLE IF EXISTS gen_test;" [] rawExecute "DROP TABLE IF EXISTS gen_migrate_test;" [] runMigration migrate1 - insert_ GenTest- { genTestFieldOne = Just "like, literally this exact string"- , genTestFieldTwo = Just "like, totally some other string"- , genTestFieldThree = Nothing- }+ insert_+ GenTest+ { genTestFieldOne = Just "like, literally this exact string"+ , genTestFieldTwo = Just "like, totally some other string"+ , genTestFieldThree = Nothing+ } Just (Entity _ GenTest{..}) <- selectFirst [] [] liftIO $ genTestFieldThree @?= Just "like, literally this exact string" k1 <- insert $ MigrateTestV1 0 0 Just (MigrateTestV1 sickness1 cromulence1) <- get k1 liftIO $ sickness1 @?= 0- liftIO $ cromulence1 @?= 5+ liftIO $ cromulence1 @?= 5 it "should support adding or removing generation expressions from columns" $ runDB $ do runMigration migrate2
src/HtmlTest.hs view
@@ -1,29 +1,33 @@-{-# LANGUAGE DataKinds, UndecidableInstances #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}+ module HtmlTest (specsWith, cleanDB, htmlMigrate) where -import Data.Char (generalCategory, GeneralCategory(..))+import Data.Char (GeneralCategory (..), generalCategory) import qualified Data.Text as T-import System.Random (randomIO, randomRIO, Random)+import System.Random (Random, randomIO, randomRIO) import Text.Blaze.Html import Text.Blaze.Html.Renderer.Text import Init -- Test lower case names-share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "htmlMigrate"] [persistLowerCase|+share+ [mkPersist persistSettings{mpsGeneric = True}, mkMigrate "htmlMigrate"]+ [persistLowerCase| HtmlTable html Html deriving |] -cleanDB :: Runner backend m => ReaderT backend m ()+cleanDB :: (Runner backend m) => ReaderT backend m () cleanDB = do- deleteWhere ([] :: [Filter (HtmlTableGeneric backend)])+ deleteWhere ([] :: [Filter (HtmlTableGeneric backend)]) specsWith- :: Runner backend m+ :: (Runner backend m) => RunDb backend m -> Maybe (ReaderT backend m a) -> Spec@@ -42,15 +46,16 @@ randomValue :: IO Html randomValue =- preEscapedToMarkup- . T.pack- . filter ((`notElem` forbidden) . generalCategory)- . filter (<= '\xFFFF') -- only BMP- . filter (/= '\0') -- no nulls- <$> randomIOs- where forbidden = [NotAssigned, PrivateUse]+ preEscapedToMarkup+ . T.pack+ . filter ((`notElem` forbidden) . generalCategory)+ . filter (<= '\xFFFF') -- only BMP+ . filter (/= '\0') -- no nulls+ <$> randomIOs+ where+ forbidden = [NotAssigned, PrivateUse] -randomIOs :: Random a => IO [a]+randomIOs :: (Random a) => IO [a] randomIOs = do len <- randomRIO (0, 20) sequence $ replicate len randomIO
src/Init.hs view
@@ -8,46 +8,52 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | This will hopefully be the only module with CPP in it.-module Init (- (@/=), (@==), (==@)- , asIO- , assertNotEqual- , assertNotEmpty- , assertEmpty- , isTravis-- , module Database.Persist.Sql- , persistSettings- , MkPersistSettings (..)- , BackendKey(..)- , GenerateKey(..)-- , RunDb- , Runner- -- re-exports- , module Database.Persist- , module Test.Hspec- , module Test.HUnit- , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase- , Int32, Int64- , Text- , module Control.Monad.Reader- , module Control.Monad- , module Control.Monad.IO.Unlift- , BS.ByteString- , SomeException- , MonadFail- , TestFn(..)- , truncateTimeOfDay- , truncateToMicro- , truncateUTCTime- , arbText- , liftA2- , changeBackend- , Proxy(..)- , UUID(..)- , sqlSettingsUuid- ) where+module Init+ ( (@/=)+ , (@==)+ , (==@)+ , asIO+ , assertNotEqual+ , assertNotEmpty+ , assertEmpty+ , isTravis+ , module Database.Persist.Sql+ , persistSettings+ , MkPersistSettings (..)+ , BackendKey (..)+ , GenerateKey (..)+ , RunDb+ , Runner+ -- re-exports+ , module Database.Persist+ , module Test.Hspec+ , module Test.HUnit+ , mkPersist+ , mkMigrate+ , share+ , sqlSettings+ , persistLowerCase+ , persistUpperCase+ , Int32+ , Int64+ , Text+ , module Control.Monad.Reader+ , module Control.Monad+ , module Control.Monad.IO.Unlift+ , BS.ByteString+ , SomeException+ , MonadFail+ , TestFn (..)+ , truncateTimeOfDay+ , truncateToMicro+ , truncateUTCTime+ , arbText+ , liftA2+ , changeBackend+ , Proxy (..)+ , UUID (..)+ , sqlSettingsUuid+ ) where #if !MIN_VERSION_monad_logger(0,3,30) -- Needed for GHC versions 7.10.3. Can drop when we drop support for GHC@@ -72,7 +78,7 @@ import Control.Monad (forM_, liftM, replicateM, void, when) import Control.Monad.Fail (MonadFail) import Control.Monad.Reader-import Data.Char (GeneralCategory(..), generalCategory)+import Data.Char (GeneralCategory (..), generalCategory) import Data.Fixed (Micro, Pico) import Data.Proxy import Data.String (IsString, fromString)@@ -81,19 +87,19 @@ import Test.Hspec import Test.QuickCheck.Instances () -import Data.Aeson (FromJSON, ToJSON, Value(..))+import Data.Aeson (FromJSON, ToJSON, Value (..)) import qualified Data.Text.Encoding as TE import Database.Persist.ImplicitIdDef (mkImplicitIdDef) import Database.Persist.TH- ( MkPersistSettings(..)- , mkMigrate- , mkPersist- , persistLowerCase- , persistUpperCase- , setImplicitIdDef- , share- , sqlSettings- )+ ( MkPersistSettings (..)+ , mkMigrate+ , mkPersist+ , persistLowerCase+ , persistUpperCase+ , setImplicitIdDef+ , share+ , sqlSettings+ ) import Web.Internal.HttpApiData import Web.PathPieces @@ -116,12 +122,11 @@ -- Data types import Data.Int (Int32, Int64) - asIO :: IO a -> IO a asIO a = a (@/=), (@==), (==@) :: (HasCallStack, Eq a, Show a, MonadIO m) => a -> a -> m ()-infix 1 @/= --, /=@+infix 1 @/= -- , /=@ actual @/= expected = liftIO $ assertNotEqual "" expected actual infix 1 @==, ==@@@ -132,12 +137,16 @@ expected /=@ actual = liftIO $ assertNotEqual "" expected actual -} - assertNotEqual :: (Eq a, Show a, HasCallStack) => 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+ unless (actual /= expected) (assertFailure msg)+ where+ msg =+ (if null preface then "" else preface ++ "\n")+ ++ "expected: "+ ++ show expected+ ++ "\n to not equal: "+ ++ show actual assertEmpty :: (MonadIO m) => [a] -> m () assertEmpty xs = liftIO $ assertBool "" (null xs)@@ -149,25 +158,24 @@ isTravis = isCI isCI :: IO Bool-isCI = do+isCI = do env <- liftIO getEnvironment return $ case lookup "TRAVIS" env <|> lookup "CI" env of Just "true" -> True _ -> False - persistSettings :: MkPersistSettings-persistSettings = sqlSettings { mpsGeneric = True }+persistSettings = sqlSettings{mpsGeneric = True} instance Arbitrary PersistValue where arbitrary = PersistInt64 `fmap` choose (0, maxBound) -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+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 class GenerateKey backend where generateKey :: IO (BackendKey backend)@@ -199,36 +207,44 @@ truncateTimeOfDay :: TimeOfDay -> Gen TimeOfDay truncateTimeOfDay (TimeOfDay h m s) =- return $ TimeOfDay h m $ truncateToMicro s+ return $ TimeOfDay h m $ truncateToMicro s -- truncate less significant digits truncateToMicro :: Pico -> Pico-truncateToMicro p = let- p' = fromRational . toRational $ p :: Micro- in fromRational . toRational $ p' :: Pico+truncateToMicro p =+ let+ p' = fromRational . toRational $ p :: Micro+ in+ fromRational . toRational $ p' :: Pico 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+ 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 -arbText :: IsString s => Gen s+arbText :: (IsString s) => Gen s arbText =- fromString- . filter ((`notElem` forbidden) . generalCategory)- . filter (<= '\xFFFF') -- only BMP- . filter (/= '\0') -- no nulls- . T.unpack- <$> arbitrary- where forbidden = [NotAssigned, PrivateUse]+ fromString+ . filter ((`notElem` forbidden) . generalCategory)+ . filter (<= '\xFFFF') -- only BMP+ . filter (/= '\0') -- no nulls+ . T.unpack+ <$> arbitrary+ where+ forbidden = [NotAssigned, PrivateUse] type Runner backend m =- ( MonadIO m, MonadUnliftIO m, MonadFail m- , MonadThrow m, MonadBaseControl IO m- , PersistStoreWrite backend, PersistStoreWrite (BaseBackend backend)+ ( MonadIO m+ , MonadUnliftIO m+ , MonadFail m+ , MonadThrow m+ , MonadBaseControl IO m+ , PersistStoreWrite backend+ , PersistStoreWrite (BaseBackend backend) , GenerateKey backend , HasPersistBackend backend , PersistUniqueWrite backend@@ -240,7 +256,8 @@ type RunDb backend m = ReaderT backend m () -> IO () changeBackend- :: forall backend backend' m. MonadUnliftIO m+ :: forall backend backend' m+ . (MonadUnliftIO m) => (backend -> backend') -> RunDb backend m -> RunDb backend' m@@ -270,7 +287,7 @@ -- * For implicit ID spec -newtype UUID = UUID { unUUID :: Text }+newtype UUID = UUID {unUUID :: Text} deriving stock (Show, Eq, Ord, Read) deriving newtype@@ -293,7 +310,7 @@ sqlSettingsUuid defExpr = let uuidDef =- mkImplicitIdDef @UUID defExpr+ mkImplicitIdDef @UUID defExpr settings = setImplicitIdDef uuidDef sqlSettings in
src/LargeNumberTest.hs view
@@ -1,12 +1,15 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+ module LargeNumberTest where import Data.Word import Init -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "numberMigrate"] [persistLowerCase|+share+ [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "numberMigrate"]+ [persistLowerCase| Number intx Int int32 Int32@@ -17,27 +20,27 @@ |] cleanDB- :: Runner backend m => ReaderT backend m ()+ :: (Runner backend m) => ReaderT backend m () cleanDB = do- deleteWhere ([] :: [Filter (NumberGeneric backend)])+ deleteWhere ([] :: [Filter (NumberGeneric backend)]) -specsWith :: Runner backend m => RunDb backend m -> Spec+specsWith :: (Runner backend m) => RunDb backend m -> Spec specsWith runDb = describe "Large Numbers" $ do- it "preserves their values in the database" $ runDb $ 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+ it "preserves their values in the database" $ runDb $ do+ let+ go x = do+ xid <- insert x+ x' <- get xid+ liftIO $ x' @?= Just x - 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+ 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
src/LongIdentifierTest.hs view
@@ -11,6 +11,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+ module LongIdentifierTest where import Database.Persist.TH@@ -19,7 +20,9 @@ -- This test creates very long identifier names. The generated foreign key is over the length limit for Postgres and MySQL -- persistent-postgresql handles this by truncating foreign key names using the same algorithm that Postgres itself does (see 'refName' in Postgresql.hs) -- MySQL currently doesn't run this test, and needs truncation logic for it to pass.-share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase|+share+ [mkPersist sqlSettings, mkMigrate "migration"]+ [persistLowerCase| TableAnExtremelyFantasticallySuperLongNameParent field1 Int TableAnExtremelyFantasticallySuperLongNameChild@@ -30,9 +33,9 @@ specsWith runDb = describe "Long identifiers" $ do -- See 'refName' in Postgresql.hs for why these tests are necessary. it "migrating is idempotent" $ runDb $ do- again <- getMigration migration- liftIO $ again @?= []+ again <- getMigration migration+ liftIO $ again @?= [] it "migrating really is idempotent" $ runDb $ do- runMigration migration- again <- getMigration migration- liftIO $ again @?= []+ runMigration migration+ again <- getMigration migration+ liftIO $ again @?= []
src/MaxLenTest.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module MaxLenTest (specsWith, maxlenMigrate) where@@ -8,7 +8,9 @@ import Init -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "maxlenMigrate"] [persistLowerCase|+share+ [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "maxlenMigrate"]+ [persistLowerCase| MaxLen text1 Text text2 Text maxlen=3@@ -25,22 +27,23 @@ deriving Show Eq |] -specsWith :: Runner backend m => RunDb backend m -> Spec+specsWith :: (Runner backend m) => RunDb backend m -> Spec specsWith runDb = describe "Maximum length attribute" $ do- it "truncates values that are too long" $ runDb $ 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'-+ it "truncates values that are too long" $ runDb $ 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'
src/MaybeFieldDefsTest.hs view
@@ -9,7 +9,9 @@ import Init -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "maybeFieldDefMigrate"] [persistLowerCase|+share+ [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "maybeFieldDefMigrate"]+ [persistLowerCase| MaybeFieldDefEntity optionalString (Maybe String) optionalInt (Maybe Int)@@ -18,10 +20,10 @@ specsWith :: (Runner backend m) => RunDb backend m -> Spec specsWith runDb = describe "Maybe Field Definitions" $ do- it "runs appropriate migrations" $ runDb $ do- emptyEntity <- insert $ MaybeFieldDefEntity Nothing Nothing- emptyResult <- get emptyEntity- liftIO $ emptyResult @?= Just (MaybeFieldDefEntity Nothing Nothing)- populatedEntity <- insert $ MaybeFieldDefEntity (Just "text") (Just 8)- populatedResult <- get populatedEntity- liftIO $ populatedResult @?= Just (MaybeFieldDefEntity (Just "text") (Just 8))+ it "runs appropriate migrations" $ runDb $ do+ emptyEntity <- insert $ MaybeFieldDefEntity Nothing Nothing+ emptyResult <- get emptyEntity+ liftIO $ emptyResult @?= Just (MaybeFieldDefEntity Nothing Nothing)+ populatedEntity <- insert $ MaybeFieldDefEntity (Just "text") (Just 8)+ populatedResult <- get populatedEntity+ liftIO $ populatedResult @?= Just (MaybeFieldDefEntity (Just "text") (Just 8))
src/MigrationColumnLengthTest.hs view
@@ -1,20 +1,23 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+ module MigrationColumnLengthTest where import qualified Data.Text as T import Init -share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase|+share+ [mkPersist sqlSettings, mkMigrate "migration"]+ [persistLowerCase| VaryingLengths field1 Int field2 T.Text sqltype=varchar(5) |] -specsWith :: MonadIO m => RunDb SqlBackend m -> Spec+specsWith :: (MonadIO m) => RunDb SqlBackend m -> Spec specsWith runDb =- it "is idempotent" $ runDb $ do- again <- getMigration migration- liftIO $ again @?= []+ it "is idempotent" $ runDb $ do+ again <- getMigration migration+ liftIO $ again @?= []
src/MigrationIdempotencyTest.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+ module MigrationIdempotencyTest where import Data.Int (Int32, Int64)@@ -9,7 +10,9 @@ import Database.Persist.TH import Init -share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase|+share+ [mkPersist sqlSettings, mkMigrate "migration"]+ [persistLowerCase| Idempotency field1 Int64 field2 T.Text sqltype=varchar(5)@@ -24,6 +27,6 @@ specsWith :: (MonadIO m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "MySQL migration with backend-specific sqltypes" $ do- it "is idempotent" $ runDb $ do- again <- getMigration migration- liftIO $ again @?= []+ it "is idempotent" $ runDb $ do+ again <- getMigration migration+ liftIO $ again @?= []
src/MigrationOnlyTest.hs view
@@ -1,16 +1,19 @@-{-# LANGUAGE TypeApplications, TypeOperators, UndecidableInstances #-}-+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module MigrationOnlyTest (specsWith, migrateAll1, migrateAll2) where import qualified Data.Text as T +import Database.Persist.EntityDef import Database.Persist.TH import Init-import Database.Persist.EntityDef -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll1"] [persistLowerCase|+share+ [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "migrateAll1"]+ [persistLowerCase| TwoField1 sql=two_field field1 Int field2 T.Text@@ -18,7 +21,9 @@ deriving Eq Show |] -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll2"] [persistLowerCase|+share+ [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "migrateAll2"]+ [persistLowerCase| TwoField field1 Int field2 T.Text@@ -31,7 +36,11 @@ |] specsWith- :: (MonadIO m, PersistQueryWrite backend, PersistStoreWrite backend, PersistQueryWrite (BaseBackend backend))+ :: ( MonadIO m+ , PersistQueryWrite backend+ , PersistStoreWrite backend+ , PersistQueryWrite (BaseBackend backend)+ ) => RunDb backend m -> Maybe (ReaderT backend m a) -> Spec@@ -60,7 +69,8 @@ it "doesn't have the field in the Haskell entity" $ asIO $ runDb $ do sequence_ mmigrate sequence_ mmigrate- let tf = TwoField 5 "hello"+ let+ tf = TwoField 5 "hello" tid <- insert tf mtf <- get tid liftIO $ mtf @?= Just tf
src/MigrationTest.hs view
@@ -1,14 +1,17 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+ module MigrationTest where -import Database.Persist.TH import qualified Data.Text as T+import Database.Persist.TH import Init -share [mkPersist sqlSettings, mkMigrate "migrationMigrate"] [persistLowerCase|+share+ [mkPersist sqlSettings, mkMigrate "migrationMigrate"]+ [persistLowerCase| Target field1 Int field2 T.Text@@ -24,7 +27,9 @@ Primary pk |] -share [mkPersist sqlSettings, mkMigrate "migrationAddCol"] [persistLowerCase|+share+ [mkPersist sqlSettings, mkMigrate "migrationAddCol"]+ [persistLowerCase| Target1 sql=target field1 Int field2 T.Text@@ -40,17 +45,17 @@ specsWith :: (MonadUnliftIO m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "Migration" $ do it "is idempotent" $ runDb $ do- again <- getMigration migrationMigrate- liftIO $ again @?= []+ again <- getMigration migrationMigrate+ liftIO $ again @?= [] it "really is idempotent" $ runDb $ do- void $ runMigrationSilent migrationMigrate- void $ runMigrationSilent migrationMigrate- again <- getMigration migrationMigrate- liftIO $ again @?= []+ void $ runMigrationSilent migrationMigrate+ void $ runMigrationSilent migrationMigrate+ again <- getMigration migrationMigrate+ liftIO $ again @?= [] it "can add an extra column" $ runDb $ 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.- void $ runMigrationSilent migrationAddCol- again <- getMigration migrationAddCol- liftIO $ again @?= []+ -- 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.+ void $ runMigrationSilent migrationAddCol+ again <- getMigration migrationAddCol+ liftIO $ again @?= []
src/MpsCustomPrefixTest.hs view
@@ -3,30 +3,31 @@ import Init import PersistentTestModels -specsWith :: MonadIO m => RunDb SqlBackend m -> Spec+specsWith :: (MonadIO m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "mpsCustomPrefix" $- it "works" $ runDb $ do- deleteWhere ([] :: [Filter CustomPrefix2])- deleteWhere ([] :: [Filter CustomPrefix1])- cp1a <- insert $ CustomPrefix1 1- update cp1a [CP1CustomFieldName =. 2]- cp1b <- insert $ CustomPrefix1 3- cp2 <- insert $ CustomPrefix2 4 cp1a- update cp2 [CP2CustomPrefixedRef =. cp1b, CP2OtherCustomFieldName =. 5]+ it "works" $+ runDb $ do+ deleteWhere ([] :: [Filter CustomPrefix2])+ deleteWhere ([] :: [Filter CustomPrefix1])+ cp1a <- insert $ CustomPrefix1 1+ update cp1a [CP1CustomFieldName =. 2]+ cp1b <- insert $ CustomPrefix1 3+ cp2 <- insert $ CustomPrefix2 4 cp1a+ update cp2 [CP2CustomPrefixedRef =. cp1b, CP2OtherCustomFieldName =. 5] - mcp1a <- get cp1a- liftIO $ mcp1a @?= Just (CustomPrefix1 2)- liftIO $ fmap _cp1CustomFieldName mcp1a @?= Just 2- mcp2 <- get cp2- liftIO $ fmap _cp2CustomPrefixedRef mcp2 @?= Just cp1b- liftIO $ fmap _cp2OtherCustomFieldName mcp2 @?= Just 5+ mcp1a <- get cp1a+ liftIO $ mcp1a @?= Just (CustomPrefix1 2)+ liftIO $ fmap _cp1CustomFieldName mcp1a @?= Just 2+ mcp2 <- get cp2+ liftIO $ fmap _cp2CustomPrefixedRef mcp2 @?= Just cp1b+ liftIO $ fmap _cp2OtherCustomFieldName mcp2 @?= Just 5 - cpls <- insert $ CPCustomPrefixedLeftSum 5- cprs <- insert $ CPCustomPrefixedRightSum "Hello"- update cpls [CPCustomPrefixedLeft =. 6]- update cprs [CPCustomPrefixedRight =. "World"]- mcpls <- get cpls- mcprs <- get cprs+ cpls <- insert $ CPCustomPrefixedLeftSum 5+ cprs <- insert $ CPCustomPrefixedRightSum "Hello"+ update cpls [CPCustomPrefixedLeft =. 6]+ update cprs [CPCustomPrefixedRight =. "World"]+ mcpls <- get cpls+ mcprs <- get cprs - liftIO $ mcpls @?= Just (CPCustomPrefixedLeftSum 6)- liftIO $ mcprs @?= Just (CPCustomPrefixedRightSum "World")+ liftIO $ mcpls @?= Just (CPCustomPrefixedLeftSum 6)+ liftIO $ mcprs @?= Just (CPCustomPrefixedRightSum "World")
src/MpsNoPrefixTest.hs view
@@ -3,30 +3,31 @@ import Init import PersistentTestModels -specsWith :: MonadIO m => RunDb SqlBackend m -> Spec+specsWith :: (MonadIO m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "mpsNoPrefix" $ do- it "works" $ runDb $ 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]+ it "works" $ runDb $ 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+ 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"+ insert_ $ UnprefixedLeftSum 5+ insert_ $ UnprefixedRightSum "Hello" - it "IsSqlKey instance" $ runDb $ 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+ it "IsSqlKey instance" $ runDb $ 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
src/PersistTestPetCollarType.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+ module PersistTestPetCollarType where import Data.Aeson
src/PersistUniqueTest.hs view
@@ -1,12 +1,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+ module PersistUniqueTest where import Init -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs-share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase|+share+ [mkPersist persistSettings{mpsGeneric = False}, mkMigrate "migration"]+ [persistLowerCase| Fo foo Int@@ -35,92 +38,109 @@ deriving stock instance Show (Unique Ba) deriving stock instance Eq (Unique Ba) -shouldCompile :: (OnlyOneUniqueKey OnlyPrimaryKey, AtLeastOneUniqueKey OnlyPrimaryKey) => IO ()+shouldCompile+ :: (OnlyOneUniqueKey OnlyPrimaryKey, AtLeastOneUniqueKey OnlyPrimaryKey) => IO () shouldCompile = pure () -cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Fo ~ backend) => ReaderT backend m ()+cleanDB+ :: (MonadIO m, PersistQuery backend, PersistEntityBackend Fo ~ backend)+ => ReaderT backend m () cleanDB = do- deleteWhere ([] :: [Filter Fo])+ deleteWhere ([] :: [Filter Fo]) -specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec+specsWith :: (Runner SqlBackend m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "PersistUniqueTest" $ do describe "getBy" $ do it "works to pull a record from the database" $ runDb $ do- let b = 5- k <- insert Fo { foFoo = 3, foBar = b }+ let+ b = 5+ k <- insert Fo{foFoo = 3, foBar = b} Just vk <- get k Just vu <- getBy (UniqueBar b) vu @== Entity k vk describe "existsBy" $ do it "works to query the existence of a record in the database" $ runDb $ do- let b = 5- k <- insert Fo { foFoo = 3, foBar = b }+ let+ b = 5+ k <- insert Fo{foFoo = 3, foBar = b} result <- existsBy $ UniqueBar b result @== True it "returns false for nonexistent records" $ runDb $ do- insert_ Fo { foFoo = 3, foBar = 5 }+ insert_ Fo{foFoo = 3, foBar = 5} result <- existsBy $ UniqueBar 17 result @== False describe "insertUniqueEntity" $ do it "inserts a value if no conflicts are present" $ runDb $ do- let fo = Fo 3 5+ let+ fo = Fo 3 5 Just (Entity _ insertedFoValue) <- insertUniqueEntity fo fo @== insertedFoValue it "does not insert if the record is entirely the same" $ runDb $ do- let fo = Fo 3 5+ let+ fo = Fo 3 5 Just (Entity _ insertedFoValue) <- insertUniqueEntity fo mresult <- insertUniqueEntity fo mresult @== Nothing it "does not insert if there is a primary key conflict" $ runDb $ do- let fo = Fo 3 5+ let+ fo = Fo 3 5 Just (Entity _ insertedFoValue) <- insertUniqueEntity fo- mresult <- insertUniqueEntity fo { foFoo = 4 }+ mresult <- insertUniqueEntity fo{foFoo = 4} mresult @== Nothing it "does not insert if there is a unique key conflict" $ runDb $ do- let fo = Fo 3 5+ let+ fo = Fo 3 5 Just (Entity _ insertedFoValue) <- insertUniqueEntity fo- mresult <- insertUniqueEntity fo { foBar = 4 }+ mresult <- insertUniqueEntity fo{foBar = 4} mresult @== Nothing describe "checkUniqueUpdateable" $ do describe "with standard id" $ do it "returns the unique constraint that failed" $ runDb $ do- let ba = Ba { baFoo = 1, baBaz = 2 }+ let+ ba = Ba{baFoo = 1, baBaz = 2} bk <- insert ba mresult <- checkUnique ba mresult @== Just (UniqueBaz 2) it "returns Nothing if no constraint conflict exists" $ runDb $ do- let ba = Ba { baFoo = 1, baBaz = 2 }+ let+ ba = Ba{baFoo = 1, baBaz = 2} mresult <- checkUnique ba mresult @== Nothing describe "with Primary" $ do it "conflicts with itself" $ runDb $ do- let f = 3- let b = 5- let fo = Fo f b+ let+ f = 3+ let+ b = 5+ let+ fo = Fo f b k <- insert fo mresult <- checkUnique fo mresult @== Just (FoPrimaryKey f) it "returns the key that failed" $ runDb $ do- let f = 3- let b = 5- let fo = Fo f b+ let+ f = 3+ let+ b = 5+ let+ fo = Fo f b k <- insert fo _ <- checkUnique fo -- conflicts with itself-- let fo' = Fo (f + 1) b+ let+ fo' = Fo (f + 1) b Just _ <- checkUnique fo' -- conflicts with fo Nothing <- checkUniqueUpdateable $ Entity k fo' -- but fo can be updated to fo'-- let fo'' = Fo (f + 1) (b + 1)+ let+ fo'' = Fo (f + 1) (b + 1) insert_ fo'' mresult <- checkUniqueUpdateable $ Entity k fo'' -- fo can't be updated to fo'' mresult @== Just (FoPrimaryKey (f + 1))@@ -137,7 +157,7 @@ entity <- upsert record [OnlyPrimaryKeyName =. "Hello"] entityVal entity @== record entity' <- upsert record [OnlyPrimaryKeyName =. "Hello"]- entityVal entity' @== record { onlyPrimaryKeyName = "Hello" }+ entityVal entity' @== record{onlyPrimaryKeyName = "Hello"} describe "Fo" $ do it "cannot upsert" $ runDb $ do@@ -145,13 +165,13 @@ -- _ <- upsert Fo { foFoo = 1, foBar = 2 } [FoFoo +=. 1] pure () it "can upsertBy" $ runDb $ do- let f = Fo { foFoo = 1, foBar = 2 }+ let+ f = Fo{foFoo = 1, foBar = 2} entity <- upsertBy (FoPrimaryKey 1) f [FoBar +=. 1] entityVal entity @== f entity' <- upsertBy (FoPrimaryKey 1) f [FoBar +=. 1]- entityVal entity' @== f { foBar = 1 + foBar f }+ entityVal entity' @== f{foBar = 1 + foBar f} describe "OnlyPrimaryKey" $ do it "has unique constraints" $ do shouldCompile-
src/PersistentTest.hs view
@@ -1,659 +1,759 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE RecordWildCards, UndecidableInstances #-}--module PersistentTest- ( module PersistentTest- , cleanDB- , testMigrate- , noPrefixMigrate- , customPrefixMigrate- , treeMigrate- ) where--import Control.Monad.Fail-import Control.Monad.IO.Class-import Data.Aeson-import Data.Conduit-import qualified Data.Conduit.List as CL-import Data.Functor.Constant-import Data.Functor.Identity-import qualified Data.Map as Map-import Data.Maybe (fromJust)-import Test.Hspec.QuickCheck(prop)-import Test.HUnit hiding (Test)-import UnliftIO (MonadUnliftIO, catch)-import Web.PathPieces (PathPiece (..))-import Data.Proxy (Proxy(..))--import Database.Persist-import Init-import PersistentTestModels-import PersistTestPetType-import PersistTestPetCollarType--catchPersistException :: (MonadUnliftIO m, MonadFail m) => m a -> b -> m b-catchPersistException action errValue = do- Left res <-- (Right `fmap` action) `catch`- (\(_::PersistException) -> return $ Left errValue)- return res--filterOrSpecs- :: forall m backend. Runner backend m- => RunDb backend m- -> Spec-filterOrSpecs runDb = describe "FilterOr" $ do- it "FilterOr []" $ runDb $ do- let p = Person "z" 1 Nothing- insert_ p- ps <- selectList [FilterOr []] [Desc PersonAge]- assertEmpty ps- it "||. []" $ runDb $ do- let p = Person "z" 1 Nothing- insert_ p- c <- count $ [PersonName ==. "a"] ||. []- c @== (1::Int)---- Test proper polymorphism-_polymorphic :: (MonadFail m, 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)--safeToRemoveSpec :: forall backend m. Runner backend m => RunDb backend m -> Spec-safeToRemoveSpec runDb = do- describe "DudeWeirdColumns" $ do- it "can insert and get" $ do- let m = DudeWeirdColumns "hello"- runDb $ do- k <- insert m- mval <- get k- liftIO $ fmap dudeWeirdColumnsName mval `shouldBe` Just "hello"- it "can putMany" $ do- let ms =- [ DudeWeirdColumns "hello"- , DudeWeirdColumns "goodbyue"- ]- runDb $ putMany ms--specsWith :: forall backend m. Runner backend m => RunDb backend m -> Spec-specsWith runDb = describe "persistent" $ do- describe "SafeToRemove" (safeToRemoveSpec runDb)- 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 "FilterAnd []" $ runDb $ do- let p = Person "z" 1 Nothing- insert_ p- ps <- selectList [FilterAnd []] [Desc PersonAge]- assertNotEmpty ps-- it "Filter In" $ runDb $ do- _ <- selectList [Filter PersonName (FilterValues ["Kostas"]) In] []- return ()-- it "order of opts is irrelevant" $ runDb $ 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 <- map (personName . entityVal) <$> selectList [] [Desc PersonAge, Asc PersonName, OffsetBy 2, LimitTo 3]- a @== ["y", "v", "x"]-- b <- map (personName . entityVal) <$> selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName]- b @== a-- c <- map (personName . entityVal) <$> selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName, LimitTo 1, OffsetBy 1]- c @== a--- it "passes the general tests" $ runDb $ 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-- updateWhere [PersonName ==. "Michael"] [PersonAge =. 29]- uc <- count [PersonName ==. "Michael"]- uc @== 1- Just mic29 <- get micK- personAge mic29 @== 29-- let louis = Person "Louis" 55 $ Just "brown"- ex0 <- exists [PersonName ==. "Louis"]- ex0 @== False- louisK <- insert louis- ex1 <- exists [PersonName ==. "Louis"]- ex1 @== True- delete louisK-- 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 ()- it "persistIdField" $ runDb $ 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-- it "!=." $ runDb $ do- deleteWhere ([] :: [Filter (PersonGeneric backend)])- 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" $ runDb $ do- deleteWhere ([] :: [Filter (PersonMayGeneric backend)])- 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" $ runDb $ do- deleteWhere ([] :: [Filter (Person1Generic backend)])- 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" $ runDb $ 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" $ runDb $ 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" $ runDb $ 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-- prop "toPathPiece . fromPathPiece" $ \piece ->- let key1 = piece :: (BackendKey SqlBackend)- key2 = fromJust $ fromPathPiece $ toPathPiece key1 :: (BackendKey SqlBackend)- in toPathPiece key1 == toPathPiece key2-- it "replace" $ runDb $ 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" $ runDb $ 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" $ runDb $ 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 "repsertMany" $ do- it "adds new rows when no conflicts" $ runDb $ do- ids@[johnId, janeId, aliceId, eveId] <- replicateM 4 $ liftIO (Person1Key `fmap` generateKey)- let john = Person1 "john" 20- let jane = Person1 "jane" 18- let alice = Person1 "alice" 18- let eve = Person1 "eve" 19-- insertKey johnId john- insertKey janeId jane-- _ <- repsertMany [ (aliceId, alice), (eveId, eve) ]- es <- getMany ids-- let rs = [john, jane, alice, eve]- es @== Map.fromList (zip ids rs)- mapM_ delete ids-- it "handles conflicts by replacing old keys with new records" $ runDb $ do- let john = Person1 "john" 20- let jane = Person1 "jane" 18- let alice = Person1 "alice" 18- let eve = Person1 "eve" 19-- johnId <- insert john- janeId <- insert jane-- _ <- repsertMany [ (johnId, alice), (janeId, eve) ]- (Just alice') <- get johnId- (Just eve') <- get janeId-- [alice',eve'] @== [alice,eve]- mapM_ delete [johnId, janeId]-- it "updateWhere" $ runDb $ 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" $ runDb $ 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" $ runDb $ 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 <- runConduitRes $ selectSource [] [Desc PersonAge] .| await- ps1 @== Just (Entity k3 p3)-- ps2 <- runConduitRes $ selectSource [PersonAge <. 3] [Asc PersonAge] .| CL.consume- ps2 @== [Entity k1 p1, Entity k2 p2]-- runConduitRes $ 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" $ runDb $ 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" $ runDb $ 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 <- runConduitRes $ selectKeys [] [Desc PersonAge] .| await- ps1 @== Just k3-- ps2 <- runConduitRes $ selectKeys [PersonAge <. 3] [Asc PersonAge] .| CL.consume- ps2 @== [k1, k2]-- runConduitRes $ 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" $ runDb $ do- _ <- insertMany_ ([] :: [PersonGeneric backend])- rows <- (count ([] :: [Filter (PersonGeneric backend)]) :: ReaderT backend m Int)- rows @== 0- _ <- insertMany ([] :: [PersonGeneric backend])- rows2 <- count ([] :: [Filter (PersonGeneric backend)])- rows2 @== 0- _ <- insertEntityMany ([] :: [Entity (PersonGeneric backend)])- rows3 <- count ([] :: [Filter (PersonGeneric backend)])- rows3 @== 0-- it "insertEntityMany" $ runDb $ 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 (PersonGeneric backend)])- rows @== 5-- it "insertBy" $ runDb $ do- Right _ <- insertBy $ Person "name" 1 Nothing- Left _ <- insertBy $ Person "name" 1 Nothing- Right _ <- insertBy $ Person "name2" 1 Nothing- return ()-- it "insertKey" $ runDb $ do- k <- liftIO (PersonKey `fmap` generateKey)- insertKey k $ Person "Key" 26 Nothing- Just (Entity k2 _) <- selectFirst [PersonName ==. "Key"] []- k2 @== k-- it "insertEntity" $ runDb $ do- Entity k p <- insertEntity $ Person "name" 1 Nothing- Just p2 <- get k- p2 @== p-- it "insertRecord" $ runDb $ do- let record = Person "name" 1 Nothing- record' <- insertRecord record- record' @== record-- it "getEntity" $ runDb $ do- Entity k p <- insertEntity $ Person "name" 1 Nothing- Just (Entity k2 p2) <- getEntity k- p @== p2- k @== k2-- it "getJustEntity" $ runDb $ do- let p1 = Person "name" 1 Nothing- k1 <- insert p1- Entity k2 p2 <- getJustEntity k1- p1 @== p2- k1 @== k2-- it "repsert" $ runDb $ 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" $ runDb $ 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" $ runDb $ 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" $ runDb $ 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" $ runDb $ 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-- it "idIn" $ runDb $ 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]-- it "In" $ runDb $ 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" $ runDb $ do- let p = Person "D" 0 Nothing- k <- insert p- liftIO $ toJSON (Entity k p) @?=- object [("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"--}-- 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-- describe "documentation syntax" $ do- let edef = entityDef (Proxy :: Proxy Relationship)- it "provides comments on entity def" $ do- getEntityComments edef- `shouldBe`- Just "This is a doc comment for a relationship.\nOnly the first line requires a pipe.\nPipes are optional on subsequent lines.\n"- it "provides comments on the field" $ do- let [nameField, _] = getEntityFields edef- fieldComments nameField- `shouldBe`- Just "Fields should be documentable.\n"+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module PersistentTest+ ( module PersistentTest+ , cleanDB+ , testMigrate+ , noPrefixMigrate+ , customPrefixMigrate+ , treeMigrate+ ) where++import Control.Monad.Fail+import Control.Monad.IO.Class+import Data.Aeson+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Functor.Constant+import Data.Functor.Identity+import qualified Data.Map as Map+import Data.Maybe (fromJust)+import Data.Proxy (Proxy (..))+import Test.HUnit hiding (Test)+import Test.Hspec.QuickCheck (prop)+import UnliftIO (MonadUnliftIO, catch)+import Web.PathPieces (PathPiece (..))++import Database.Persist+import Init+import PersistTestPetCollarType+import PersistTestPetType+import PersistentTestModels++catchPersistException :: (MonadUnliftIO m, MonadFail m) => m a -> b -> m b+catchPersistException action errValue = do+ Left res <-+ (Right `fmap` action)+ `catch` (\(_ :: PersistException) -> return $ Left errValue)+ return res++filterOrSpecs+ :: forall m backend+ . (Runner backend m)+ => RunDb backend m+ -> Spec+filterOrSpecs runDb = describe "FilterOr" $ do+ it "FilterOr []" $ runDb $ do+ let+ p = Person "z" 1 Nothing+ insert_ p+ ps <- selectList [FilterOr []] [Desc PersonAge]+ assertEmpty ps+ it "||. []" $ runDb $ do+ let+ p = Person "z" 1 Nothing+ insert_ p+ c <- count $ [PersonName ==. "a"] ||. []+ c @== (1 :: Int)++-- Test proper polymorphism+_polymorphic+ :: ( MonadFail m+ , 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)++safeToRemoveSpec+ :: forall backend m. (Runner backend m) => RunDb backend m -> Spec+safeToRemoveSpec runDb = do+ describe "DudeWeirdColumns" $ do+ it "can insert and get" $ do+ let+ m = DudeWeirdColumns "hello"+ runDb $ do+ k <- insert m+ mval <- get k+ liftIO $ fmap dudeWeirdColumnsName mval `shouldBe` Just "hello"+ it "can putMany" $ do+ let+ ms =+ [ DudeWeirdColumns "hello"+ , DudeWeirdColumns "goodbyue"+ ]+ runDb $ putMany ms++specsWith :: forall backend m. (Runner backend m) => RunDb backend m -> Spec+specsWith runDb = describe "persistent" $ do+ describe "SafeToRemove" (safeToRemoveSpec runDb)+ 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 "FilterAnd []" $ runDb $ do+ let+ p = Person "z" 1 Nothing+ insert_ p+ ps <- selectList [FilterAnd []] [Desc PersonAge]+ assertNotEmpty ps++ it "Filter In" $ runDb $ do+ _ <- selectList [Filter PersonName (FilterValues ["Kostas"]) In] []+ return ()++ it "order of opts is irrelevant" $ runDb $ 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 <-+ map (personName . entityVal)+ <$> selectList [] [Desc PersonAge, Asc PersonName, OffsetBy 2, LimitTo 3]+ a @== ["y", "v", "x"]++ b <-+ map (personName . entityVal)+ <$> selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName]+ b @== a++ c <-+ map (personName . entityVal)+ <$> selectList+ []+ [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName, LimitTo 1, OffsetBy 1]+ c @== a++ it "passes the general tests" $ runDb $ 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++ updateWhere [PersonName ==. "Michael"] [PersonAge =. 29]+ uc <- count [PersonName ==. "Michael"]+ uc @== 1+ Just mic29 <- get micK+ personAge mic29 @== 29++ let+ louis = Person "Louis" 55 $ Just "brown"+ ex0 <- exists [PersonName ==. "Louis"]+ ex0 @== False+ louisK <- insert louis+ ex1 <- exists [PersonName ==. "Louis"]+ ex1 @== True+ delete louisK++ 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 ()+ it "persistIdField" $ runDb $ 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++ it "!=." $ runDb $ do+ deleteWhere ([] :: [Filter (PersonGeneric backend)])+ 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" $ runDb $ do+ deleteWhere ([] :: [Filter (PersonMayGeneric backend)])+ 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" $ runDb $ do+ deleteWhere ([] :: [Filter (Person1Generic backend)])+ 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" $ runDb $ 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" $ runDb $ 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" $ runDb $ 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++ prop "toPathPiece . fromPathPiece" $ \piece ->+ let+ key1 = piece :: (BackendKey SqlBackend)+ key2 = fromJust $ fromPathPiece $ toPathPiece key1 :: (BackendKey SqlBackend)+ in+ toPathPiece key1 == toPathPiece key2++ it "replace" $ runDb $ 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" $ runDb $ 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" $ runDb $ 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 "repsertMany" $ do+ it "adds new rows when no conflicts" $ runDb $ do+ ids@[johnId, janeId, aliceId, eveId] <-+ replicateM 4 $ liftIO (Person1Key `fmap` generateKey)+ let+ john = Person1 "john" 20+ let+ jane = Person1 "jane" 18+ let+ alice = Person1 "alice" 18+ let+ eve = Person1 "eve" 19++ insertKey johnId john+ insertKey janeId jane++ _ <- repsertMany [(aliceId, alice), (eveId, eve)]+ es <- getMany ids++ let+ rs = [john, jane, alice, eve]+ es @== Map.fromList (zip ids rs)+ mapM_ delete ids++ it "handles conflicts by replacing old keys with new records" $ runDb $ do+ let+ john = Person1 "john" 20+ let+ jane = Person1 "jane" 18+ let+ alice = Person1 "alice" 18+ let+ eve = Person1 "eve" 19++ johnId <- insert john+ janeId <- insert jane++ _ <- repsertMany [(johnId, alice), (janeId, eve)]+ (Just alice') <- get johnId+ (Just eve') <- get janeId++ [alice', eve'] @== [alice, eve]+ mapM_ delete [johnId, janeId]++ it "updateWhere" $ runDb $ 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" $ runDb $ 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" $ runDb $ 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 <- runConduitRes $ selectSource [] [Desc PersonAge] .| await+ ps1 @== Just (Entity k3 p3)++ ps2 <-+ runConduitRes $ selectSource [PersonAge <. 3] [Asc PersonAge] .| CL.consume+ ps2 @== [Entity k1 p1, Entity k2 p2]++ runConduitRes $+ 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" $ runDb $ 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" $ runDb $ 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 <- runConduitRes $ selectKeys [] [Desc PersonAge] .| await+ ps1 @== Just k3++ ps2 <- runConduitRes $ selectKeys [PersonAge <. 3] [Asc PersonAge] .| CL.consume+ ps2 @== [k1, k2]++ runConduitRes $+ 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" $ runDb $ do+ _ <- insertMany_ ([] :: [PersonGeneric backend])+ rows <-+ (count ([] :: [Filter (PersonGeneric backend)]) :: ReaderT backend m Int)+ rows @== 0+ _ <- insertMany ([] :: [PersonGeneric backend])+ rows2 <- count ([] :: [Filter (PersonGeneric backend)])+ rows2 @== 0+ _ <- insertEntityMany ([] :: [Entity (PersonGeneric backend)])+ rows3 <- count ([] :: [Filter (PersonGeneric backend)])+ rows3 @== 0++ it "insertEntityMany" $ runDb $ 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 (PersonGeneric backend)])+ rows @== 5++ it "insertBy" $ runDb $ do+ Right _ <- insertBy $ Person "name" 1 Nothing+ Left _ <- insertBy $ Person "name" 1 Nothing+ Right _ <- insertBy $ Person "name2" 1 Nothing+ return ()++ it "insertKey" $ runDb $ do+ k <- liftIO (PersonKey `fmap` generateKey)+ insertKey k $ Person "Key" 26 Nothing+ Just (Entity k2 _) <- selectFirst [PersonName ==. "Key"] []+ k2 @== k++ it "insertEntity" $ runDb $ do+ Entity k p <- insertEntity $ Person "name" 1 Nothing+ Just p2 <- get k+ p2 @== p++ it "insertRecord" $ runDb $ do+ let+ record = Person "name" 1 Nothing+ record' <- insertRecord record+ record' @== record++ it "getEntity" $ runDb $ do+ Entity k p <- insertEntity $ Person "name" 1 Nothing+ Just (Entity k2 p2) <- getEntity k+ p @== p2+ k @== k2++ it "getJustEntity" $ runDb $ do+ let+ p1 = Person "name" 1 Nothing+ k1 <- insert p1+ Entity k2 p2 <- getJustEntity k1+ p1 @== p2+ k1 @== k2++ it "repsert" $ runDb $ 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" $ runDb $ 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" $ runDb $ 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" $ runDb $ 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" $ runDb $ 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++ it "idIn" $ runDb $ 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]++ it "In" $ runDb $ 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" $ runDb $ do+ let+ p = Person "D" 0 Nothing+ k <- insert p+ liftIO $+ toJSON (Entity k p)+ @?= object+ [("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"+ -}++ 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++ describe "documentation syntax" $ do+ let+ edef = entityDef (Proxy :: Proxy Relationship)+ it "provides comments on entity def" $ do+ getEntityComments edef+ `shouldBe` Just+ "This is a doc comment for a relationship.\nOnly the first line requires a pipe.\nPipes are optional on subsequent lines.\n"+ it "provides comments on the field" $ do+ let+ [nameField, _] = getEntityFields edef+ fieldComments nameField+ `shouldBe` Just "Fields should be documentable.\n"
src/PersistentTestModelsImports.hs view
@@ -1,12 +1,14 @@ {-# LANGUAGE TypeOperators #-}-{-# language UndecidableInstances #-}+{-# LANGUAGE UndecidableInstances #-} -- | this just needs to compile module PersistentTestModelsImports where import Database.Persist.TH -share [mkPersist sqlSettings] [persistUpperCase|+share+ [mkPersist sqlSettings]+ [persistUpperCase| User name String
src/PrimaryTest.hs view
@@ -1,14 +1,16 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DeriveGeneric #-} module PrimaryTest where import Init -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs-share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase|+share+ [mkPersist persistSettings{mpsGeneric = False}, mkMigrate "migration"]+ [persistLowerCase| Foo name String Primary name@@ -28,33 +30,33 @@ Primary name age |] --cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Foo ~ backend) => ReaderT backend m ()+cleanDB+ :: (MonadIO m, PersistQuery backend, PersistEntityBackend Foo ~ backend)+ => ReaderT backend m () cleanDB = do- deleteWhere ([] :: [Filter Foo])- deleteWhere ([] :: [Filter Bar])+ deleteWhere ([] :: [Filter Foo])+ deleteWhere ([] :: [Filter Bar]) specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "primary key reference" $ do- it "insert a primary reference" $ runDb $ do- kf <- insert $ Foo "name"- _kb <- insert $ Bar kf- return ()- it "uses RawSql for a Primary key" $ runDb $ do- key <- insert $ Foo "name"- keyFromRaw <- rawSql "SELECT name FROM foo LIMIT 1" []- [key] @== keyFromRaw- describe "keyFromRecordM" $ do- it "works on singleton case" $ do- let- foo = Foo "hello"- fooKey = fmap ($ foo) keyFromRecordM- fooKey `shouldBe` Just (FooKey "hello")- it "works on multiple fields" $ do- let- name = "hello"- age = 31- rec = CompositePrimary name age- fmap ($ rec) keyFromRecordM- `shouldBe`- Just (CompositePrimaryKey name age)+ it "insert a primary reference" $ runDb $ do+ kf <- insert $ Foo "name"+ _kb <- insert $ Bar kf+ return ()+ it "uses RawSql for a Primary key" $ runDb $ do+ key <- insert $ Foo "name"+ keyFromRaw <- rawSql "SELECT name FROM foo LIMIT 1" []+ [key] @== keyFromRaw+ describe "keyFromRecordM" $ do+ it "works on singleton case" $ do+ let+ foo = Foo "hello"+ fooKey = fmap ($ foo) keyFromRecordM+ fooKey `shouldBe` Just (FooKey "hello")+ it "works on multiple fields" $ do+ let+ name = "hello"+ age = 31+ rec = CompositePrimary name age+ fmap ($ rec) keyFromRecordM+ `shouldBe` Just (CompositePrimaryKey name age)
src/RawSqlTest.hs view
@@ -1,4 +1,5 @@-{-# language ScopedTypeVariables, DataKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module RawSqlTest where@@ -9,129 +10,211 @@ import qualified Data.Text as T import Database.Persist.Class.PersistEntity-import Init import Database.Persist.SqlBackend+import Init import PersistTestPetType import PersistentTestModels -specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec+specsWith :: (Runner SqlBackend m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "rawSql" $ do it "2+2" $ runDb $ do ret <- rawSql "SELECT 2+2" []- liftIO $ ret @?= [Single (4::Int)]+ liftIO $ ret @?= [Single (4 :: Int)] it "?-?" $ runDb $ do ret <- rawSql "SELECT ?-?" [PersistInt64 5, PersistInt64 3]- liftIO $ ret @?= [Single (2::Int)]+ liftIO $ ret @?= [Single (2 :: Int)] it "NULL" $ runDb $ do ret <- rawSql "SELECT NULL" [] liftIO $ ret @?= [Nothing :: Maybe (Single Int)] it "entity" $ runDb $ do- Entity p1k p1 <- insertEntity $ Person "Mathias" 23 Nothing- Entity p2k p2 <- insertEntity $ Person "Norbert" 44 Nothing- Entity p3k _ <- insertEntity $ Person "Cassandra" 19 Nothing- Entity _ _ <- insertEntity $ Person "Thiago" 19 Nothing+ Entity p1k p1 <- insertEntity $ Person "Mathias" 23 Nothing+ Entity p2k p2 <- insertEntity $ Person "Norbert" 44 Nothing+ Entity p3k _ <- insertEntity $ Person "Cassandra" 19 Nothing+ Entity _ _ <- insertEntity $ Person "Thiago" 19 Nothing Entity a1k a1 <- insertEntity $ Pet p1k "Rodolfo" Cat- Entity a2k a2 <- insertEntity $ Pet p1k "Zeno" Cat- Entity a3k a3 <- insertEntity $ Pet p2k "Lhama" Dog- Entity _ _ <- insertEntity $ Pet p3k "Abacate" Cat+ Entity a2k a2 <- insertEntity $ Pet p1k "Zeno" Cat+ Entity a3k a3 <- insertEntity $ Pet p2k "Lhama" Dog+ Entity _ _ <- insertEntity $ Pet p3k "Abacate" Cat escape <- getEscape person <- getTableName (error "rawSql Person" :: Person)- name_ <- getFieldName PersonName+ name_ <- getFieldName PersonName pet <- getTableName (error "rawSql Pet" :: Pet)- petName_ <- getFieldName PetName- 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_, ", ", pet, ".", petName_- ]+ petName_ <- getFieldName PetName+ 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_+ , ", "+ , pet+ , "."+ , petName_+ ] 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) ]+ 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)) ]+ 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) ]+ liftIO $+ ret3+ @?= [ Just (Entity p1k p1, Entity a1k a1)+ , Just (Entity p1k p1, Entity a2k a2)+ , Just (Entity p2k p2, Entity a3k a3)+ ] it "order-proof" $ runDb $ do- let p1 = Person "Zacarias" 93 Nothing+ let+ p1 = Person "Zacarias" 93 Nothing p1k <- insert p1 escape <- getEscape- let query = T.concat [ "SELECT ?? "- , "FROM ", escape "Person"- ]+ let+ query =+ T.concat+ [ "SELECT ?? "+ , "FROM "+ , escape "Person"+ ] ret1 <- rawSql query []- ret2 <- rawSql query [] :: MonadIO m => SqlPersistT m [Entity (ReverseFieldOrder Person)]+ ret2 <-+ rawSql query []+ :: (MonadIO m) => SqlPersistT m [Entity (ReverseFieldOrder Person)] liftIO $ ret1 @?= [Entity p1k p1] liftIO $ ret2 @?= [Entity (RFOKey $ unPersonKey p1k) (RFO p1)] it "permits prefixes" $ runDb $ do- let r1 = Relationship "Foo" Nothing+ let+ r1 = Relationship "Foo" Nothing r1k <- insert r1- let r2 = Relationship "Bar" (Just r1k)+ let+ r2 = Relationship "Bar" (Just r1k) r2k <- insert r2- let r3 = Relationship "Lmao" (Just r1k)+ let+ r3 = Relationship "Lmao" (Just r1k) r3k <- insert r3- let r4 = Relationship "Boring" (Just r2k)+ let+ r4 = Relationship "Boring" (Just r2k) r4k <- insert r4 escape <- getEscape- let query = T.concat- [ "SELECT ??, ?? "- , "FROM ", escape "Relationship", " AS parent "- , "LEFT OUTER JOIN ", escape "Relationship", " AS child "- , "ON parent.id = child.parent"- ]+ let+ query =+ T.concat+ [ "SELECT ??, ?? "+ , "FROM "+ , escape "Relationship"+ , " AS parent "+ , "LEFT OUTER JOIN "+ , escape "Relationship"+ , " AS child "+ , "ON parent.id = child.parent"+ ] - result :: [(EntityWithPrefix "parent" Relationship, Maybe (EntityWithPrefix "child" Relationship))] <-+ result+ :: [ ( EntityWithPrefix "parent" Relationship+ , Maybe (EntityWithPrefix "child" Relationship)+ )+ ] <- rawSql query [] liftIO $- coerce result `shouldMatchList`- [ (Entity r1k r1, Just (Entity r2k r2))- , (Entity r1k r1, Just (Entity r3k r3))- , (Entity r2k r2, Just (Entity r4k r4))- , (Entity r3k r3, Nothing)- , (Entity r4k r4, Nothing)- ]-+ coerce result+ `shouldMatchList` [ (Entity r1k r1, Just (Entity r2k r2))+ , (Entity r1k r1, Just (Entity r3k r3))+ , (Entity r2k r2, Just (Entity r4k r4))+ , (Entity r3k r3, Nothing)+ , (Entity r4k r4, Nothing)+ ] it "OUTER JOIN" $ runDb $ do- let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m, SafeToInsert val)- => val -> ReaderT backend m (Key val, val)+ let+ insert'+ :: ( PersistStore backend+ , PersistEntity val+ , PersistEntityBackend val ~ BaseBackend backend+ , MonadIO m+ , SafeToInsert val+ )+ => 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+ (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+ (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat escape <- getEscape- let query = T.concat [ "SELECT ??, ?? "- , "FROM ", person- , "LEFT OUTER JOIN ", pet- , " ON ", person, ".", escape "id"- , " = ", pet, ".", escape "ownerId"- , " ORDER BY ", person, ".", escape "name"- , ", ", pet, ".", escape "id" ]+ let+ query =+ T.concat+ [ "SELECT ??, ?? "+ , "FROM "+ , person+ , "LEFT OUTER JOIN "+ , pet+ , " ON "+ , person+ , "."+ , escape "id"+ , " = "+ , pet+ , "."+ , escape "ownerId"+ , " ORDER BY "+ , person+ , "."+ , escape "name"+ , ", "+ , pet+ , "."+ , escape "id"+ ] person = escape "Person"- pet = escape "Pet"+ 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) ]+ liftIO $+ ret+ @?= [ (Entity p1k p1, Just (Entity a1k a1))+ , (Entity p1k p1, Just (Entity a2k a2))+ , (Entity p2k p2, Nothing)+ ] it "handles lower casing" $ runDb $ do- C.runConduitRes $ rawQuery "SELECT full_name from lower_case_table WHERE my_id=5" [] C..| CL.sinkNull- C.runConduitRes $ rawQuery "SELECT something_else from ref_table WHERE id=4" [] C..| CL.sinkNull+ C.runConduitRes $+ rawQuery "SELECT full_name from lower_case_table WHERE my_id=5" []+ C..| CL.sinkNull+ C.runConduitRes $+ rawQuery "SELECT something_else from ref_table WHERE id=4" [] C..| CL.sinkNull it "commit/rollback" $ do caseCommitRollback runDb@@ -140,18 +223,40 @@ it "queries with large number of results" $ runDb $ do -- max size of a GHC tuple is 62, but Eq instances currently only exist up to 15-tuples -- See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3369- ret <- rawSql "SELECT ?,?,?,?,?,?,?,?,?,?,?,?,?,?,?" $ map PersistInt64 [1..15]- liftIO $ ret @?= [(Single (1::Int), Single (2::Int), Single (3::Int), Single (4::Int), Single (5::Int), Single (6::Int), Single (7::Int), Single (8::Int), Single (9::Int), Single (10::Int), Single (11::Int), Single (12::Int), Single (13::Int), Single (14::Int), Single (15::Int))]+ ret <-+ rawSql "SELECT ?,?,?,?,?,?,?,?,?,?,?,?,?,?,?" $ map PersistInt64 [1 .. 15]+ liftIO $+ ret+ @?= [+ ( Single (1 :: Int)+ , Single (2 :: Int)+ , Single (3 :: Int)+ , Single (4 :: Int)+ , Single (5 :: Int)+ , Single (6 :: Int)+ , Single (7 :: Int)+ , Single (8 :: Int)+ , Single (9 :: Int)+ , Single (10 :: Int)+ , Single (11 :: Int)+ , Single (12 :: Int)+ , Single (13 :: Int)+ , Single (14 :: Int)+ , Single (15 :: Int)+ )+ ] -getEscape :: MonadReader SqlBackend m => m (Text -> Text)+getEscape :: (MonadReader SqlBackend m) => m (Text -> Text) getEscape = getEscapeRawNameFunction -caseCommitRollback :: Runner SqlBackend m => RunDb SqlBackend m -> Assertion+caseCommitRollback :: (Runner SqlBackend m) => RunDb SqlBackend m -> Assertion caseCommitRollback runDb = runDb $ do- let filt :: [Filter Person1]+ let+ filt :: [Filter Person1] filt = [] - let p = Person1 "foo" 0+ let+ p = Person1 "foo" 0 insert_ p insert_ p
src/ReadWriteTest.hs view
@@ -1,15 +1,17 @@ {-# LANGUAGE ScopedTypeVariables #-}+ module ReadWriteTest where import Init import PersistentTestModels --specsWith :: forall m. Runner SqlBackend m => RunDb SqlBackend m -> Spec+specsWith :: forall m. (Runner SqlBackend m) => RunDb SqlBackend m -> Spec specsWith originalRunDb = describe "ReadWriteTest" $ do- let personFilters = [] :: [Filter Person]+ let+ personFilters = [] :: [Filter Person] describe "SqlReadBackend" $ do- let runDb :: RunDb SqlReadBackend m+ let+ runDb :: RunDb SqlReadBackend m runDb = changeBackend SqlReadBackend originalRunDb it "type checks on all PersistStoreRead functions" $ do runDb $ do@@ -29,12 +31,14 @@ pure () describe "SqlWriteBackend" $ do- let runDb :: RunDb SqlWriteBackend m+ let+ runDb :: RunDb SqlWriteBackend m runDb = changeBackend SqlWriteBackend originalRunDb it "type checks on PersistStoreWrite and Read functions" $ do runDb $ do- let person = Person "Matt Parsons" 30 Nothing+ let+ person = Person "Matt Parsons" 30 Nothing k <- insert person mperson <- get k Just person @== mperson@@ -46,7 +50,8 @@ it "type checks on PersistUniqueWrite/Read functions" $ do runDb $ do- let name_ = "Matt Parsons New"+ let+ name_ = "Matt Parsons New" person = Person name_ 30 Nothing _mkey0 <- insertUnique person mkey1 <- insertUnique person@@ -54,13 +59,11 @@ mperson <- selectFirst [PersonName ==. name_] [] fmap entityVal mperson @== Just person - let nameLuke = "Luke Seale New"+ let+ nameLuke = "Luke Seale New" personLuke = Person nameLuke 31 Nothing mkey2 <- insertUnique_ personLuke mkey3 <- insertUnique_ personLuke mkey3 @== Nothing mpersonLuke <- selectFirst [PersonName ==. nameLuke] [] fmap entityVal mpersonLuke @== Just personLuke---
src/Recursive.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-}-+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module Recursive (specsWith, recursiveMigrate, cleanup) where import Init -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "recursiveMigrate"] [persistLowerCase|+share+ [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "recursiveMigrate"]+ [persistLowerCase| SubType object [MenuObject]@@ -23,22 +24,24 @@ :: (PersistStoreWrite (BaseBackend backend), PersistQueryWrite backend) => ReaderT backend IO () cleanup = do- deleteWhere ([] :: [Filter (MenuObjectGeneric backend)])- deleteWhere ([] :: [Filter (SubTypeGeneric backend)])+ deleteWhere ([] :: [Filter (MenuObjectGeneric backend)])+ deleteWhere ([] :: [Filter (SubTypeGeneric backend)]) specsWith- ::- ( PersistStoreWrite backend- , PersistStoreWrite (BaseBackend backend)- , MonadIO m- )+ :: ( PersistStoreWrite backend+ , PersistStoreWrite (BaseBackend backend)+ , MonadIO m+ ) => RunDb backend m -> Spec specsWith runDb = describe "recursive definitions" $ do- it "mutually recursive" $ runDb $ 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+ it "mutually recursive" $ runDb $ 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
src/RenameTest.hs view
@@ -1,10 +1,12 @@-{-# LANGUAGE TypeApplications, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module RenameTest where import qualified Data.Map as Map import qualified Data.Text as T-import Data.Time (getCurrentTime, Day, UTCTime(..))+import Data.Time (Day, UTCTime (..), getCurrentTime) import Init @@ -13,7 +15,9 @@ type TextId = Text -- Test lower case names-share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migration"] [persistLowerCase|+share+ [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "migration"]+ [persistLowerCase| -- This just tests that a field can be named "key" KeyTable key Text@@ -53,47 +57,51 @@ |] cleanDB- :: forall backend.- ( BaseBackend backend ~ backend- , PersistQueryWrite backend- )+ :: forall backend+ . ( BaseBackend backend ~ backend+ , PersistQueryWrite backend+ ) => ReaderT backend IO () cleanDB = do- deleteWhere ([] :: [Filter (IdTableGeneric backend)])- deleteWhere ([] :: [Filter (LowerCaseTableGeneric backend)])- deleteWhere ([] :: [Filter (RefTableGeneric backend)])+ deleteWhere ([] :: [Filter (IdTableGeneric backend)])+ deleteWhere ([] :: [Filter (LowerCaseTableGeneric backend)])+ deleteWhere ([] :: [Filter (RefTableGeneric backend)]) specsWith- ::- ( PersistStoreWrite backend, PersistQueryRead backend- , backend ~ BaseBackend backend- , MonadIO m, MonadFail m- , Eq (BackendKey backend)- )+ :: ( PersistStoreWrite backend+ , PersistQueryRead backend+ , backend ~ BaseBackend backend+ , MonadIO m+ , MonadFail m+ , Eq (BackendKey backend)+ ) => RunDb backend m -> Spec specsWith runDb = describe "rename specs" $ do describe "LowerCaseTable" $ do it "LowerCaseTable has the right sql name" $ do fmap fieldDB (getEntityIdField (entityDef (Proxy @LowerCaseTable)))- `shouldBe`- Just (FieldNameDB "my_id")+ `shouldBe` Just (FieldNameDB "my_id") it "user specified id, insertKey, no default=" $ runDb $ do- let rec2 = IdTable "Foo2" Nothing- let rec1 = IdTable "Foo1" $ Just rec2- let rec = IdTable "Foo" $ Just rec1+ 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+ let+ key = IdTableKey $ utctDay now insertKey key rec Just rec' <- get key rec' @== rec- (Entity key' _):_ <- selectList ([] :: [Filter (IdTableGeneric backend)]) []+ (Entity key' _) : _ <- selectList ([] :: [Filter (IdTableGeneric backend)]) [] key' @== key it "extra blocks" $- getEntityExtra (entityDef (Nothing :: Maybe LowerCaseTable)) @?=- Map.fromList+ getEntityExtra (entityDef (Nothing :: Maybe LowerCaseTable))+ @?= Map.fromList [ ("ExtraBlock", map T.words ["foo bar", "baz", "bin"]) , ("ExtraBlock2", map T.words ["something"]) ]
src/SumTypeTest.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}+ module SumTypeTest (specsWith, sumTypeMigrate) where import qualified Data.Text as T@@ -9,7 +10,9 @@ import Database.Persist.TH import Init -share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "sumTypeMigrate"] [persistLowerCase|+share+ [mkPersist persistSettings{mpsGeneric = True}, mkMigrate "sumTypeMigrate"]+ [persistLowerCase| Bicycle brand T.Text Car@@ -23,35 +26,37 @@ -- 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)+deriving instance (Show (BackendKey backend)) => Show (VehicleGeneric backend)+deriving instance (Eq (BackendKey backend)) => Eq (VehicleGeneric backend) specsWith- ::- ( PersistQueryWrite backend- , BaseBackend backend ~ backend- , MonadIO m, MonadFail m- )+ :: ( PersistQueryWrite backend+ , BaseBackend backend ~ backend+ , MonadIO m+ , MonadFail m+ ) => RunDb backend m -> Maybe (ReaderT backend m a) -- ^ Optional migrations for SQL backends -> Spec specsWith runDb mmigrate = describe "sum types" $- it "works" $ asIO $ runDb $ do- sequence_ mmigrate- car1 <- insert $ Car "Ford" "Thunderbird"- car2 <- insert $ Car "Kia" "Rio"- bike1 <- insert $ Bicycle "Shwinn"+ it "works" $+ asIO $+ runDb $ do+ sequence_ mmigrate+ 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+ vc1 <- insert $ VehicleCarSum car1+ vc2 <- insert $ VehicleCarSum car2+ vb1 <- insert $ VehicleBicycleSum bike1 - x1 <- get vc1- liftIO $ x1 @?= Just (VehicleCarSum car1)+ x1 <- get vc1+ liftIO $ x1 @?= Just (VehicleCarSum car1) - x2 <- get vc2- liftIO $ x2 @?= Just (VehicleCarSum car2)+ x2 <- get vc2+ liftIO $ x2 @?= Just (VehicleCarSum car2) - x3 <- get vb1- liftIO $ x3 @?= Just (VehicleBicycleSum bike1)+ x3 <- get vb1+ liftIO $ x3 @?= Just (VehicleBicycleSum bike1)
src/TransactionLevelTest.hs view
@@ -6,7 +6,9 @@ import Init -share [mkPersist sqlSettings, mkMigrate "migration"] [persistUpperCase|+share+ [mkPersist sqlSettings, mkMigrate "migration"]+ [persistUpperCase| Wombat name Text sqltype=varchar(80) @@ -17,12 +19,13 @@ specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "IsolationLevel" $ do- let item = Wombat "uno"- isolationLevels = [minBound..maxBound]- forM_ isolationLevels $ \il -> describe "insertOnDuplicateKeyUpdate" $ do- it (show il ++ " works") $ runDb $ do- transactionUndoWithIsolation il- deleteWhere ([] :: [Filter Wombat])- insert_ item- Just item' <- get (WombatKey "uno")- item' @== item+ let+ item = Wombat "uno"+ isolationLevels = [minBound .. maxBound]+ forM_ isolationLevels $ \il -> describe "insertOnDuplicateKeyUpdate" $ do+ it (show il ++ " works") $ runDb $ do+ transactionUndoWithIsolation il+ deleteWhere ([] :: [Filter Wombat])+ insert_ item+ Just item' <- get (WombatKey "uno")+ item' @== item
src/TreeTest.hs view
@@ -1,17 +1,19 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module TreeTest where import Init - -- mpsGeneric = False is due to a bug or at least lack of a feature in -- mkKeyTypeDec TH.hs share- [ mkPersist persistSettings { mpsGeneric = False }+ [ mkPersist persistSettings{mpsGeneric = False} , mkMigrate "treeMigrate"- ] [persistLowerCase|+ ]+ [persistLowerCase| Tree sql=trees name Text parent Text Maybe@@ -19,12 +21,11 @@ Foreign Tree fkparent parent |] - cleanDB :: (PersistQuery backend, PersistEntityBackend Tree ~ backend, MonadIO m) => ReaderT backend m () cleanDB = do- deleteWhere ([] :: [Filter Tree])+ deleteWhere ([] :: [Filter Tree]) specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "tree" $ do@@ -39,29 +40,32 @@ gp <- getJust kgp treeFkparent gp @== Nothing describe "entityDef" $ do- let ed = entityDef (Proxy :: Proxy Tree)+ let+ ed = entityDef (Proxy :: Proxy Tree) it "has the right haskell name" $ do getEntityHaskellName ed `shouldBe` EntityNameHS "Tree" it "has the right DB name" $ do getEntityDBName ed `shouldBe` EntityNameDB "trees" describe "foreign ref" $ do- let [ForeignDef{..}] = getEntityForeignDefs (entityDef (Proxy :: Proxy Tree))+ let+ [ForeignDef{..}] = getEntityForeignDefs (entityDef (Proxy :: Proxy Tree)) it "has the right haskell name" $ do- foreignRefTableHaskell `shouldBe`- EntityNameHS "Tree"+ foreignRefTableHaskell+ `shouldBe` EntityNameHS "Tree" it "has the right db name" $ do- foreignRefTableDBName `shouldBe`- EntityNameDB "trees"+ foreignRefTableDBName+ `shouldBe` EntityNameDB "trees" it "has the right constraint name" $ do- foreignConstraintNameHaskell `shouldBe`- ConstraintNameHS "fkparent"+ foreignConstraintNameHaskell+ `shouldBe` ConstraintNameHS "fkparent" it "has the right DB constraint name" $ do- foreignConstraintNameDBName `shouldBe`- ConstraintNameDB "treefkparent"+ foreignConstraintNameDBName+ `shouldBe` ConstraintNameDB "treefkparent" it "has the right fields" $ do- foreignFields `shouldBe`- [ ( (FieldNameHS "parent", FieldNameDB "parent")- , (FieldNameHS "name", FieldNameDB "name")- )- ]+ foreignFields+ `shouldBe` [+ ( (FieldNameHS "parent", FieldNameDB "parent")+ , (FieldNameHS "name", FieldNameDB "name")+ )+ ]
src/TypeLitFieldDefsTest.hs view
@@ -30,7 +30,11 @@ instance PersistFieldSql (Labelled n) where sqlType _ = sqlType (Proxy :: Proxy Int) -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "typeLitFieldDefsMigrate"] [persistLowerCase|+share+ [ mkPersist sqlSettings{mpsGeneric = True}+ , mkMigrate "typeLitFieldDefsMigrate"+ ]+ [persistLowerCase| TypeLitFieldDefsNumeric one (Finite 1) twenty (Finite 20)@@ -54,7 +58,7 @@ twentyLabelled :: Labelled "twenty" twentyLabelled = Labelled 20 -specsWith :: Runner backend m => RunDb backend m -> Spec+specsWith :: (Runner backend m) => RunDb backend m -> Spec specsWith runDb = describe "Type Lit Field Definitions" $ do it "runs appropriate migrations" $ runDb $ do
src/UniqueTest.hs view
@@ -1,11 +1,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+ module UniqueTest where import Init -share [mkPersist sqlSettings, mkMigrate "uniqueMigrate"] [persistLowerCase|+share+ [mkPersist sqlSettings, mkMigrate "uniqueMigrate"]+ [persistLowerCase| TestNonNull fieldA Int UniqueTestNonNull fieldA sql=UniqueTestNonNull !force@@ -24,39 +27,51 @@ deriving Eq Show |] -cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend TestNonNull ~ backend) => ReaderT backend m ()+cleanDB+ :: (MonadIO m, PersistQuery backend, PersistEntityBackend TestNonNull ~ backend)+ => ReaderT backend m () cleanDB = do- deleteWhere ([] :: [Filter TestNonNull])- deleteWhere ([] :: [Filter TestNull])+ deleteWhere ([] :: [Filter TestNonNull])+ deleteWhere ([] :: [Filter TestNull]) -specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec+specsWith :: (Runner SqlBackend m) => RunDb SqlBackend m -> Spec specsWith runDb =- describe "uniqueness constraints" $ do- it "are respected for non-nullable Ints" $ do- let ins = insert . TestNonNull- (runDb $ void $ ins 1 >> ins 2)- (runDb $ void $ ins 1 >> ins 2 >> ins 1) `shouldThrow` anyException- (runDb $ 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)- (runDb $ void ctx)- (runDb $ void $ ctx >> ins 1 (Just 3)) `shouldThrow` anyException- (runDb $ void $ ctx >> ins 1 (Just 4)) `shouldThrow` anyException- (runDb $ 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- (runDb $ void ctx)- (runDb $ void $ ctx >> ins "name" "Melissa" Active) `shouldThrow` anyException- (runDb $ void $ ctx >> ins "name" "Melissa" Inactive)- (runDb $ void $ ctx >>= flip update [TestCheckmarkActive =. Active])- (runDb $ void $ do- void ctx- updateWhere [TestCheckmarkName ==. "name"]- [TestCheckmarkActive =. Inactive]- ins "name" "Melissa" Active)+ describe "uniqueness constraints" $ do+ it "are respected for non-nullable Ints" $ do+ let+ ins = insert . TestNonNull+ (runDb $ void $ ins 1 >> ins 2)+ (runDb $ void $ ins 1 >> ins 2 >> ins 1) `shouldThrow` anyException+ (runDb $ 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)+ (runDb $ void ctx)+ (runDb $ void $ ctx >> ins 1 (Just 3)) `shouldThrow` anyException+ (runDb $ void $ ctx >> ins 1 (Just 4)) `shouldThrow` anyException+ (runDb $ 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+ (runDb $ void ctx)+ (runDb $ void $ ctx >> ins "name" "Melissa" Active) `shouldThrow` anyException+ (runDb $ void $ ctx >> ins "name" "Melissa" Inactive)+ (runDb $ void $ ctx >>= flip update [TestCheckmarkActive =. Active])+ ( runDb $ void $ do+ void ctx+ updateWhere+ [TestCheckmarkName ==. "name"]+ [TestCheckmarkActive =. Inactive]+ ins "name" "Melissa" Active+ )
src/UpsertTest.hs view
@@ -20,173 +20,186 @@ | UpsertPreserveOldKey specsWith- :: forall backend m. Runner backend m+ :: forall backend m+ . (Runner backend m) => RunDb backend m -> BackendNullUpdateBehavior -> BackendUpsertKeyBehavior -> Spec specsWith runDb handleNull handleKey = describe "UpsertTests" $ do- let- ifKeyIsPreserved expectation =- case handleKey of- UpsertGenerateNewKey -> pure ()- UpsertPreserveOldKey -> expectation-- describe "upsert" $ do- it "adds a new row with no updates" $ runDb $ do- Entity _ u <- upsert (Upsert "a" "new" "" 2) [UpsertAttr =. "update"]- c <- count ([] :: [Filter (UpsertGeneric backend)])- c @== 1- upsertAttr u @== "new"- it "keeps the existing row" $ runDb $ do- Entity k0 initial <- insertEntity (Upsert "a" "initial" "" 1)- Entity k1 update' <- upsert (Upsert "a" "update" "" 2) []- update' @== initial- ifKeyIsPreserved $ k0 @== k1- it "updates an existing row - assignment" $ runDb $ 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"]- ifKeyIsPreserved $ ((==@) `on` entityKey) initial update'- upsertAttr (entityVal update') @== "update"- upsertExtra (entityVal update') @== "extra"--- #endif- it "updates existing row - addition " $ runDb $ 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]- ifKeyIsPreserved $ ((==@) `on` entityKey) initial update'- upsertAge (entityVal update') @== 5- upsertExtra (entityVal update') @== "extra"--- #endif+ let+ ifKeyIsPreserved expectation =+ case handleKey of+ UpsertGenerateNewKey -> pure ()+ UpsertPreserveOldKey -> expectation - describe "upsertBy" $ do- let uniqueEmail = UniqueUpsertBy "a"- _uniqueCity = UniqueUpsertByCity "Boston"- it "adds a new row with no updates" $ runDb $ do- Entity _ u <-- upsertBy- uniqueEmail- (UpsertBy "a" "Boston" "new")- [UpsertByAttr =. "update"]- c <- count ([] :: [Filter (UpsertByGeneric backend)])- c @== 1- upsertByAttr u @== "new"- it "keeps the existing row" $ runDb $ do- Entity k0 initial <- insertEntity (UpsertBy "a" "Boston" "initial")- Entity k1 update' <- upsertBy uniqueEmail (UpsertBy "a" "Boston" "update") []- update' @== initial- ifKeyIsPreserved $ k0 @== k1- it "updates an existing row" $ runDb $ 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"]- ifKeyIsPreserved $ ((==@) `on` entityKey) initial update'- upsertByAttr (entityVal update') @== "update"- upsertByCity (entityVal update') @== "Boston"--- #endif- it "updates by the appropriate constraint" $ runDb $ 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"]- ifKeyIsPreserved $ ((==@) `on` entityKey) initBoston updBoston- ifKeyIsPreserved $ ((==@) `on` entityKey) initKrum updKrum- entityVal updBoston @== UpsertBy "bos" "Boston" "bos update"- entityVal updKrum @== UpsertBy "krum" "Krum" "krum update"+ describe "upsert" $ do+ it "adds a new row with no updates" $ runDb $ do+ Entity _ u <- upsert (Upsert "a" "new" "" 2) [UpsertAttr =. "update"]+ c <- count ([] :: [Filter (UpsertGeneric backend)])+ c @== 1+ upsertAttr u @== "new"+ it "keeps the existing row" $ runDb $ do+ Entity k0 initial <- insertEntity (Upsert "a" "initial" "" 1)+ Entity k1 update' <- upsert (Upsert "a" "update" "" 2) []+ update' @== initial+ ifKeyIsPreserved $ k0 @== k1+ it "updates an existing row - assignment" $ runDb $ 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"]+ ifKeyIsPreserved $ ((==@) `on` entityKey) initial update'+ upsertAttr (entityVal update') @== "update"+ upsertExtra (entityVal update') @== "extra"+ -- #endif+ it "updates existing row - addition " $ runDb $ 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]+ ifKeyIsPreserved $ ((==@) `on` entityKey) initial update'+ upsertAge (entityVal update') @== 5+ upsertExtra (entityVal update') @== "extra"+ -- #endif - it "maybe update" $ runDb $ do- let noAge = PersonMaybeAge "Michael" Nothing- keyNoAge <- insert noAge- noAge2 <- updateGet keyNoAge [PersonMaybeAgeAge +=. Just 2]- -- the correct answer depends on the backend. MongoDB assumes- -- a 'Nothing' value is 0, and does @0 + 2@ for @Just 2@. In a SQL- -- database, @NULL@ annihilates, so @NULL + 2 = NULL@.- personMaybeAgeAge noAge2 @== case handleNull of- AssumeNullIsZero ->- Just 2- Don'tUpdateNull ->- Nothing+ describe "upsertBy" $ do+ let+ uniqueEmail = UniqueUpsertBy "a"+ _uniqueCity = UniqueUpsertByCity "Boston"+ it "adds a new row with no updates" $ runDb $ do+ Entity _ u <-+ upsertBy+ uniqueEmail+ (UpsertBy "a" "Boston" "new")+ [UpsertByAttr =. "update"]+ c <- count ([] :: [Filter (UpsertByGeneric backend)])+ c @== 1+ upsertByAttr u @== "new"+ it "keeps the existing row" $ runDb $ do+ Entity k0 initial <- insertEntity (UpsertBy "a" "Boston" "initial")+ Entity k1 update' <- upsertBy uniqueEmail (UpsertBy "a" "Boston" "update") []+ update' @== initial+ ifKeyIsPreserved $ k0 @== k1+ it "updates an existing row" $ runDb $ 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"]+ ifKeyIsPreserved $ ((==@) `on` entityKey) initial update'+ upsertByAttr (entityVal update') @== "update"+ upsertByCity (entityVal update') @== "Boston"+ -- #endif+ it "updates by the appropriate constraint" $ runDb $ 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"]+ ifKeyIsPreserved $ ((==@) `on` entityKey) initBoston updBoston+ ifKeyIsPreserved $ ((==@) `on` entityKey) initKrum updKrum+ entityVal updBoston @== UpsertBy "bos" "Boston" "bos update"+ entityVal updKrum @== UpsertBy "krum" "Krum" "krum update" - describe "putMany" $ do- it "adds new rows when entity has no unique constraints" $ runDb $ do- let mkPerson name_ = Person1 name_ 25- let names = ["putMany bob", "putMany bob", "putMany smith"]- let records = map mkPerson names- _ <- putMany records- entitiesDb <- selectList [Person1Name <-. names] []- let recordsDb = fmap entityVal entitiesDb- recordsDb @== records- deleteWhere [Person1Name <-. names]- it "adds new rows when no conflicts" $ runDb $ do- let mkUpsert e = Upsert e "new" "" 1- let keys = ["putMany1","putMany2","putMany3"]- let vals = map mkUpsert keys- _ <- putMany vals- Just (Entity _ v1) <- getBy $ UniqueUpsert "putMany1"- Just (Entity _ v2) <- getBy $ UniqueUpsert "putMany2"- Just (Entity _ v3) <- getBy $ UniqueUpsert "putMany3"- [v1,v2,v3] @== vals- deleteBy $ UniqueUpsert "putMany1"- deleteBy $ UniqueUpsert "putMany2"- deleteBy $ UniqueUpsert "putMany3"- it "handles conflicts by replacing old keys with new records" $ runDb $ do- let mkUpsert1 e = Upsert e "new" "" 1- let mkUpsert2 e = Upsert e "new" "" 2- let vals = map mkUpsert2 ["putMany4", "putMany5", "putMany6", "putMany7"]- Entity k1 _ <- insertEntity $ mkUpsert1 "putMany4"- Entity k2 _ <- insertEntity $ mkUpsert1 "putMany5"- _ <- putMany $ mkUpsert1 "putMany4" : vals- Just e1 <- getBy $ UniqueUpsert "putMany4"- Just e2 <- getBy $ UniqueUpsert "putMany5"- Just e3@(Entity k3 _) <- getBy $ UniqueUpsert "putMany6"- Just e4@(Entity k4 _) <- getBy $ UniqueUpsert "putMany7"+ it "maybe update" $ runDb $ do+ let+ noAge = PersonMaybeAge "Michael" Nothing+ keyNoAge <- insert noAge+ noAge2 <- updateGet keyNoAge [PersonMaybeAgeAge +=. Just 2]+ -- the correct answer depends on the backend. MongoDB assumes+ -- a 'Nothing' value is 0, and does @0 + 2@ for @Just 2@. In a SQL+ -- database, @NULL@ annihilates, so @NULL + 2 = NULL@.+ personMaybeAgeAge noAge2 @== case handleNull of+ AssumeNullIsZero ->+ Just 2+ Don'tUpdateNull ->+ Nothing - [e1,e2,e3,e4] @== [ Entity k1 (mkUpsert2 "putMany4")- , Entity k2 (mkUpsert2 "putMany5")- , Entity k3 (mkUpsert2 "putMany6")- , Entity k4 (mkUpsert2 "putMany7")- ]- deleteBy $ UniqueUpsert "putMany4"- deleteBy $ UniqueUpsert "putMany5"- deleteBy $ UniqueUpsert "putMany6"- deleteBy $ UniqueUpsert "putMany7"+ describe "putMany" $ do+ it "adds new rows when entity has no unique constraints" $ runDb $ do+ let+ mkPerson name_ = Person1 name_ 25+ let+ names = ["putMany bob", "putMany bob", "putMany smith"]+ let+ records = map mkPerson names+ _ <- putMany records+ entitiesDb <- selectList [Person1Name <-. names] []+ let+ recordsDb = fmap entityVal entitiesDb+ recordsDb @== records+ deleteWhere [Person1Name <-. names]+ it "adds new rows when no conflicts" $ runDb $ do+ let+ mkUpsert e = Upsert e "new" "" 1+ let+ keys = ["putMany1", "putMany2", "putMany3"]+ let+ vals = map mkUpsert keys+ _ <- putMany vals+ Just (Entity _ v1) <- getBy $ UniqueUpsert "putMany1"+ Just (Entity _ v2) <- getBy $ UniqueUpsert "putMany2"+ Just (Entity _ v3) <- getBy $ UniqueUpsert "putMany3"+ [v1, v2, v3] @== vals+ deleteBy $ UniqueUpsert "putMany1"+ deleteBy $ UniqueUpsert "putMany2"+ deleteBy $ UniqueUpsert "putMany3"+ it "handles conflicts by replacing old keys with new records" $ runDb $ do+ let+ mkUpsert1 e = Upsert e "new" "" 1+ let+ mkUpsert2 e = Upsert e "new" "" 2+ let+ vals = map mkUpsert2 ["putMany4", "putMany5", "putMany6", "putMany7"]+ Entity k1 _ <- insertEntity $ mkUpsert1 "putMany4"+ Entity k2 _ <- insertEntity $ mkUpsert1 "putMany5"+ _ <- putMany $ mkUpsert1 "putMany4" : vals+ Just e1 <- getBy $ UniqueUpsert "putMany4"+ Just e2 <- getBy $ UniqueUpsert "putMany5"+ Just e3@(Entity k3 _) <- getBy $ UniqueUpsert "putMany6"+ Just e4@(Entity k4 _) <- getBy $ UniqueUpsert "putMany7" + [e1, e2, e3, e4]+ @== [ Entity k1 (mkUpsert2 "putMany4")+ , Entity k2 (mkUpsert2 "putMany5")+ , Entity k3 (mkUpsert2 "putMany6")+ , Entity k4 (mkUpsert2 "putMany7")+ ]+ deleteBy $ UniqueUpsert "putMany4"+ deleteBy $ UniqueUpsert "putMany5"+ deleteBy $ UniqueUpsert "putMany6"+ deleteBy $ UniqueUpsert "putMany7"