persistent-2.15.0.0: test/Database/Persist/THSpec.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
--
-- DeriveAnyClass is not actually used by persistent-template
-- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving
-- This was fixed by using DerivingStrategies to specify newtype deriving should be used.
-- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled.
-- See https://github.com/yesodweb/persistent/issues/578
{-# LANGUAGE DeriveAnyClass #-}
module Database.Persist.THSpec where
import Control.Applicative (Const(..))
import Data.Aeson (decode, encode)
import Data.ByteString.Lazy.Char8 ()
import Data.Coerce
import Data.Functor.Identity (Identity(..))
import Data.Int
import qualified Data.List as List
import Data.Proxy
import Data.Text (Text, pack)
import Data.Time
import GHC.Generics (Generic)
import qualified Language.Haskell.TH.Syntax as TH
import System.Environment
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Gen (Gen)
import Database.Persist
import Database.Persist.EntityDef.Internal
import Database.Persist.Quasi.Internal (SourceLoc(..), sourceLocFromTHLoc)
import Database.Persist.Sql
import Database.Persist.Sql.Util
import Database.Persist.TH
import TemplateTestImports
import qualified Database.Persist.TH.CommentSpec as CommentSpec
import qualified Database.Persist.TH.CompositeKeyStyleSpec as CompositeKeyStyleSpec
import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec
import qualified Database.Persist.TH.EmbedSpec as EmbedSpec
import qualified Database.Persist.TH.EntityHaddockSpec as EntityHaddockSpec
import qualified Database.Persist.TH.ForeignRefSpec as ForeignRefSpec
import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec
import qualified Database.Persist.TH.JsonEncodingSpec as JsonEncodingSpec
import qualified Database.Persist.TH.KindEntitiesSpec as KindEntitiesSpec
import qualified Database.Persist.TH.MaybeFieldDefsSpec as MaybeFieldDefsSpec
import qualified Database.Persist.TH.MigrationOnlySpec as MigrationOnlySpec
import qualified Database.Persist.TH.MultiBlockSpec as MultiBlockSpec
import qualified Database.Persist.TH.NestedSymbolsInTypeSpec as NestedSymbolsInTypeSpec
import qualified Database.Persist.TH.NoFieldSelectorsSpec as NoFieldSelectorsSpec
import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec
import qualified Database.Persist.TH.PersistWithSpec as PersistWithSpec
import qualified Database.Persist.TH.RequireOnlyPersistImportSpec as RequireOnlyPersistImportSpec
import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec
import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec
import qualified Database.Persist.TH.SumSpec as SumSpec
import qualified Database.Persist.TH.ToFromPersistValuesSpec as ToFromPersistValuesSpec
import qualified Database.Persist.TH.TypeLitFieldDefsSpec as TypeLitFieldDefsSpec
-- test to ensure we can have types ending in Id that don't trash the TH
-- machinery
type TextId = Text
-- | Location above the block defining Person below. Must be before it. Do not move!
-- Used to test TH definition positions are plausible.
personDefBeforeLoc :: SourceLoc
personDefBeforeLoc = $(TH.lift . sourceLocFromTHLoc =<< TH.location)
share [mkPersistWith sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] } [entityDef @JsonEncodingSpec.JsonEncoding Proxy]] [persistUpperCase|
Person json
name Text
age Int Maybe
foo Foo
address Address
deriving Show Eq
HasSimpleCascadeRef
person PersonId OnDeleteCascade
deriving Show Eq
Address json
street Text
city Text
zip Int Maybe
deriving Show Eq
NoJson
foo Text
deriving Show Eq
CustomIdName
Id sql=id_col
name Text
deriving Show Eq
QualifiedReference
jsonEncoding JsonEncodingSpec.JsonEncodingId
|]
-- | Location after the block defining Person above. Must be after it. Do not move!
-- Used to test TH definition positions are plausible.
personDefAfterLoc :: SourceLoc
personDefAfterLoc = $(TH.lift . sourceLocFromTHLoc =<< TH.location)
mkPersist sqlSettings [persistLowerCase|
HasPrimaryDef
userId Int
name String
Primary userId
HasMultipleColPrimaryDef
foobar Int
barbaz String
Primary foobar barbaz
TestDefaultKeyCol
Id TestDefaultKeyColId
name String
HasIdDef
Id Int
name String
HasDefaultId
name String
HasCustomSqlId
Id String sql=my_id
name String
SharedPrimaryKey
Id HasDefaultIdId
name String
SharedPrimaryKeyWithCascade
Id (Key HasDefaultId) OnDeleteCascade
name String
SharedPrimaryKeyWithCascadeAndCustomName
Id (Key HasDefaultId) OnDeleteCascade sql=my_id
name String
Top
name Text
Middle
top TopId
Primary top
Bottom
middle MiddleId
Primary middle
-- Test that a field can be named Key
KeyTable
key Text
|]
share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase|
Lperson json
name Text
age Int Maybe
address Laddress
deriving Show Eq
Laddress json
street Text
city Text
zip Int Maybe
deriving Show Eq
CustomPrimaryKey
anInt Int
Primary anInt
|]
arbitraryT :: Gen Text
arbitraryT = pack <$> arbitrary
instance Arbitrary Person where
arbitrary = Person <$> arbitraryT <*> arbitrary <*> arbitrary <*> arbitrary
instance Arbitrary Address where
arbitrary = Address <$> arbitraryT <*> arbitraryT <*> arbitrary
spec :: Spec
spec = describe "THSpec" $ do
describe "SumSpec" $ SumSpec.spec
PersistWithSpec.spec
KindEntitiesSpec.spec
NestedSymbolsInTypeSpec.spec
OverloadedLabelSpec.spec
SharedPrimaryKeySpec.spec
SharedPrimaryKeyImportedSpec.spec
ImplicitIdColSpec.spec
MaybeFieldDefsSpec.spec
TypeLitFieldDefsSpec.spec
MigrationOnlySpec.spec
NoFieldSelectorsSpec.spec
EmbedSpec.spec
DiscoverEntitiesSpec.spec
MultiBlockSpec.spec
ForeignRefSpec.spec
ToFromPersistValuesSpec.spec
JsonEncodingSpec.spec
CommentSpec.spec
EntityHaddockSpec.spec
CompositeKeyStyleSpec.spec
it "QualifiedReference" $ do
let ed = entityDef @QualifiedReference Proxy
[FieldDef {..}] = entityFields ed
fieldType `shouldBe` FTTypeCon (Just "JsonEncodingSpec") "JsonEncodingId"
fieldSqlType `shouldBe` sqlType @JsonEncodingSpec.JsonEncodingId Proxy
fieldReference `shouldBe` ForeignRef (EntityNameHS "JsonEncoding")
describe "TestDefaultKeyCol" $ do
let EntityIdField FieldDef{..} =
entityId (entityDef (Proxy @TestDefaultKeyCol))
it "should be a BackendKey SqlBackend" $ do
-- the purpose of this test is to verify that a custom Id column of
-- the form:
-- > ModelName
-- > Id ModelNameId
--
-- should behave like an implicit id column.
(TestDefaultKeyColKey (SqlBackendKey 32) :: Key TestDefaultKeyCol)
`shouldBe`
(toSqlKey 32 :: Key TestDefaultKeyCol)
describe "HasDefaultId" $ do
let EntityIdField FieldDef{..} =
entityId (entityDef (Proxy @HasDefaultId))
it "should have usual db name" $ do
fieldDB `shouldBe` FieldNameDB "id"
it "should have usual haskell name" $ do
fieldHaskell `shouldBe` FieldNameHS "Id"
it "should have correct underlying sql type" $ do
fieldSqlType `shouldBe` SqlInt64
it "persistfieldsql should be right" $ do
sqlType (Proxy @HasDefaultIdId) `shouldBe` SqlInt64
it "should have correct haskell type" $ do
fieldType `shouldBe` FTTypeCon Nothing "HasDefaultIdId"
describe "HasCustomSqlId" $ do
let EntityIdField FieldDef{..} =
entityId (entityDef (Proxy @HasCustomSqlId))
it "should have custom db name" $ do
fieldDB `shouldBe` FieldNameDB "my_id"
it "should have usual haskell name" $ do
fieldHaskell `shouldBe` FieldNameHS "Id"
it "should have correct underlying sql type" $ do
fieldSqlType `shouldBe` SqlString
it "should have correct haskell type" $ do
fieldType `shouldBe` FTTypeCon Nothing "String"
describe "HasIdDef" $ do
let EntityIdField FieldDef{..} =
entityId (entityDef (Proxy @HasIdDef))
it "should have usual db name" $ do
fieldDB `shouldBe` FieldNameDB "id"
it "should have usual haskell name" $ do
fieldHaskell `shouldBe` FieldNameHS "Id"
it "should have correct underlying sql type" $ do
fieldSqlType `shouldBe` SqlInt64
it "should have correct haskell type" $ do
fieldType `shouldBe` FTTypeCon Nothing "Int"
describe "SharedPrimaryKey" $ do
let sharedDef = entityDef (Proxy @SharedPrimaryKey)
EntityIdField FieldDef{..} =
entityId sharedDef
it "should have usual db name" $ do
fieldDB `shouldBe` FieldNameDB "id"
it "should have usual haskell name" $ do
fieldHaskell `shouldBe` FieldNameHS "Id"
it "should have correct underlying sql type" $ do
fieldSqlType `shouldBe` SqlInt64
it "should have correct underlying (as reported by sqltype)" $ do
fieldSqlType `shouldBe` sqlType (Proxy :: Proxy HasDefaultIdId)
it "should have correct haskell type" $ do
fieldType `shouldBe` (FTTypeCon Nothing "HasDefaultIdId")
it "should have correct sql type from PersistFieldSql" $ do
sqlType (Proxy @SharedPrimaryKeyId)
`shouldBe`
SqlInt64
it "should have same sqlType as underlying record" $ do
sqlType (Proxy @SharedPrimaryKeyId)
`shouldBe`
sqlType (Proxy @HasDefaultIdId)
it "should be a coercible newtype" $ do
coerce @Int64 3
`shouldBe`
SharedPrimaryKeyKey (toSqlKey 3)
describe "SharedPrimaryKeyWithCascade" $ do
let EntityIdField FieldDef{..} =
entityId (entityDef (Proxy @SharedPrimaryKeyWithCascade))
it "should have usual db name" $ do
fieldDB `shouldBe` FieldNameDB "id"
it "should have usual haskell name" $ do
fieldHaskell `shouldBe` FieldNameHS "Id"
it "should have correct underlying sql type" $ do
fieldSqlType `shouldBe` SqlInt64
it "should have correct haskell type" $ do
fieldType
`shouldBe`
FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId")
it "should have cascade in field def" $ do
fieldCascade `shouldBe` noCascade { fcOnDelete = Just Cascade }
describe "OnCascadeDelete" $ do
let subject :: FieldDef
Just subject =
List.find ((FieldNameHS "person" ==) . fieldHaskell)
$ entityFields
$ simpleCascadeDef
simpleCascadeDef =
entityDef (Proxy :: Proxy HasSimpleCascadeRef)
expected =
FieldCascade
{ fcOnDelete = Just Cascade
, fcOnUpdate = Nothing
}
describe "entityDef" $ do
it "correct position" $ do
let Just theSpan = entitySpan simpleCascadeDef
theSpan `shouldSatisfy` ((> locStartLine personDefBeforeLoc) . spanStartLine)
theSpan `shouldSatisfy` (\s -> spanStartLine s < spanEndLine s)
theSpan `shouldSatisfy` ((< locStartLine personDefAfterLoc) . spanEndLine)
it "works" $ do
simpleCascadeDef
`shouldBe`
EntityDef
{ entityHaskell = EntityNameHS "HasSimpleCascadeRef"
, entityDB = EntityNameDB "HasSimpleCascadeRef"
, entityId =
EntityIdField FieldDef
{ fieldHaskell = FieldNameHS "Id"
, fieldDB = FieldNameDB "id"
, fieldType = FTTypeCon Nothing "HasSimpleCascadeRefId"
, fieldSqlType = SqlInt64
, fieldReference =
NoReference
, fieldAttrs = []
, fieldStrict = True
, fieldComments = Nothing
, fieldCascade = noCascade
, fieldGenerated = Nothing
, fieldIsImplicitIdColumn = True
}
, entityAttrs = []
, entityFields =
[ FieldDef
{ fieldHaskell = FieldNameHS "person"
, fieldDB = FieldNameDB "person"
, fieldType = FTTypeCon Nothing "PersonId"
, fieldSqlType = SqlInt64
, fieldAttrs = []
, fieldStrict = True
, fieldReference =
ForeignRef
(EntityNameHS "Person")
, fieldCascade =
FieldCascade { fcOnUpdate = Nothing, fcOnDelete = Just Cascade }
, fieldComments = Nothing
, fieldGenerated = Nothing
, fieldIsImplicitIdColumn = False
}
]
, entityUniques = []
, entityForeigns = []
, entityDerives = ["Show", "Eq"]
, entityExtra = mempty
, entitySum = False
, entityComments = Nothing
-- We cannot test this is a precise value without
-- being really fragile, but we have another test to
-- verify the line is in range.
, entitySpan = entitySpan simpleCascadeDef
}
it "has the cascade on the field def" $ do
fieldCascade subject `shouldBe` expected
it "doesn't have any extras" $ do
entityExtra simpleCascadeDef
`shouldBe`
mempty
describe "hasNaturalKey" $ do
let subject :: PersistEntity a => Proxy a -> Bool
subject p = hasNaturalKey (entityDef p)
it "is True for Primary keyword" $ do
subject (Proxy @HasPrimaryDef)
`shouldBe`
True
it "is True for multiple Primary columns " $ do
subject (Proxy @HasMultipleColPrimaryDef)
`shouldBe`
True
it "is False for Id keyword" $ do
subject (Proxy @HasIdDef)
`shouldBe`
False
it "is False for unspecified/default id" $ do
subject (Proxy @HasDefaultId)
`shouldBe`
False
describe "hasCompositePrimaryKey" $ do
let subject :: PersistEntity a => Proxy a -> Bool
subject p = hasCompositePrimaryKey (entityDef p)
it "is False for Primary with single column" $ do
subject (Proxy @HasPrimaryDef)
`shouldBe`
False
it "is True for multiple Primary columns " $ do
subject (Proxy @HasMultipleColPrimaryDef)
`shouldBe`
True
it "is False for Id keyword" $ do
subject (Proxy @HasIdDef)
`shouldBe`
False
it "is False for unspecified/default id" $ do
subject (Proxy @HasDefaultId)
`shouldBe`
False
describe "JSON serialization" $ do
prop "to/from is idempotent" $ \person ->
decode (encode person) == Just (person :: Person)
it "decode" $
decode "{\"name\":\"Michael\",\"age\":27,\"foo\":\"Bar\",\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just
(Person "Michael" (Just 27) Bar $ Address "Narkis" "Maalot" Nothing)
describe "JSON serialization for Entity" $ do
let key = PersonKey 0
prop "to/from is idempotent" $ \person ->
decode (encode (Entity key person)) == Just (Entity key (person :: Person))
it "decode" $
decode "{\"id\": 0, \"name\":\"Michael\",\"age\":27,\"foo\":\"Bar\",\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just
(Entity key (Person "Michael" (Just 27) Bar $ Address "Narkis" "Maalot" Nothing))
it "lens operations" $ do
let street1 = "street1"
city1 = "city1"
city2 = "city2"
zip1 = Just 12345
address1 = Laddress street1 city1 zip1
address2 = Laddress street1 city2 zip1
name1 = "name1"
age1 = Just 27
person1 = Lperson name1 age1 address1
person2 = Lperson name1 age1 address2
(person1 ^. lpersonAddress) `shouldBe` address1
(person1 ^. (lpersonAddress . laddressCity)) `shouldBe` city1
(person1 & ((lpersonAddress . laddressCity) .~ city2)) `shouldBe` person2
describe "Derived Show/Read instances" $ do
-- This tests confirms https://github.com/yesodweb/persistent/issues/1104 remains fixed
it "includes the name of the newtype when showing/reading a Key, i.e. uses the stock strategy when deriving Show/Read" $ do
show (PersonKey 0) `shouldBe` "PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 0}}"
read (show (PersonKey 0)) `shouldBe` PersonKey 0
show (CustomPrimaryKeyKey 0) `shouldBe` "CustomPrimaryKeyKey {unCustomPrimaryKeyKey = 0}"
read (show (CustomPrimaryKeyKey 0)) `shouldBe` CustomPrimaryKeyKey 0
describe "tabulateEntityA" $ do
it "works" $ do
person <-
tabulateEntityA $ \case
PersonName ->
pure "Matt"
PersonAge -> do
(year, _, _) <- toGregorian . utctDay <$> getCurrentTime
pure $ Just (fromInteger year - 1988)
PersonFoo -> do
_ <- lookupEnv "PERSON_FOO" :: IO (Maybe String)
pure Bar
PersonAddress ->
pure $ Address "lol no" "Denver" Nothing
PersonId ->
pure $ toSqlKey 123
expectedAge <- fromInteger . subtract 1988 . (\(a, _, _) -> a) . toGregorian . utctDay <$> getCurrentTime
person `shouldBe` Entity (toSqlKey 123) Person
{ personName =
"Matt"
, personAge =
Just expectedAge
, personFoo =
Bar
, personAddress =
Address "lol no" "Denver" Nothing
}
describe "tabulateEntity" $ do
it "works" $ do
let
addressTabulate =
tabulateEntity $ \case
AddressId ->
toSqlKey 123
AddressStreet ->
"nope"
AddressCity ->
"Denver"
AddressZip ->
Nothing
addressTabulate `shouldBe`
Entity (toSqlKey 123) Address
{ addressStreet = "nope"
, addressCity = "Denver"
, addressZip = Nothing
}
describe "CustomIdName" $ do
it "has a good safe to insert class instance" $ do
let proxy = Proxy :: SafeToInsert CustomIdName => Proxy CustomIdName
proxy `shouldBe` Proxy
(&) :: a -> (a -> b) -> b
x & f = f x
(^.) :: s
-> ((a -> Const a b) -> (s -> Const a t))
-> a
x ^. lens = getConst $ lens Const x
(.~) :: ((a -> Identity b) -> (s -> Identity t))
-> b
-> s
-> t
lens .~ val = runIdentity . lens (\_ -> Identity val)