persistent-test 2.0.0.3 → 2.0.3.0
raw patch · 37 files changed
+1408/−2321 lines, 37 filesdep +monad-controldep −aeson-compatdep −attoparsecdep −base64-bytestringdep ~QuickCheckdep ~aesondep ~basenew-uploader
Dependencies added: monad-control
Dependencies removed: aeson-compat, attoparsec, base64-bytestring, binary, blaze-builder, blaze-markup, bson, cereal, fast-logger, hashable, http-api-data, hzk, lifted-base, mongoDB, mtl, mysql, mysql-simple, network, old-locale, persistent-mongoDB, persistent-mysql, persistent-postgresql, persistent-sqlite, persistent-test, persistent-zookeeper, postgresql-libpq, postgresql-simple, process, resource-pool, scientific, semigroups, silently, system-fileio, system-filepath, tagged, template-haskell, utf8-string, vector
Dependency ranges changed: QuickCheck, aeson, base, blaze-html, bytestring, conduit, containers, exceptions, hspec, monad-logger, path-pieces, persistent-template, random, resourcet, text, time, transformers
Files
- persistent-test.cabal +57/−171
- src/CompositeTest.hs +46/−98
- src/CustomPersistField.hs +5/−5
- src/CustomPersistFieldTest.hs +8/−21
- src/CustomPrimaryKeyReferenceTest.hs +6/−22
- src/DataTypeTest.hs +83/−145
- src/EmbedOrderTest.hs +20/−49
- src/EmbedTest.hs +51/−229
- src/EmptyEntityTest.hs +21/−21
- src/EntityEmbedTest.hs +2/−6
- src/EquivalentTypeTest.hs +10/−42
- src/HtmlTest.hs +19/−22
- src/Init.hs +141/−246
- src/InsertDuplicateUpdate.hs +0/−103
- src/LargeNumberTest.hs +11/−16
- src/MaxLenTest.hs +9/−19
- src/MigrationColumnLengthTest.hs +4/−17
- src/MigrationIdempotencyTest.hs +5/−16
- src/MigrationOnlyTest.hs +16/−27
- src/MigrationTest.hs +6/−18
- src/MpsNoPrefixTest.hs +32/−0
- src/PersistTestPetCollarType.hs +3/−3
- src/PersistTestPetType.hs +0/−1
- src/PersistUniqueTest.hs +7/−18
- src/PersistentTest.hs +151/−745
- src/PersistentTestModels.hs +157/−0
- src/PrimaryTest.hs +8/−22
- src/RawSqlTest.hs +130/−0
- src/ReadWriteTest.hs +55/−0
- src/Recursive.hs +21/−25
- src/RenameTest.hs +26/−46
- src/SumTypeTest.hs +17/−19
- src/TransactionLevelTest.hs +27/−0
- src/TreeTest.hs +41/−0
- src/UniqueTest.hs +21/−33
- src/UpsertTest.hs +192/−0
- test/main.hs +0/−116
persistent-test.cabal view
@@ -1,11 +1,11 @@ name: persistent-test-version: 2.0.0.3+version: 2.0.3.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com> synopsis: Tests for Persistent-description: Tests for Persistent+description: Tests for Persistent. This is only for use in developing libraries that should conform to the persistent interface, not for users of the persistent suite of database libraries. category: Database, Yesod stability: Stable cabal-version: >= 1.10@@ -13,195 +13,81 @@ homepage: http://www.yesodweb.com/book/persistent bug-reports: https://github.com/yesodweb/persistent/issues -extra-source-files:- test/main.hs--Flag sqlite- Description: use sqlite. This is just present for consistency, and is not used- Default: False- manual: True--Flag zookeeper- Description: test only Zookeeper. default is to test just sqlite.- Default: False- manual: True--Flag mongodb- Description: test only MongoDB. default is to test just sqlite.- Default: False- manual: True--Flag postgresql- Description: test postgresql. default is to test just sqlite.- Default: False- manual: True--Flag mysql- Description: test MySQL. default is to test just sqlite.- Default: False- manual: True--Flag high_precision_date- Description: for MongoDB use a time storage with nano second precision.- Default: False- manual: True--flag nooverlap- default: False- description: test out our assumption that OverlappingInstances is just for String- manual: True- library- exposed-modules: PersistentTest- PersistTestPetType- PersistTestPetCollarType- RenameTest+ exposed-modules: CompositeTest+ CustomPersistField+ CustomPersistFieldTest+ CustomPrimaryKeyReferenceTest DataTypeTest- EmptyEntityTest- HtmlTest EmbedTest EmbedOrderTest+ EmptyEntityTest EntityEmbedTest+ EquivalentTypeTest+ HtmlTest+ Init LargeNumberTest- UniqueTest MaxLenTest- Recursive- SumTypeTest+ MigrationColumnLengthTest+ MigrationIdempotencyTest MigrationOnlyTest MigrationTest- MigrationIdempotencyTest+ MpsNoPrefixTest+ PersistentTest+ PersistentTestModels+ PersistTestPetType+ PersistTestPetCollarType PersistUniqueTest- CompositeTest- Init PrimaryTest- CustomPersistField- CustomPersistFieldTest- CustomPrimaryKeyReferenceTest- InsertDuplicateUpdate- MigrationColumnLengthTest- EquivalentTypeTest-- hs-source-dirs: src, test+ RawSqlTest+ ReadWriteTest+ RenameTest+ Recursive+ SumTypeTest+ TransactionLevelTest+ TreeTest+ UniqueTest+ UpsertTest - ghc-options: -Wall- if impl(ghc >= 7.8)- ghc-options: -Wall -j+ hs-source-dirs: src - build-depends: base >= 4.6 && < 5+ build-depends: base >= 4.9 && < 5 , persistent , persistent-template- , HUnit- , hspec >= 1.12.1+ , aeson >= 1.0+ , blaze-html >= 0.9+ , bytestring >= 0.10+ , conduit >= 1.2.12+ , containers >= 0.5+ , exceptions >= 0.8+ , hspec >= 2.4 , hspec-expectations- , template-haskell- , aeson >= 0.7- , aeson-compat >= 0.3.2.0 && < 0.4- , lifted-base >= 0.1- , network- , path-pieces >= 0.1- , http-api-data >= 0.2- , text >= 0.8- , transformers >= 0.2.1- , unliftio-core- , unliftio- , containers >= 0.2- , bytestring >= 0.9- , base64-bytestring- , conduit >= 1.0- , resourcet >= 0.4- , exceptions >= 0.6- , time >= 1.1.4- , random >= 1.0- , QuickCheck >= 2.7- , blaze-html >= 0.5- , blaze-markup >= 0.5.1- , quickcheck-instances >= 0.3+ , HUnit+ , monad-control+ , monad-logger >= 0.3.25+ , path-pieces >= 0.2+ , QuickCheck >= 2.9+ , quickcheck-instances >= 0.3+ , random >= 1.1+ , resourcet >= 1.1+ , text >= 1.2+ , time >= 1.6+ , transformers >= 0.5 , transformers-base- , attoparsec- , vector+ , unliftio+ , unliftio-core , unordered-containers- , monad-logger >= 0.3- , hashable- -- actually just a mongoDB dependency- -- fixes build warning on current build server- , cereal- , silently- , blaze-builder- , mtl- , fast-logger- , semigroups- , scientific- , resource-pool- , exceptions- , tagged- , old-locale - if flag(nooverlap)- cpp-options: -DNO_OVERLAP-- if !flag(postgresql) && !flag(mysql) && !flag(mongodb) && !flag(zookeeper)- build-depends: persistent-sqlite >= 2.6.1.1- cpp-options: -DWITH_SQLITE -DDEBUG-- if flag(postgresql)- build-depends: persistent-postgresql- , postgresql-simple- , postgresql-libpq- cpp-options: -DWITH_POSTGRESQL -DDEBUG-- if flag(mysql)- build-depends: persistent-mysql- , mysql-simple >= 0.4.3 && < 0.5- , mysql >= 0.1.1.3 && < 0.2- cpp-options: -DWITH_MYSQL-- if flag(mongodb)- build-depends: persistent-mongoDB- , mongoDB >= 2.0.4 && < 3.0- , cereal- , bson >= 0.3.1- , process- cpp-options: -DWITH_NOSQL -DWITH_MONGODB -DDEBUG-- if flag(zookeeper)- build-depends: persistent-zookeeper- , hzk >= 2.1.0- , binary- , utf8-string >= 0.3.7 && < 0.4.0- , process- cpp-options: -DWITH_NOSQL -DWITH_ZOOKEEPER -DDEBUG-- if flag(high_precision_date)- cpp-options: -DHIGH_PRECISION_DATE- default-language: Haskell2010---executable persistent-test- main-is: main.hs- hs-source-dirs: test- default-language: Haskell2010-- build-depends: base >= 4.6 && < 5- , persistent-test- , persistent- , hspec- , system-filepath- , system-fileio- , resourcet- , scientific-- if !flag(postgresql) && !flag(mysql) && !flag(mongodb) && !flag(zookeeper)- cpp-options: -DWITH_SQLITE -DDEBUG- if flag(zookeeper)- cpp-options: -DWITH_NOSQL -DWITH_ZOOKEEPER -DDEBUG- if flag(mongodb)- cpp-options: -DWITH_NOSQL -DWITH_MONGODB -DDEBUG- if flag(postgresql)- cpp-options: -DWITH_POSTGRESQL- if flag(mysql)- cpp-options: -DWITH_MYSQL-+ default-extensions:+ ExistentialQuantification+ FlexibleContexts+ FlexibleInstances+ MultiParamTypeClasses+ OverloadedStrings+ QuasiQuotes+ TemplateHaskell+ TypeFamilies source-repository head type: git
src/CompositeTest.hs view
@@ -1,38 +1,18 @@-{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans #-}-{-# LANGUAGE UndecidableInstances #-} -- FIXME-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-} -- FIXME+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module CompositeTest where -import Test.Hspec.Expectations ()-import Init--#ifndef WITH_NOSQL+import qualified Data.Map as Map import Data.Maybe (isJust)+ import Database.Persist.TH (mkDeleteCascade)-#endif+import Init -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs-#if WITH_NOSQL-mkPersist persistSettings { mpsGeneric = False } [persistUpperCase|-#else share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate", mkDeleteCascade persistSettings { mpsGeneric = False }] [persistLowerCase|-#endif TestParent name String maxlen=20 name2 String maxlen=20@@ -47,13 +27,6 @@ extra4 String Foreign TestParent fkparent name name2 age deriving Show Eq-#ifndef WITH_MYSQL- Tree- name Text- parent Text Maybe- Primary name- Foreign Tree fkparent parent-#endif Citizen name String@@ -77,8 +50,6 @@ deriving Eq Show |] --#ifdef WITH_NOSQL cleanDB :: (PersistQuery backend, PersistEntityBackend TestChild ~ backend, MonadIO m) => ReaderT backend m () cleanDB = do deleteWhere ([] :: [Filter TestChild])@@ -87,15 +58,8 @@ deleteWhere ([] :: [Filter Citizen]) deleteWhere ([] :: [Filter Address]) -db :: Action IO () -> Assertion-db = db' cleanDB--specs :: Spec-specs = return ()-#else--specs :: Spec-specs = describe "composite" $+specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec+specsWith runDb = describe "composite" $ describe "primary keys" $ do let p1 = TestParent "a1" "b1" 11 "p1"@@ -105,16 +69,16 @@ let c1 = TestChild "a1" "b1" 11 "c1" let c1' = TestChild "a1" "b1" 11 "c1'" - it "insertWithKey" $ db $ do+ it "insertWithKey" $ runDb $ do kp1 <- insert p1 delete kp1 insertKey kp1 p2 - it "repsert" $ db $ do+ it "repsert" $ runDb $ do kp1 <- insert p1 repsert kp1 p2 - it "Insert" $ db $ do+ it "Insert" $ runDb $ do kp1 <- insert p1 matchParentK kp1 @== Right ("a1","b1",11) mp <- get kp1@@ -127,49 +91,49 @@ matchParentK kp1 @== matchParentK newkp1 p1 @== newp1 - it "Id field" $ db $ do+ it "Id field" $ runDb $ do kp1 <- insert p1 kp2 <- insert p2 xs <- selectList [TestParentId <-. [kp1,kp2]] [] length xs @== 2- let [e1@(Entity newkp1 newp1),e2@(Entity newkp2 newp2)] = xs+ [(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'" $ db $ do+ 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+ let [Entity newkp2 _newp2] = xs matchParentK kp2 @== matchParentK newkp2 - it "Filter by Id with 'in'" $ db $ do+ 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+ let [Entity newkp1 _newp1,Entity newkp2 _newp2] = xs matchParentK kp1 @== matchParentK newkp1 matchParentK kp2 @== matchParentK newkp2 - it "Filter by Id with 'not in'" $ db $ do+ 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+ let [Entity newkp2 _newp2] = xs matchParentK kp2 @== matchParentK newkp2 - it "Filter by Id with 'not in' with no data" $ db $ do+ 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" $ db $ do+ it "Extract Parent Foreign Key from Child value" $ runDb $ do kp1 <- insert p1 _ <- insert p2 kc1 <- insert c1@@ -179,20 +143,7 @@ c1 @== c11 testChildFkparent c11 @== kp1 -#ifndef WITH_MYSQL- it "Tree relationships" $ db $ do- kgp@(TreeKey gpt) <- insert $ Tree "grandpa" Nothing- kdad@(TreeKey dadt) <- insert $ Tree "dad" $ Just gpt- kc <- insert $ Tree "child" $ Just dadt- c <- getJust kc- treeFkparent c @== Just kdad- dad <- getJust kdad- treeFkparent dad @== Just kgp- gp <- getJust kgp- treeFkparent gp @== Nothing-#endif-- it "Validate Key contents" $ db $ do+ it "Validate Key contents" $ runDb $ do _ <- insert p1 _ <- insert p2 _ <- insert p3@@ -203,7 +154,7 @@ matchParentK kps2 @== Right ("a2","b2",22) matchParentK kps3 @== Right ("a3","b3",33) - it "Delete" $ db $ do+ it "Delete" $ runDb $ do kp1 <- insert p1 kp2 <- insert p2 @@ -213,19 +164,19 @@ r1 <- get kp2 isJust r1 @== True - it "Update" $ db $ do+ it "Update" $ runDb $ do kp1 <- insert p1 _ <- update kp1 [TestParentExtra44 =. "q1"] newkps1 <- get kp1 newkps1 @== Just (TestParent "a1" "b1" 11 "q1") - it "Replace Parent" $ db $ do+ it "Replace Parent" $ runDb $ do kp1 <- insert p1 _ <- replace kp1 p1' newp1 <- get kp1 newp1 @== Just p1' - it "Replace Child" $ db $ do+ it "Replace Child" $ runDb $ do -- c1 FKs p1 _ <- insert p1 kc1 <- insert c1@@ -233,7 +184,7 @@ newc1 <- get kc1 newc1 @== Just c1' - it "Insert Many to Many" $ db $ do+ it "Insert Many to Many" $ runDb $ do let z1 = Citizen "mk" (Just 11) let a1 = Address "abc" "usa" let z2 = Citizen "gb" (Just 22)@@ -261,38 +212,35 @@ let [Entity newkca1 newca2] = xs matchCitizenAddressK kca1 @== matchCitizenAddressK newkca1 ca1 @== newca2- it "insertMany" $ db $ do+ it "insertMany" $ runDb $ do [kp1, kp2] <- insertMany [p1, p2]- newp1 <- get kp1- newp1 @== Just p1-- newp2 <- get kp2- newp2 @== Just p2- it "RawSql Key instance" $ db $ do+ 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 - it "RawSql Key instance with sqlQQ" $ db $ 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" $ db $ do+ it "RawSql Entity instance" $ runDb $ do key <- insert p1 newp1 <- rawSql "SELECT ?? FROM test_parent LIMIT 1" [] [Entity key p1] @== newp1 - it "RawSql Entity instance with sqlQQ" $ db $ do- key <- insert p1- newp1' <- [sqlQQ| SELECT ?? FROM ^{TestParent} |]- [Entity key p1] @== newp1'--#endif+-- TODO: put into persistent-qq test suite+-- it "RawSql Entity instance with sqlQQ" $ runDb $ do+-- key <- insert p1+-- newp1' <- [sqlQQ| SELECT ?? FROM ^{TestParent} |]+-- [Entity key p1] @== newp1' matchK :: (PersistField a, PersistEntity record) => Key record -> Either Text a matchK = (\(pv:[]) -> fromPersistValue pv) . keyToValues
src/CustomPersistField.hs view
@@ -1,14 +1,14 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, FlexibleInstances, EmptyDataDecls, MultiParamTypeClasses #-}- -- This module is used for CustomPersistFieldTest; the TH GHC stage restriction requires it to be here. -- The code is taken from the Yesod.Text.Markdown package; see https://github.com/yesodweb/persistent/issues/448+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module CustomPersistField where -import Init+import Data.String (IsString) import Data.Text (pack)-import qualified Data.Text.Lazy as TL import Data.Text.Lazy (toStrict, fromStrict)-import Data.String (IsString)+import qualified Data.Text.Lazy as TL (Text)++import Init newtype Markdown = Markdown TL.Text deriving (Eq, Ord, IsString, Show)
src/CustomPersistFieldTest.hs view
@@ -1,33 +1,20 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, FlexibleInstances, EmptyDataDecls, MultiParamTypeClasses #-}--module CustomPersistFieldTest (- specs-#ifndef WITH_NOSQL- , customFieldMigrate-#endif-) where+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+module CustomPersistFieldTest (specsWith, customFieldMigrate) where -import Init import CustomPersistField+import Init -#ifdef WITH_NOSQL-db :: Action IO () -> Assertion-db = db' (return ())-mkPersist persistSettings [persistUpperCase|-#else-share [mkPersist sqlSettings, mkMigrate "customFieldMigrate"] [persistLowerCase|-#endif+share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "customFieldMigrate"] [persistLowerCase| BlogPost article Markdown deriving Show Eq |] -specs :: Spec-specs = describe "Custom persist field" $ do- it "should read what it wrote" $ db $ do+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-
src/CustomPrimaryKeyReferenceTest.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}-+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# 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@@ -7,11 +7,7 @@ import Init -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs-#if WITH_NOSQL-mkPersist persistSettings { mpsGeneric = False } [persistUpperCase|-#else share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase|-#endif Tweet tweetId Int statusText Text sqltype=varchar(170)@@ -25,29 +21,17 @@ UniqueTweetIdTweetUrl tweetId tweetUrl deriving Show |]-#ifdef WITH_NOSQL+ cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Tweet ~ backend) => ReaderT backend m () cleanDB = do deleteWhere ([] :: [Filter Tweet]) deleteWhere ([] :: [Filter TweetUrl]) -db :: Action IO () -> Assertion-db = db' cleanDB-#endif--specs :: Spec-specs = describe "custom primary key reference" $ do-#ifdef WITH_NOSQL- return ()-#else-+specsWith :: (MonadFail m, MonadIO m) => RunDb SqlBackend m -> Spec+specsWith runDb = describe "custom primary key reference" $ do let tweet = Tweet {tweetTweetId = 1, tweetStatusText = "Hello!"} - it "can insert a Tweet" $ db $ do+ 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-- return ()--#endif
src/DataTypeTest.hs view
@@ -1,33 +1,33 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}-module DataTypeTest (specs) where+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+module DataTypeTest+ ( specsWith+ , dataTypeMigrate+ , roundTime+ , roundUTCTime+ ) where +import Control.Applicative (liftA2)+import qualified Data.ByteString as BS+import Data.Fixed (Pico)+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 Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) import Test.QuickCheck.Gen (Gen(..)) import Test.QuickCheck.Instances () import Test.QuickCheck.Random (newQCGen)-import Database.Persist.TH-import Data.Char (generalCategory, GeneralCategory(..))-import qualified Data.Text as T-import qualified Data.ByteString as BS-import Data.Time (Day, UTCTime (..), fromGregorian, picosecondsToDiffTime,- TimeOfDay (TimeOfDay), timeToTimeOfDay, timeOfDayToTime)-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)-import Data.IntMap (IntMap)-import Data.Fixed (Pico,Micro) +import Database.Persist.TH import Init type Tuple a b = (a, b) -#ifdef WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else -- Test lower case names share [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase|-#endif DataTypeTable no-json text Text textMaxLen Text maxlen=100@@ -40,159 +40,97 @@ double Double bool Bool day Day-#ifndef WITH_NOSQL- pico Pico- time TimeOfDay-#endif utc UTCTime-#if defined(WITH_MYSQL) && !(defined(OLD_MYSQL))- -- For MySQL, provide extra tests for time fields with fractional seconds,- -- since the default (used above) is to have no fractional part. This- -- requires the server version to be at least 5.6.4, and should be switched- -- off for older servers by defining OLD_MYSQL.- timeFrac TimeOfDay sqltype=TIME(6)- utcFrac UTCTime sqltype=DATETIME(6)-#endif |] -cleanDB :: (MonadIO m, PersistQuery backend, backend ~ PersistEntityBackend DataTypeTable) => ReaderT backend m ()-cleanDB = deleteWhere ([] :: [Filter DataTypeTable])--specs :: Spec-specs = describe "data type specs" $- it "handles all types" $ asIO $ runConn $ do-#ifndef WITH_NOSQL- _ <- runMigrationSilent dataTypeMigrate- -- Ensure reading the data from the database works...- _ <- runMigrationSilent dataTypeMigrate-#endif- rvals <- liftIO randomValues- forM_ (take 1000 rvals) $ \x -> do- key <- insert x- Just y <- get key- liftIO $ do- let check :: (Eq a, Show a) => String -> (DataTypeTable -> a) -> IO ()- check s f = (s, f x) @=? (s, f y)- -- Check floating-point near equality- let check' :: String -> (DataTypeTable -> Pico) -> IO ()- check' s f- | abs (f x - f y) < 0.000001 = return ()- | otherwise = (s, f x) @=? (s, f y)- -- Check individual fields for better error messages- check "text" dataTypeTableText- check "textMaxLen" dataTypeTableTextMaxLen- check "bytes" dataTypeTableBytes- check "bytesTextTuple" dataTypeTableBytesTextTuple- check "bytesMaxLen" dataTypeTableBytesMaxLen- check "int" dataTypeTableInt- check "intList" dataTypeTableIntList- check "intMap" dataTypeTableIntMap- check "bool" dataTypeTableBool- check "day" dataTypeTableDay-#ifndef WITH_NOSQL- check' "pico" dataTypeTablePico- check "time" (roundTime . dataTypeTableTime)-#endif-#if !(defined(WITH_NOSQL)) || (defined(WITH_NOSQL) && defined(HIGH_PRECISION_DATE))- check "utc" (roundUTCTime . dataTypeTableUtc)-#endif-#if defined(WITH_MYSQL) && !(defined(OLD_MYSQL))- check "timeFrac" (dataTypeTableTimeFrac)- check "utcFrac" (dataTypeTableUtcFrac)-#endif-- -- Do a special check for Double since it may- -- lose precision when serialized.- when (getDoubleDiff (dataTypeTableDouble x)(dataTypeTableDouble y) > 1e-14) $- check "double" dataTypeTableDouble- where- normDouble :: Double -> Double- normDouble x | abs x > 1 = x / 10 ^ (truncate (logBase 10 (abs x)) :: Integer)- | otherwise = x- getDoubleDiff x y = abs (normDouble x - normDouble y)+cleanDB'+ ::+ ( MonadIO m, PersistStoreWrite (BaseBackend backend), PersistQuery backend) => ReaderT backend m ()+cleanDB' = deleteWhere ([] :: [Filter (DataTypeTableGeneric backend)]) roundFn :: RealFrac a => a -> Integer-#ifdef OLD_MYSQL--- At version 5.6.4, MySQL changed the method used to round values for--- date/time types - this is the same version which added support for--- fractional seconds in the storage type.-roundFn = truncate-#else roundFn = round-#endif roundTime :: TimeOfDay -> TimeOfDay-#ifdef WITH_MYSQL roundTime t = timeToTimeOfDay $ fromIntegral $ roundFn $ timeOfDayToTime t-#else-roundTime = id-#endif roundUTCTime :: UTCTime -> UTCTime-#ifdef WITH_MYSQL roundUTCTime t = posixSecondsToUTCTime $ fromIntegral $ roundFn $ utcTimeToPOSIXSeconds t-#else-roundUTCTime = id-#endif -randomValues :: IO [DataTypeTable]-randomValues = do- g <- newQCGen- return $ map (unGen arbitrary g) [0..]+randomValues :: Arbitrary a => Int -> IO [a]+randomValues i = do+ gs <- replicateM i newQCGen+ return $ zipWith (unGen arbitrary) gs [0..] instance Arbitrary DataTypeTable where arbitrary = DataTypeTable <$> arbText -- text- <*> (T.take 100 <$> arbText) -- textManLen+ <*> (T.take 100 <$> arbText) -- textManLen <*> arbitrary -- bytes- <*> arbTuple arbitrary arbText -- bytesTextTuple- <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen+ <*> liftA2 (,) arbitrary arbText -- bytesTextTuple+ <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen <*> arbitrary -- int <*> arbitrary -- intList <*> arbitrary -- intMap <*> arbitrary -- double <*> arbitrary -- bool <*> arbitrary -- day-#ifndef WITH_NOSQL- <*> arbitrary -- pico- <*> (truncateTimeOfDay =<< arbitrary) -- time-#endif <*> (truncateUTCTime =<< arbitrary) -- utc-#if defined(WITH_MYSQL) && !(defined(OLD_MYSQL))- <*> (truncateTimeOfDay =<< arbitrary) -- timeFrac- <*> (truncateUTCTime =<< arbitrary) -- utcFrac-#endif -arbText :: Gen Text-arbText =- T.pack- . filter ((`notElem` forbidden) . generalCategory)- . filter (<= '\xFFFF') -- only BMP- . filter (/= '\0') -- no nulls- <$> arbitrary- where forbidden = [NotAssigned, PrivateUse]--arbTuple :: Gen a -> Gen b -> Gen (a, b)-arbTuple x y = (,) <$> x <*> y---- truncate less significant digits-truncateToMicro :: Pico -> Pico-truncateToMicro p = let- p' = fromRational . toRational $ p :: Micro- in fromRational . toRational $ p' :: Pico--truncateTimeOfDay :: TimeOfDay -> Gen TimeOfDay-truncateTimeOfDay (TimeOfDay h m s) =- return $ TimeOfDay h m $ truncateToMicro s+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+ )+ => (db () -> IO ())+ -- ^ DB Runner+ -> Maybe (db [Text])+ -- ^ Optional migrations to run+ -> [TestFn entity]+ -- ^ List of entity fields to test+ -> [(String, entity -> Pico)]+ -- ^ List of pico fields to test+ -> (entity -> Double)+ -> Spec+specsWith runDb mmigration checks apprxChecks doubleFn = describe "data type specs" $+ it "handles all types" $ asIO $ runDb $ do -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+ _ <- 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) => 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) => 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 -asIO :: IO a -> IO a-asIO = id+ -- 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,25 +1,16 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleInstances #-}-{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell,- OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls, MultiParamTypeClasses #-}-module EmbedOrderTest (specs,-#ifndef WITH_NOSQL-embedOrderMigrate-#endif-) where+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+module EmbedOrderTest (specsWith, embedOrderMigrate, cleanDB) where +import qualified Data.Map as Map+import Debug.Trace (trace)+ import Init-import Data.Map hiding (insert) -import Debug.Trace (trace) debug :: Show s => s -> s debug x = trace (show x) x -#if WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else-share [mkPersist sqlSettings, mkMigrate "embedOrderMigrate"] [persistUpperCase|-#endif+share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "embedOrderMigrate"] [persistUpperCase| Foo sql=foo_embed_order bars [Bar] deriving Eq Show@@ -30,42 +21,22 @@ deriving Eq Show |] -#ifdef WITH_NOSQL-cleanDB :: (PersistQuery backend, PersistEntityBackend Foo ~ backend, MonadIO m) => ReaderT backend m ()+cleanDB :: Runner backend m => ReaderT backend m () cleanDB = do- deleteWhere ([] :: [Filter Foo])- deleteWhere ([] :: [Filter Bar])--db :: Action IO () -> Assertion-db = db' cleanDB-#endif--specs :: Spec-specs = describe "embedded entities" $ do- it "preserves ordering" $ db $ do- let foo = Foo [Bar "b" "u" "g"]- fooId <- insert foo- Just otherFoo <- get fooId- foo @== otherFoo-- it "PersistMap PersistValue serializaion" $ db $ do- let record = fromList [("b","b"),("u","u"),("g","g")] :: Map Text Text- record @== (fromRight . fromPersistValue . toPersistValue) record-- -- this demonstrates a change in ordering- -- that won't be a problem if the keys are properly tracked- {-- let precord = PersistMap [("b",PersistText "b"),("u",PersistText "u"),("g",PersistText "g")]- precord ==@ (debug . toPersistValue . debug . (fromRight . fromPersistValue :: PersistValue -> Map Text Text)) precord-- let precord = PersistMap [("b",PersistText "b"),("u",PersistText "u"),("g",PersistText "g")]- precord ==@ (fromSuccess . fromJSON . debug . (toJSON :: PersistValue -> Value)) precord+ deleteWhere ([] :: [Filter (FooGeneric backend)])+ deleteWhere ([] :: [Filter (BarGeneric backend)]) +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"]+ fooId <- insert foo+ Just otherFoo <- get fooId+ foo @== otherFoo -fromSuccess :: Result a -> a-fromSuccess (Success s) = s-fromSuccess (Error e) = error $ "expected Success, got Error " ++ e- -}+ it "PersistMap PersistValue serializaion" $ db $ do+ 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 (Left e) = error $ "expected Right, got Left " ++ show e
src/EmbedTest.hs view
@@ -1,29 +1,17 @@-{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}-module EmbedTest (specs,-#ifndef WITH_NOSQL-embedMigrate-#endif-) where+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans -O0 #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+module EmbedTest (specsWith, cleanDB, embedMigrate) where -import Init import Control.Exception (Exception, throw)-import Data.Typeable (Typeable)-+import Data.List.NonEmpty hiding (insert, length)+import qualified Data.Map as M import qualified Data.Text as T+import Data.Typeable (Typeable) import qualified Data.Set as S-import qualified Data.Map as M-#if WITH_NOSQL-#ifdef WITH_MONGODB-import Database.Persist.MongoDB-import Database.MongoDB (genObjectId)-import Database.MongoDB (Value(String))-#endif+ import EntityEmbedTest-import System.Process (readProcess)-#endif-import Data.List.NonEmpty hiding (insert, length)+import Init data TestException = TestException deriving (Show, Typeable, Eq)@@ -31,36 +19,17 @@ instance PersistFieldSql a => PersistFieldSql (NonEmpty a) where sqlType _ = SqlString+ instance PersistField a => PersistField (NonEmpty a) where toPersistValue = toPersistValue . toList- fromPersistValue pv = case fromPersistValue pv of- Left e -> Left e- Right [] -> Left "PersistField: NonEmpty found unexpected Empty List"- Right (l:ls) -> Right (l:|ls)+ fromPersistValue pv = do+ xs <- fromPersistValue pv+ case xs of+ [] -> Left "PersistField: NonEmpty found unexpected Empty List"+ (l:ls) -> Right (l:|ls) -#if WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-# ifdef WITH_MONGODB- HasObjectId- oid ObjectId- name Text- deriving Show Eq Read Ord-- HasArrayWithObjectIds- name Text- arrayWithObjectIds [HasObjectId]- deriving Show Eq Read Ord-- HasArrayWithEntities- hasEntity (Entity ARecord)- arrayWithEntities [AnEntity]- deriving Show Eq Read Ord-# endif--#else-share [mkPersist sqlSettings, mkMigrate "embedMigrate"] [persistUpperCase|-#endif+share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "embedMigrate"] [persistUpperCase| OnlyName name Text@@ -150,6 +119,10 @@ map (M.Map T.Text (Key OnlyName)) deriving Show Eq Read Ord + HasArrayWithEntities+ hasEntity (Entity ARecord)+ arrayWithEntities [AnEntity]+ deriving Show Eq Read Ord -- Self refrences are only allowed as a nullable type: -- a Maybe or a List@@ -163,48 +136,43 @@ -- SelfDirect -- reference SelfDirect |]-#ifdef WITH_NOSQL cleanDB :: (PersistQuery backend, PersistEntityBackend HasMap ~ backend, MonadIO m) => ReaderT backend m () cleanDB = do- deleteWhere ([] :: [Filter HasEmbed])- deleteWhere ([] :: [Filter HasEmbeds])- deleteWhere ([] :: [Filter HasListEmbed])- deleteWhere ([] :: [Filter HasSetEmbed])- deleteWhere ([] :: [Filter User])- deleteWhere ([] :: [Filter HasMap])- deleteWhere ([] :: [Filter HasList])- deleteWhere ([] :: [Filter EmbedsHasMap])- deleteWhere ([] :: [Filter ListEmbed])- deleteWhere ([] :: [Filter ARecord])- deleteWhere ([] :: [Filter Account])- deleteWhere ([] :: [Filter HasNestedList])--db :: Action IO () -> Assertion-db = db' cleanDB-#endif+ 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 predicate body = do+_unlessM :: MonadIO m => IO Bool -> m () -> m ()+_unlessM predicate body = do b <- liftIO predicate unless b body -specs :: Spec-specs = describe "embedded entities" $ do+specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec+specsWith runDb = describe "embedded entities" $ do - it "simple entities" $ db $ 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 "query for equality of embeded entity" $ db $ do+ 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" $ db $ do+ it "Set" $ runDb $ do let container = HasSetEmbed "set" $ S.fromList [ HasEmbed "embed" (OnlyName "1") , HasEmbed "embed" (OnlyName "2")@@ -213,13 +181,13 @@ Just res <- selectFirst [HasSetEmbedName ==. "set"] [] res @== Entity contK container - it "Set empty" $ db $ do+ 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) $ db $ do+ it "exception" $ flip shouldThrow (== TestException) $ runDb $ do let container = HasSetEmbed "set" $ S.fromList [ HasEmbed "embed" (OnlyName "1") , HasEmbed "embed" (OnlyName "2")@@ -228,7 +196,7 @@ Just res <- selectFirst [HasSetEmbedName ==. throw TestException] [] res @== Entity contK container - it "ListEmbed" $ db $ do+ it "ListEmbed" $ runDb $ do let container = HasListEmbed "list" [ HasEmbed "embed" (OnlyName "1") , HasEmbed "embed" (OnlyName "2")@@ -237,19 +205,19 @@ Just res <- selectFirst [HasListEmbedName ==. "list"] [] res @== Entity contK container - it "ListEmbed empty" $ db $ do+ 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" $ db $ do+ it "List empty" $ runDb $ do let container = HasList [] contK <- insert container Just res <- selectFirst [] [] res @== Entity contK container - it "NonEmpty List wrapper" $ db $ do+ 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@@ -258,7 +226,7 @@ Just res <- selectFirst [AccountUserIds ==. (uid:|[])] [] res @== Entity contK container - it "Map" $ db $ do+ it "Map" $ runDb $ do let container = HasMap "2 items" $ M.fromList [ ("k1","v1") , ("k2","v2")@@ -267,13 +235,13 @@ Just res <- selectFirst [HasMapName ==. "2 items"] [] res @== Entity contK container - it "Map empty" $ db $ do+ 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" $ db $ do+ it "Embeds a Map" $ runDb $ do let container = EmbedsHasMap (Just "non-empty map") $ HasMap "2 items" $ M.fromList [ ("k1","v1") , ("k2","v2")@@ -282,162 +250,16 @@ Just res <- selectFirst [EmbedsHasMapName ==. Just "non-empty map"] [] res @== Entity contK container - it "Embeds a Map empty" $ db $ do+ 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")] []+ Just res <- selectFirst [EmbedsHasMapName ==. Just "empty map"] [] res @== Entity contK container - it "Embeds a Map with ids as values" $ db $ do+ 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--#ifdef WITH_NOSQL-#ifdef WITH_MONGODB- it "List" $ db $ do- k1 <- insert $ HasList []- k2 <- insert $ HasList [k1]- let container = HasList [k1, k2]- contK <- insert container- Just res <- selectFirst [HasListList `anyEq` k2] []- res @== Entity contK container-- it "can embed an Entity" $ db $ do- let foo = ARecord "foo"- bar = ARecord "bar"- _ <- insertMany [foo, bar]- arecords <- selectList ([ARecordName ==. "foo"] ||. [ARecordName ==. "bar"]) []- length arecords @== 2-- kfoo <- insert foo- let hasEnts = HasArrayWithEntities (Entity kfoo foo) arecords- kEnts <- insert hasEnts- Just retrievedHasEnts <- get kEnts- retrievedHasEnts @== hasEnts-- it "can embed objects with ObjectIds" $ db $ do- oid <- liftIO $ genObjectId- let hoid = HasObjectId oid "oid"- hasArr = HasArrayWithObjectIds "array" [hoid]-- k <- insert hasArr- Just v <- get k- v @== hasArr-- describe "mongoDB filters" $ do- it "mongo single nesting filters" $ db $ do- let usr = User "foo" (Just "pswd") prof- prof = Profile "fstN" "lstN" (Just con)- con = Contact 123456 "foo@bar.com"- uId <- insert usr- Just r1 <- selectFirst [UserProfile &->. ProfileFirstName `nestEq` "fstN"] []- r1 @== (Entity uId usr)- Just r2 <- selectFirst [UserProfile &~>. ProfileContact ?&->. ContactEmail `nestEq` "foo@bar.com", UserIdent ==. "foo"] []- r2 @== (Entity uId usr)-- it "mongo embedded array filters" $ db $ do- let container = HasListEmbed "list" [- (HasEmbed "embed" (OnlyName "1"))- , (HasEmbed "embed" (OnlyName "2"))- ]- contK <- insert container- let contEnt = Entity contK container- Just meq <- selectFirst [HasListEmbedList `anyEq` HasEmbed "embed" (OnlyName "1")] []- meq @== contEnt-- Just neq1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestEq` "embed"] []- neq1 @== contEnt-- Just nne1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestNe` "notEmbed"] []- nne1 @== contEnt-- Just neq2 <- selectFirst [HasListEmbedList ~>. HasEmbedEmbed &->. OnlyNameName `nestEq` "1"] []- neq2 @== contEnt-- Just nbq1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestBsonEq` String "embed"] []- nbq1 @== contEnt-- Just nbq2 <- selectFirst [HasListEmbedList ~>. HasEmbedEmbed &->. OnlyNameName `nestBsonEq` String "1"] []- nbq2 @== contEnt-- it "regexp match" $ db $ do- let container = HasListEmbed "list" [- (HasEmbed "embed" (OnlyName "abcd"))- , (HasEmbed "embed" (OnlyName "efgh"))- ]- contK <- insert container- let mkReg t = (t, "ims")- Just res <- selectFirst [HasListEmbedName =~. mkReg "ist"] []- res @== (Entity contK container)-- it "nested anyEq" $ db $ do- let top = HasNestedList [IntList [1,2]]- k <- insert top- Nothing <- selectFirst [HasNestedListList ->. IntListInts `nestEq` ([]::[Int])] []- Nothing <- selectFirst [HasNestedListList ->. IntListInts `nestAnyEq` 3] []- Just res <- selectFirst [HasNestedListList ->. IntListInts `nestAnyEq` 2] []- res @== (Entity k top)-- describe "mongoDB updates" $ do- it "mongo single nesting updates" $ db $ do- let usr = User "foo" (Just "pswd") prof- prof = Profile "fstN" "lstN" (Just con)- con = Contact 123456 "foo@bar.com"- uid <- insert usr- let newName = "fstN2"- usr1 <- updateGet uid [UserProfile &->. ProfileFirstName `nestSet` newName]- (profileFirstName $ userProfile usr1) @== newName-- let newEmail = "foo@example.com"- let newIdent = "bar"- usr2 <- updateGet uid [UserProfile &~>. ProfileContact ?&->. ContactEmail `nestSet` newEmail, UserIdent =. newIdent]- (userIdent usr2) @== newIdent- (fmap contactEmail . profileContact . userProfile $ usr2) @== Just newEmail--- it "mongo embedded array updates" $ db $ do- let container = HasListEmbed "list" [- (HasEmbed "embed" (OnlyName "1"))- , (HasEmbed "embed" (OnlyName "2"))- ]- contk <- insert container- let contEnt = Entity contk container-- pushed <- updateGet contk [HasListEmbedList `push` HasEmbed "embed" (OnlyName "3")]- (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList pushed) @== ["1","2","3"]-- -- same, don't add anything- addedToSet <- updateGet contk [HasListEmbedList `addToSet` HasEmbed "embed" (OnlyName "3")]- (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList addedToSet) @== ["1","2","3"]- pulled <- updateGet contk [HasListEmbedList `pull` HasEmbed "embed" (OnlyName "3")]- (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList pulled) @== ["1","2"]-- -- now it is new- addedToSet2 <- updateGet contk [HasListEmbedList `addToSet` HasEmbed "embed" (OnlyName "3")]- (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList addedToSet2) @== ["1","2","3"]-- allPulled <- updateGet contk [eachOp pull HasListEmbedList- [ HasEmbed "embed" (OnlyName "3")- , HasEmbed "embed" (OnlyName "2")- ] ]- (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList allPulled) @== ["1"]- allPushed <- updateGet contk [eachOp push HasListEmbedList- [ HasEmbed "embed" (OnlyName "4")- , HasEmbed "embed" (OnlyName "5")- ] ]- (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList allPushed) @== ["1","4","5"]--- it "re-orders json inserted from another source" $ db $ do- let cname = T.unpack $ collectionName (error "ListEmbed" :: ListEmbed)- liftIO $ putStrLn =<< readProcess "mongoimport" ["-d", T.unpack dbName, "-c", cname] "{ \"nested\": [{ \"one\": 1, \"two\": 2 }, { \"two\": 2, \"one\": 1}], \"two\": 2, \"one\": 1, \"_id\" : { \"$oid\" : \"50184f5a92d7ae0000001e89\" } }"- -- liftIO $ putStrLn =<< readProcess "mongo" ["--eval", "printjson(db." ++ cname ++ ".find().toArray())", T.unpack dbName] ""-- lists <- selectList [] []- fmap entityVal lists @== [ListEmbed [InList 1 2, InList 1 2] 1 2]-#endif-#endif
src/EmptyEntityTest.hs view
@@ -1,36 +1,36 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}-module EmptyEntityTest (specs) where+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+module EmptyEntityTest (specsWith, migration, cleanDB) where import Database.Persist.Sql import Database.Persist.TH-import Control.Monad.Trans.Resource (runResourceT) import Init -#ifdef WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else -- Test lower case names-share [mkPersist sqlSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase|-#endif+share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migration"] [persistLowerCase| EmptyEntity |] -#ifdef WITH_NOSQL-cleanDB :: MonadIO m => ReaderT Context m ()-cleanDB = deleteWhere ([] :: [Filter EmptyEntity])-#endif+cleanDB+ ::+ ( PersistQueryWrite backend+ , MonadIO m+ , PersistStoreWrite (BaseBackend backend)+ )+ => ReaderT backend m ()+cleanDB = deleteWhere ([] :: [Filter (EmptyEntityGeneric backend)]) -specs :: Spec-specs = describe "empty entity" $- it "inserts" $ (id :: IO () -> IO ()) $ runResourceT $ runConn $ do-#ifndef WITH_NOSQL- _ <- runMigrationSilent dataTypeMigrate+specsWith+ :: 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...- _ <- runMigrationSilent dataTypeMigrate-#endif+ _ <- sequence_ mmigrate x <- insert EmptyEntity Just EmptyEntity <- get x return ()
src/EntityEmbedTest.hs view
@@ -1,18 +1,14 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# 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-#if WITH_NOSQL import Init -mkPersist persistSettings [persistUpperCase|+mkPersist persistSettings { mpsGeneric = True } [persistUpperCase| ARecord name Text deriving Show Eq Read Ord |] type AnEntity = Entity ARecord-#endif
src/EquivalentTypeTest.hs view
@@ -1,61 +1,29 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module EquivalentTypeTest (specs) where+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-} -import Database.Persist.TH-import Control.Monad.Trans.Resource (runResourceT)-#ifdef WITH_POSTGRESQL-import qualified Data.Text as T-#endif+module EquivalentTypeTest (specsWith) where +import UnliftIO++import Database.Persist.TH import Init -#ifdef WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase|-#endif EquivalentType sql=equivalent_types field1 Int-#ifdef WITH_POSTGRESQL- field2 T.Text sqltype=text- field3 T.Text sqltype=us_postal_code-#endif deriving Eq Show |] -#ifdef WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else share [mkPersist sqlSettings, mkMigrate "migrateAll2"] [persistLowerCase|-#endif EquivalentType2 sql=equivalent_types field1 Int-#ifdef WITH_POSTGRESQL- field2 T.Text- field3 T.Text sqltype=us_postal_code-#endif deriving Eq Show |] -specs :: Spec-specs = describe "doesn't migrate equivalent types" $ do- it "works" $ asIO $ runResourceT $ runConn $ do--#ifdef WITH_POSTGRESQL- _ <- rawExecute "DROP DOMAIN IF EXISTS us_postal_code" []- _ <- rawExecute "CREATE DOMAIN us_postal_code AS TEXT CHECK(VALUE ~ '^\\d{5}$')" []-#endif--#ifndef WITH_NOSQL+specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec+specsWith runDb = describe "doesn't migrate equivalent types" $ do+ it "works" $ runDb $ do _ <- runMigrationSilent migrateAll1 xs <- getMigration migrateAll2 liftIO $ xs @?= []-#else- return ()-#endif- --asIO :: IO a -> IO a-asIO = id
src/HtmlTest.hs view
@@ -1,43 +1,43 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}-module HtmlTest (specs) where+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+module HtmlTest (specsWith, cleanDB, htmlMigrate) where -import Database.Persist.TH import Data.Char (generalCategory, GeneralCategory(..)) import qualified Data.Text as T import System.Random (randomIO, randomRIO, Random)-import Control.Monad.Trans.Resource (runResourceT)--import Init import Text.Blaze.Html import Text.Blaze.Html.Renderer.Text +import Init+ -- Test lower case names-share [mkPersist persistSettings, mkMigrate "htmlMigrate"] [persistLowerCase|+share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "htmlMigrate"] [persistLowerCase| HtmlTable html Html deriving |] -cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend HtmlTable ~ backend) => ReaderT backend m ()+cleanDB :: Runner backend m => ReaderT backend m () cleanDB = do- deleteWhere ([] :: [Filter HtmlTable])+ deleteWhere ([] :: [Filter (HtmlTableGeneric backend)]) -specs :: Spec-specs = describe "html" $ do- it "works" $ asIO $ runResourceT $ runConn $ do-#ifndef WITH_NOSQL- _ <- runMigrationSilent htmlMigrate+specsWith+ :: Runner backend m+ => RunDb backend m+ -> Maybe (ReaderT backend m a)+ -> Spec+specsWith runConn mmigrate = describe "html" $ do+ it "works" $ asIO $ runConn $ do+ sequence_ mmigrate -- Ensure reading the data from the database works...- _ <- runMigrationSilent htmlMigrate-#endif+ sequence_ mmigrate sequence_ $ replicate 1000 $ do x <- liftIO randomValue key <- insert $ HtmlTable x- Just (HtmlTable y) <- get key+ Just htmlTableY <- get key liftIO $ do- renderHtml x @?= renderHtml y+ renderHtml x @?= renderHtml (htmlTableHtml htmlTableY) randomValue :: IO Html randomValue =@@ -48,9 +48,6 @@ . filter (/= '\0') -- no nulls <$> randomIOs where forbidden = [NotAssigned, PrivateUse]--asIO :: IO a -> IO a-asIO = id randomIOs :: Random a => IO [a] randomIOs = do
src/Init.hs view
@@ -1,38 +1,28 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | This will hopefully be the only module with CPP in it. module Init ( (@/=), (@==), (==@)+ , asIO , assertNotEqual , assertNotEmpty , assertEmpty , isTravis- , BackendMonad- , runConn + , module Database.Persist.Sql , MonadIO , persistSettings , MkPersistSettings (..)-#ifdef WITH_NOSQL- , dbName- , db'- , setup- , mkPersistSettings- , Action- , Context-#else- , db- , sqlite_database- , sqlite_database_file-#endif , BackendKey(..)- , generateKey+ , GenerateKey(..) + , RunDb+ , Runner -- re-exports- , (A.<$>), (A.<*>) , module Database.Persist , module Test.Hspec , module Test.HUnit@@ -42,96 +32,66 @@ , Text , module Control.Monad.Trans.Reader , module Control.Monad-#ifndef WITH_NOSQL- , module Database.Persist.Sql-#else- , PersistFieldSql(..)-#endif , BS.ByteString , SomeException-) where+ , MonadFail+ , TestFn(..)+ , truncateTimeOfDay+ , truncateToMicro+ , truncateUTCTime+ , arbText+ , liftA2+ , changeBackend+ ) where +-- needed for backwards compatibility+import Control.Monad.Base+import Control.Monad.Catch+import qualified Control.Monad.Fail as MonadFail+import Control.Monad.Logger+import Control.Monad.Trans.Class+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource+import Control.Monad.Trans.Resource.Internal+ -- re-exports-import Control.Applicative as A ((<$>), (<*>))+import Control.Applicative (liftA2) import Control.Exception (SomeException) import Control.Monad (void, replicateM, liftM, when, forM_)+import Control.Monad.Fail (MonadFail) import Control.Monad.Trans.Reader-import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..))+import Data.Char (generalCategory, GeneralCategory(..))+import Data.Fixed (Pico,Micro)+import qualified Data.Text as T+import Data.Time import Test.Hspec+import Test.QuickCheck.Instances () +import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..))+ -- testing import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) import Test.QuickCheck +import Control.Monad (unless, (>=>))+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift (MonadUnliftIO) import qualified Data.ByteString as BS+import Data.IORef import Data.Text (Text, unpack)-import Database.Persist-import Database.Persist.TH () import System.Environment (getEnvironment)--#ifdef WITH_NOSQL-import Database.Persist.Sql (PersistFieldSql(..))-import Database.Persist.TH (mkPersistSettings)-import Language.Haskell.TH.Syntax (Type(..))--# ifdef WITH_MONGODB-import qualified Database.MongoDB as MongoDB-import Database.Persist.MongoDB (Action, withMongoPool, runMongoDBPool, defaultMongoConf, applyDockerEnv, BackendKey(..))-# endif--# ifdef WITH_ZOOKEEPER-import Data.IORef (newIORef, IORef, writeIORef, readIORef)-import qualified Data.Text as T-import Database.Persist.Zookeeper (Action, withZookeeperPool, runZookeeperPool, ZookeeperConf(..), defaultZookeeperConf, BackendKey(..), deleteRecursive)-import qualified Database.Zookeeper as Z-import System.IO.Unsafe (unsafePerformIO)-# endif+import System.IO.Unsafe -#else-import Control.Monad.Logger-import Control.Monad.Trans.Resource (ResourceT, runResourceT)+import Database.Persist import Database.Persist.Sql-import System.Log.FastLogger (fromLogStr)--# ifdef WITH_POSTGRESQL-import Data.Maybe (fromMaybe)-import Data.Monoid ((<>))-import Database.Persist.Postgresql-# endif-# ifdef WITH_SQLITE-import Database.Persist.Sqlite-# endif-# ifdef WITH_MYSQL-import Database.Persist.MySQL-import qualified Database.MySQL.Base as MySQL-# endif-import Data.IORef (newIORef, IORef, writeIORef, readIORef)-import System.IO.Unsafe (unsafePerformIO)-#endif--import Control.Monad (unless, (>=>))-import Control.Monad.IO.Unlift (MonadUnliftIO)+import Database.Persist.TH () -- Data types import Data.Int (Int32, Int64) -import Control.Monad.IO.Class --#ifdef WITH_MONGODB-setup :: Action IO ()-setup = setupMongo-type Context = MongoDB.MongoContext-#endif--#ifdef WITH_ZOOKEEPER-setup :: Action IO ()-setup = setupZookeeper-type Context = Z.Zookeeper-#endif---+asIO :: IO a -> IO a+asIO a = a (@/=), (@==), (==@) :: (Eq a, Show a, MonadIO m) => a -> a -> m () infix 1 @/= --, /=@@@ -152,10 +112,10 @@ where msg = (if null preface then "" else preface ++ "\n") ++ "expected: " ++ show expected ++ "\n to not equal: " ++ show actual -assertEmpty :: (Monad m, MonadIO m) => [a] -> m ()-assertEmpty xs = liftIO $ assertBool "" (null xs)+assertEmpty :: (MonadIO m) => [a] -> m ()+assertEmpty xs = liftIO $ assertBool "" (null xs) -assertNotEmpty :: (Monad m, MonadIO m) => [a] -> m ()+assertNotEmpty :: (MonadIO m) => [a] -> m () assertNotEmpty xs = liftIO $ assertBool "" (not (null xs)) isTravis :: IO Bool@@ -165,146 +125,12 @@ Just "true" -> True _ -> False -_debugOn :: Bool-#ifdef DEBUG-_debugOn = True-#else-_debugOn = False-#endif--#ifdef WITH_POSTGRESQL-dockerPg :: IO (Maybe BS.ByteString)-dockerPg = do- env <- liftIO getEnvironment- return $ case lookup "POSTGRES_NAME" env of- Just _name -> Just "postgres" -- /persistent/postgres- _ -> Nothing-#endif--#ifdef WITH_NOSQL persistSettings :: MkPersistSettings-persistSettings = (mkPersistSettings $ ConT ''Context) { mpsGeneric = True }--dbName :: Text-dbName = "persistent"--type BackendMonad = Context--#ifdef WITH_MONGODB-runConn :: MonadUnliftIO m => Action m backend -> m ()-runConn f = do- conf <- liftIO $ applyDockerEnv $ defaultMongoConf dbName -- { mgRsPrimary = Just "replicaset" }- void $ withMongoPool conf $ runMongoDBPool MongoDB.master f--setupMongo :: Action IO ()-setupMongo = void $ MongoDB.dropDatabase dbName-#endif--#ifdef WITH_ZOOKEEPER-runConn :: MonadUnliftIO m => Action m backend -> m ()-runConn f = do- let conf = defaultZookeeperConf {zCoord = "localhost:2181/" ++ T.unpack dbName}- void $ withZookeeperPool conf $ runZookeeperPool f--setupZookeeper :: Action IO ()-setupZookeeper = do- liftIO $ Z.setDebugLevel Z.ZLogError- deleteRecursive "/"-#endif--db' :: Action IO () -> Action IO () -> Assertion-db' actions cleanDB = do- r <- runConn (actions >> cleanDB)- return r--instance Arbitrary PersistValue where- arbitrary = PersistObjectId `fmap` BS.pack `fmap` replicateM 12 arbitrary-#else-persistSettings :: MkPersistSettings persistSettings = sqlSettings { mpsGeneric = True }-type BackendMonad = SqlBackend-# ifdef WITH_SQLITE-sqlite_database_file :: Text-sqlite_database_file = "testdb.sqlite3"-sqlite_database :: SqliteConnectionInfo-sqlite_database = mkSqliteConnectionInfo sqlite_database_file-# else-sqlite_database_file :: Text-sqlite_database_file = error "Sqlite tests disabled"-sqlite_database :: ()-sqlite_database = error "Sqlite tests disabled"-# endif-runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m ()-runConn f = do- travis <- liftIO isTravis- let debugPrint = not travis && _debugOn- let printDebug = if debugPrint then print . fromLogStr else void . return- flip runLoggingT (\_ _ _ s -> printDebug s) $ do-# ifdef WITH_POSTGRESQL- _ <- if travis- then withPostgresqlPool "host=localhost port=5432 user=postgres dbname=persistent" 1 $ runSqlPool f- else do- host <- fromMaybe "localhost" A.<$> liftIO dockerPg- withPostgresqlPool ("host=" <> host <> " port=5432 user=postgres dbname=test") 1 $ runSqlPool f-# else-# ifdef WITH_MYSQL- -- Since version 5.7.5, MySQL adds a mode value `STRICT_TRANS_TABLES`- -- which can cause an exception in MaxLenTest, depending on the server- -- configuration. Persistent tests do not need any of the modes which are- -- set by default, so it is simplest to clear `sql_mode` for the session.- let baseConnectInfo =- defaultConnectInfo {- connectOptions =- connectOptions defaultConnectInfo- ++ [MySQL.InitCommand "SET SESSION sql_mode = '';\0"]- }- _ <- if not travis- then withMySQLPool baseConnectInfo- { connectHost = "localhost"- , connectUser = "test"- , connectPassword = "test"- , connectDatabase = "test"- } 1 $ runSqlPool f- else withMySQLPool baseConnectInfo- { connectHost = "localhost"- , connectUser = "travis"- , connectPassword = ""- , connectDatabase = "persistent"- } 1 $ runSqlPool f-# else- _<-withSqlitePoolInfo sqlite_database 1 $ runSqlPool f-# endif-# endif- return () -db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion-db actions = do- runResourceT $ runConn $ actions >> transactionUndo--#if !MIN_VERSION_random(1,0,1)-instance Random Int32 where- random g =- let ((i::Int), g') = random g in- (fromInteger $ toInteger i, g')- randomR (lo, hi) g =- let ((i::Int), g') = randomR (fromInteger $ toInteger lo, fromInteger $ toInteger hi) g in- (fromInteger $ toInteger i, g')--instance Random Int64 where- random g =- let ((i0::Int32), g0) = random g- ((i1::Int32), g1) = random g0 in- (fromInteger (toInteger i0) + fromInteger (toInteger i1) * 2 ^ (32::Int), g1)- randomR (lo, hi) g = -- TODO : generate on the whole range, and not only on a part of it- let ((i::Int), g') = randomR (fromInteger $ toInteger lo, fromInteger $ toInteger hi) g in- (fromInteger $ toInteger i, g')-#endif- instance Arbitrary PersistValue where arbitrary = PersistInt64 `fmap` choose (0, maxBound) -#endif- instance PersistStore backend => Arbitrary (BackendKey backend) where arbitrary = (errorLeft . fromPersistValue) `fmap` arbitrary where@@ -312,32 +138,101 @@ Left e -> error $ unpack e Right r -> r -#ifdef WITH_NOSQL-#ifdef WITH_MONGODB-generateKey :: IO (BackendKey Context)-generateKey = MongoKey `liftM` MongoDB.genObjectId-#endif+class GenerateKey backend where+ generateKey :: IO (BackendKey backend) -#ifdef WITH_ZOOKEEPER+instance GenerateKey SqlBackend where+ generateKey = do+ i <- readIORef keyCounter+ writeIORef keyCounter (i + 1)+ return $ SqlBackendKey $ i+ keyCounter :: IORef Int64 keyCounter = unsafePerformIO $ newIORef 1 {-# NOINLINE keyCounter #-} -generateKey :: IO (BackendKey Context)-generateKey = do- i <- readIORef keyCounter- writeIORef keyCounter (i + 1)- return $ ZooKey $ T.pack $ show i-#endif+-- | A datatype that wraps a function on @entity@ that can has testable results.+--+-- Allows us to write:+--+-- @+-- foo :: entity -> entity -> [TestFn entity] -> Bool+-- foo e0 e1 = all (\(TestFn msg f) -> f e0 == f e1)+-- @+data TestFn entity where+ TestFn+ :: (Show a, Eq a)+ => String+ -> (entity -> a)+ -> TestFn entity -#else-keyCounter :: IORef Int64-keyCounter = unsafePerformIO $ newIORef 1-{-# NOINLINE keyCounter #-}+truncateTimeOfDay :: TimeOfDay -> Gen TimeOfDay+truncateTimeOfDay (TimeOfDay h m s) =+ return $ TimeOfDay h m $ truncateToMicro s -generateKey :: IO (BackendKey SqlBackend)-generateKey = do- i <- readIORef keyCounter- writeIORef keyCounter (i + 1)- return $ SqlBackendKey $ i+-- truncate less significant digits+truncateToMicro :: Pico -> 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++arbText :: Gen Text+arbText =+ T.pack+ . 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)+ , GenerateKey backend+ , HasPersistBackend backend+ , PersistUniqueWrite backend+ , PersistQueryWrite backend+ , backend ~ BaseBackend backend+ , PersistQueryRead backend+ )++type RunDb backend m = ReaderT backend m () -> IO ()++changeBackend+ :: forall backend backend' m. MonadUnliftIO m+ => (backend -> backend')+ -> RunDb backend m+ -> RunDb backend' m+changeBackend f runDb =+ runDb . ReaderT . (. f) . runReaderT++#if !MIN_VERSION_monad_logger(0,3,30)+-- Needed for GHC versions 7.10.3. Can drop when we drop support for GHC+-- 7.10.3+instance MonadFail (LoggingT (ResourceT IO)) where+ fail = liftIO . MonadFail.fail+#endif++#if MIN_VERSION_resourcet(1,2,0)+-- This instance is necessary because LTS-9 and below are on+-- MonadBaseControl, while LTS 11 and up are on UnliftIO. We can drop this+-- instance (and related CPP) when we drop support for LTS-9 (GHC 8.0).+instance MonadBase b m => MonadBase b (ResourceT m) where+ liftBase = lift . liftBase+instance MonadBaseControl b m => MonadBaseControl b (ResourceT m) where+ type StM (ResourceT m) a = StM m a+ liftBaseWith f = ResourceT $ \reader' ->+ liftBaseWith $ \runInBase ->+ f $ runInBase . (\(ResourceT r) -> r reader')+ restoreM = ResourceT . const . restoreM #endif
− src/InsertDuplicateUpdate.hs
@@ -1,103 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}--module InsertDuplicateUpdate where--import Init-#ifdef WITH_MYSQL-import Database.Persist.MySQL-import Data.List (sort)--share [mkPersist sqlSettings, mkMigrate "duplicateMigrate"] [persistUpperCase|- Item- name Text sqltype=varchar(80)- description Text- price Double Maybe- quantity Int Maybe-- Primary name- deriving Eq Show Ord--|]--specs :: Spec-specs = describe "DuplicateKeyUpdate" $ do- let item1 = Item "item1" "" (Just 3) Nothing- item2 = Item "item2" "hello world" Nothing (Just 2)- items = [item1, item2]- describe "insertOnDuplicateKeyUpdate" $ do- it "inserts appropriately" $ db $ do- deleteWhere ([] :: [Filter Item])- insertOnDuplicateKeyUpdate item1 [ItemDescription =. "i am item 1"]- Just item <- get (ItemKey "item1")- item @== item1-- it "performs only updates given if record already exists" $ db $ do- deleteWhere ([] :: [Filter Item])- let newDescription = "I am a new description"- _ <- insert item1- insertOnDuplicateKeyUpdate- (Item "item1" "i am inserted description" (Just 1) (Just 2))- [ItemDescription =. newDescription]- Just item <- get (ItemKey "item1")- item @== item1 { itemDescription = newDescription }-- describe "insertManyOnDuplicateKeyUpdate" $ do- it "inserts fresh records" $ db $ do- deleteWhere ([] :: [Filter Item])- insertMany_ items- let newItem = Item "item3" "fresh" Nothing Nothing- insertManyOnDuplicateKeyUpdate- (newItem : items)- [copyField ItemDescription]- []- dbItems <- map entityVal <$> selectList [] []- sort dbItems @== sort (newItem : items)- it "updates existing records" $ db $ do- deleteWhere ([] :: [Filter Item])- insertMany_ items- insertManyOnDuplicateKeyUpdate- items- []- [ItemQuantity +=. Just 1]- it "only copies passing values" $ db $ do- deleteWhere ([] :: [Filter Item])- insertMany_ items- let newItems = map (\i -> i { itemQuantity = Just 0, itemPrice = fmap (*2) (itemPrice i) }) items- postUpdate = map (\i -> i { itemPrice = fmap (*2) (itemPrice i) }) items- insertManyOnDuplicateKeyUpdate- newItems- [ copyUnlessEq ItemQuantity (Just 0)- , copyField ItemPrice- ]- []- dbItems <- sort . fmap entityVal <$> selectList [] []- dbItems @== sort postUpdate- it "inserts without modifying existing records if no updates specified" $ db $ do- let newItem = Item "item3" "hi friends!" Nothing Nothing- deleteWhere ([] :: [Filter Item])- insertMany_ items- insertManyOnDuplicateKeyUpdate- (newItem : items)- []- []- dbItems <- sort . fmap entityVal <$> selectList [] []- dbItems @== sort (newItem : items)--#else-specs :: Spec-specs = describe "DuplicateKeyUpdate" $ do- it "Is only supported on MySQL currently." $ do- True `shouldBe` True-#endif
src/LargeNumberTest.hs view
@@ -1,14 +1,11 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} module LargeNumberTest where -import Init import Data.Word -#ifdef WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else-share [mkPersist sqlSettings, mkMigrate "numberMigrate"] [persistLowerCase|-#endif+import Init++share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "numberMigrate"] [persistLowerCase| Number intx Int int32 Int32@@ -18,17 +15,14 @@ deriving Show Eq |] -#ifdef WITH_NOSQL-cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Number ~ backend) => ReaderT backend m ()+cleanDB+ :: Runner backend m => ReaderT backend m () cleanDB = do- deleteWhere ([] :: [Filter Number])-db :: Action IO () -> Assertion-db = db' cleanDB-#endif+ deleteWhere ([] :: [Filter (NumberGeneric backend)]) -specs :: Spec-specs = describe "persistent" $ do- it "large numbers" $ db $ do+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@@ -45,3 +39,4 @@ go $ Number 0 0 minBound 0 0 go $ Number 0 0 0 minBound 0 go $ Number 0 0 0 0 minBound+
src/MaxLenTest.hs view
@@ -1,23 +1,13 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, FlexibleInstances, EmptyDataDecls, MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-} -module MaxLenTest (- specs-#ifndef WITH_NOSQL- , maxlenMigrate-#endif-) where+module MaxLenTest (specsWith, maxlenMigrate) where -import Init import Data.String (IsString) -#ifdef WITH_NOSQL-db :: Action IO () -> Assertion-db = db' (return ())-mkPersist persistSettings [persistUpperCase|-#else-share [mkPersist sqlSettings, mkMigrate "maxlenMigrate"] [persistLowerCase|-#endif+import Init++share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "maxlenMigrate"] [persistLowerCase| MaxLen text1 Text text2 Text maxlen=3@@ -34,9 +24,9 @@ deriving Show Eq |] -specs :: Spec-specs = describe "Maximum length attribute" $ do- it "" $ db $ do+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'
src/MigrationColumnLengthTest.hs view
@@ -1,32 +1,19 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} module MigrationColumnLengthTest where -import Database.Persist.TH import qualified Data.Text as T import Init -#ifdef WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase|-#endif VaryingLengths field1 Int field2 T.Text sqltype=varchar(5) |] --specs :: Spec-specs = describe "Migration" $ do-#ifdef WITH_NOSQL- return ()-#else- it "is idempotent" $ db $ do+specsWith :: MonadIO m => RunDb SqlBackend m -> Spec+specsWith runDb =+ it "is idempotent" $ runDb $ do again <- getMigration migration liftIO $ again @?= []-#endif-
src/MigrationIdempotencyTest.hs view
@@ -1,19 +1,13 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} module MigrationIdempotencyTest where -import Database.Persist.TH import qualified Data.Text as T +import Database.Persist.TH import Init -#ifdef WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase|-#endif Idempotency field1 Int field2 T.Text sqltype=varchar(5)@@ -24,13 +18,8 @@ field7 Double sqltype=double(6,5) |] --specs :: Spec-specs = describe "MySQL migration with backend-specific sqltypes" $ do-#ifdef WITH_NOSQL- return ()-#else- it "is idempotent" $ db $ do+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 @?= []-#endif
src/MigrationOnlyTest.hs view
@@ -1,19 +1,13 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module MigrationOnlyTest (specs) where+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+module MigrationOnlyTest (specsWith, migrateAll1, migrateAll2) where -import Database.Persist.TH-import Control.Monad.Trans.Resource (runResourceT) import qualified Data.Text as T +import Database.Persist.TH import Init -#ifdef WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else-share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase|-#endif+share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll1"] [persistLowerCase| TwoField1 sql=two_field field1 Int field2 T.Text@@ -21,11 +15,7 @@ deriving Eq Show |] -#ifdef WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else-share [mkPersist sqlSettings, mkMigrate "migrateAll2", mkDeleteCascade sqlSettings] [persistLowerCase|-#endif+share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll2", mkDeleteCascade sqlSettings] [persistLowerCase| TwoField field1 Int field2 T.Text@@ -37,18 +27,17 @@ field2 TwoFieldId MigrationOnly |] -specs :: Spec-specs = describe "migration only" $ do- it "works" $ asIO $ runResourceT $ runConn $ do-#ifndef WITH_NOSQL- _ <- runMigrationSilent migrateAll1- _ <- runMigrationSilent migrateAll2-#endif+specsWith+ :: (MonadIO m, PersistQueryWrite backend, PersistStoreWrite backend, PersistQueryWrite (BaseBackend backend))+ => RunDb backend m+ -> Maybe (ReaderT backend m a)+ -> Spec+specsWith runDb mmigrate = describe "MigrationOnly field" $ do+ it "doesn't have the field in the Haskell entity" $ asIO $ runDb $ do+ sequence_ mmigrate+ sequence_ mmigrate let tf = TwoField 5 "hello" tid <- insert tf mtf <- get tid liftIO $ mtf @?= Just tf- deleteWhere ([] :: [Filter TwoField])--asIO :: IO a -> IO a-asIO = id+ deleteWhere ([] :: [Filter (TwoFieldGeneric backend)])
src/MigrationTest.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} module MigrationTest where import Database.Persist.TH@@ -9,11 +7,7 @@ import Init -#ifdef WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else share [mkPersist sqlSettings, mkMigrate "migrationMigrate", mkDeleteCascade sqlSettings] [persistLowerCase|-#endif Target field1 Int field2 T.Text@@ -25,11 +19,7 @@ field4 TargetId |] -#ifdef WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else share [mkPersist sqlSettings, mkMigrate "migrationAddCol", mkDeleteCascade sqlSettings] [persistLowerCase|-#endif Target1 sql=target field1 Int field2 T.Text@@ -42,21 +32,19 @@ field4 Target1Id |] -#ifndef WITH_NOSQL-specs :: Spec-specs = describe "Migration" $ do- it "is idempotent" $ db $ do+specsWith :: (MonadIO m) => RunDb SqlBackend m -> Spec+specsWith runDb = describe "Migration" $ do+ it "is idempotent" $ runDb $ do again <- getMigration migrationMigrate liftIO $ again @?= []- it "really is idempotent" $ db $ do+ it "really is idempotent" $ runDb $ do runMigration migrationMigrate again <- getMigration migrationMigrate liftIO $ again @?= []- it "can add an extra column" $ db $ do+ 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. _ <- runMigration migrationAddCol again <- getMigration migrationAddCol liftIO $ again @?= []-#endif
+ src/MpsNoPrefixTest.hs view
@@ -0,0 +1,32 @@+module MpsNoPrefixTest where++import Init+import PersistentTestModels++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]++ mnp1a <- get np1a+ liftIO $ mnp1a @?= Just (NoPrefix1 2)+ liftIO $ fmap someFieldName mnp1a @?= Just 2+ mnp2 <- get np2+ liftIO $ fmap unprefixedRef mnp2 @?= Just np1b+ liftIO $ fmap someOtherFieldName mnp2 @?= Just 5++ insert_ $ UnprefixedLeftSum 5+ insert_ $ UnprefixedRightSum "Hello"++ it "IsSqlKey instance" $ 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,11 +1,11 @@ {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TemplateHaskell #-} module PersistTestPetCollarType where -import GHC.Generics import Data.Aeson-import Database.Persist.TH import Data.Text (Text)+import GHC.Generics++import Database.Persist.TH data PetCollar = PetCollar {tag :: Text, bell :: Bool} deriving (Generic, Eq, Show)
src/PersistTestPetType.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE TemplateHaskell #-} module PersistTestPetType where import Database.Persist.TH
src/PersistUniqueTest.hs view
@@ -1,14 +1,11 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# 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-#if WITH_NOSQL-mkPersist persistSettings { mpsGeneric = False } [persistUpperCase|-#else share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase|-#endif Fo foo Int bar Int@@ -16,29 +13,21 @@ UniqueBar bar deriving Eq Show |]-#ifdef WITH_NOSQL+ cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Fo ~ backend) => ReaderT backend m () cleanDB = do deleteWhere ([] :: [Filter Fo]) -db :: Action IO () -> Assertion-db = db' cleanDB-#endif--specs :: Spec-specs = describe "custom primary key" $ do-#ifdef WITH_NOSQL- return ()-#else- it "getBy" $ db $ do+specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec+specsWith runDb = describe "custom primary key" $ do+ it "getBy" $ runDb $ do let b = 5 k <- insert $ Fo 3 b Just vk <- get k Just vu <- getBy (UniqueBar b) vu @== Entity k vk- it "insertUniqueEntity" $ db $ do+ it "insertUniqueEntity" $ runDb $ do let fo = Fo 3 5 Just (Entity _ insertedFoValue) <- insertUniqueEntity fo Nothing <- insertUniqueEntity fo fo @== insertedFoValue-#endif
src/PersistentTest.hs view
@@ -1,231 +1,90 @@-{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans #-}-{-# LANGUAGE UndecidableInstances #-} -- FIXME-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-module PersistentTest where--import Test.HUnit hiding (Test)-import Control.Monad.Trans.Resource (runResourceT)-import Test.Hspec.Expectations ()-import Test.Hspec.QuickCheck(prop)-import UnliftIO (MonadUnliftIO, catch)--import Database.Persist--#ifdef WITH_NOSQL-#ifdef WITH_MONGODB-import qualified Database.MongoDB as MongoDB-import Database.Persist.MongoDB (toInsertDoc, docToEntityThrow, collectionName, recordToDocument)-#endif--#else--import Database.Persist.TH (mkDeleteCascade, mkSave)-import qualified Data.Text as T--# ifdef WITH_POSTGRESQL-import Data.List (sort)-# endif-# if WITH_MYSQL-import Database.Persist.MySQL()-# endif--#endif+{-# LANGUAGE UndecidableInstances #-} -- FIXME+module PersistentTest+ ( module PersistentTest+ , cleanDB+ , testMigrate+ , noPrefixMigrate+ ) where +import Control.Monad.Fail import Control.Monad.IO.Class--import Web.PathPieces (PathPiece (..))-import Data.Maybe (fromJust)-import qualified Data.HashMap.Lazy as M-import Init import Data.Aeson- import Data.Conduit import qualified Data.Conduit.List as CL-import Data.Function (on)-import Data.Functor.Identity import Data.Functor.Constant+import Data.Functor.Identity+import qualified Data.HashMap.Lazy as M+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 Database.Persist+import Init+import PersistentTestModels import PersistTestPetType import PersistTestPetCollarType -#ifdef WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else-share [mkPersist persistSettings, mkMigrate "testMigrate", mkDeleteCascade persistSettings, mkSave "_ignoredSave"] [persistUpperCase|-#endif---- Dedented comment- -- Header-level comment- -- Indented comment- Person json- name Text- age Int "some ignored -- \" attribute"- color Text Maybe -- this is a comment sql=foobarbaz- PersonNameKey name -- this is a comment sql=foobarbaz- deriving Show Eq- Person1--- Dedented comment- -- Header-level comment- -- Indented comment- name Text- age Int- PersonMaybeAge- name Text- age Int Maybe- PersonMay json- name Text Maybe- color Text Maybe- deriving Show Eq- Pet- ownerId PersonId- name Text- -- deriving Show Eq--- Dedented comment- -- Header-level comment- -- Indented comment- type PetType- MaybeOwnedPet- ownerId PersonId Maybe- name Text- type PetType--- Dedented comment- -- Header-level comment- -- Indented comment- NeedsPet- petKey PetId- OutdoorPet- ownerId PersonId- collar PetCollar- type PetType-- -- From the scaffold- UserPT- ident Text- password Text Maybe- UniqueUserPT ident- EmailPT- email Text- user UserPTId Maybe- verkey Text Maybe- UniqueEmailPT email-- Upsert- email Text- attr Text- extra Text- age Int - UniqueUpsert email- deriving Eq Show-- UpsertBy- email Text- city Text- attr Text- UniqueUpsertBy email- UniqueUpsertByCity city- deriving Eq Show-- Strict- !yes Int- ~no Int- def Int-|]--deriving instance Show (BackendKey backend) => Show (PetGeneric backend)-deriving instance Eq (BackendKey backend) => Eq (PetGeneric backend)--share [mkPersist persistSettings { mpsPrefixFields = False, mpsGeneric = False }-#ifdef WITH_NOSQL- ] [persistUpperCase|-#else- , mkMigrate "noPrefixMigrate"- ] [persistLowerCase|-#endif-NoPrefix1- someFieldName Int- deriving Show Eq-NoPrefix2- someOtherFieldName Int- unprefixedRef NoPrefix1Id- deriving Show Eq-+NoPrefixSum- unprefixedLeft Int- unprefixedRight String- deriving Show Eq-|]--cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend EmailPT ~ backend) => ReaderT backend m ()-cleanDB = do- deleteWhere ([] :: [Filter Person])- deleteWhere ([] :: [Filter Person1])- deleteWhere ([] :: [Filter Pet])- deleteWhere ([] :: [Filter MaybeOwnedPet])- deleteWhere ([] :: [Filter NeedsPet])- deleteWhere ([] :: [Filter OutdoorPet])- deleteWhere ([] :: [Filter UserPT])- deleteWhere ([] :: [Filter EmailPT])--#ifdef WITH_NOSQL-db :: Action IO () -> Assertion-db = db' cleanDB-#endif--catchPersistException :: MonadUnliftIO m => m a -> b -> m b+catchPersistException :: (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) -specs :: Spec-specs = describe "persistent" $ do+-- 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)++specsWith :: forall backend m. Runner backend m => RunDb backend m -> Spec+specsWith runDb = describe "persistent" $ do it "fieldLens" $ do let michael = Entity undefined $ Person "Michael" 28 Nothing :: Entity Person michaelP1 = Person "Michael" 29 Nothing :: Person view michael (fieldLens PersonAge) @?= 28 entityVal (set (fieldLens PersonAge) 29 michael) @?= michaelP1 - it "FilterOr []" $ db $ do- let p = Person "z" 1 Nothing- _ <- insert p-#ifdef WITH_MONGODB- ps <- catchPersistException (selectList [FilterOr []] [Desc PersonAge]) []-#else- ps <- (selectList [FilterOr []] [Desc PersonAge])-#endif- assertEmpty ps-- it "||. []" $ db $ do- let p = Person "z" 1 Nothing- _ <- insert p-#ifdef WITH_MONGODB- c <- catchPersistException (count $ [PersonName ==. "a"] ||. []) 1-#else- c <- (count $ [PersonName ==. "a"] ||. [])-#endif- c @== (1::Int)-- it "FilterAnd []" $ db $ do+ it "FilterAnd []" $ runDb $ do let p = Person "z" 1 Nothing _ <- insert p ps <- selectList [FilterAnd []] [Desc PersonAge] assertNotEmpty ps - it "order of opts is irrelevant" $ db $ do+ 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@@ -242,17 +101,17 @@ , Person "u" 2 Nothing ] - a <- fmap (map $ personName . entityVal) $ selectList [] [Desc PersonAge, Asc PersonName, OffsetBy 2, LimitTo 3]+ a <- map (personName . entityVal) <$> selectList [] [Desc PersonAge, Asc PersonName, OffsetBy 2, LimitTo 3] a @== ["y", "v", "x"] - b <- fmap (map $ personName . entityVal) $ selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName]+ b <- map (personName . entityVal) <$> selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName] b @== a - c <- fmap (map $ personName . entityVal) $ selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName, LimitTo 1, OffsetBy 1]+ c <- map (personName . entityVal) <$> selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName, LimitTo 1, OffsetBy 1] c @== a - it "passes the general tests" $ db $ do+ it "passes the general tests" $ runDb $ do let mic26 = Person "Michael" 26 Nothing micK <- insert mic26 results <- selectList [PersonName ==. "Michael"] []@@ -264,12 +123,9 @@ p28 <- updateGet micK [PersonAge =. 28] personAge p28 @== 28 -#ifdef WITH_NOSQL updateWhere [PersonName ==. "Michael"] [PersonAge =. 29]-#else- uc <- updateWhereCount [PersonName ==. "Michael"] [PersonAge =. 29]+ uc <- count [PersonName ==. "Michael"] uc @== 1-#endif Just mic29 <- get micK personAge mic29 @== 29 @@ -298,12 +154,7 @@ delete micK Nothing <- get micK return ()-#ifdef WITH_ZOOKEEPER- -- zookeeper backend does not support idfield- -- zookeeper's key is node-name.- -- When uniq-key exists, zookeeper's key becomes encoded uniq-key.-#else- it "persistIdField" $ db $ do+ it "persistIdField" $ runDb $ do let p = Person "foo" 100 (Just "blue") q = Person "bar" 101 Nothing pk <- insert p@@ -314,10 +165,9 @@ mq <- selectFirst [persistIdField ==. qk] [] fmap entityVal mq @== Just q-#endif - it "!=." $ db $ do- deleteWhere ([] :: [Filter Person])+ it "!=." $ runDb $ do+ deleteWhere ([] :: [Filter (PersonGeneric backend)]) let mic = Person "Michael" 25 Nothing _ <- insert mic let eli = Person "Eliezer" 25 (Just "Red")@@ -332,8 +182,9 @@ pnm <- selectList [PersonName !=. "Eliezer"] [] map entityVal pnm @== [mic] - it "Double Maybe" $ db $ do- deleteWhere ([] :: [Filter PersonMay])++ it "Double Maybe" $ runDb $ do+ deleteWhere ([] :: [Filter (PersonMayGeneric backend)]) let mic = PersonMay (Just "Michael") Nothing _ <- insert mic let eli = PersonMay (Just "Eliezer") (Just "Red")@@ -343,8 +194,8 @@ pne <- selectList [PersonMayName !=. Nothing, PersonMayColor !=. Nothing] [] map entityVal pne @== [eli] - it "and/or" $ db $ do- deleteWhere ([] :: [Filter Person1])+ it "and/or" $ runDb $ do+ deleteWhere ([] :: [Filter (Person1Generic backend)]) insertMany_ [ Person1 "Michael" 25 , Person1 "Miriam" 25 , Person1 "Michael" 30@@ -379,11 +230,11 @@ c40 @== 4 - it "deleteWhere" $ db $ do+ it "deleteWhere" $ runDb $ do key2 <- insert $ Person "Michael2" 90 Nothing _ <- insert $ Person "Michael3" 90 Nothing let p91 = Person "Michael4" 91 Nothing- key91 <- insert $ p91+ key91 <- insert p91 ps90 <- selectList [PersonAge ==. 90] [] assertNotEmpty ps90@@ -396,10 +247,10 @@ p91 @== p2_91 - it "deleteBy" $ db $ do+ it "deleteBy" $ runDb $ do _ <- insert $ Person "Michael2" 27 Nothing let p3 = Person "Michael3" 27 Nothing- key3 <- insert $ p3+ key3 <- insert p3 ps2 <- selectList [PersonName ==. "Michael2"] [] assertNotEmpty ps2@@ -412,10 +263,10 @@ p3 @== p32 - it "delete" $ db $ do+ it "delete" $ runDb $ do key2 <- insert $ Person "Michael2" 27 Nothing let p3 = Person "Michael3" 27 Nothing- key3 <- insert $ p3+ key3 <- insert p3 pm2 <- selectList [PersonName ==. "Michael2"] [] assertNotEmpty pm2@@ -426,21 +277,12 @@ Just p <- get key3 p3 @== p -#ifdef WITH_ZOOKEEPER- it "toPathPiece . fromPathPiece" $ do- -- Below quickcheck causes error of "Cannot convert PersistObjectId to Text."- -- Currently, ZooKey does not support PersistObjectId.- let key1 = ZooKey "hogehogekey" :: (BackendKey BackendMonad)- key2 = fromJust $ fromPathPiece $ toPathPiece key1 :: (BackendKey BackendMonad)- toPathPiece key1 `shouldBe` toPathPiece key2-#else prop "toPathPiece . fromPathPiece" $ \piece ->- let key1 = piece :: (BackendKey BackendMonad)- key2 = fromJust $ fromPathPiece $ toPathPiece key1 :: (BackendKey BackendMonad)+ let key1 = piece :: (BackendKey SqlBackend)+ key2 = fromJust $ fromPathPiece $ toPathPiece key1 :: (BackendKey SqlBackend) in toPathPiece key1 == toPathPiece key2-#endif - it "replace" $ db $ do+ it "replace" $ runDb $ do key2 <- insert $ Person "Michael2" 27 Nothing let p3 = Person "Michael3" 27 Nothing replace key2 p3@@ -470,7 +312,7 @@ - it "getBy" $ db $ do+ it "getBy" $ runDb $ do let p2 = Person "Michael2" 27 Nothing key2 <- insert p2 Just (Entity k p) <- getBy $ PersonNameKey "Michael2"@@ -484,7 +326,7 @@ return () - it "updateGet" $ db $ do+ it "updateGet" $ runDb $ do let p25 = Person "Michael" 25 Nothing key25 <- insert p25 pBlue28 <- updateGet key25 [PersonAge =. 28, PersonName =. "Updated"]@@ -492,131 +334,41 @@ pBlue30 <- updateGet key25 [PersonAge +=. 2] pBlue30 @== Person "Updated" 30 Nothing - describe "upsert" $ do- it "adds a new row with no updates" $ db $ do- Entity _ u <- upsert (Upsert "a" "new" "" 2) [UpsertAttr =. "update"]- c <- count ([] :: [Filter Upsert])- c @== 1- upsertAttr u @== "new"- it "keeps the existing row" $ db $ do-#ifdef WITH_MONGODB- initial <- insertEntity (Upsert "foo" "initial" "" 2)- update' <- upsert (Upsert "foo" "update" "" 3) []- update' @== initial -#else- initial <- insertEntity (Upsert "a" "initial" "" 1)- update' <- upsert (Upsert "a" "update" "" 2) []- update' @== initial-#endif - it "updates an existing row - assignment" $ db $ do-#ifdef WITH_MONGODB- initial <- insertEntity (Upsert "cow" "initial" "extra" 1)- update' <-- upsert (Upsert "cow" "wow" "such unused" 2) [UpsertAttr =. "update"]- ((==@) `on` entityKey) initial update'- upsertAttr (entityVal update') @== "update"- upsertExtra (entityVal update') @== "extra"-#else- initial <- insertEntity (Upsert "a" "initial" "extra" 1)- update' <-- upsert (Upsert "a" "wow" "such unused" 2) [UpsertAttr =. "update"]- ((==@) `on` entityKey) initial update'- upsertAttr (entityVal update') @== "update"- upsertExtra (entityVal update') @== "extra"-#endif- it "updates existing row - addition " $ db $ do-#ifdef WITH_MONGODB- initial <- insertEntity (Upsert "a1" "initial" "extra" 2)- update' <-- upsert (Upsert "a1" "wow" "such unused" 2) [UpsertAge +=. 3]- ((==@) `on` entityKey) initial update'- upsertAge (entityVal update') @== 5- upsertExtra (entityVal update') @== "extra"-#else- initial <- insertEntity (Upsert "a" "initial" "extra" 2)- update' <-- upsert (Upsert "a" "wow" "such unused" 2) [UpsertAge +=. 3]- ((==@) `on` entityKey) initial update'- upsertAge (entityVal update') @== 5- upsertExtra (entityVal update') @== "extra"-#endif+ describe "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 - describe "upsertBy" $ do- let uniqueEmail = UniqueUpsertBy "a"- uniqueCity = UniqueUpsertByCity "Boston"- it "adds a new row with no updates" $ db $ do- Entity _ u <-- upsertBy- uniqueEmail- (UpsertBy "a" "Boston" "new")- [UpsertByAttr =. "update"]- c <- count ([] :: [Filter UpsertBy])- c @== 1- upsertByAttr u @== "new"- it "keeps the existing row" $ db $ do-#ifdef WITH_MONGODB- initial <- insertEntity (UpsertBy "foo" "Chennai" "initial")- update' <- upsertBy (UniqueUpsertBy "foo") (UpsertBy "foo" "Chennai" "update") []- update' @== initial-#else- initial <- insertEntity (UpsertBy "a" "Boston" "initial")- update' <- upsertBy uniqueEmail (UpsertBy "a" "Boston" "update") []- update' @== initial-#endif- it "updates an existing row" $ db $ do-#ifdef WITH_MONGODB- initial <- insertEntity (UpsertBy "ko" "Kumbakonam" "initial")- update' <-- upsertBy- (UniqueUpsertBy "ko")- (UpsertBy "ko" "Bangalore" "such unused")- [UpsertByAttr =. "update"]- ((==@) `on` entityKey) initial update'- upsertByAttr (entityVal update') @== "update"- upsertByCity (entityVal update') @== "Kumbakonam"-#else- initial <- insertEntity (UpsertBy "a" "Boston" "initial")- update' <-- upsertBy- uniqueEmail- (UpsertBy "a" "wow" "such unused")- [UpsertByAttr =. "update"]- ((==@) `on` entityKey) initial update'- upsertByAttr (entityVal update') @== "update"- upsertByCity (entityVal update') @== "Boston"-#endif- it "updates by the appropriate constraint" $ db $ do- initBoston <- insertEntity (UpsertBy "bos" "Boston" "bos init")- initKrum <- insertEntity (UpsertBy "krum" "Krum" "krum init")- updBoston <-- upsertBy- (UniqueUpsertBy "bos")- (UpsertBy "bos" "Krum" "unused")- [UpsertByAttr =. "bos update"]- updKrum <-- upsertBy- (UniqueUpsertByCity "Krum")- (UpsertBy "bos" "Krum" "unused")- [UpsertByAttr =. "krum update"]- ((==@) `on` entityKey) initBoston updBoston- ((==@) `on` entityKey) initKrum updKrum- entityVal updBoston @== UpsertBy "bos" "Boston" "bos update"- entityVal updKrum @== UpsertBy "krum" "Krum" "krum update"+ insertKey johnId john+ insertKey janeId jane - it "maybe update" $ db $ do- let noAge = PersonMaybeAge "Michael" Nothing- keyNoAge <- insert noAge- noAge2 <- updateGet keyNoAge [PersonMaybeAgeAge +=. Just 2]- -- the correct answer is very debatable-#ifdef WITH_NOSQL- personMaybeAgeAge noAge2 @== Just 2-#else- personMaybeAgeAge noAge2 @== Nothing-#endif+ _ <- 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 - it "updateWhere" $ db $ do+ 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@@ -628,8 +380,7 @@ Just p <- get key1 p @== p1 -- it "selectList" $ db $ do+ it "selectList" $ runDb $ do let p25 = Person "Michael" 25 Nothing let p26 = Person "Michael2" 26 Nothing [key25, key26] <- insertMany [p25, p26]@@ -650,19 +401,19 @@ ps6 <- selectList [PersonAge ==. 26] [] ps6 @== [(Entity key26 p26)] - it "selectSource" $ db $ do+ 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 <- runResourceT $ selectSource [] [Desc PersonAge] $$ await+ ps1 <- runConduitRes $ selectSource [] [Desc PersonAge] .| await ps1 @== Just (Entity k3 p3) - ps2 <- runResourceT $ selectSource [PersonAge <. 3] [Asc PersonAge] $$ CL.consume+ ps2 <- runConduitRes $ selectSource [PersonAge <. 3] [Asc PersonAge] .| CL.consume ps2 @== [Entity k1 p1, Entity k2 p2] - runResourceT $ selectSource [] [Desc PersonAge] $$ do+ runConduitRes $ selectSource [] [Desc PersonAge] .| do e1 <- await e1 @== Just (Entity k3 p3) @@ -675,7 +426,7 @@ e4 <- await e4 @== Nothing - it "selectFirst" $ db $ do+ it "selectFirst" $ runDb $ do _ <- insert $ Person "Michael" 26 Nothing let pOld = Person "Oldie" 75 Nothing kOld <- insert pOld@@ -684,19 +435,19 @@ x @== Just (Entity kOld pOld) - it "selectKeys" $ db $ do+ 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 <- runResourceT $ selectKeys [] [Desc PersonAge] $$ await+ ps1 <- runConduitRes $ selectKeys [] [Desc PersonAge] .| await ps1 @== Just k3 - ps2 <- runResourceT $ selectKeys [PersonAge <. 3] [Asc PersonAge] $$ CL.consume+ ps2 <- runConduitRes $ selectKeys [PersonAge <. 3] [Asc PersonAge] .| CL.consume ps2 @== [k1, k2] - runResourceT $ selectKeys [] [Desc PersonAge] $$ do+ runConduitRes $ selectKeys [] [Desc PersonAge] .| do e1 <- await e1 @== Just k3 @@ -709,18 +460,18 @@ e4 <- await e4 @== Nothing - it "insertMany_ with no arguments" $ db $ do- _ <- insertMany_ ([] :: [Person])- rows <- count ([] :: [Filter Person])+ it "insertMany_ with no arguments" $ runDb $ do+ _ <- insertMany_ ([] :: [PersonGeneric backend])+ rows <- (count ([] :: [Filter (PersonGeneric backend)]) :: ReaderT backend m Int) rows @== 0- _ <- insertMany ([] :: [Person])- rows2 <- count ([] :: [Filter Person])+ _ <- insertMany ([] :: [PersonGeneric backend])+ rows2 <- count ([] :: [Filter (PersonGeneric backend)]) rows2 @== 0- _ <- insertEntityMany ([] :: [Entity Person])- rows3 <- count ([] :: [Filter Person])+ _ <- insertEntityMany ([] :: [Entity (PersonGeneric backend)])+ rows3 <- count ([] :: [Filter (PersonGeneric backend)]) rows3 @== 0 - it "insertEntityMany" $ db $ do+ 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@@ -728,45 +479,45 @@ p4 = Entity id4 $ Person "insertEntityMany4" 3 Nothing p5 = Entity id5 $ Person "insertEntityMany5" 3 Nothing insertEntityMany [p1,p2,p3,p4,p5]- rows <- count ([] :: [Filter Person])+ rows <- count ([] :: [Filter (PersonGeneric backend)]) rows @== 5 - it "insertBy" $ db $ do+ 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" $ db $ do+ 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" $ db $ do+ it "insertEntity" $ runDb $ do Entity k p <- insertEntity $ Person "name" 1 Nothing Just p2 <- get k p2 @== p - it "insertRecord" $ db $ do+ it "insertRecord" $ runDb $ do let record = Person "name" 1 Nothing- record' <- insertRecord record + record' <- insertRecord record record' @== record - it "getEntity" $ db $ do+ it "getEntity" $ runDb $ do Entity k p <- insertEntity $ Person "name" 1 Nothing Just (Entity k2 p2) <- getEntity k p @== p2 k @== k2 - it "getJustEntity" $ db $ do+ it "getJustEntity" $ runDb $ do let p1 = Person "name" 1 Nothing k1 <- insert p1 Entity k2 p2 <- getJustEntity k1 p1 @== p2 k1 @== k2 - it "repsert" $ db $ do+ it "repsert" $ runDb $ do k <- liftIO (PersonKey `fmap` generateKey) Nothing <- selectFirst [PersonName ==. "Repsert"] [] repsert k $ Person "Repsert" 26 Nothing@@ -777,25 +528,25 @@ k3 @== k 27 @== personAge p - it "retrieves a belongsToJust association" $ db $ do+ it "retrieves a belongsToJust association" $ runDb $ do let p = Person "pet owner" 30 Nothing- person <- insert $ p+ person <- insert p let cat = Pet person "Mittens" Cat p2 <- getJust $ petOwnerId cat p @== p2- p3 <- belongsToJust petOwnerId $ cat+ p3 <- belongsToJust petOwnerId cat p @== p3 - it "retrieves a belongsTo association" $ db $ do+ 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+ Just p4 <- belongsTo maybeOwnedPetOwnerId cat p @== p4 - it "derivePersistField" $ db $ do+ it "derivePersistField" $ runDb $ do person <- insert $ Person "pet owner" 30 Nothing catKey <- insert $ Pet person "Mittens" Cat Just cat' <- get catKey@@ -804,19 +555,14 @@ Just dog' <- get dog liftIO $ petType dog' @?= Dog - it "derivePersistFieldJSON" $ db $ do+ 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 -#ifdef WITH_ZOOKEEPER- -- zookeeper backend does not support idfield- -- zookeeper's key is node-name.- -- When uniq-key exists, zookeeper's key becomes encoded uniq-key.-#else- it "idIn" $ db $ do+ it "idIn" $ runDb $ do let p1 = Person "D" 0 Nothing p2 = Person "E" 1 Nothing p3 = Person "F" 2 Nothing@@ -825,9 +571,8 @@ pid3 <- insert p3 x <- selectList [PersonId <-. [pid1, pid3]] [] liftIO $ x @?= [Entity pid1 p1, Entity pid3 p3]-#endif - it "In" $ db $ do+ it "In" $ runDb $ do let p1 = Person "D" 0 Nothing p2 = Person "E" 1 Nothing p3 = Person "F" 2 (Just "blue")@@ -850,7 +595,7 @@ liftIO $ x6 @?= [p3] describe "toJSON" $ do- it "serializes" $ db $ do+ it "serializes" $ runDb $ do let p = Person "D" 0 Nothing k <- insert p liftIO $ toJSON (Entity k p) @?=@@ -861,348 +606,9 @@ case (fromJSON . toJSON) person of Success p -> p == person _ -> error "fromJSON"- -}---#ifdef WITH_NOSQL-#ifdef WITH_MONGODB- describe "raw MongoDB helpers" $ do- it "collectionName" $ do- collectionName (Person "Duder" 0 Nothing) @?= "Person"-- it "toInsertFields, entityFields, & docToEntityThrow" $ db $ do- let p1 = Person "Duder" 0 Nothing- let doc = toInsertDoc p1- MongoDB.ObjId _id <- MongoDB.insert "Person" $ doc- let idSelector = "_id" MongoDB.=: _id- Entity _ ent1 <- docToEntityThrow $ idSelector:doc- liftIO $ p1 @?= ent1-- let p2 = p1 {personColor = Just "blue"}- let doc2 = idSelector:recordToDocument p2- MongoDB.save "Person" doc2- Entity _ ent2 <- docToEntityThrow doc2- liftIO $ p2 @?= ent2-#endif-#else- it "rawSql/2+2" $ db $ do- ret <- rawSql "SELECT 2+2" []- liftIO $ ret @?= [Single (4::Int)]-- it "sqlQQ/?-?" $ db $ do- ret <- [sqlQQ| SELECT #{2 :: Int}+#{2 :: Int} |]- liftIO $ ret @?= [Single (4::Int)]-- it "rawSql/?-?" $ db $ do- ret <- rawSql "SELECT ?-?" [PersistInt64 5, PersistInt64 3]- liftIO $ ret @?= [Single (2::Int)]-- it "sqlQQ/?-?" $ db $ do- ret <- [sqlQQ| SELECT #{5 :: Int}-#{3 :: Int} |]- liftIO $ ret @?= [Single (2::Int)]-- it "rawSql/NULL" $ db $ do- ret <- rawSql "SELECT NULL" []- liftIO $ ret @?= [Nothing :: Maybe (Single Int)]-- it "sqlQQ/NULL" $ db $ do- ret <- [sqlQQ| SELECT NULL |]- liftIO $ ret @?= [Nothing :: Maybe (Single Int)]-- it "rawSql/entity" $ db $ do- let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m)- => val -> ReaderT backend m (Key val, val)- insert' v = insert v >>= \k -> return (k, v)- (p1k, p1) <- insert' $ Person "Mathias" 23 Nothing- (p2k, p2) <- insert' $ Person "Norbert" 44 Nothing- (p3k, _ ) <- insert' $ Person "Cassandra" 19 Nothing- (_ , _ ) <- insert' $ Person "Thiago" 19 Nothing- (a1k, a1) <- insert' $ Pet p1k "Rodolfo" Cat- (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat- (a3k, a3) <- insert' $ Pet p2k "Lhama" Dog- (_ , _ ) <- insert' $ Pet p3k "Abacate" Cat- escape <- ((. DBName) . connEscapeName) `fmap` ask- person <- getTableName (error "rawSql Person" :: Person)- name <- getFieldName PersonName- let query = T.concat [ "SELECT ??, ?? "- , "FROM ", person- , ", ", escape "Pet"- , " WHERE ", person, ".", escape "age", " >= ? "- , "AND ", escape "Pet", ".", escape "ownerId", " = "- , person, ".", escape "id"- , " ORDER BY ", person, ".", name- ]- ret <- rawSql query [PersistInt64 20]- liftIO $ ret @?= [ (Entity p1k p1, Entity a1k a1)- , (Entity p1k p1, Entity a2k a2)- , (Entity p2k p2, Entity a3k a3) ]- ret2 <- rawSql query [PersistInt64 20]- liftIO $ ret2 @?= [ (Just (Entity p1k p1), Just (Entity a1k a1))- , (Just (Entity p1k p1), Just (Entity a2k a2))- , (Just (Entity p2k p2), Just (Entity a3k a3)) ]- ret3 <- rawSql query [PersistInt64 20]- liftIO $ ret3 @?= [ Just (Entity p1k p1, Entity a1k a1)- , Just (Entity p1k p1, Entity a2k a2)- , Just (Entity p2k p2, Entity a3k a3) ]-- it "rawSql/order-proof" $ db $ do- let p1 = Person "Zacarias" 93 Nothing- p1k <- insert p1- escape <- ((. DBName) . connEscapeName) `fmap` ask- let query = T.concat [ "SELECT ?? "- , "FROM ", escape "Person"- ]- ret1 <- rawSql query []- ret2 <- rawSql query [] :: MonadIO m => SqlPersistT m [Entity (ReverseFieldOrder Person)]- liftIO $ ret1 @?= [Entity p1k p1]- liftIO $ ret2 @?= [Entity (RFOKey $ unPersonKey $ p1k) (RFO p1)]-- it "rawSql/OUTER JOIN" $ db $ do- let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m)- => val -> ReaderT backend m (Key val, val)- insert' v = insert v >>= \k -> return (k, v)- (p1k, p1) <- insert' $ Person "Mathias" 23 Nothing- (p2k, p2) <- insert' $ Person "Norbert" 44 Nothing- (a1k, a1) <- insert' $ Pet p1k "Rodolfo" Cat- (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat- escape <- ((. DBName) . connEscapeName) `fmap` ask- let query = T.concat [ "SELECT ??, ?? "- , "FROM ", person- , "LEFT OUTER JOIN ", pet- , " ON ", person, ".", escape "id"- , " = ", pet, ".", escape "ownerId"- , " ORDER BY ", person, ".", escape "name"]- person = escape "Person"- pet = escape "Pet"- ret <- rawSql query []- liftIO $ ret @?= [ (Entity p1k p1, Just (Entity a1k a1))- , (Entity p1k p1, Just (Entity a2k a2))- , (Entity p2k p2, Nothing) ]-- it "sqlQQ/entity" $ db $ do- let insert'- :: PersistStore backend- => PersistEntity val- => PersistEntityBackend val ~ BaseBackend backend- => MonadIO m- => val- -> ReaderT backend m (Key val, val)- insert' v = insert v >>= \k -> return (k, v)- (p1k, p1) <- insert' $ Person "Mathias" 23 Nothing- (p2k, p2) <- insert' $ Person "Norbert" 44 Nothing- (p3k, _ ) <- insert' $ Person "Cassandra" 19 Nothing- (_ , _ ) <- insert' $ Person "Thiago" 19 Nothing- (a1k, a1) <- insert' $ Pet p1k "Rodolfo" Cat- (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat- (a3k, a3) <- insert' $ Pet p2k "Lhama" Dog- (_ , _ ) <- insert' $ Pet p3k "Abacate" Cat-- let runQuery- :: (RawSql a, Functor m, MonadIO m)- => Int- -> ReaderT SqlBackend m [a]- runQuery age =- [sqlQQ|- SELECT ??, ??- FROM- ^{Person},- ^{Pet}- WHERE ^{Person}.@{PersonAge} >= #{age}- AND ^{Pet}.@{PetOwnerId} = ^{Person}.@{PersonId}- ORDER BY ^{Person}.@{PersonName}- |]-- ret <- runQuery 20- liftIO $ ret @?= [ (Entity p1k p1, Entity a1k a1)- , (Entity p1k p1, Entity a2k a2)- , (Entity p2k p2, Entity a3k a3) ]- ret2 <- runQuery 20- liftIO $ ret2 @?= [ (Just (Entity p1k p1), Just (Entity a1k a1))- , (Just (Entity p1k p1), Just (Entity a2k a2))- , (Just (Entity p2k p2), Just (Entity a3k a3)) ]- ret3 <- runQuery 20- liftIO $ ret3 @?= [ Just (Entity p1k p1, Entity a1k a1)- , Just (Entity p1k p1, Entity a2k a2)- , Just (Entity p2k p2, Entity a3k a3) ]-- it "sqlQQ/order-proof" $ db $ do- let p1 = Person "Zacarias" 93 Nothing- p1k <- insert p1-- let runQuery- :: (RawSql a, Functor m, MonadIO m)- => ReaderT SqlBackend m [a]- runQuery = [sqlQQ| SELECT ?? FROM ^{Person} |]- ret1 <- runQuery- ret2 <- runQuery :: (MonadIO m, Functor m) => SqlPersistT m [Entity (ReverseFieldOrder Person)]- liftIO $ ret1 @?= [Entity p1k p1]- liftIO $ ret2 @?= [Entity (RFOKey $ unPersonKey $ p1k) (RFO p1)]-- it "sqlQQ/OUTER JOIN" $ db $ do- let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m)- => val -> ReaderT backend m (Key val, val)- insert' v = insert v >>= \k -> return (k, v)- (p1k, p1) <- insert' $ Person "Mathias" 23 Nothing- (p2k, p2) <- insert' $ Person "Norbert" 44 Nothing- (a1k, a1) <- insert' $ Pet p1k "Rodolfo" Cat- (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat- ret <- [sqlQQ|- SELECT ??, ??- FROM ^{Person}- LEFT OUTER JOIN ^{Pet}- ON ^{Person}.@{PersonId} = ^{Pet}.@{PetOwnerId}- ORDER BY ^{Person}.@{PersonName}- |]- liftIO $ ret @?= [ (Entity p1k p1, Just (Entity a1k a1))- , (Entity p1k p1, Just (Entity a2k a2))- , (Entity p2k p2, Nothing) ]-- it "commit/rollback" (caseCommitRollback >> runResourceT (runConn cleanDB))--#ifndef WITH_MYSQL-# ifndef WITH_POSTGRESQL-# ifndef WITH_NOSQL- it "afterException" $ db $ do- let catcher :: Monad m => SomeException -> m ()- catcher _ = return ()- _ <- insert $ Person "A" 0 Nothing- _ <- (insert (Person "A" 1 Nothing) >> return ()) `catch` catcher- _ <- insert $ Person "B" 0 Nothing- return ()-# endif-# endif-#endif---#ifndef WITH_NOSQL- it "mpsNoPrefix" $ db $ do- deleteWhere ([] :: [Filter NoPrefix2])- deleteWhere ([] :: [Filter NoPrefix1])- np1a <- insert $ NoPrefix1 1- update np1a [SomeFieldName =. 2]- np1b <- insert $ NoPrefix1 3- np2 <- insert $ NoPrefix2 4 np1a- update np2 [UnprefixedRef =. np1b, SomeOtherFieldName =. 5]-- mnp1a <- get np1a- liftIO $ mnp1a @?= Just (NoPrefix1 2)- liftIO $ fmap someFieldName mnp1a @?= Just 2- mnp2 <- get np2- liftIO $ fmap unprefixedRef mnp2 @?= Just np1b- liftIO $ fmap someOtherFieldName mnp2 @?= Just 5-- insert_ $ UnprefixedLeftSum 5- insert_ $ UnprefixedRightSum "Hello"-- it "IsSqlKey instance" $ db $ do- let p = Person "Alice" 30 Nothing- key@(PersonKey (SqlBackendKey i)) <- insert p- liftIO $ fromSqlKey key `shouldBe` (i :: Int64)- mp <- get $ toSqlKey i- liftIO $ mp `shouldBe` Just p-#endif+-} describe "strictness" $ do it "bang" $ (return $! Strict (error "foo") 5 5) `shouldThrow` anyErrorCall it "tilde" $ void (return $! Strict 5 (error "foo") 5 :: IO Strict) it "blank" $ (return $! Strict 5 5 (error "foo")) `shouldThrow` anyErrorCall--#ifdef WITH_POSTGRESQL- describe "rawSql/array_agg" $ do- let runArrayAggTest dbField expected = db $ do- void $ insertMany- [ UserPT "a" $ Just "b"- , UserPT "c" $ Just "d"- , UserPT "e" Nothing- , UserPT "g" $ Just "h" ]- escape <- ((. DBName) . connEscapeName) `fmap` ask- let query = T.concat [ "SELECT array_agg(", escape dbField, ") "- , "FROM ", escape "UserPT"- ]- [Single xs] <- rawSql query []- liftIO $ sort xs @?= expected-- it "works for [Text]" $ runArrayAggTest "ident" ["a", "c", "e", "g" :: Text]- it "works for [Maybe Text]" $ runArrayAggTest "password" [Nothing, Just "b", Just "d", Just "h" :: Maybe Text]-#endif---- | Reverses the order of the fields of an entity. Used to test--- @??@ placeholders of 'rawSql'.-newtype ReverseFieldOrder a = RFO {unRFO :: a} deriving (Eq, Show)-instance ToJSON (Key (ReverseFieldOrder a)) where toJSON = error "ReverseFieldOrder"-instance FromJSON (Key (ReverseFieldOrder a)) where parseJSON = error "ReverseFieldOrder"-instance (PersistEntity a) => PersistEntity (ReverseFieldOrder a) where- type PersistEntityBackend (ReverseFieldOrder a) = PersistEntityBackend a-- newtype Key (ReverseFieldOrder a) = RFOKey { unRFOKey :: BackendKey SqlBackend } deriving (Show, Read, Eq, Ord, PersistField, PersistFieldSql)- keyFromValues = fmap RFOKey . fromPersistValue . head- keyToValues = (:[]) . toPersistValue . unRFOKey-- entityDef = revFields . entityDef . liftM unRFO- where- revFields ed = ed { entityFields = reverse (entityFields ed) }-- toPersistFields = reverse . toPersistFields . unRFO- newtype EntityField (ReverseFieldOrder a) b = EFRFO {unEFRFO :: EntityField a b}- persistFieldDef = persistFieldDef . unEFRFO- fromPersistValues = fmap RFO . fromPersistValues . reverse-- newtype Unique (ReverseFieldOrder a) = URFO {unURFO :: Unique a }- persistUniqueToFieldNames = reverse . persistUniqueToFieldNames . unURFO- persistUniqueToValues = reverse . persistUniqueToValues . unURFO- persistUniqueKeys = map URFO . reverse . persistUniqueKeys . unRFO-- persistIdField = error "ReverseFieldOrder.persistIdField"- fieldLens = error "ReverseFieldOrder.fieldLens"--caseCommitRollback :: Assertion-caseCommitRollback = db $ do- let filt :: [Filter Person1]- filt = []-- let p = Person1 "foo" 0-- _ <- insert p- _ <- insert p- _ <- insert p-- c1 <- count filt- c1 @== 3-- transactionSave- c2 <- count filt- c2 @== 3-- _ <- insert p- transactionUndo- c3 <- count filt- c3 @== 3-- _ <- insert p- transactionSave- _ <- insert p- _ <- insert p- transactionUndo- c4 <- count filt- c4 @== 4--#endif---- Test proper polymorphism-_polymorphic :: (MonadIO m, PersistQuery backend, BaseBackend backend ~ PersistEntityBackend Pet) => ReaderT backend m ()-_polymorphic = do- ((Entity id' _):_) <- selectList [] [LimitTo 1]- _ <- selectList [PetOwnerId ==. id'] []- _ <- insert $ Pet id' "foo" Cat- return ()---- Some lens stuff-type ASetter s t a b = (a -> Identity b) -> s -> Identity t--set :: ASetter s t a b -> b -> s -> t-set l b = runIdentity . (l (\_ -> Identity b))--type Getting r s t a b = (a -> Constant r b) -> s -> Constant r t--view :: s -> Getting a s t a b -> a-view s l = getConstant (l Constant s)
+ src/PersistentTestModels.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-} -- FIXME+module PersistentTestModels where++import Data.Aeson++import Database.Persist.Sql+import Database.Persist.TH+import Init+import PersistTestPetType+import PersistTestPetCollarType++share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "testMigrate", mkDeleteCascade persistSettings, mkSave "_ignoredSave"] [persistUpperCase|++-- Dedented comment+ -- Header-level comment+ -- Indented comment+ Person json+ name Text+ age Int "some ignored -- \" attribute"+ color Text Maybe -- this is a comment sql=foobarbaz+ PersonNameKey name -- this is a comment sql=foobarbaz+ deriving Show Eq+ Person1+-- Dedented comment+ -- Header-level comment+ -- Indented comment+ name Text+ age Int+ deriving Show Eq+ PersonMaybeAge+ name Text+ age Int Maybe+ PersonMay json+ name Text Maybe+ color Text Maybe+ deriving Show Eq+ Pet+ ownerId PersonId+ name Text+ -- deriving Show Eq+-- Dedented comment+ -- Header-level comment+ -- Indented comment+ type PetType+ MaybeOwnedPet+ ownerId PersonId Maybe+ name Text+ type PetType+-- Dedented comment+ -- Header-level comment+ -- Indented comment+ NeedsPet+ petKey PetId+ OutdoorPet+ ownerId PersonId+ collar PetCollar+ type PetType++ -- From the scaffold+ UserPT+ ident Text+ password Text Maybe+ UniqueUserPT ident+ EmailPT+ email Text+ user UserPTId Maybe+ verkey Text Maybe+ UniqueEmailPT email++ Upsert+ email Text+ attr Text+ extra Text+ age Int+ UniqueUpsert email+ deriving Eq Show++ UpsertBy+ email Text+ city Text+ attr Text+ UniqueUpsertBy email+ UniqueUpsertByCity city+ deriving Eq Show++ Strict+ !yes Int+ ~no Int+ def Int+|]++deriving instance Show (BackendKey backend) => Show (PetGeneric backend)+deriving instance Eq (BackendKey backend) => Eq (PetGeneric backend)++share [mkPersist persistSettings { mpsPrefixFields = False, mpsGeneric = True }+ , mkMigrate "noPrefixMigrate"+ ] [persistLowerCase|+NoPrefix1+ someFieldName Int+NoPrefix2+ someOtherFieldName Int+ unprefixedRef NoPrefix1Id++NoPrefixSum+ unprefixedLeft Int+ unprefixedRight String+ deriving Show Eq+|]++deriving instance Show (BackendKey backend) => Show (NoPrefix1Generic backend)+deriving instance Eq (BackendKey backend) => Eq (NoPrefix1Generic backend)++deriving instance Show (BackendKey backend) => Show (NoPrefix2Generic backend)+deriving instance Eq (BackendKey backend) => Eq (NoPrefix2Generic backend)++-- | Reverses the order of the fields of an entity. Used to test+-- @??@ placeholders of 'rawSql'.+newtype ReverseFieldOrder a = RFO {unRFO :: a} deriving (Eq, Show)+instance ToJSON (Key (ReverseFieldOrder a)) where toJSON = error "ReverseFieldOrder"+instance FromJSON (Key (ReverseFieldOrder a)) where parseJSON = error "ReverseFieldOrder"+instance (PersistEntity a) => PersistEntity (ReverseFieldOrder a) where+ type PersistEntityBackend (ReverseFieldOrder a) = PersistEntityBackend a++ newtype Key (ReverseFieldOrder a) = RFOKey { unRFOKey :: BackendKey SqlBackend } deriving (Show, Read, Eq, Ord, PersistField, PersistFieldSql)+ keyFromValues = fmap RFOKey . fromPersistValue . head+ keyToValues = (:[]) . toPersistValue . unRFOKey++ entityDef = revFields . entityDef . liftM unRFO+ where+ revFields ed = ed { entityFields = reverse (entityFields ed) }++ toPersistFields = reverse . toPersistFields . unRFO+ newtype EntityField (ReverseFieldOrder a) b = EFRFO {unEFRFO :: EntityField a b}+ persistFieldDef = persistFieldDef . unEFRFO+ fromPersistValues = fmap RFO . fromPersistValues . reverse++ newtype Unique (ReverseFieldOrder a) = URFO {unURFO :: Unique a }+ persistUniqueToFieldNames = reverse . persistUniqueToFieldNames . unURFO+ persistUniqueToValues = reverse . persistUniqueToValues . unURFO+ persistUniqueKeys = map URFO . reverse . persistUniqueKeys . unRFO++ persistIdField = error "ReverseFieldOrder.persistIdField"+ fieldLens = error "ReverseFieldOrder.fieldLens"++cleanDB+ :: (MonadIO m, PersistQuery backend, PersistStoreWrite (BaseBackend backend))+ => ReaderT backend m ()+cleanDB = do+ deleteWhere ([] :: [Filter (PersonGeneric backend)])+ deleteWhere ([] :: [Filter (Person1Generic backend)])+ deleteWhere ([] :: [Filter (PetGeneric backend)])+ deleteWhere ([] :: [Filter (MaybeOwnedPetGeneric backend)])+ deleteWhere ([] :: [Filter (NeedsPetGeneric backend)])+ deleteWhere ([] :: [Filter (OutdoorPetGeneric backend)])+ deleteWhere ([] :: [Filter (UserPTGeneric backend)])+ deleteWhere ([] :: [Filter (EmailPTGeneric backend)])
src/PrimaryTest.hs view
@@ -1,14 +1,11 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-} module PrimaryTest where import Init -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs-#if WITH_NOSQL-mkPersist persistSettings { mpsGeneric = False } [persistUpperCase|-#else share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase|-#endif Foo name String Primary name@@ -21,31 +18,20 @@ Primary name Foreign Trees fkparent parent |]-#ifdef WITH_NOSQL++ cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Foo ~ backend) => ReaderT backend m () cleanDB = do deleteWhere ([] :: [Filter Foo]) deleteWhere ([] :: [Filter Bar]) -db :: Action IO () -> Assertion-db = db' cleanDB-#endif--specs :: Spec-specs = describe "primary key reference" $ do-#ifdef WITH_NOSQL- return ()-#else-# ifdef WITH_MYSQL- return ()-# else- it "insert a primary reference" $ db $ do+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" $ db $ do+ it "uses RawSql for a Primary key" $ runDb $ do key <- insert $ Foo "name" keyFromRaw <- rawSql "SELECT name FROM foo LIMIT 1" [] [key] @== keyFromRaw-# endif-#endif
+ src/RawSqlTest.hs view
@@ -0,0 +1,130 @@+module RawSqlTest where++import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import qualified Data.Text as T++import Init+import PersistTestPetType+import PersistentTestModels++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)]++ it "?-?" $ runDb $ do+ ret <- rawSql "SELECT ?-?" [PersistInt64 5, PersistInt64 3]+ 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 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+ escape <- ((. DBName) . connEscapeName) `fmap` ask+ person <- getTableName (error "rawSql Person" :: Person)+ name <- getFieldName PersonName+ let query = T.concat [ "SELECT ??, ?? "+ , "FROM ", person+ , ", ", escape "Pet"+ , " WHERE ", person, ".", escape "age", " >= ? "+ , "AND ", escape "Pet", ".", escape "ownerId", " = "+ , person, ".", escape "id"+ , " ORDER BY ", person, ".", name+ ]+ ret <- rawSql query [PersistInt64 20]+ liftIO $ ret @?= [ (Entity p1k p1, Entity a1k a1)+ , (Entity p1k p1, Entity a2k a2)+ , (Entity p2k p2, Entity a3k a3) ]+ ret2 <- rawSql query [PersistInt64 20]+ liftIO $ ret2 @?= [ (Just (Entity p1k p1), Just (Entity a1k a1))+ , (Just (Entity p1k p1), Just (Entity a2k a2))+ , (Just (Entity p2k p2), Just (Entity a3k a3)) ]+ ret3 <- rawSql query [PersistInt64 20]+ liftIO $ ret3 @?= [ Just (Entity p1k p1, Entity a1k a1)+ , Just (Entity p1k p1, Entity a2k a2)+ , Just (Entity p2k p2, Entity a3k a3) ]++ it "order-proof" $ runDb $ do+ let p1 = Person "Zacarias" 93 Nothing+ p1k <- insert p1+ escape <- ((. DBName) . connEscapeName) `fmap` ask+ let query = T.concat [ "SELECT ?? "+ , "FROM ", escape "Person"+ ]+ ret1 <- rawSql query []+ ret2 <- rawSql query [] :: MonadIO m => SqlPersistT m [Entity (ReverseFieldOrder Person)]+ liftIO $ ret1 @?= [Entity p1k p1]+ liftIO $ ret2 @?= [Entity (RFOKey $ unPersonKey p1k) (RFO p1)]++ it "OUTER JOIN" $ runDb $ do+ let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m)+ => val -> ReaderT backend m (Key val, val)+ insert' v = insert v >>= \k -> return (k, v)+ (p1k, p1) <- insert' $ Person "Mathias" 23 Nothing+ (p2k, p2) <- insert' $ Person "Norbert" 44 Nothing+ (a1k, a1) <- insert' $ Pet p1k "Rodolfo" Cat+ (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat+ escape <- ((. DBName) . connEscapeName) `fmap` ask+ let query = T.concat [ "SELECT ??, ?? "+ , "FROM ", person+ , "LEFT OUTER JOIN ", pet+ , " ON ", person, ".", escape "id"+ , " = ", pet, ".", escape "ownerId"+ , " ORDER BY ", person, ".", escape "name"]+ person = escape "Person"+ pet = escape "Pet"+ ret <- rawSql query []+ liftIO $ ret @?= [ (Entity p1k p1, Just (Entity a1k a1))+ , (Entity p1k p1, Just (Entity a2k a2))+ , (Entity p2k p2, Nothing) ]++ it "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++ it "commit/rollback" $ do+ caseCommitRollback runDb+ runDb cleanDB++caseCommitRollback :: Runner SqlBackend m => RunDb SqlBackend m -> Assertion+caseCommitRollback runDb = runDb $ do+ let filt :: [Filter Person1]+ filt = []++ let p = Person1 "foo" 0++ _ <- insert p+ _ <- insert p+ _ <- insert p++ c1 <- count filt+ c1 @== 3++ transactionSave+ c2 <- count filt+ c2 @== 3++ _ <- insert p+ transactionUndo+ c3 <- count filt+ c3 @== 3++ _ <- insert p+ transactionSave+ _ <- insert p+ _ <- insert p+ transactionUndo+ c4 <- count filt+ c4 @== 4
+ src/ReadWriteTest.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE ScopedTypeVariables #-}+module ReadWriteTest where++import Init+import PersistentTestModels+++specsWith :: forall m. Runner SqlBackend m => RunDb SqlBackend m -> Spec+specsWith originalRunDb = describe "ReadWriteTest" $ do+ let personFilters = [] :: [Filter Person]+ describe "SqlReadBackend" $ do+ let runDb :: RunDb SqlReadBackend m+ runDb = changeBackend SqlReadBackend originalRunDb+ it "type checks on all PersistStoreRead functions" $ do+ runDb $ do+ _ <- get (PersonKey 3)+ _ <- getMany [PersonKey 1, PersonKey 2]+ pure ()++ it "type checks on all PersistQueryRead functions" $ do+ runDb $ do+ _ <- selectList personFilters []+ _ <- count personFilters+ pure ()++ it "type checks on PersistUniqueRead functions" $ do+ runDb $ do+ _ <- getBy (PersonNameKey "Matt")+ pure ()++ describe "SqlWriteBackend" $ do+ 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+ k <- insert person+ mperson <- get k+ Just person @== mperson++ it "type checks on PersistQueryWrite and Read functions" $ do+ runDb $ do+ _ <- selectList personFilters []+ updateWhere personFilters []++ it "type checks on PersistUniqueWrite/Read functions" $ do+ runDb $ do+ let name = "Matt Parsons New"+ person = Person name 30 Nothing+ _mkey0 <- insertUnique person+ mkey1 <- insertUnique person+ mkey1 @== Nothing+ mperson <- selectFirst [PersonName ==. name] []+ fmap entityVal mperson @== Just person
src/Recursive.hs view
@@ -1,20 +1,10 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleInstances #-}-{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell,- OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls, MultiParamTypeClasses #-}-module Recursive (specs,-#ifndef WITH_NOSQL-recursiveMigrate-#endif-) where+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+module Recursive (specsWith, recursiveMigrate, cleanup) where import Init -#if WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else-share [mkPersist sqlSettings, mkMigrate "recursiveMigrate"] [persistLowerCase|-#endif+share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "recursiveMigrate"] [persistLowerCase| SubType object [MenuObject] deriving Show Eq@@ -22,18 +12,24 @@ sub SubType Maybe deriving Show Eq |]-#if WITH_NOSQL-cleanDB :: ReaderT Context IO ()-cleanDB = do- deleteWhere ([] :: [Filter MenuObject])- deleteWhere ([] :: [Filter SubType])-db :: Action IO () -> Assertion-db = db' cleanDB-#endif -specs :: Spec-specs = describe "recursive definitions" $ do- it "mutually recursive" $ db $ do+cleanup+ :: (PersistStoreWrite (BaseBackend backend), PersistQueryWrite backend)+ => ReaderT backend IO ()+cleanup = do+ deleteWhere ([] :: [Filter (MenuObjectGeneric backend)])+ deleteWhere ([] :: [Filter (SubTypeGeneric backend)])++specsWith+ ::+ ( 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]
src/RenameTest.hs view
@@ -1,15 +1,10 @@-{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} module RenameTest where -#ifndef WITH_NOSQL-import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL-import Control.Monad.Trans.Resource (runResourceT)-#endif-import Data.Time (getCurrentTime, Day, UTCTime(..)) import qualified Data.Map as Map import qualified Data.Text as T+import Data.Time (getCurrentTime, Day, UTCTime(..))+ import Init -- persistent used to not allow types with an "Id" suffix@@ -17,11 +12,7 @@ type TextId = Text -- Test lower case names-#if WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else-share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase|-#endif+share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migration"] [persistLowerCase| -- This just tests that a field can be named "key" KeyTable key Text@@ -55,26 +46,29 @@ ForeignIdTable idId IdTableId |]-#if WITH_NOSQL-cleanDB :: ReaderT Context IO ()-cleanDB = do- deleteWhere ([] :: [Filter IdTable])- deleteWhere ([] :: [Filter LowerCaseTable])- deleteWhere ([] :: [Filter RefTable])-db :: Action IO () -> Assertion-db = db' cleanDB-#endif -specs :: Spec-specs = describe "rename specs" $ do-#ifndef WITH_NOSQL- it "handles lower casing" $ asIO $- runConn $ do- runResourceT $ rawQuery "SELECT full_name from lower_case_table WHERE my_id=5" [] C.$$ CL.sinkNull- runResourceT $ rawQuery "SELECT something_else from ref_table WHERE id=4" [] C.$$ CL.sinkNull-#endif+cleanDB+ :: forall backend.+ ( BaseBackend backend ~ backend+ , PersistQueryWrite backend+ )+ => ReaderT backend IO ()+cleanDB = do+ deleteWhere ([] :: [Filter (IdTableGeneric backend)])+ deleteWhere ([] :: [Filter (LowerCaseTableGeneric backend)])+ deleteWhere ([] :: [Filter (RefTableGeneric backend)]) - it "user specified id, insertKey, no default=" $ db $ do+specsWith+ ::+ ( PersistStoreWrite backend, PersistQueryRead backend+ , backend ~ BaseBackend backend+ , MonadIO m, MonadFail m+ , Eq (BackendKey backend)+ )+ => RunDb backend m+ -> Spec+specsWith runDb = describe "rename specs" $ do+ 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@@ -83,26 +77,12 @@ insertKey key rec Just rec' <- get key rec' @== rec- (Entity key' _):_ <- selectList ([] :: [Filter IdTable]) []+ (Entity key' _):_ <- selectList ([] :: [Filter (IdTableGeneric backend)]) [] key' @== key -#ifndef WITH_MYSQL-# ifndef WITH_NOSQL- -- this uses default=- it "user specified id, default=" $ db $ do- let rec = IdTable "Foo" Nothing- k <- insert rec- Just rec' <- get k- rec' @== rec-# endif-#endif- it "extra blocks" $ entityExtra (entityDef (Nothing :: Maybe LowerCaseTable)) @?= Map.fromList [ ("ExtraBlock", map T.words ["foo bar", "baz", "bin"]) , ("ExtraBlock2", map T.words ["something"]) ]--asIO :: IO a -> IO a-asIO = id
src/SumTypeTest.hs view
@@ -1,20 +1,14 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}-module SumTypeTest (specs) where+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+module SumTypeTest (specsWith, sumTypeMigrate) where -import Database.Persist.TH-import Control.Monad.Trans.Resource (runResourceT) import qualified Data.Text as T +import Database.Persist.TH import Init -#if WITH_NOSQL-mkPersist persistSettings [persistLowerCase|-#else-share [mkPersist persistSettings, mkMigrate "sumTypeMigrate"] [persistLowerCase|-#endif+share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "sumTypeMigrate"] [persistLowerCase| Bicycle brand T.Text Car@@ -31,12 +25,19 @@ deriving instance Show (BackendKey backend) => Show (VehicleGeneric backend) deriving instance Eq (BackendKey backend) => Eq (VehicleGeneric backend) -specs :: Spec-specs = describe "sum types" $- it "works" $ asIO $ runResourceT $ runConn $ do-#ifndef WITH_NOSQL- _ <- runMigrationSilent sumTypeMigrate-#endif+specsWith+ ::+ ( 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"@@ -53,6 +54,3 @@ x3 <- get vb1 liftIO $ x3 @?= Just (VehicleBicycleSum bike1)--asIO :: IO a -> IO a-asIO = id
+ src/TransactionLevelTest.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++module TransactionLevelTest where++import Init++share [mkPersist sqlSettings, mkMigrate "migration"] [persistUpperCase|+ Wombat+ name Text sqltype=varchar(80)++ Primary name+ deriving Eq Show Ord++|]++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
+ src/TreeTest.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-} -- FIXME+module TreeTest where++import Database.Persist.TH (mkDeleteCascade)++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 "treeMigrate"+ , mkDeleteCascade persistSettings { mpsGeneric = False } ] [persistLowerCase|+ Tree+ name Text+ parent Text Maybe+ Primary name+ Foreign Tree fkparent parent+|]+++cleanDB+ :: (PersistQuery backend, PersistEntityBackend Tree ~ backend, MonadIO m)+ => ReaderT backend m ()+cleanDB = do+ deleteWhere ([] :: [Filter Tree])++specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec+specsWith runDb = describe "tree" $+ it "Tree relationships" $ runDb $ do+ kgp@(TreeKey gpt) <- insert $ Tree "grandpa" Nothing+ kdad@(TreeKey dadt) <- insert $ Tree "dad" $ Just gpt+ kc <- insert $ Tree "child" $ Just dadt+ c <- getJust kc+ treeFkparent c @== Just kdad+ dad <- getJust kdad+ treeFkparent dad @== Just kgp+ gp <- getJust kgp+ treeFkparent gp @== Nothing
src/UniqueTest.hs view
@@ -1,73 +1,61 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-} module UniqueTest where import Init -#ifdef WITH_NOSQL-mkPersist persistSettings [persistUpperCase|-#else share [mkPersist sqlSettings, mkMigrate "uniqueMigrate"] [persistLowerCase|-#endif TestNonNull fieldA Int- UniqueTestNonNull fieldA+ UniqueTestNonNull fieldA sql=UniqueTestNonNull !force deriving Eq Show TestNull fieldA Int fieldB Int Maybe- UniqueTestNull fieldA fieldB !force+ UniqueTestNull fieldA fieldB sql=UniqueTestNonNullSqlName !force deriving Eq Show-#ifndef WITH_NOSQL+ TestCheckmark name Text value Text active Checkmark nullable UniqueTestCheckmark name active !force deriving Eq Show-#endif |]-#ifdef WITH_NOSQL+ cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend TestNonNull ~ backend) => ReaderT backend m () cleanDB = do deleteWhere ([] :: [Filter TestNonNull]) deleteWhere ([] :: [Filter TestNull]) -db :: Action IO () -> Assertion-db = db' cleanDB-#endif--specs :: Spec-specs = describe "uniqueness constraints" $-#ifdef WITH_NOSQL- return ()-#else- do+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- (db $ void $ ins 1 >> ins 2)- (db $ void $ ins 1 >> ins 2 >> ins 1) `shouldThrow` anyException- (db $ void $ ins 1 >>= \k -> ins 2 >> delete k >> ins 1)+ (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)- (db $ void ctx)- (db $ void $ ctx >> ins 1 (Just 3)) `shouldThrow` anyException- (db $ void $ ctx >> ins 1 (Just 4)) `shouldThrow` anyException- (db $ void $ ctx >>= \k -> delete k >> ins 1 (Just 4))+ (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- (db $ void ctx)- (db $ void $ ctx >> ins "name" "Melissa" Active) `shouldThrow` anyException- (db $ void $ ctx >> ins "name" "Melissa" Inactive)- (db $ void $ ctx >>= flip update [TestCheckmarkActive =. Active])- (db $ void $ do+ (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)-#endif
+ src/UpsertTest.hs view
@@ -0,0 +1,192 @@+module UpsertTest where++import Data.Function (on)++import Init+import PersistentTestModels++-- | MongoDB assumes that a @NULL@ value in the database is some "empty"+-- value. So a query that does @+ 2@ to a @NULL@ value results in @2@. SQL+-- databases instead "annihilate" with null, so @NULL + 2 = NULL@.+data BackendNullUpdateBehavior+ = AssumeNullIsZero+ | Don'tUpdateNull++-- | @UPSERT@ on SQL databses does an "update-or-insert," which preserves+-- all prior values, including keys. MongoDB does not preserve the+-- identifier, so the entity key changes on an upsert.+data BackendUpsertKeyBehavior+ = UpsertGenerateNewKey+ | UpsertPreserveOldKey++specsWith+ :: 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++ 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"++ 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 "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"+
− test/main.hs
@@ -1,116 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--import qualified CompositeTest-import qualified CustomPersistFieldTest-import qualified CustomPrimaryKeyReferenceTest-import qualified DataTypeTest-import qualified EmbedOrderTest-import qualified EmbedTest-import qualified EmptyEntityTest-import qualified HtmlTest-import Init-import qualified LargeNumberTest-import qualified MaxLenTest-import qualified MigrationOnlyTest-import qualified PersistentTest-import qualified PersistUniqueTest-import qualified PrimaryTest-import qualified Recursive-import qualified RenameTest-import qualified SumTypeTest-import qualified InsertDuplicateUpdate-import qualified UniqueTest-import qualified MigrationColumnLengthTest-import qualified EquivalentTypeTest--#ifndef WITH_NOSQL-# ifdef WITH_SQLITE-import Control.Exception (handle, IOException)-import Filesystem (removeFile)-import Filesystem.Path.CurrentOS (fromText)-import qualified MigrationTest-# endif-#endif--#ifdef WITH_MYSQL-import qualified MigrationIdempotencyTest-#endif---#ifdef WITH_NOSQL-#else--setup :: MonadIO m => Migration -> ReaderT SqlBackend m ()-setup migration = do- printMigration migration- runMigrationUnsafe migration-#endif--main :: IO ()-main = do-#ifndef WITH_NOSQL-# ifdef WITH_SQLITE- handle (\(_ :: IOException) -> return ())- $ removeFile $ fromText sqlite_database_file-# endif-- runConn $ do- mapM_ setup- [ PersistentTest.testMigrate- , PersistentTest.noPrefixMigrate- , EmbedTest.embedMigrate- , EmbedOrderTest.embedOrderMigrate- , LargeNumberTest.numberMigrate- , UniqueTest.uniqueMigrate- , MaxLenTest.maxlenMigrate- , Recursive.recursiveMigrate- , CompositeTest.compositeMigrate-# ifdef WITH_SQLITE- , MigrationTest.migrationMigrate-# endif- , PersistUniqueTest.migration- , RenameTest.migration- , CustomPersistFieldTest.customFieldMigrate-# ifndef WITH_MYSQL- , PrimaryTest.migration-# endif-# ifdef WITH_MYSQL- , InsertDuplicateUpdate.duplicateMigrate- , MigrationIdempotencyTest.migration-# endif- , CustomPrimaryKeyReferenceTest.migration- , MigrationColumnLengthTest.migration- ]- PersistentTest.cleanDB-#endif-- hspec $ do- RenameTest.specs- DataTypeTest.specs- HtmlTest.specs- EmbedTest.specs- EmbedOrderTest.specs- LargeNumberTest.specs- UniqueTest.specs- MaxLenTest.specs- Recursive.specs- SumTypeTest.specs- MigrationOnlyTest.specs- PersistentTest.specs- EmptyEntityTest.specs- CompositeTest.specs- PersistUniqueTest.specs- PrimaryTest.specs- CustomPersistFieldTest.specs- CustomPrimaryKeyReferenceTest.specs- InsertDuplicateUpdate.specs- MigrationColumnLengthTest.specs- EquivalentTypeTest.specs--#ifdef WITH_SQLITE- MigrationTest.specs-#endif-#ifdef WITH_MYSQL- MigrationIdempotencyTest.specs-#endif