diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 4f2552cfe..96274c860 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -2,6 +2,8 @@ ## 2.13.0.0 (unreleased) +* [#1244](https://github.com/yesodweb/persistent/pull/1244) + * Implement config for customising the FK name * [#1252](https://github.com/yesodweb/persistent/pull/1252) * `mkMigrate` now defers to `mkEntityDefList` and `migrateModels` instead of fixing the foreign key references itself. diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 2bd030221..7bf538637 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -423,6 +423,7 @@ module Database.Persist.Quasi ) where import Data.Text (Text) +import Database.Persist.Names import Database.Persist.Quasi.Internal -- | Retrieve the function in the 'PersistSettings' that modifies the names into @@ -439,6 +440,21 @@ getPsToDBName = psToDBName setPsToDBName :: (Text -> Text) -> PersistSettings -> PersistSettings setPsToDBName f ps = ps { psToDBName = f } +-- | Set a custom function used to create the constraint name +-- for a foreign key. +-- +-- @since 2.13.0.0 +setPsToFKName :: (EntityNameHS -> ConstraintNameHS -> Text) -> PersistSettings -> PersistSettings +setPsToFKName setter ps = ps { psToFKName = setter } + +-- | A preset configuration function that puts an underscore +-- between the entity name and the constraint name when +-- creating a foreign key constraint name +-- +-- @since 2.13.0.0 +setPsUseSnakeCaseForiegnKeys :: PersistSettings -> PersistSettings +setPsUseSnakeCaseForiegnKeys = setPsToFKName (toFKNameInfixed "_") + -- | Retrieve whether or not the 'PersistSettings' will generate code with -- strict fields. -- diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 1054b9ff3..7e3a898e3 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -16,6 +16,7 @@ module Database.Persist.Quasi.Internal , PersistSettings (..) , upperCaseSettings , lowerCaseSettings + , toFKNameInfixed , nullable , Token (..) , Line (..) @@ -30,15 +31,15 @@ module Database.Persist.Quasi.Internal import Prelude hiding (lines) -import Control.Applicative ( Alternative((<|>)) ) +import Control.Applicative (Alternative((<|>))) import Control.Arrow ((&&&)) -import Control.Monad (msum, mplus) -import Data.Char ( isLower, isSpace, isUpper, toLower ) +import Control.Monad (mplus, msum) +import Data.Char (isLower, isSpace, isUpper, toLower) import Data.List (find, foldl') -import qualified Data.List.NonEmpty as NEL import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M -import Data.Maybe (mapMaybe, fromMaybe, maybeToList, listToMaybe) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList) import Data.Monoid (mappend) #if !MIN_VERSION_base(4,11,0) -- This can be removed when GHC < 8.2.2 isn't supported anymore @@ -46,9 +47,9 @@ import Data.Semigroup ((<>)) #endif import Data.Text (Text) import qualified Data.Text as T +import Database.Persist.EntityDef.Internal import Database.Persist.Types import Text.Read (readEither) -import Database.Persist.EntityDef.Internal data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show @@ -102,6 +103,11 @@ parseFieldType t0 = data PersistSettings = PersistSettings { psToDBName :: !(Text -> Text) -- ^ Modify the Haskell-style name into a database-style name. + , psToFKName :: !(EntityNameHS -> ConstraintNameHS -> Text) + -- ^ A function for generating the constraint name, with access to + -- the entity and constraint names. Default value: @mappend@ + -- + -- @since 2.13.0.0 , psStrictFields :: !Bool -- ^ Whether fields are by default strict. Default value: @True@. -- @@ -117,6 +123,7 @@ data PersistSettings = PersistSettings defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings defaultPersistSettings = PersistSettings { psToDBName = id + , psToFKName = \(EntityNameHS entName) (ConstraintNameHS conName) -> entName <> conName , psStrictFields = True , psIdName = "id" } @@ -131,6 +138,10 @@ lowerCaseSettings = defaultPersistSettings in T.dropWhile (== '_') . T.concatMap go } +toFKNameInfixed :: Text -> EntityNameHS -> ConstraintNameHS -> Text +toFKNameInfixed inf (EntityNameHS entName) (ConstraintNameHS conName) = + entName <> inf <> conName + -- | Parses a quasi-quoted syntax into a list of entity definitions. parse :: PersistSettings -> Text -> [EntityDef] parse ps = maybe [] (parseLines ps) . preparse @@ -226,14 +237,50 @@ lowestIndent = minimum . fmap lineIndent -- | Divide lines into blocks and make entity definitions. parseLines :: PersistSettings -> NonEmpty Line -> [EntityDef] -parseLines ps = - fixForeignKeysAll . map mk . associateLines +parseLines ps = do + fixForeignKeysAll . fmap (mkEntityDef ps . toParsedEntityDef) . associateLines + +data ParsedEntityDef = ParsedEntityDef + { parsedEntityDefComments :: [Text] + , parsedEntityDefEntityName :: EntityNameHS + , parsedEntityDefIsSum :: Bool + , parsedEntityDefEntityAttributes :: [Attr] + , parsedEntityDefFieldAttributes :: [[Token]] + , parsedEntityDefExtras :: M.Map Text [ExtraLine] + } + +entityNamesFromParsedDef :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB) +entityNamesFromParsedDef ps parsedEntDef = (entNameHS, entNameDB) + where + entNameHS = + parsedEntityDefEntityName parsedEntDef + + entNameDB = + EntityNameDB $ getDbName ps (unEntityNameHS entNameHS) (parsedEntityDefEntityAttributes parsedEntDef) + +toParsedEntityDef :: LinesWithComments -> ParsedEntityDef +toParsedEntityDef lwc = ParsedEntityDef + { parsedEntityDefComments = lwcComments lwc + , parsedEntityDefEntityName = entNameHS + , parsedEntityDefIsSum = isSum + , parsedEntityDefEntityAttributes = entAttribs + , parsedEntityDefFieldAttributes = attribs + , parsedEntityDefExtras = extras + } where - mk :: LinesWithComments -> UnboundEntityDef - mk lwc = - let ln :| rest = lwcLines lwc - (name :| entAttribs) = lineText ln - in setComments (lwcComments lwc) $ mkEntityDef ps name entAttribs rest + entityLine :| fieldLines = + lwcLines lwc + + (entityName :| entAttribs) = + lineText entityLine + + (isSum, entNameHS) = + case T.uncons entityName of + Just ('+', x) -> (True, EntityNameHS x) + _ -> (False, EntityNameHS entityName) + + (attribs, extras) = + splitExtras fieldLines isDocComment :: Token -> Maybe Text isDocComment tok = @@ -302,11 +349,6 @@ associateLines lines = minimumIndentOf = lowestIndent . lwcLines -setComments :: [Text] -> UnboundEntityDef -> UnboundEntityDef -setComments [] = id -setComments comments = - overUnboundEntityDef (\ed -> ed { entityComments = Just (T.unlines comments) }) - fixForeignKeysAll :: [UnboundEntityDef] -> [EntityDef] fixForeignKeysAll unEnts = map fixForeignKeys unEnts where @@ -417,50 +459,45 @@ data UnboundEntityDef , unboundEntityDef :: EntityDef } -overUnboundEntityDef - :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef -overUnboundEntityDef f ubed = - ubed { unboundEntityDef = f (unboundEntityDef ubed) } - -- | Construct an entity definition. mkEntityDef :: PersistSettings - -> Text -- ^ name - -> [Attr] -- ^ entity attributes - -> [Line] -- ^ indented lines + -> ParsedEntityDef -- ^ parsed entity definition -> UnboundEntityDef -mkEntityDef ps name entattribs lines = +mkEntityDef ps parsedEntDef = UnboundEntityDef foreigns $ EntityDef - { entityHaskell = entName - , entityDB = EntityNameDB $ getDbName ps name' entattribs + { entityHaskell = entNameHS + , entityDB = entNameDB -- idField is the user-specified Id -- otherwise useAutoIdField -- but, adjust it if the user specified a Primary , entityId = setComposite primaryComposite $ fromMaybe autoIdField idField - , entityAttrs = entattribs + , entityAttrs = parsedEntityDefEntityAttributes parsedEntDef , entityFields = cols , entityUniques = uniqs , entityForeigns = [] , entityDerives = concat $ mapMaybe takeDerives textAttribs - , entityExtra = extras - , entitySum = isSum - , entityComments = Nothing + , entityExtra = parsedEntityDefExtras parsedEntDef + , entitySum = parsedEntityDefIsSum parsedEntDef + , entityComments = + case parsedEntityDefComments parsedEntDef of + [] -> Nothing + comments -> Just (T.unlines comments) } where - entName = EntityNameHS name' - (isSum, name') = - case T.uncons name of - Just ('+', x) -> (True, x) - _ -> (False, name) - (attribs, extras) = splitExtras lines + (entNameHS, entNameDB) = + entityNamesFromParsedDef ps parsedEntDef + + attribs = + parsedEntityDefFieldAttributes parsedEntDef textAttribs :: [[Text]] textAttribs = fmap tokenText <$> attribs (idField, primaryComposite, uniqs, foreigns) = foldl' (\(mid, mp, us, fs) attr -> - let (i, p, u, f) = takeConstraint ps name' cols attr + let (i, p, u, f) = takeConstraint ps entNameHS cols attr squish xs m = xs `mappend` maybeToList m in (just1 mid i, just1 mp p, squish us u, squish fs f)) (Nothing, Nothing, [],[]) textAttribs @@ -483,7 +520,7 @@ mkEntityDef ps name entattribs lines = go ft = case ft of FTTypeCon Nothing x - | x == name -> + | x == unEntityNameHS entNameHS -> field { fieldReference = SelfReference @@ -496,8 +533,12 @@ mkEntityDef ps name entattribs lines = go ft' _ -> field - autoIdField = mkAutoIdField ps entName idSqlType - idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite + + autoIdField = + mkAutoIdField ps entNameHS idSqlType + + idSqlType = + maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite setComposite Nothing fd = fd setComposite (Just c) fd = fd @@ -523,7 +564,7 @@ mkAutoIdField ps entName idSqlType = -- but that sucks for non-ID field -- TODO: use a sumtype FieldDef | IdFieldDef , fieldDB = FieldNameDB $ psIdName ps - , fieldType = FTTypeCon Nothing $ keyConName $ unEntityNameHS entName + , fieldType = FTTypeCon Nothing $ keyConName entName , fieldSqlType = idSqlType -- the primary field is actually a reference to the entity , fieldReference = ForeignRef entName defaultReferenceTypeCon @@ -538,8 +579,8 @@ mkAutoIdField ps entName idSqlType = defaultReferenceTypeCon :: FieldType defaultReferenceTypeCon = FTTypeCon (Just "Data.Int") "Int64" -keyConName :: Text -> Text -keyConName entName = entName `mappend` "Id" +keyConName :: EntityNameHS -> Text +keyConName entName = unEntityNameHS entName `mappend` "Id" splitExtras :: [Line] @@ -611,25 +652,26 @@ getDbName :: PersistSettings -> Text -> [Text] -> Text getDbName ps n [] = psToDBName ps n getDbName ps n (a:as) = fromMaybe (getDbName ps n as) $ T.stripPrefix "sql=" a -takeConstraint :: PersistSettings - -> Text - -> [FieldDef] - -> [Text] - -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef) -takeConstraint ps tableName defs (n:rest) | isCapitalizedText n = takeConstraint' - where - takeConstraint' - | n == "Unique" = (Nothing, Nothing, Just $ takeUniq ps tableName defs rest, Nothing) - | n == "Foreign" = (Nothing, Nothing, Nothing, Just $ takeForeign ps tableName defs rest) - | n == "Primary" = (Nothing, Just $ takeComposite defs rest, Nothing, Nothing) - | n == "Id" = (Just $ takeId ps tableName (n:rest), Nothing, Nothing, Nothing) - | otherwise = (Nothing, Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint +takeConstraint + :: PersistSettings + -> EntityNameHS + -> [FieldDef] + -> [Text] + -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef) +takeConstraint ps entityName defs (n:rest) | isCapitalizedText n = takeConstraint' + where + takeConstraint' + | n == "Unique" = (Nothing, Nothing, Just $ takeUniq ps (unEntityNameHS entityName) defs rest, Nothing) + | n == "Foreign" = (Nothing, Nothing, Nothing, Just $ takeForeign ps entityName defs rest) + | n == "Primary" = (Nothing, Just $ takeComposite defs rest, Nothing, Nothing) + | n == "Id" = (Just $ takeId ps entityName (n:rest), Nothing, Nothing, Nothing) + | otherwise = (Nothing, Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing, Nothing) -- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName. -- need to re-work takeCols function -takeId :: PersistSettings -> Text -> [Text] -> FieldDef -takeId ps tableName (n:rest) = +takeId :: PersistSettings -> EntityNameHS -> [Text] -> FieldDef +takeId ps entityName (n:rest) = setFieldDef $ fromMaybe (error "takeId: impossible!") $ takeCols (\_ _ -> addDefaultIdType) ps (field:rest) -- `mappend` setIdName) @@ -640,16 +682,16 @@ takeId ps tableName (n:rest) = addDefaultIdType = takeColsEx ps (field : keyCon : rest ) -- `mappend` setIdName) setFieldDef fd = fd { fieldReference = - ForeignRef (EntityNameHS tableName) $ + ForeignRef entityName $ if fieldType fd == FTTypeCon Nothing keyCon then defaultReferenceTypeCon else fieldType fd } - keyCon = keyConName tableName + keyCon = keyConName entityName -- this will be ignored if there is already an existing sql= -- TODO: I think there is a ! ignore syntax that would screw this up -- setIdName = ["sql=" `mappend` psIdName ps] -takeId _ tableName _ = error $ "empty Id field for " `mappend` show tableName +takeId _ (EntityNameHS tableName) _ = error $ "empty Id field for " `mappend` show tableName takeComposite @@ -677,7 +719,7 @@ takeUniq :: PersistSettings -> [FieldDef] -> [Text] -> UniqueDef -takeUniq ps tableName defs (n:rest) +takeUniq ps tableName defs (n : rest) | isCapitalizedText n = UniqueDef (ConstraintNameHS n) @@ -690,11 +732,12 @@ takeUniq ps tableName defs (n:rest) isSqlName a = "sql=" `T.isPrefixOf` a isNonField a = - isAttr a - || isSqlName a + isAttr a || isSqlName a (fields, nonFields) = break isNonField rest + attrs = filter isAttr nonFields + usualDbName = ConstraintNameDB $ psToDBName ps (tableName `T.append` n) sqlName :: Maybe ConstraintNameDB @@ -713,6 +756,7 @@ takeUniq ps tableName defs (n:rest) getDBName (d:ds) t | fieldHaskell d == FieldNameHS t = fieldDB d | otherwise = getDBName ds t + takeUniq _ tableName _ xs = error $ "invalid unique constraint on table[" ++ show tableName @@ -731,14 +775,14 @@ data UnboundForeignDef takeForeign :: PersistSettings - -> Text + -> EntityNameHS -> [FieldDef] -> [Text] -> UnboundForeignDef -takeForeign ps tableName _defs = takeRefTable +takeForeign ps entityName _defs = takeRefTable where errorPrefix :: String - errorPrefix = "invalid foreign key constraint on table[" ++ show tableName ++ "] " + errorPrefix = "invalid foreign key constraint on table[" ++ show (unEntityNameHS entityName) ++ "] " takeRefTable :: [Text] -> UnboundForeignDef takeRefTable [] = @@ -747,8 +791,8 @@ takeForeign ps tableName _defs = takeRefTable go restLine Nothing Nothing where go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef - go (constraintName:rest) onDelete onUpdate - | not (T.null constraintName) && isLower (T.head constraintName) = + go (constraintNameText:rest) onDelete onUpdate + | not (T.null constraintNameText) && isLower (T.head constraintNameText) = UnboundForeignDef { _unboundForeignFields = foreignFields @@ -761,9 +805,9 @@ takeForeign ps tableName _defs = takeRefTable , foreignRefTableDBName = EntityNameDB $ psToDBName ps refTableName , foreignConstraintNameHaskell = - ConstraintNameHS constraintName + constraintName , foreignConstraintNameDBName = - ConstraintNameDB $ psToDBName ps (tableName `T.append` constraintName) + toFKConstraintNameDB ps entityName constraintName , foreignFieldCascade = FieldCascade { fcOnDelete = onDelete , fcOnUpdate = onUpdate @@ -779,6 +823,9 @@ takeForeign ps tableName _defs = takeRefTable } } where + constraintName = + ConstraintNameHS constraintNameText + (fields, attrs) = break ("!" `T.isPrefixOf`) rest (foreignFields, parentFields) = @@ -813,6 +860,10 @@ takeForeign ps tableName _defs = takeRefTable 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 = + ConstraintNameDB $ psToDBName ps (psToFKName ps entityName constraintName) + data CascadePrefix = CascadeUpdate | CascadeDelete parseCascade :: [Text] -> (FieldCascade, [Text]) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 399f054e1..92537520d 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -232,11 +232,8 @@ embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts) -- so start with entityHaskell ent and accumulate embeddedHaskell em breakEntDefCycle :: EntityDef -> EntityDef breakEntDefCycle entDef = - overEntityFields (map (breakCycleField entName)) entDef + overEntityFields (map (breakCycleField (entityHaskell entDef))) entDef where - entName = - entityHaskell entDef - breakCycleField entName f = case fieldReference f of EmbedRef em -> @@ -402,10 +399,10 @@ setEmbedField entName allEntities field = ref = case mEmbedded allEntities (fieldType field) of Left _ -> fromMaybe NoReference $ do - entName <- lookupEmbedEntity allEntities field + refEntName <- lookupEmbedEntity allEntities field -- This can get corrected in mkEntityDefSqlTypeExp let placeholderIdType = FTTypeCon (Just "Data.Int") "Int64" - pure $ ForeignRef entName placeholderIdType + pure $ ForeignRef refEntName placeholderIdType Right em -> if embeddedHaskell em /= entName then EmbedRef em diff --git a/persistent/test/main.hs b/persistent/test/main.hs index 5017da8e7..60d5200b2 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -22,7 +22,18 @@ import Data.Time import Text.Shakespeare.Text import Database.Persist.Class.PersistField +import Database.Persist.Quasi import Database.Persist.Quasi.Internal + ( Line(..) + , LinesWithComments(..) + , Token(..) + , associateLines + , parseFieldType + , parseLine + , preparse + , splitExtras + , takeColsEx + ) import Database.Persist.Types import Database.Persist.EntityDef.Internal @@ -366,6 +377,34 @@ Notification entityComments car `shouldBe` Just "This is a Car\n" entityComments vehicle `shouldBe` Nothing + describe "foreign keys" $ 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 emailSecond +|] + + it "should allow you to modify the FK name via provided function" $ do + let flippedFK = \(EntityNameHS entName) (ConstraintNameHS conName) -> conName <> entName + let [user, notification] = parse (setPsToFKName flippedFK lowerCaseSettings) definitions + let [notificationForeignDef] = entityForeigns notification + foreignConstraintNameDBName notificationForeignDef `shouldBe` ConstraintNameDB "fk_noti_user_notification" + + it "should allow you to enable snake cased foriegn keys via a preset configuration function" $ do + let [user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + let [notificationForeignDef] = entityForeigns notification + foreignConstraintNameDBName notificationForeignDef `shouldBe` ConstraintNameDB "notification_fk_noti_user" + describe "parseFieldType" $ do it "simple types" $ parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar")