diff --git a/persistent-test.cabal b/persistent-test.cabal --- a/persistent-test.cabal +++ b/persistent-test.cabal @@ -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 @@ -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 diff --git a/src/EmbedTest.hs b/src/EmbedTest.hs --- a/src/EmbedTest.hs +++ b/src/EmbedTest.hs @@ -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 diff --git a/src/ForeignKey.hs b/src/ForeignKey.hs new file mode 100644 --- /dev/null +++ b/src/ForeignKey.hs @@ -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 diff --git a/src/Init.hs b/src/Init.hs --- a/src/Init.hs +++ b/src/Init.hs @@ -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 diff --git a/src/LongIdentifierTest.hs b/src/LongIdentifierTest.hs new file mode 100644 --- /dev/null +++ b/src/LongIdentifierTest.hs @@ -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 @?= [] diff --git a/src/MigrationTest.hs b/src/MigrationTest.hs --- a/src/MigrationTest.hs +++ b/src/MigrationTest.hs @@ -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 @?= [] diff --git a/src/MpsCustomPrefixTest.hs b/src/MpsCustomPrefixTest.hs new file mode 100644 --- /dev/null +++ b/src/MpsCustomPrefixTest.hs @@ -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") diff --git a/src/PersistentTest.hs b/src/PersistentTest.hs --- a/src/PersistentTest.hs +++ b/src/PersistentTest.hs @@ -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) + ]) + + diff --git a/src/PersistentTestModels.hs b/src/PersistentTestModels.hs --- a/src/PersistentTestModels.hs +++ b/src/PersistentTestModels.hs @@ -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'. diff --git a/src/PersistentTestModelsImports.hs b/src/PersistentTestModelsImports.hs new file mode 100644 --- /dev/null +++ b/src/PersistentTestModelsImports.hs @@ -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 + +|] diff --git a/src/PrimaryTest.hs b/src/PrimaryTest.hs --- a/src/PrimaryTest.hs +++ b/src/PrimaryTest.hs @@ -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) diff --git a/src/RawSqlTest.hs b/src/RawSqlTest.hs --- a/src/RawSqlTest.hs +++ b/src/RawSqlTest.hs @@ -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 diff --git a/src/TreeTest.hs b/src/TreeTest.hs --- a/src/TreeTest.hs +++ b/src/TreeTest.hs @@ -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") + ) + ]