diff --git a/persistent-test.cabal b/persistent-test.cabal --- a/persistent-test.cabal +++ b/persistent-test.cabal @@ -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 maintainer: Michael Snoyman 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 diff --git a/src/CompositeTest.hs b/src/CompositeTest.hs --- a/src/CompositeTest.hs +++ b/src/CompositeTest.hs @@ -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 diff --git a/src/CustomPersistField.hs b/src/CustomPersistField.hs --- a/src/CustomPersistField.hs +++ b/src/CustomPersistField.hs @@ -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) diff --git a/src/CustomPersistFieldTest.hs b/src/CustomPersistFieldTest.hs --- a/src/CustomPersistFieldTest.hs +++ b/src/CustomPersistFieldTest.hs @@ -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 - diff --git a/src/CustomPrimaryKeyReferenceTest.hs b/src/CustomPrimaryKeyReferenceTest.hs --- a/src/CustomPrimaryKeyReferenceTest.hs +++ b/src/CustomPrimaryKeyReferenceTest.hs @@ -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 diff --git a/src/DataTypeTest.hs b/src/DataTypeTest.hs --- a/src/DataTypeTest.hs +++ b/src/DataTypeTest.hs @@ -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) diff --git a/src/EmbedOrderTest.hs b/src/EmbedOrderTest.hs --- a/src/EmbedOrderTest.hs +++ b/src/EmbedOrderTest.hs @@ -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 diff --git a/src/EmbedTest.hs b/src/EmbedTest.hs --- a/src/EmbedTest.hs +++ b/src/EmbedTest.hs @@ -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 diff --git a/src/EmptyEntityTest.hs b/src/EmptyEntityTest.hs --- a/src/EmptyEntityTest.hs +++ b/src/EmptyEntityTest.hs @@ -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 () diff --git a/src/EntityEmbedTest.hs b/src/EntityEmbedTest.hs --- a/src/EntityEmbedTest.hs +++ b/src/EntityEmbedTest.hs @@ -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 diff --git a/src/EquivalentTypeTest.hs b/src/EquivalentTypeTest.hs --- a/src/EquivalentTypeTest.hs +++ b/src/EquivalentTypeTest.hs @@ -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 diff --git a/src/HtmlTest.hs b/src/HtmlTest.hs --- a/src/HtmlTest.hs +++ b/src/HtmlTest.hs @@ -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 diff --git a/src/Init.hs b/src/Init.hs --- a/src/Init.hs +++ b/src/Init.hs @@ -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 diff --git a/src/InsertDuplicateUpdate.hs b/src/InsertDuplicateUpdate.hs deleted file mode 100644 --- a/src/InsertDuplicateUpdate.hs +++ /dev/null @@ -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 diff --git a/src/LargeNumberTest.hs b/src/LargeNumberTest.hs --- a/src/LargeNumberTest.hs +++ b/src/LargeNumberTest.hs @@ -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 + diff --git a/src/MaxLenTest.hs b/src/MaxLenTest.hs --- a/src/MaxLenTest.hs +++ b/src/MaxLenTest.hs @@ -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' diff --git a/src/MigrationColumnLengthTest.hs b/src/MigrationColumnLengthTest.hs --- a/src/MigrationColumnLengthTest.hs +++ b/src/MigrationColumnLengthTest.hs @@ -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 - diff --git a/src/MigrationIdempotencyTest.hs b/src/MigrationIdempotencyTest.hs --- a/src/MigrationIdempotencyTest.hs +++ b/src/MigrationIdempotencyTest.hs @@ -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 diff --git a/src/MigrationOnlyTest.hs b/src/MigrationOnlyTest.hs --- a/src/MigrationOnlyTest.hs +++ b/src/MigrationOnlyTest.hs @@ -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)]) diff --git a/src/MigrationTest.hs b/src/MigrationTest.hs --- a/src/MigrationTest.hs +++ b/src/MigrationTest.hs @@ -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 diff --git a/src/MpsNoPrefixTest.hs b/src/MpsNoPrefixTest.hs new file mode 100644 --- /dev/null +++ b/src/MpsNoPrefixTest.hs @@ -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 diff --git a/src/PersistTestPetCollarType.hs b/src/PersistTestPetCollarType.hs --- a/src/PersistTestPetCollarType.hs +++ b/src/PersistTestPetCollarType.hs @@ -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) diff --git a/src/PersistTestPetType.hs b/src/PersistTestPetType.hs --- a/src/PersistTestPetType.hs +++ b/src/PersistTestPetType.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} module PersistTestPetType where import Database.Persist.TH diff --git a/src/PersistUniqueTest.hs b/src/PersistUniqueTest.hs --- a/src/PersistUniqueTest.hs +++ b/src/PersistUniqueTest.hs @@ -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 diff --git a/src/PersistentTest.hs b/src/PersistentTest.hs --- a/src/PersistentTest.hs +++ b/src/PersistentTest.hs @@ -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) diff --git a/src/PersistentTestModels.hs b/src/PersistentTestModels.hs new file mode 100644 --- /dev/null +++ b/src/PersistentTestModels.hs @@ -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)]) diff --git a/src/PrimaryTest.hs b/src/PrimaryTest.hs --- a/src/PrimaryTest.hs +++ b/src/PrimaryTest.hs @@ -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 diff --git a/src/RawSqlTest.hs b/src/RawSqlTest.hs new file mode 100644 --- /dev/null +++ b/src/RawSqlTest.hs @@ -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 diff --git a/src/ReadWriteTest.hs b/src/ReadWriteTest.hs new file mode 100644 --- /dev/null +++ b/src/ReadWriteTest.hs @@ -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 diff --git a/src/Recursive.hs b/src/Recursive.hs --- a/src/Recursive.hs +++ b/src/Recursive.hs @@ -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] diff --git a/src/RenameTest.hs b/src/RenameTest.hs --- a/src/RenameTest.hs +++ b/src/RenameTest.hs @@ -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 diff --git a/src/SumTypeTest.hs b/src/SumTypeTest.hs --- a/src/SumTypeTest.hs +++ b/src/SumTypeTest.hs @@ -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 diff --git a/src/TransactionLevelTest.hs b/src/TransactionLevelTest.hs new file mode 100644 --- /dev/null +++ b/src/TransactionLevelTest.hs @@ -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 diff --git a/src/TreeTest.hs b/src/TreeTest.hs new file mode 100644 --- /dev/null +++ b/src/TreeTest.hs @@ -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 diff --git a/src/UniqueTest.hs b/src/UniqueTest.hs --- a/src/UniqueTest.hs +++ b/src/UniqueTest.hs @@ -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 diff --git a/src/UpsertTest.hs b/src/UpsertTest.hs new file mode 100644 --- /dev/null +++ b/src/UpsertTest.hs @@ -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" + diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 --- a/test/main.hs +++ /dev/null @@ -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