diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,11 @@ # Changelog for persistent -# 2.13.3.4 +## 2.13.3.5 + +* [#1374](https://github.com/yesodweb/persistent/pull/1374) + * Increasing test coverage for errors thrown when parsing entity definitions + +## 2.13.3.4 * [#1379](https://github.com/yesodweb/persistent/pull/1379) * `mkPersist` now generates code that compiles under `NoFieldSelectors` and `DuplicateRecordFields` even if field labels are not prefixed diff --git a/Database/Persist/Quasi/Internal.hs b/Database/Persist/Quasi/Internal.hs --- a/Database/Persist/Quasi/Internal.hs +++ b/Database/Persist/Quasi/Internal.hs @@ -1152,9 +1152,7 @@ _ -> Nothing dbName = fromMaybe usualDbName sqlName - getDBName [] t = - error $ "Unknown column in unique constraint: " ++ show t - ++ " " ++ show defs ++ show n ++ " " ++ show attrs + getDBName [] t = error $ T.unpack (unknownUniqueColumnError t defs n) getDBName (d:ds) t | unboundFieldNameHS d == FieldNameHS t = unboundFieldNameDB d @@ -1167,6 +1165,15 @@ ++ "] expecting an uppercase constraint name xs=" ++ show xs +unknownUniqueColumnError :: Text -> [UnboundFieldDef] -> Text -> Text +unknownUniqueColumnError t defs n = + "Unknown column in \"" <> n <> "\" constraint: \"" <> t <> "\"" + <> " possible fields: " <> T.pack (show (toFieldName <$> defs)) + where + toFieldName :: UnboundFieldDef -> Text + toFieldName fd = + unFieldNameHS (unboundFieldNameHS fd) + -- | Define an explicit foreign key reference. -- -- @ @@ -1400,7 +1407,7 @@ Nothing -> go acc mupd (Just cascDel) rest Just _ -> - nope "found more than one OnDelete action: " + nope "found more than one OnDelete action" Nothing -> go (this : acc) mupd mdel rest nope msg = diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.13.3.4 +version: 2.13.3.5 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/test/Database/Persist/QuasiSpec.hs b/test/Database/Persist/QuasiSpec.hs --- a/test/Database/Persist/QuasiSpec.hs +++ b/test/Database/Persist/QuasiSpec.hs @@ -82,6 +82,10 @@ subject ["asdf"] `shouldBe` Nothing + it "errors on invalid input" $ do + evaluate (subject ["name", "int"]) + `shouldThrow` + errorCall "Invalid field type \"int\" PSFail ('i',\"nt\")" it "works if it has a name and a type" $ do subject ["asdf", "Int"] `shouldBe` @@ -145,6 +149,11 @@ ] ) + it "should error if quotes are unterminated" $ do + evaluate (parseLine " \"foo bar") + `shouldThrow` + errorCall "Unterminated quoted string starting with foo bar" + it "handles quotes mid-token" $ parseLine " x=\"foo bar\" \"baz\"" `shouldBe` Just @@ -340,6 +349,37 @@ entityComments (unboundEntityDef car) `shouldBe` Just "This is a Car\n" entityComments (unboundEntityDef vehicle) `shouldBe` Nothing + it "should error on malformed input, unterminated parens" $ do + let definitions = [st| +User + name Text + age (Maybe Int +|] + let [user] = parse lowerCaseSettings definitions + evaluate (unboundEntityDef user) + `shouldThrow` + errorCall "Unterminated parens string starting with Maybe Int" + + it "errors on duplicate cascade update declarations" $ do + let definitions = [st| +User + age Int OnUpdateCascade OnUpdateCascade +|] + let [user] = parse lowerCaseSettings definitions + mapM (evaluate . unboundFieldCascade) (unboundEntityFields user) + `shouldThrow` + errorCall "found more than one OnUpdate action, tokens: [\"OnUpdateCascade\",\"OnUpdateCascade\"]" + + it "errors on duplicate cascade delete declarations" $ do + let definitions = [st| +User + age Int OnDeleteCascade OnDeleteCascade +|] + let [user] = parse lowerCaseSettings definitions + mapM (evaluate . unboundFieldCascade) (unboundEntityFields user) + `shouldThrow` + errorCall "found more than one OnDelete action, tokens: [\"OnDeleteCascade\",\"OnDeleteCascade\"]" + describe "custom Id column" $ do it "parses custom Id column" $ do let definitions = [st| @@ -423,8 +463,51 @@ evaluate (unboundEntityDef user) `shouldThrow` errorCall (T.unpack errMsg) + it "triggers error on invalid declaration" $ do + let definitions = [st| +User + age Text + Primary ref +|] + let [user] = parse lowerCaseSettings definitions + case unboundPrimarySpec user of + NaturalKey ucd -> do + evaluate (head $ unboundCompositeCols ucd) `shouldThrow` + errorCall "Unknown column in primary key constraint: \"ref\"" + _ -> + error "Expected NaturalKey, failing" + + describe "entity unique constraints" $ do + it "triggers error if declared field does not exist" $ do + let definitions = [st| +User + name Text + emailFirst Text + + UniqueEmail emailFirst emailSecond +|] + let [user] = parse lowerCaseSettings definitions + uniques = entityUniques (unboundEntityDef user) + [dbNames] = fmap snd . uniqueFields <$> uniques + errMsg = unwords + [ "Unknown column in \"UniqueEmail\" constraint: \"emailSecond\"" + , "possible fields: [\"name\",\"emailFirst\"]" + ] + evaluate (head (NEL.tail dbNames)) `shouldThrow` + errorCall errMsg + + it "triggers error if no valid constraint name provided" $ do + let definitions = [st| +User + age Text + Unique some +|] + let [user] = parse lowerCaseSettings definitions + evaluate (unboundPrimarySpec user) `shouldThrow` + errorCall "invalid unique constraint on table[\"User\"] expecting an uppercase constraint name xs=[\"some\"]" + describe "foreign keys" $ do - let definitions = [st| + let validDefinitions = [st| User name Text emailFirst Text @@ -445,17 +528,116 @@ flippedFK (EntityNameHS entName) (ConstraintNameHS conName) = conName <> entName [_user, notification] = - parse (setPsToFKName flippedFK lowerCaseSettings) definitions + parse (setPsToFKName flippedFK lowerCaseSettings) validDefinitions [notificationForeignDef] = unboundForeignDef <$> unboundForeignDefs notification foreignConstraintNameDBName notificationForeignDef `shouldBe` ConstraintNameDB "fk_noti_user_notification" + it "should error when insufficient params provided" $ do + let definitions = [st| +User + name Text + emailFirst Text + emailSecond Text + + UniqueEmail emailFirst emailSecond + +Notification + content Text + sentToFirst Text + sentToSecond Text + Foreign User +|] + let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) + `shouldThrow` + errorCall "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| +User + name Text + emailFirst Text + emailSecond Text + + UniqueEmail emailFirst emailSecond + +Notification + content Text + sentToFirst Text + sentToSecond Text + Foreign User fk_noti_user +|] + let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) + `shouldThrow` + errorCall "No fields on foreign reference." + + it "should error when number of parent and foreign fields differ" $ do + let definitions = [st| +User + name Text + emailFirst Text + emailSecond Text + + UniqueEmail emailFirst emailSecond + +Notification + content Text + sentToFirst Text + sentToSecond Text + Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst +|] + let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) + `shouldThrow` + errorCall "invalid foreign key constraint on table[\"Notification\"] Found 2 foreign fields but 1 parent fields" + + it "should throw error when there is more than one delete cascade on the declaration" $ do + let definitions = [st| +User + name Text + emailFirst Text + emailSecond Text + + UniqueEmail emailFirst emailSecond + +Notification + content Text + sentToFirst Text + sentToSecond Text + Foreign User OnDeleteCascade OnDeleteCascade +|] + let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) + `shouldThrow` + errorCall "invalid foreign key constraint on table[\"Notification\"] found more than one OnDelete actions" + + it "should throw error when there is more than one update cascade on the declaration" $ do + let definitions = [st| +User + name Text + emailFirst Text + emailSecond Text + + UniqueEmail emailFirst emailSecond + +Notification + content Text + sentToFirst Text + sentToSecond Text + Foreign User OnUpdateCascade OnUpdateCascade +|] + let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) + `shouldThrow` + errorCall "invalid foreign key constraint on table[\"Notification\"] found more than one OnUpdate actions" + it "should allow you to enable snake cased foriegn keys via a preset configuration function" $ do - let - [_user, notification] = - parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + let [_user, notification] = + parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) validDefinitions [notificationForeignDef] = unboundForeignDef <$> unboundForeignDefs notification foreignConstraintNameDBName notificationForeignDef