From 5d0b4f0de370f96552b055d9b242d3ea58e7550d Mon Sep 17 00:00:00 2001 From: ben j Date: Wed, 2 Oct 2024 14:53:12 -0500 Subject: [PATCH 1/5] include schema in qq parse --- persistent/Database/Persist/Quasi/Internal.hs | 14 ++++++-------- persistent/test/Database/Persist/QuasiSpec.hs | 10 ++++++++-- persistent/test/Database/Persist/THSpec.hs | 6 +++--- 3 files changed, 17 insertions(+), 13 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 9e418c4f3..a47ee9ff1 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -310,6 +310,7 @@ parseLines ps = do data ParsedEntityDef = ParsedEntityDef { parsedEntityDefComments :: [Text] , parsedEntityDefEntityName :: EntityNameHS + , parsedEntityDefSchemaName :: Maybe SchemaNameDB , parsedEntityDefIsSum :: Bool , parsedEntityDefEntityAttributes :: [Attr] , parsedEntityDefFieldAttributes :: [[Token]] @@ -329,6 +330,7 @@ toParsedEntityDef :: LinesWithComments -> ParsedEntityDef toParsedEntityDef lwc = ParsedEntityDef { parsedEntityDefComments = lwcComments lwc , parsedEntityDefEntityName = entNameHS + , parsedEntityDefSchemaName = schemaName , parsedEntityDefIsSum = isSum , parsedEntityDefEntityAttributes = entAttribs , parsedEntityDefFieldAttributes = attribs @@ -349,6 +351,9 @@ toParsedEntityDef lwc = ParsedEntityDef (attribs, extras) = parseEntityFields fieldLines + schemaName = + fmap SchemaNameDB $ listToMaybe $ mapMaybe (T.stripPrefix "schema=") entAttribs + isDocComment :: Token -> Maybe Text isDocComment tok = case tok of @@ -712,8 +717,7 @@ mkUnboundEntityDef ps parsedEntDef = case parsedEntityDefComments parsedEntDef of [] -> Nothing comments -> Just (T.unlines comments) - , -- TODO: start parsing the schema attribute and write it here. - entitySchema = Nothing + , entitySchema = parsedEntityDefSchemaName parsedEntDef } } where @@ -1392,12 +1396,6 @@ takeForeign ps entityName = takeRefTable EntityNameHS refTableName , foreignRefTableDBName = EntityNameDB $ psToDBName ps refTableName - , -- TODO: The existing foreign key syntax for - -- UnboundForeignDef is not sufficiently rich to - -- allow specifying the schema of the foreign - -- relation. We need to add the ability to parse - -- schema=foo directives inline for foreign keys - -- and insert those values here. foreignRefSchemaDBName = Nothing , foreignConstraintNameHaskell = diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index 02356ee9f..1954ced30 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -258,7 +258,7 @@ Bicycle -- | this is a bike baz deriving Eq -- | This is a Car -Car +Car schema=transportation -- | the make of the Car make String -- | the model of the Car @@ -284,9 +284,14 @@ Car it "should parse the `entityAttrs` field" $ do entityAttrs (unboundEntityDef bicycle) `shouldBe` ["-- | this is a bike"] - entityAttrs (unboundEntityDef car) `shouldBe` [] + entityAttrs (unboundEntityDef car) `shouldBe` ["schema=transportation"] entityAttrs (unboundEntityDef vehicle) `shouldBe` [] + it "should parse the `entitySchema` field" $ do + entitySchema (unboundEntityDef bicycle) `shouldBe` Nothing + entitySchema (unboundEntityDef car) `shouldBe` (Just $ SchemaNameDB "transportation") + entitySchema (unboundEntityDef vehicle) `shouldBe` Nothing + it "should parse the `unboundEntityFields` field" $ do let simplifyField field = (unboundFieldNameHS field, unboundFieldNameDB field, unboundFieldComments field) @@ -332,6 +337,7 @@ Notification [ ForeignDef { foreignRefTableHaskell = EntityNameHS "User" , foreignRefTableDBName = EntityNameDB "user" + , foreignRefSchemaDBName = Nothing , foreignConstraintNameHaskell = ConstraintNameHS "fk_noti_user" , foreignConstraintNameDBName = ConstraintNameDB "notificationfk_noti_user" , foreignFieldCascade = FieldCascade Nothing Nothing diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index cfba70c6b..19abd878a 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -85,7 +85,7 @@ Person json address Address deriving Show Eq -HasSimpleCascadeRef +HasSimpleCascadeRef schema=cascade person PersonId OnDeleteCascade deriving Show Eq @@ -346,7 +346,7 @@ spec = describe "THSpec" $ do , fieldGenerated = Nothing , fieldIsImplicitIdColumn = True } - , entityAttrs = [] + , entityAttrs = ["schema=cascade"] , entityFields = [ FieldDef { fieldHaskell = FieldNameHS "person" @@ -371,7 +371,7 @@ spec = describe "THSpec" $ do , entityExtra = mempty , entitySum = False , entityComments = Nothing - , entitySchema = Nothing + , entitySchema = Just $ SchemaNameDB "cascade" } it "has the cascade on the field def" $ do fieldCascade subject `shouldBe` expected From e48552bcc0e7c2d4ca08641ace798a0a53ee65fc Mon Sep 17 00:00:00 2001 From: ben j Date: Wed, 2 Oct 2024 22:08:12 -0500 Subject: [PATCH 2/5] include schema name in foreign def --- persistent/Database/Persist/Quasi/Internal.hs | 33 +++++++++++++------ persistent/test/Database/Persist/QuasiSpec.hs | 20 +++++------ 2 files changed, 33 insertions(+), 20 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index a47ee9ff1..46eef2b00 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -59,7 +59,7 @@ import Data.List (find, foldl') import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.Maybe (fromMaybe, isNothing, isJust, listToMaybe, mapMaybe) import Data.Monoid (mappend) import Data.Text (Text) import qualified Data.Text as T @@ -1382,11 +1382,11 @@ takeForeign ps entityName = takeRefTable takeRefTable [] = error $ errorPrefix ++ " expecting foreign table name" takeRefTable (refTableName:restLine) = - go restLine Nothing Nothing + go restLine Nothing Nothing Nothing where - go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef - go (constraintNameText:rest) onDelete onUpdate - | not (T.null constraintNameText) && isLower (T.head constraintNameText) = + go :: [Text] -> Maybe SchemaNameDB -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef + go (constraintNameText:rest) schemaName onDelete onUpdate + | isConstraintName = UnboundForeignDef { unboundForeignFields = either error id $ mkUnboundForeignFieldList foreignFields parentFields @@ -1418,6 +1418,10 @@ takeForeign ps entityName = takeRefTable } } where + isConstraintName = not (T.null constraintNameText) + && isLower (T.head constraintNameText) + && isNothing (parseSchemaName constraintNameText) + constraintName = ConstraintNameHS constraintNameText @@ -1439,21 +1443,30 @@ takeForeign ps entityName = takeRefTable , show plen, " parent fields" ] - go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) onDelete' onUpdate = + go ((parseSchemaName -> Just schemaName) : rest) schemaName' onDelete onUpdate + | isJust schemaName' = error $ errorPrefix ++ "found more than one schema definition" + | otherwise = go rest (Just schemaName) onDelete onUpdate + + go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) schemaName onDelete' onUpdate = case onDelete' of Nothing -> - go rest (Just cascadingAction) onUpdate + go rest schemaName (Just cascadingAction) onUpdate Just _ -> error $ errorPrefix ++ "found more than one OnDelete actions" - go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) onDelete onUpdate' = + go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) schemaName onDelete onUpdate' = case onUpdate' of Nothing -> - go rest onDelete (Just cascadingAction) + go rest schemaName onDelete (Just cascadingAction) Just _ -> error $ errorPrefix ++ "found more than one OnUpdate actions" - go xs _ _ = error $ errorPrefix ++ "expecting a lower case constraint name or a cascading action xs=" ++ show xs + go xs _ _ _ = error $ errorPrefix ++ "expecting a lower case constraint name, schema name, or a cascading action xs=" ++ show xs + +parseSchemaName :: Text -> Maybe SchemaNameDB +parseSchemaName schemaNameText + | ["", schemaName] <- T.splitOn "schema=" schemaNameText = Just $ SchemaNameDB schemaName + | otherwise = Nothing toFKConstraintNameDB :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB toFKConstraintNameDB ps entityName constraintName = diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index 1954ced30..db6f1d0c6 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -251,14 +251,14 @@ spec = describe "Quasi" $ do describe "parse" $ do let subject = [st| -Bicycle -- | this is a bike +Bicycle schema=transportation -- | this is a bike brand String -- | the brand of the bike ExtraBike foo bar -- | this is a foo bar baz deriving Eq -- | This is a Car -Car schema=transportation +Car sql=auto schema=transportation -- | the make of the Car make String -- | the model of the Car @@ -279,16 +279,16 @@ Car schema=transportation it "should parse the `entityDB` field" $ do entityDB (unboundEntityDef bicycle) `shouldBe` EntityNameDB "bicycle" - entityDB (unboundEntityDef car) `shouldBe` EntityNameDB "car" + entityDB (unboundEntityDef car) `shouldBe` EntityNameDB "auto" entityDB (unboundEntityDef vehicle) `shouldBe` EntityNameDB "vehicle" it "should parse the `entityAttrs` field" $ do - entityAttrs (unboundEntityDef bicycle) `shouldBe` ["-- | this is a bike"] - entityAttrs (unboundEntityDef car) `shouldBe` ["schema=transportation"] + entityAttrs (unboundEntityDef bicycle) `shouldBe` ["schema=transportation", "-- | this is a bike"] + entityAttrs (unboundEntityDef car) `shouldBe` ["sql=auto", "schema=transportation"] entityAttrs (unboundEntityDef vehicle) `shouldBe` [] it "should parse the `entitySchema` field" $ do - entitySchema (unboundEntityDef bicycle) `shouldBe` Nothing + entitySchema (unboundEntityDef bicycle) `shouldBe` (Just $ SchemaNameDB "transportation") entitySchema (unboundEntityDef car) `shouldBe` (Just $ SchemaNameDB "transportation") entitySchema (unboundEntityDef vehicle) `shouldBe` Nothing @@ -330,17 +330,17 @@ Notification sentToFirst Text sentToSecond Text - Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond + Foreign User schema=some_schema OnDeleteCascade fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond |] unboundForeignDefs user `shouldBe` [] map unboundForeignDef (unboundForeignDefs notification) `shouldBe` [ ForeignDef { foreignRefTableHaskell = EntityNameHS "User" , foreignRefTableDBName = EntityNameDB "user" - , foreignRefSchemaDBName = Nothing + , foreignRefSchemaDBName = Just $ SchemaNameDB "some_schema" , foreignConstraintNameHaskell = ConstraintNameHS "fk_noti_user" , foreignConstraintNameDBName = ConstraintNameDB "notificationfk_noti_user" - , foreignFieldCascade = FieldCascade Nothing Nothing + , foreignFieldCascade = FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Just Cascade} , foreignFields = [] -- the foreign fields are not set yet in an unbound @@ -587,7 +587,7 @@ Notification let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) `shouldErrorWithMessage` - "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name or a cascading action xs=[]" + "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name, schema name, or a cascading action xs=[]" it "should error when foreign fields not provided" $ do let definitions = [st| From 6194a913d7f1bb44ee85807864a2044fe4d0baf4 Mon Sep 17 00:00:00 2001 From: ben j Date: Wed, 2 Oct 2024 23:20:09 -0500 Subject: [PATCH 3/5] update quasi haddock --- persistent/Database/Persist/Quasi.hs | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 451f92229..3b0cb40a5 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -186,13 +186,23 @@ User sql=big_user_table This will alter the generated SQL to be: @ -CREATE TABEL big_user_table ( +CREATE TABLE big_user_table ( id SERIAL PRIMARY KEY, name VARCHAR, age INT ); @ += Table Schema + +You can use a @schema=some_schema@ annotation to specify the table's schema name. +This can be placed before or after the entity's @sql=custom@ annotation, if it has one. + +@ +Foo schema=bar + baz Int +@ + = Customizing Types/Tables == JSON instances @@ -498,7 +508,7 @@ The above example is a "simple" foreign key. It refers directly to the Id column A pseudo formal syntax for @Foreign@ is: @ -Foreign $(TargetEntity) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ] +Foreign $(TargetEntity) $(schema name) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ] columns := column0 [column1 column2 .. columnX] references := References $(target-columns) @@ -544,6 +554,12 @@ We can specify delete/cascade behavior directly after the target table. Now, if the email is deleted or updated, the user will be deleted or updated to match. +Schema names can be specified between the target table and the constraint name. + +@ + Foreign Email schema=some_schema OnDeleteCascade fk_user_email emailFirstPart emailSecondPart +@ + === Non-Primary Key References SQL database backends allow you to create a foreign key to any column(s) with a Unique constraint. From b04da5255dc04d732780174d2ec3aa3282e4221b Mon Sep 17 00:00:00 2001 From: ben j Date: Wed, 2 Oct 2024 23:38:26 -0500 Subject: [PATCH 4/5] additional foreign schema test --- persistent/test/Database/Persist/TH/ForeignRefSpec.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/persistent/test/Database/Persist/TH/ForeignRefSpec.hs b/persistent/test/Database/Persist/TH/ForeignRefSpec.hs index b4e694e57..dfdc230e5 100644 --- a/persistent/test/Database/Persist/TH/ForeignRefSpec.hs +++ b/persistent/test/Database/Persist/TH/ForeignRefSpec.hs @@ -85,7 +85,7 @@ ParentExplicit ChildExplicit name Text - Foreign ParentExplicit OnDeleteCascade OnUpdateCascade fkparent name + Foreign ParentExplicit schema=kids OnDeleteCascade OnUpdateCascade fkparent name |] spec :: Spec @@ -102,6 +102,15 @@ spec = describe "ForeignRefSpec" $ do it "should compile" $ do True `shouldBe` True + describe "ForeignSchemaName" $ do + let + [childForeignDef] = + entityForeigns $ entityDef $ Proxy @ChildExplicit + it "should have a schema name defined" $ do + (foreignRefSchemaDBName childForeignDef) + `shouldBe` + (Just $ SchemaNameDB "kids") + describe "ForeignPrimarySource" $ do let fpsDef = From d57084fa78b1bf0c755b941d2cafa1b28891165c Mon Sep 17 00:00:00 2001 From: ben j Date: Thu, 3 Oct 2024 16:12:36 -0500 Subject: [PATCH 5/5] defer foreign reference schema definitions to TH --- persistent/Database/Persist/Quasi.hs | 8 +---- persistent/Database/Persist/Quasi/Internal.hs | 36 +++++++------------ persistent/Database/Persist/TH.hs | 4 +++ persistent/test/Database/Persist/QuasiSpec.hs | 23 +++++------- .../Database/Persist/TH/ForeignRefSpec.hs | 23 ++++++------ persistent/test/Database/Persist/THSpec.hs | 16 ++++++--- 6 files changed, 49 insertions(+), 61 deletions(-) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 3b0cb40a5..e41292d6c 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -508,7 +508,7 @@ The above example is a "simple" foreign key. It refers directly to the Id column A pseudo formal syntax for @Foreign@ is: @ -Foreign $(TargetEntity) $(schema name) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ] +Foreign $(TargetEntity) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ] columns := column0 [column1 column2 .. columnX] references := References $(target-columns) @@ -554,12 +554,6 @@ We can specify delete/cascade behavior directly after the target table. Now, if the email is deleted or updated, the user will be deleted or updated to match. -Schema names can be specified between the target table and the constraint name. - -@ - Foreign Email schema=some_schema OnDeleteCascade fk_user_email emailFirstPart emailSecondPart -@ - === Non-Primary Key References SQL database backends allow you to create a foreign key to any column(s) with a Unique constraint. diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 46eef2b00..330645202 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -59,7 +59,7 @@ import Data.List (find, foldl') import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M -import Data.Maybe (fromMaybe, isNothing, isJust, listToMaybe, mapMaybe) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Monoid (mappend) import Data.Text (Text) import qualified Data.Text as T @@ -1382,11 +1382,11 @@ takeForeign ps entityName = takeRefTable takeRefTable [] = error $ errorPrefix ++ " expecting foreign table name" takeRefTable (refTableName:restLine) = - go restLine Nothing Nothing Nothing + go restLine Nothing Nothing where - go :: [Text] -> Maybe SchemaNameDB -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef - go (constraintNameText:rest) schemaName onDelete onUpdate - | isConstraintName = + go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef + go (constraintNameText:rest) onDelete onUpdate + | not (T.null constraintNameText) && isLower (T.head constraintNameText) = UnboundForeignDef { unboundForeignFields = either error id $ mkUnboundForeignFieldList foreignFields parentFields @@ -1396,8 +1396,9 @@ takeForeign ps entityName = takeRefTable EntityNameHS refTableName , foreignRefTableDBName = EntityNameDB $ psToDBName ps refTableName - foreignRefSchemaDBName = + , foreignRefSchemaDBName = Nothing + -- ^ This will be determined in the TH phase ('fixForeignRefSchemaDBName'). , foreignConstraintNameHaskell = constraintName , foreignConstraintNameDBName = @@ -1418,10 +1419,6 @@ takeForeign ps entityName = takeRefTable } } where - isConstraintName = not (T.null constraintNameText) - && isLower (T.head constraintNameText) - && isNothing (parseSchemaName constraintNameText) - constraintName = ConstraintNameHS constraintNameText @@ -1443,30 +1440,21 @@ takeForeign ps entityName = takeRefTable , show plen, " parent fields" ] - go ((parseSchemaName -> Just schemaName) : rest) schemaName' onDelete onUpdate - | isJust schemaName' = error $ errorPrefix ++ "found more than one schema definition" - | otherwise = go rest (Just schemaName) onDelete onUpdate - - go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) schemaName onDelete' onUpdate = + go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) onDelete' onUpdate = case onDelete' of Nothing -> - go rest schemaName (Just cascadingAction) onUpdate + go rest (Just cascadingAction) onUpdate Just _ -> error $ errorPrefix ++ "found more than one OnDelete actions" - go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) schemaName onDelete onUpdate' = + go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) onDelete onUpdate' = case onUpdate' of Nothing -> - go rest schemaName onDelete (Just cascadingAction) + go rest onDelete (Just cascadingAction) Just _ -> error $ errorPrefix ++ "found more than one OnUpdate actions" - go xs _ _ _ = error $ errorPrefix ++ "expecting a lower case constraint name, schema name, or a cascading action xs=" ++ show xs - -parseSchemaName :: Text -> Maybe SchemaNameDB -parseSchemaName schemaNameText - | ["", schemaName] <- T.splitOn "schema=" schemaNameText = Just $ SchemaNameDB schemaName - | otherwise = Nothing + go xs _ _ = error $ errorPrefix ++ "expecting a lower case constraint name or a cascading action xs=" ++ show xs toFKConstraintNameDB :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB toFKConstraintNameDB ps entityName constraintName = diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 0a2df94cc..009f0b94b 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -331,11 +331,15 @@ liftAndFixKeys mps emEntities entityMap unboundEnt = $(lift fixForeignNullable) , foreignRefTableDBName = $(lift fixForeignRefTableDBName) + , foreignRefSchemaDBName = + $(lift fixForeignRefSchemaDBName) } |] where fixForeignRefTableDBName = getEntityDBName (unboundEntityDef parentDef) + fixForeignRefSchemaDBName = + getEntitySchema (unboundEntityDef parentDef) foreignFieldNames = case unboundForeignFields of FieldListImpliedId ffns -> diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index db6f1d0c6..6d08fe27e 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -251,14 +251,14 @@ spec = describe "Quasi" $ do describe "parse" $ do let subject = [st| -Bicycle schema=transportation -- | this is a bike +Bicycle -- | this is a bike brand String -- | the brand of the bike ExtraBike foo bar -- | this is a foo bar baz deriving Eq -- | This is a Car -Car sql=auto schema=transportation +Car -- | the make of the Car make String -- | the model of the Car @@ -279,19 +279,14 @@ Car sql=auto schema=transportation it "should parse the `entityDB` field" $ do entityDB (unboundEntityDef bicycle) `shouldBe` EntityNameDB "bicycle" - entityDB (unboundEntityDef car) `shouldBe` EntityNameDB "auto" + entityDB (unboundEntityDef car) `shouldBe` EntityNameDB "car" entityDB (unboundEntityDef vehicle) `shouldBe` EntityNameDB "vehicle" it "should parse the `entityAttrs` field" $ do - entityAttrs (unboundEntityDef bicycle) `shouldBe` ["schema=transportation", "-- | this is a bike"] - entityAttrs (unboundEntityDef car) `shouldBe` ["sql=auto", "schema=transportation"] + entityAttrs (unboundEntityDef bicycle) `shouldBe` ["-- | this is a bike"] + entityAttrs (unboundEntityDef car) `shouldBe` [] entityAttrs (unboundEntityDef vehicle) `shouldBe` [] - it "should parse the `entitySchema` field" $ do - entitySchema (unboundEntityDef bicycle) `shouldBe` (Just $ SchemaNameDB "transportation") - entitySchema (unboundEntityDef car) `shouldBe` (Just $ SchemaNameDB "transportation") - entitySchema (unboundEntityDef vehicle) `shouldBe` Nothing - it "should parse the `unboundEntityFields` field" $ do let simplifyField field = (unboundFieldNameHS field, unboundFieldNameDB field, unboundFieldComments field) @@ -330,17 +325,17 @@ Notification sentToFirst Text sentToSecond Text - Foreign User schema=some_schema OnDeleteCascade fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond + Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond |] unboundForeignDefs user `shouldBe` [] map unboundForeignDef (unboundForeignDefs notification) `shouldBe` [ ForeignDef { foreignRefTableHaskell = EntityNameHS "User" , foreignRefTableDBName = EntityNameDB "user" - , foreignRefSchemaDBName = Just $ SchemaNameDB "some_schema" + , foreignRefSchemaDBName = Nothing , foreignConstraintNameHaskell = ConstraintNameHS "fk_noti_user" , foreignConstraintNameDBName = ConstraintNameDB "notificationfk_noti_user" - , foreignFieldCascade = FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Just Cascade} + , foreignFieldCascade = FieldCascade Nothing Nothing , foreignFields = [] -- the foreign fields are not set yet in an unbound @@ -587,7 +582,7 @@ Notification let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) `shouldErrorWithMessage` - "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name, schema name, or a cascading action xs=[]" + "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name or a cascading action xs=[]" it "should error when foreign fields not provided" $ do let definitions = [st| diff --git a/persistent/test/Database/Persist/TH/ForeignRefSpec.hs b/persistent/test/Database/Persist/TH/ForeignRefSpec.hs index dfdc230e5..0e876076e 100644 --- a/persistent/test/Database/Persist/TH/ForeignRefSpec.hs +++ b/persistent/test/Database/Persist/TH/ForeignRefSpec.hs @@ -49,6 +49,7 @@ mkPersist sqlSettings [persistLowerCase| HasCustomName sql=custom_name name Text + Primary name ForeignTarget name Text @@ -79,13 +80,13 @@ ChildImplicit name Text parent ParentImplicitId OnDeleteCascade OnUpdateCascade -ParentExplicit +ParentExplicit schema=adult name Text Primary name ChildExplicit name Text - Foreign ParentExplicit schema=kids OnDeleteCascade OnUpdateCascade fkparent name + Foreign ParentExplicit OnDeleteCascade OnUpdateCascade fkparent name |] spec :: Spec @@ -102,15 +103,6 @@ spec = describe "ForeignRefSpec" $ do it "should compile" $ do True `shouldBe` True - describe "ForeignSchemaName" $ do - let - [childForeignDef] = - entityForeigns $ entityDef $ Proxy @ChildExplicit - it "should have a schema name defined" $ do - (foreignRefSchemaDBName childForeignDef) - `shouldBe` - (Just $ SchemaNameDB "kids") - describe "ForeignPrimarySource" $ do let fpsDef = @@ -185,3 +177,12 @@ spec = describe "ForeignRefSpec" $ do , "got: " , show as ] + + describe "Foreign Schema Name" $ do + let + [childForeignDef] = + entityForeigns $ entityDef $ Proxy @ChildExplicit + it "should have the correct schema name" $ do + (foreignRefSchemaDBName childForeignDef) + `shouldBe` + (Just $ SchemaNameDB "adult") diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index 19abd878a..1397f8dbe 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -71,21 +71,20 @@ import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpe 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 share [mkPersistWith sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] } [entityDef @JsonEncodingSpec.JsonEncoding Proxy]] [persistUpperCase| -Person json +Person json schema=some_schema name Text age Int Maybe foo Foo address Address deriving Show Eq -HasSimpleCascadeRef schema=cascade +HasSimpleCascadeRef person PersonId OnDeleteCascade deriving Show Eq @@ -346,7 +345,7 @@ spec = describe "THSpec" $ do , fieldGenerated = Nothing , fieldIsImplicitIdColumn = True } - , entityAttrs = ["schema=cascade"] + , entityAttrs = [] , entityFields = [ FieldDef { fieldHaskell = FieldNameHS "person" @@ -371,7 +370,7 @@ spec = describe "THSpec" $ do , entityExtra = mempty , entitySum = False , entityComments = Nothing - , entitySchema = Just $ SchemaNameDB "cascade" + , entitySchema = Nothing } it "has the cascade on the field def" $ do fieldCascade subject `shouldBe` expected @@ -507,6 +506,13 @@ spec = describe "THSpec" $ do it "has a good safe to insert class instance" $ do let proxy = Proxy :: SafeToInsert CustomIdName => Proxy CustomIdName proxy `shouldBe` Proxy + describe "Entity Schema" $ do + let personDef = + entityDef (Proxy :: Proxy Person) + it "reads the entity schema" $ do + (entitySchema personDef) + `shouldBe` + (Just $ SchemaNameDB "some_schema") (&) :: a -> (a -> b) -> b x & f = f x