persistent-test 2.0.3.1 → 2.0.3.2
raw patch · 13 files changed
+535/−106 lines, 13 filesdep +mtlnew-uploader
Dependencies added: mtl
Files
- persistent-test.cabal +6/−1
- src/EmbedTest.hs +1/−2
- src/ForeignKey.hs +66/−0
- src/Init.hs +4/−4
- src/LongIdentifierTest.hs +37/−0
- src/MigrationTest.hs +3/−3
- src/MpsCustomPrefixTest.hs +32/−0
- src/PersistentTest.hs +90/−1
- src/PersistentTestModels.hs +94/−1
- src/PersistentTestModelsImports.hs +15/−0
- src/PrimaryTest.hs +22/−0
- src/RawSqlTest.hs +122/−80
- src/TreeTest.hs +43/−14
persistent-test.cabal view
@@ -1,5 +1,5 @@ name: persistent-test-version: 2.0.3.1+version: 2.0.3.2 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -24,6 +24,7 @@ EmptyEntityTest EntityEmbedTest EquivalentTypeTest+ ForeignKey HtmlTest Init LargeNumberTest@@ -33,8 +34,10 @@ MigrationOnlyTest MigrationTest MpsNoPrefixTest+ MpsCustomPrefixTest PersistentTest PersistentTestModels+ PersistentTestModelsImports PersistTestPetType PersistTestPetCollarType PersistUniqueTest@@ -48,6 +51,7 @@ TreeTest UniqueTest UpsertTest+ LongIdentifierTest hs-source-dirs: src @@ -65,6 +69,7 @@ , HUnit , monad-control , monad-logger >= 0.3.25+ , mtl , path-pieces >= 0.2 , QuickCheck >= 2.9 , quickcheck-instances >= 0.3
src/EmbedTest.hs view
@@ -7,14 +7,13 @@ 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 EntityEmbedTest import Init data TestException = TestException- deriving (Show, Typeable, Eq)+ deriving (Show, Eq) instance Exception TestException instance PersistFieldSql a => PersistFieldSql (NonEmpty a) where
+ src/ForeignKey.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+module ForeignKey where++import Init++-- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs+share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate"] [persistLowerCase|+ Parent+ name String+ Primary name++ Child+ pname String+ Foreign Parent OnDeleteCascade OnUpdateCascade fkparent pname+ deriving Show Eq++ ParentComposite+ name String+ lastName String+ Primary name lastName++ ChildComposite+ pname String+ plastName String+ Foreign ParentComposite OnDeleteCascade fkparent pname plastName+ deriving Show Eq++ SelfReferenced+ name String+ pname String+ Primary name+ Foreign SelfReferenced OnDeleteCascade fkparent pname+ deriving Show Eq+|]++specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec+specsWith runDb = describe "foreign keys options" $ do+ it "delete cascades" $ runDb $ do+ kf <- insert $ Parent "A"+ kc <- insert $ Child "A"+ delete kf+ cs <- selectList [] []+ let expected = [] :: [Entity Child]+ cs @== expected+ it "update cascades" $ runDb $ do+ kf <- insert $ Parent "A"+ kc <- insert $ Child "A"+ update kf [ParentName =. "B"]+ cs <- selectList [] []+ fmap (childPname . entityVal) cs @== ["B"]+ it "delete Composite cascades" $ runDb $ do+ kf <- insert $ ParentComposite "A" "B"+ kc <- insert $ ChildComposite "A" "B"+ delete kf+ cs <- selectList [] []+ let expected = [] :: [Entity ChildComposite]+ cs @== expected+ it "delete self referenced cascades" $ runDb $ do+ kf <- insert $ SelfReferenced "A" "A" -- bootstrap self reference+ kc <- insert $ SelfReferenced "B" "A"+ delete kf+ srs <- selectList [] []+ let expected = [] :: [Entity SelfReferenced]+ srs @== expected
src/Init.hs view
@@ -14,7 +14,6 @@ , isTravis , module Database.Persist.Sql- , MonadIO , persistSettings , MkPersistSettings (..) , BackendKey(..)@@ -26,12 +25,12 @@ , module Database.Persist , module Test.Hspec , module Test.HUnit- , liftIO , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase , Int32, Int64 , Text- , module Control.Monad.Trans.Reader+ , module Control.Monad.Reader , module Control.Monad+ , module Control.Monad.IO.Unlift , BS.ByteString , SomeException , MonadFail@@ -47,6 +46,7 @@ -- needed for backwards compatibility import Control.Monad.Base import Control.Monad.Catch+import Control.Monad.IO.Unlift import qualified Control.Monad.Fail as MonadFail import Control.Monad.Logger import Control.Monad.Trans.Class@@ -59,7 +59,7 @@ import Control.Exception (SomeException) import Control.Monad (void, replicateM, liftM, when, forM_) import Control.Monad.Fail (MonadFail)-import Control.Monad.Trans.Reader+import Control.Monad.Reader import Data.Char (generalCategory, GeneralCategory(..)) import Data.Fixed (Pico,Micro) import qualified Data.Text as T
+ src/LongIdentifierTest.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module LongIdentifierTest where++import Database.Persist.TH+import Init++-- This test creates very long identifier names. The generated foreign key is over the length limit for Postgres and MySQL+-- persistent-postgresql handles this by truncating foreign key names using the same algorithm that Postgres itself does (see 'refName' in Postgresql.hs)+-- MySQL currently doesn't run this test, and needs truncation logic for it to pass.+share [mkPersist sqlSettings, mkMigrate "migration", mkDeleteCascade sqlSettings] [persistLowerCase|+TableAnExtremelyFantasticallySuperLongNameParent+ field1 Int+TableAnExtremelyFantasticallySuperLongNameChild+ columnAnExtremelyFantasticallySuperLongNameParentId TableAnExtremelyFantasticallySuperLongNameParentId+|]++specsWith :: (MonadIO m) => RunDb SqlBackend m -> Spec+specsWith runDb = describe "Long identifiers" $ do+ -- See 'refName' in Postgresql.hs for why these tests are necessary.+ it "migrating is idempotent" $ runDb $ do+ again <- getMigration migration+ liftIO $ again @?= []+ it "migrating really is idempotent" $ runDb $ do+ runMigration migration+ again <- getMigration migration+ liftIO $ again @?= []
src/MigrationTest.hs view
@@ -32,19 +32,19 @@ field4 Target1Id |] -specsWith :: (MonadIO m) => RunDb SqlBackend m -> Spec+specsWith :: (MonadUnliftIO m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "Migration" $ do it "is idempotent" $ runDb $ do again <- getMigration migrationMigrate liftIO $ again @?= [] it "really is idempotent" $ runDb $ do- runMigration migrationMigrate+ runMigrationSilent migrationMigrate again <- getMigration migrationMigrate liftIO $ again @?= [] it "can add an extra column" $ runDb $ do -- Failing test case for #735. Foreign-key checking, switched on in -- version 2.6.1, caused persistent-sqlite to generate a `references` -- constraint in a *temporary* table during migration, which fails.- _ <- runMigration migrationAddCol+ _ <- runMigrationSilent migrationAddCol again <- getMigration migrationAddCol liftIO $ again @?= []
+ src/MpsCustomPrefixTest.hs view
@@ -0,0 +1,32 @@+module MpsCustomPrefixTest where++import Init+import PersistentTestModels++specsWith :: MonadIO m => RunDb SqlBackend m -> Spec+specsWith runDb = describe "mpsCustomPrefix" $+ it "works" $ runDb $ do+ deleteWhere ([] :: [Filter CustomPrefix2])+ deleteWhere ([] :: [Filter CustomPrefix1])+ cp1a <- insert $ CustomPrefix1 1+ update cp1a [CP1CustomFieldName =. 2]+ cp1b <- insert $ CustomPrefix1 3+ cp2 <- insert $ CustomPrefix2 4 cp1a+ update cp2 [CP2CustomPrefixedRef =. cp1b, CP2OtherCustomFieldName =. 5]++ mcp1a <- get cp1a+ liftIO $ mcp1a @?= Just (CustomPrefix1 2)+ liftIO $ fmap _cp1CustomFieldName mcp1a @?= Just 2+ mcp2 <- get cp2+ liftIO $ fmap _cp2CustomPrefixedRef mcp2 @?= Just cp1b+ liftIO $ fmap _cp2OtherCustomFieldName mcp2 @?= Just 5++ cpls <- insert $ CPCustomPrefixedLeftSum 5+ cprs <- insert $ CPCustomPrefixedRightSum "Hello"+ update cpls [CPCustomPrefixedLeft =. 6]+ update cprs [CPCustomPrefixedRight =. "World"]+ mcpls <- get cpls+ mcprs <- get cprs++ liftIO $ mcpls @?= Just (CPCustomPrefixedLeftSum 6)+ liftIO $ mcprs @?= Just (CPCustomPrefixedRightSum "World")
src/PersistentTest.hs view
@@ -1,16 +1,20 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-} -- FIXME+{-# LANGUAGE RecordWildCards, UndecidableInstances #-}+ module PersistentTest ( module PersistentTest , cleanDB , testMigrate , noPrefixMigrate+ , customPrefixMigrate+ , treeMigrate ) where import Control.Monad.Fail import Control.Monad.IO.Class import Data.Aeson import Data.Conduit+import qualified Data.Text as T import qualified Data.Conduit.List as CL import Data.Functor.Constant import Data.Functor.Identity@@ -21,8 +25,10 @@ import Test.HUnit hiding (Test) import UnliftIO (MonadUnliftIO, catch) import Web.PathPieces (PathPiece (..))+import Data.Proxy (Proxy(..)) import Database.Persist+import Database.Persist.Quasi import Init import PersistentTestModels import PersistTestPetType@@ -616,3 +622,86 @@ it "bang" $ (return $! Strict (error "foo") 5 5) `shouldThrow` anyErrorCall it "tilde" $ void (return $! Strict 5 (error "foo") 5 :: IO Strict) it "blank" $ (return $! Strict 5 5 (error "foo")) `shouldThrow` anyErrorCall++ describe "documentation syntax" $ do+ let edef = entityDef (Proxy :: Proxy Relationship)+ it "provides comments on entity def" $ do+ entityComments edef+ `shouldBe`+ Just "This is a doc comment for a relationship.\nYou need to put the pipe character for each line of documentation.\nBut you can resume the doc comments afterwards.\n"+ it "provides comments on the field" $ do+ let [nameField, parentField] = entityFields edef+ fieldComments nameField+ `shouldBe`+ Just "Fields should be documentable.\n"++ describe "JsonEncoding" $ do+ let+ subject =+ JsonEncoding "Bob" 32+ subjectEntity =+ Entity (JsonEncodingKey (jsonEncodingName subject)) subject++ it "encodes without an ID field" $ do+ toJSON subjectEntity+ `shouldBe`+ Object (M.fromList+ [ ("name", String "Bob")+ , ("age", toJSON (32 :: Int))+ , ("id", String "Bob")+ ])++ it "decodes without an ID field" $ do+ let+ json = encode . Object . M.fromList $+ [ ("name", String "Bob")+ , ("age", toJSON (32 :: Int))+ ]+ decode json+ `shouldBe`+ Just subjectEntity++ prop "works with a Primary" $ \jsonEncoding -> do+ let+ ent =+ Entity (JsonEncodingKey (jsonEncodingName jsonEncoding)) jsonEncoding+ decode (encode ent)+ `shouldBe`+ Just ent++ prop "excuse me what" $ \j@JsonEncoding{..} -> do+ let+ ent =+ Entity (JsonEncodingKey jsonEncodingName) j+ toJSON ent+ `shouldBe`+ Object (M.fromList+ [ ("name", toJSON jsonEncodingName)+ , ("age", toJSON jsonEncodingAge)+ , ("id", toJSON jsonEncodingName)+ ])++ prop "round trip works with composite key" $ \j@JsonEncoding2{..} -> do+ let+ key = JsonEncoding2Key jsonEncoding2Name jsonEncoding2Blood+ ent =+ Entity key j+ decode (encode ent)+ `shouldBe`+ Just ent++ prop "works with a composite key" $ \j@JsonEncoding2{..} -> do+ let+ key = JsonEncoding2Key jsonEncoding2Name jsonEncoding2Blood+ ent =+ Entity key j+ toJSON ent+ `shouldBe`+ Object (M.fromList+ [ ("name", toJSON jsonEncoding2Name)+ , ("age", toJSON jsonEncoding2Age)+ , ("blood", toJSON jsonEncoding2Blood)+ , ("id", toJSON key)+ ])++
src/PersistentTestModels.hs view
@@ -1,16 +1,22 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE UndecidableInstances #-} -- FIXME module PersistentTestModels where import Data.Aeson +import Test.QuickCheck import Database.Persist.Sql import Database.Persist.TH import Init import PersistTestPetType import PersistTestPetCollarType+import Data.Text (append) +-- just need to ensure this compiles+import PersistentTestModelsImports()+ share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "testMigrate", mkDeleteCascade persistSettings, mkSave "_ignoredSave"] [persistUpperCase| -- Dedented comment@@ -89,12 +95,35 @@ !yes Int ~no Int def Int++ -- | This is a doc comment for a relationship.+ -- | You need to put the pipe character for each line of documentation.+ -- Lines without a pipe are omitted.+ -- | But you can resume the doc comments afterwards.+ Relationship+ -- | Fields should be documentable.+ name String+ parent RelationshipId Maybe++ MutA+ mutB MutBId++ MutB+ mutA MutAId |] deriving instance Show (BackendKey backend) => Show (PetGeneric backend) deriving instance Eq (BackendKey backend) => Eq (PetGeneric backend) -share [mkPersist persistSettings { mpsPrefixFields = False, mpsGeneric = True }+deriving instance Show (BackendKey backend) => Show (RelationshipGeneric backend)+deriving instance Eq (BackendKey backend) => Eq (RelationshipGeneric backend)++share [mkPersist persistSettings { + mpsPrefixFields = False+ , mpsFieldLabelModifier = \_ _ -> "" -- this field is ignored when mpsPrefixFields == False+ , mpsConstraintLabelModifier = \_ _ -> "" -- this field is ignored when mpsPrefixFields == False+ , mpsGeneric = True + } , mkMigrate "noPrefixMigrate" ] [persistLowerCase| NoPrefix1@@ -106,13 +135,77 @@ unprefixedLeft Int unprefixedRight String deriving Show Eq+ |] +share [mkPersist sqlSettings] [persistLowerCase|+JsonEncoding json+ name Text+ age Int+ Primary name+ deriving Show Eq++JsonEncoding2 json+ name Text+ age Int+ blood Text+ Primary name blood+ deriving Show Eq+|]++instance Arbitrary JsonEncoding where+ arbitrary = JsonEncoding <$> arbitrary <*> arbitrary++instance Arbitrary JsonEncoding2 where+ arbitrary = JsonEncoding2 <$> arbitrary <*> arbitrary <*> arbitrary+ 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)++share [mkPersist persistSettings { + mpsFieldLabelModifier = \entity field -> case entity of+ "CustomPrefix1" -> append "_cp1" field+ "CustomPrefix2" -> append "_cp2" field+ _ -> error "should not be called"+ , mpsConstraintLabelModifier = \entity field -> case entity of+ "CustomPrefix1" -> append "CP1" field+ "CustomPrefix2" -> append "CP2" field+ "CustomPrefixSum" -> append "CP" field+ _ -> error "should not be called"+ , mpsGeneric = True+ }+ , mkMigrate "customPrefixMigrate"+ ] [persistLowerCase|+CustomPrefix1+ customFieldName Int+CustomPrefix2+ otherCustomFieldName Int+ customPrefixedRef CustomPrefix1Id++CustomPrefixSum+ customPrefixedLeft Int+ customPrefixedRight String+ deriving Show Eq+|]++deriving instance Show (BackendKey backend) => Show (CustomPrefix1Generic backend)+deriving instance Eq (BackendKey backend) => Eq (CustomPrefix1Generic backend)++deriving instance Show (BackendKey backend) => Show (CustomPrefix2Generic backend)+deriving instance Eq (BackendKey backend) => Eq (CustomPrefix2Generic backend)++share [mkPersist persistSettings { mpsPrefixFields = False, mpsGeneric = False }+ , mkMigrate "treeMigrate"+ ] [persistLowerCase|++Tree sql=trees+ name String+ parent String Maybe+ Primary name+ Foreign Tree fkparent parent+|] -- | Reverses the order of the fields of an entity. Used to test -- @??@ placeholders of 'rawSql'.
+ src/PersistentTestModelsImports.hs view
@@ -0,0 +1,15 @@+{-# language UndecidableInstances #-}++-- | this just needs to compile+module PersistentTestModelsImports where++import Database.Persist.TH++share [mkPersist sqlSettings] [persistUpperCase|++User+ name String+ age Int+ deriving Eq Show++|]
src/PrimaryTest.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveGeneric #-}+ module PrimaryTest where import Init@@ -9,6 +11,7 @@ Foo name String Primary name+ Bar quux FooId @@ -17,6 +20,11 @@ parent String Maybe Primary name Foreign Trees fkparent parent++ CompositePrimary+ name String+ age Int+ Primary name age |] @@ -35,3 +43,17 @@ key <- insert $ Foo "name" keyFromRaw <- rawSql "SELECT name FROM foo LIMIT 1" [] [key] @== keyFromRaw+ describe "keyFromRecordM" $ do+ it "works on singleton case" $ do+ let+ foo = Foo "hello"+ fooKey = fmap ($ foo) keyFromRecordM+ fooKey `shouldBe` Just (FooKey "hello")+ it "works on multiple fields" $ do+ let+ name = "hello"+ age = 31+ rec = CompositePrimary name age+ fmap ($ rec) keyFromRecordM+ `shouldBe`+ Just (CompositePrimaryKey name age)
src/RawSqlTest.hs view
@@ -1,5 +1,8 @@+{-# language ScopedTypeVariables, DataKinds #-}+ module RawSqlTest where +import Data.Coerce import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import qualified Data.Text as T@@ -10,93 +13,132 @@ 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 "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 "?-?" $ 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 "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 "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 <- getEscape+ 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 "order-proof" $ runDb $ do+ let p1 = Person "Zacarias" 93 Nothing+ p1k <- insert p1+ escape <- getEscape+ 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 "permits prefixes" $ runDb $ do+ let r1 = Relationship "Foo" Nothing+ r1k <- insert r1+ let r2 = Relationship "Bar" (Just r1k)+ r2k <- insert r2+ let r3 = Relationship "Lmao" (Just r1k)+ r3k <- insert r3+ let r4 = Relationship "Boring" (Just r2k)+ r4k <- insert r4+ escape <- getEscape+ let query = T.concat+ [ "SELECT ??, ?? "+ , "FROM ", escape "Relationship", " AS parent "+ , "LEFT OUTER JOIN ", escape "Relationship", " AS child "+ , "ON parent.id = child.parent"+ ] - 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+ result :: [(EntityWithPrefix "parent" Relationship, Maybe (EntityWithPrefix "child" Relationship))] <-+ rawSql query [] - it "commit/rollback" $ do- caseCommitRollback runDb- runDb cleanDB+ liftIO $+ coerce result `shouldMatchList`+ [ (Entity r1k r1, Just (Entity r2k r2))+ , (Entity r1k r1, Just (Entity r3k r3))+ , (Entity r2k r2, Just (Entity r4k r4))+ , (Entity r3k r3, Nothing)+ , (Entity r4k r4, Nothing)+ ]+++ 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 <- getEscape+ 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++ it "queries with large number of results" $ runDb $ do+ -- max size of a GHC tuple is 62, but Eq instances currently only exist up to 15-tuples+ -- See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3369+ ret <- rawSql "SELECT ?,?,?,?,?,?,?,?,?,?,?,?,?,?,?" $ map PersistInt64 [1..15]+ liftIO $ ret @?= [(Single (1::Int), Single (2::Int), Single (3::Int), Single (4::Int), Single (5::Int), Single (6::Int), Single (7::Int), Single (8::Int), Single (9::Int), Single (10::Int), Single (11::Int), Single (12::Int), Single (13::Int), Single (14::Int), Single (15::Int))]++getEscape :: MonadReader SqlBackend m => m (Text -> Text)+getEscape = asks ((. DBName) . connEscapeName) caseCommitRollback :: Runner SqlBackend m => RunDb SqlBackend m -> Assertion caseCommitRollback runDb = runDb $ do
src/TreeTest.hs view
@@ -1,19 +1,21 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UndecidableInstances #-} -- FIXME-module TreeTest where+{-# LANGUAGE RecordWildCards, UndecidableInstances #-} -import Database.Persist.TH (mkDeleteCascade)+module TreeTest where import Init +import Database.Persist.TH (mkDeleteCascade)+import Data.Proxy + -- 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+ Tree sql=trees name Text parent Text Maybe Primary name@@ -28,14 +30,41 @@ deleteWhere ([] :: [Filter Tree]) specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec-specsWith runDb = describe "tree" $+specsWith runDb = describe "tree" $ do 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+ 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+ describe "entityDef" $ do+ let EntityDef{..} = entityDef (Proxy :: Proxy Tree)+ it "has the right haskell name" $ do+ entityHaskell `shouldBe` HaskellName "Tree"+ it "has the right DB name" $ do+ entityDB `shouldBe` DBName "trees"++ describe "foreign ref" $ do+ let [ForeignDef{..}] = entityForeigns (entityDef (Proxy :: Proxy Tree))+ it "has the right haskell name" $ do+ foreignRefTableHaskell `shouldBe`+ HaskellName "Tree"+ it "has the right db name" $ do+ foreignRefTableDBName `shouldBe`+ DBName "trees"+ it "has the right constraint name" $ do+ foreignConstraintNameHaskell `shouldBe`+ HaskellName "fkparent"+ it "has the right DB constraint name" $ do+ foreignConstraintNameDBName `shouldBe`+ DBName "treesfkparent"+ it "has the right fields" $ do+ foreignFields `shouldBe`+ [ ( (HaskellName "parent", DBName "parent")+ , (HaskellName "name", DBName "name")+ )+ ]