diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index db2952ee7..e407910df 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -29,8 +29,6 @@ module Database.Persist.MySQL , copyUnlessEq ) where -import qualified Debug.Trace as Debug - import qualified Blaze.ByteString.Builder.Char8 as BBB import qualified Blaze.ByteString.Builder.ByteString as BBS @@ -349,12 +347,14 @@ migrate' connectInfo allDefs getter val = do $ map (findTypeAndMaxLen name) ucols let foreigns = do - Column { cName=cname, cReference=Just (refTblName, refConstraintName) } <- newcols + Column { cName=cname, cReference=Just cRef } <- newcols + let refConstraintName = crConstraintName cRef + let refTblName = crTableName cRef let refTarget = - addReference allDefs refConstraintName refTblName cname + addReference allDefs refConstraintName refTblName cname (crFieldCascade cRef) guard $ refTblName /= name && cname /= fieldDB (entityId val) - return $ Debug.traceShowId $ AlterColumn name (refTblName, refTarget) + return $ AlterColumn name (refTblName, refTarget) let foreignsAlt = map @@ -371,6 +371,7 @@ migrate' connectInfo allDefs getter val = do (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields + (foreignFieldCascade fdef) ) ) fdefs @@ -386,7 +387,7 @@ migrate' connectInfo allDefs getter val = do ( map (\c -> case cReference c of - Just (_,fk) -> + Just ColumnReference {crConstraintName=fk} -> case find (\f -> fk == foreignConstraintNameDBName f) fdefs of Just _ -> c { cReference = Nothing } Nothing -> c @@ -488,9 +489,19 @@ findMaxLenOfField fieldDef = do readMaybe $ T.unpack maxLenAttr -- | Helper for 'AddReference' that finds out the which primary key columns to reference. -addReference :: [EntityDef] -> DBName -> DBName -> DBName -> AlterColumn -addReference allDefs fkeyname reftable cname = - AddReference reftable fkeyname [cname] referencedColumns +addReference + :: [EntityDef] + -- ^ List of all known 'EntityDef's. + -> DBName + -- ^ Foreign key name + -> DBName + -- ^ Referenced table name + -> DBName + -- ^ Column name + -> FieldCascade + -> AlterColumn +addReference allDefs fkeyname reftable cname fc = + AddReference reftable fkeyname [cname] referencedColumns fc where errorMessage = error @@ -513,6 +524,7 @@ data AlterColumn = Change Column DBName -- Foreign key name [DBName] -- Referencing columns [DBName] -- Referenced columns + FieldCascade | DropReference DBName deriving Show @@ -614,7 +626,7 @@ getColumn -> (Text -> IO Statement) -> DBName -> [PersistValue] - -> Maybe (DBName, DBName) + -> Maybe ColumnReference -> IO (Either Text Column) getColumn connectInfo getter tname [ PersistText cname , PersistText null_ @@ -623,68 +635,97 @@ getColumn connectInfo getter tname [ PersistText cname , colMaxLen , colPrecision , colScale - , default'] refName = + , default'] cRef = fmap (either (Left . pack) Right) $ runExceptT $ do - -- Default value - default_ <- case default' of - PersistNull -> return Nothing - PersistText t -> return (Just t) - PersistByteString bs -> - case T.decodeUtf8' bs of - Left exc -> fail $ "Invalid default column: " ++ - show default' ++ " (error: " ++ - show exc ++ ")" - Right t -> return (Just t) - _ -> fail $ "Invalid default column: " ++ show default' - - ref <- getRef refName - let colMaxLen' = case colMaxLen of - PersistInt64 l -> Just (fromIntegral l) - _ -> Nothing - ci = ColumnInfo - { ciColumnType = colType - , ciMaxLength = colMaxLen' - , ciNumericPrecision = colPrecision - , ciNumericScale = colScale + -- Default value + default_ <- + case default' of + PersistNull -> return Nothing + PersistText t -> return (Just t) + PersistByteString bs -> + case T.decodeUtf8' bs of + Left exc -> + fail + $ "Invalid default column: " + ++ show default' + ++ " (error: " ++ show exc ++ ")" + Right t -> + return (Just t) + _ -> + fail $ "Invalid default column: " ++ show default' + + ref <- getRef (crConstraintName <$> cRef) + let colMaxLen' = + case colMaxLen of + PersistInt64 l -> Just (fromIntegral l) + _ -> Nothing + ci = ColumnInfo + { ciColumnType = colType + , ciMaxLength = colMaxLen' + , ciNumericPrecision = colPrecision + , ciNumericScale = colScale + } + (typ, maxLen) <- parseColumnType dataType ci + -- Okay! + return Column + { cName = DBName $ cname + , cNull = null_ == "YES" + , cSqlType = typ + , cDefault = default_ + , cDefaultConstraintName = Nothing + , cMaxLen = maxLen + , cReference = ref } - (typ, maxLen) <- parseColumnType dataType ci - -- Okay! - return Column - { cName = DBName $ cname - , cNull = null_ == "YES" - , cSqlType = typ - , cDefault = default_ - , cDefaultConstraintName = Nothing - , cMaxLen = maxLen - , cReference = ref - } - where getRef Nothing = return Nothing - getRef (Just (_, refName')) = do - -- Foreign key (if any) - stmt <- lift . getter $ T.concat - [ "SELECT REFERENCED_TABLE_NAME, " - , "CONSTRAINT_NAME, " - , "ORDINAL_POSITION " - , "FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE " - , "WHERE TABLE_SCHEMA = ? " - , "AND TABLE_NAME = ? " - , "AND COLUMN_NAME = ? " - , "AND REFERENCED_TABLE_SCHEMA = ? " - , "AND CONSTRAINT_NAME = ? " - , "ORDER BY CONSTRAINT_NAME, " - , "COLUMN_NAME" + where + getRef Nothing = return Nothing + getRef (Just refName') = do + -- Foreign key (if any) + stmt <- lift . getter $ T.concat + [ "SELECT KCU.REFERENCED_TABLE_NAME, " + , "KCU.CONSTRAINT_NAME, " + , "KCU.ORDINAL_POSITION, " + , "DELETE_RULE, " + , "UPDATE_RULE " + , "FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE AS KCU " + , "INNER JOIN INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS AS RC " + , " ON KCU.CONSTRAINT_NAME = RC.CONSTRAINT_NAME " + , "WHERE KCU.TABLE_SCHEMA = ? " + , "AND KCU.TABLE_NAME = ? " + , "AND KCU.COLUMN_NAME = ? " + , "AND KCU.REFERENCED_TABLE_SCHEMA = ? " + , "AND KCU.CONSTRAINT_NAME = ? " + , "ORDER BY KCU.CONSTRAINT_NAME, " + , "KCU.COLUMN_NAME" ] - let vars = [ PersistText $ pack $ MySQL.connectDatabase connectInfo - , PersistText $ unDBName $ tname - , PersistText cname - , PersistText $ pack $ MySQL.connectDatabase connectInfo - , PersistText $ unDBName refName' ] - cntrs <- liftIO $ with (stmtQuery stmt vars) (\src -> runConduit $ src .| CL.consume) - case cntrs of - [] -> return Nothing - [[PersistText tab, PersistText ref, PersistInt64 pos]] -> - return $ if pos == 1 then Just (DBName tab, DBName ref) else Nothing + let vars = + [ PersistText $ pack $ MySQL.connectDatabase connectInfo + , PersistText $ unDBName $ tname + , PersistText cname + , PersistText $ pack $ MySQL.connectDatabase connectInfo + , PersistText $ unDBName refName' + ] + parseCascadeAction txt = + case txt of + "RESTRICT" -> Just Restrict + "CASCADE" -> Just Cascade + "SET NULL" -> Just SetNull + "SET DEFAULT" -> Just SetDefault + "NO ACTION" -> Nothing + _ -> + error $ "Unexpected value in parseCascadeAction: " <> show txt + + cntrs <- liftIO $ with (stmtQuery stmt vars) (\src -> runConduit $ src .| CL.consume) + pure $ case cntrs of + [] -> + Nothing + [[PersistText tab, PersistText ref, PersistInt64 pos, PersistText onDel, PersistText onUpd]] -> + if pos == 1 + then Just $ ColumnReference (DBName tab) (DBName ref) FieldCascade + { fcOnUpdate = parseCascadeAction onUpd + , fcOnDelete = parseCascadeAction onDel + } + else Nothing xs -> error $ mconcat [ "MySQL.getColumn/getRef: error fetching constraints. Expected a single result for foreign key query for table: " , T.unpack (unDBName tname) @@ -756,7 +797,7 @@ getAlters allDefs edef (c1, u1) (c2, u2) = dropColumn col = map ((,) (cName col)) $ - [DropReference n | Just (_, n) <- [cReference col]] ++ + [DropReference (crConstraintName cr) | Just cr <- [cReference col]] ++ [Drop] getAltersU [] old = map (DropUniqueConstraint . fst) old @@ -795,25 +836,27 @@ findAlters edef allDefs col@(Column name isNull type_ def _defConstraintName max [] -> case ref of Nothing -> ([(name, Add' col)],[]) - Just (tname, cname) -> - let cnstr = [addReference allDefs cname tname name] + Just cr -> + let tname = crTableName cr + cname = crConstraintName cr + cnstr = [addReference allDefs cname tname name (crFieldCascade cr)] in (map ((,) tname) (Add' col : cnstr), cols) Column _ isNull' type_' def' _defConstraintName' maxLen' ref' : _ -> let -- Foreign key refDrop = case (ref == ref', ref') of - (False, Just (_, cname)) -> + (False, Just ColumnReference {crConstraintName=cname}) -> [(name, DropReference cname)] _ -> [] refAdd = case (ref == ref', ref) of - (False, Just (tname, cname)) + (False, Just ColumnReference {crTableName=tname, crConstraintName=cname, crFieldCascade = cfc }) | tname /= entityDB edef , cname /= fieldDB (entityId edef) -> - [(tname, addReference allDefs cname tname name)] + [(tname, addReference allDefs cname tname name cfc)] _ -> [] -- Type and nullability modType | showSqlType type_ maxLen False `ciEquals` showSqlType type_' maxLen' False && isNull == isNull' = [] @@ -821,9 +864,10 @@ findAlters edef allDefs col@(Column name isNull type_ def _defConstraintName max -- Default value -- Avoid DEFAULT NULL, since it is always unnecessary, and is an error for text/blob fields modDef | def == def' = [] - | otherwise = case def of - Nothing -> [(name, NoDefault)] - Just s -> if T.toUpper s == "NULL" then [] + | otherwise = + case def of + Nothing -> [(name, NoDefault)] + Just s -> if T.toUpper s == "NULL" then [] else [(name, Default $ T.unpack s)] in ( refDrop ++ modType ++ modDef ++ refAdd , filter ((name /=) . cName) cols @@ -851,7 +895,8 @@ showColumn (Column n nu t def _defConstraintName maxLen ref) = concat else " DEFAULT " ++ T.unpack s , case ref of Nothing -> "" - Just (s, _) -> " REFERENCES " ++ escapeDBName s + Just cRef -> " REFERENCES " ++ escapeDBName (crTableName cRef) + <> " " <> T.unpack (renderFieldCascade (crFieldCascade cRef)) ] @@ -965,7 +1010,7 @@ showAlter table (n, Update' s) = , escapeDBName n , " IS NULL" ] -showAlter table (_, AddReference reftable fkeyname t2 id2) = concat +showAlter table (_, AddReference reftable fkeyname t2 id2 fc) = concat [ "ALTER TABLE " , escapeDBName table , " ADD CONSTRAINT " @@ -976,7 +1021,8 @@ showAlter table (_, AddReference reftable fkeyname t2 id2) = concat , escapeDBName reftable , "(" , intercalate "," $ map escapeDBName id2 - , ")" + , ") " + , T.unpack $ renderFieldCascade fc ] showAlter table (_, DropReference cname) = concat [ "ALTER TABLE " @@ -1081,11 +1127,26 @@ mockMigrate _connectInfo allDefs _getter val = do AddUniqueConstraint uname $ map (findTypeAndMaxLen name) ucols ] let foreigns = do - Column { cName=cname, cReference=Just (refTblName, refConstraintName) } <- newcols - return $ AlterColumn name (refTblName, addReference allDefs refConstraintName refTblName cname) - - let foreignsAlt = map (\fdef -> let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) - in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignRefTableDBName fdef) (foreignConstraintNameDBName fdef) childfields parentfields)) fdefs + Column { cName=cname, cReference= Just ColumnReference{crTableName = refTable, crConstraintName = refConstr, crFieldCascade = cfc }} <- newcols + return $ AlterColumn name (refTable, addReference allDefs refConstr refTable cname cfc) + + let foreignsAlt = + map + (\fdef -> + let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) + in + AlterColumn + name + ( foreignRefTableDBName fdef + , AddReference + (foreignRefTableDBName fdef) + (foreignConstraintNameDBName fdef) + childfields + parentfields + (foreignFieldCascade fdef) + ) + ) + fdefs return $ Right $ map showAlterDb $ (addTable newcols val): uniques ++ foreigns ++ foreignsAlt diff --git a/persistent-mysql/test/main.hs b/persistent-mysql/test/main.hs index 751abb77f..fce4ebde7 100644 --- a/persistent-mysql/test/main.hs +++ b/persistent-mysql/test/main.hs @@ -52,6 +52,7 @@ import qualified UniqueTest import qualified UpsertTest import qualified CustomConstraintTest import qualified LongIdentifierTest +import qualified ForeignKey type Tuple a b = (a, b) @@ -102,7 +103,7 @@ instance Arbitrary (DataTypeTableGeneric backend) where setup :: (HasCallStack, MonadUnliftIO m) => Migration -> ReaderT SqlBackend m () setup migration = do printMigration migration - _ <- runMigrationSilent migration + _ <- runMigrationUnsafe migration pure () main :: IO () @@ -128,8 +129,10 @@ main = do , MigrationColumnLengthTest.migration , TransactionLevelTest.migration -- , LongIdentifierTest.migration + , ForeignKey.compositeMigrate ] PersistentTest.cleanDB + ForeignKey.cleanDB hspec $ do xdescribe "This is pending on MySQL because you can't have DEFAULT CURRENT_DATE" $ do @@ -178,6 +181,7 @@ main = do UpsertTest.Don'tUpdateNull UpsertTest.UpsertPreserveOldKey + ForeignKey.specsWith db MpsNoPrefixTest.specsWith db MpsCustomPrefixTest.specsWith db EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration)) diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index 7d9b14a23..7e7633963 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -2,6 +2,10 @@ ## (Unreleased) 2.11.0.0 +* Foreign Key improvements [#1121] https://github.com/yesodweb/persistent/pull/1121 + * It is now supported to refer to a table with an auto generated Primary Kay + * It is now supported to refer to non-primary fields, using the keyword `References` + * Implement interval support. [#1053](https://github.com/yesodweb/persistent/pull/1053) * [#1060](https://github.com/yesodweb/persistent/pull/1060) * The QuasiQuoter now supports `OnDelete` and `OnUpdate` cascade options. diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 07254947f..05af39546 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NamedFieldPuns #-} @@ -39,9 +40,11 @@ import qualified Database.PostgreSQL.Simple.Types as PG import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS import Database.PostgreSQL.Simple.Ok (Ok (..)) +import Data.Foldable import Control.Arrow import Control.Exception (Exception, throw, throwIO) -import Control.Monad (forM, guard) +import Control.Monad +import Control.Monad.Except import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO) import Control.Monad.Logger (MonadLogger, runNoLoggingT) import Control.Monad.Trans.Reader (runReaderT) @@ -816,23 +819,25 @@ getColumns getter def cols = do , "AND table_name=? " ] --- DOMAINS Postgres supports the concept of domains, which are data types with optional constraints. --- An app might make an "email" domain over the varchar type, with a CHECK that the emails are valid --- In this case the generated SQL should use the domain name: ALTER TABLE users ALTER COLUMN foo TYPE email --- This code exists to use the domain name (email), instead of the underlying type (varchar). --- This is tested in EquivalentTypeTest.hs +-- DOMAINS Postgres supports the concept of domains, which are data types +-- with optional constraints. An app might make an "email" domain over the +-- varchar type, with a CHECK that the emails are valid In this case the +-- generated SQL should use the domain name: ALTER TABLE users ALTER COLUMN +-- foo TYPE email This code exists to use the domain name (email), instead +-- of the underlying type (varchar). This is tested in +-- EquivalentTypeTest.hs stmt <- getter sqlv let vals = [ PersistText $ unDBName $ entityDB def ] - cs <- with (stmtQuery stmt vals) (\src -> runConduit $ src .| helper) + columns <- with (stmtQuery stmt vals) (\src -> runConduit $ src .| processColumns .| CL.consume) let sqlc = T.concat [ "SELECT " , "c.constraint_name, " , "c.column_name " - , "FROM information_schema.key_column_usage c, " - , "information_schema.table_constraints k " + , "FROM information_schema.key_column_usage AS c, " + , "information_schema.table_constraints AS k " , "WHERE c.table_catalog=current_database() " , "AND c.table_catalog=k.table_catalog " , "AND c.table_schema=current_schema() " @@ -847,34 +852,34 @@ getColumns getter def cols = do stmt' <- getter sqlc us <- with (stmtQuery stmt' vals) (\src -> runConduit $ src .| helperU) - return $ cs ++ us + return $ columns ++ us where - refMap = Map.fromList $ foldl' ref [] cols - where ref rs c = case cReference c of - Nothing -> rs - (Just r) -> (unDBName $ cName c, r) : rs - getAll front = do - x <- CL.head - case x of - Nothing -> return $ front [] - Just [PersistText con, PersistText col] -> getAll (front . (:) (con, col)) - Just [PersistByteString con, PersistByteString col] -> getAll (front . (:) (T.decodeUtf8 con, T.decodeUtf8 col)) - Just o -> error $ "unexpected datatype returned for postgres o="++show o + refMap = + fmap (\cr -> (crTableName cr, crConstraintName cr)) + $ Map.fromList + $ foldl' ref [] cols + where + ref rs c = + maybe rs (\r -> (unDBName $ cName c, r) : rs) (cReference c) + getAll = + CL.mapM $ \x -> + pure $ case x of + [PersistText con, PersistText col] -> + (con, col) + [PersistByteString con, PersistByteString col] -> + (T.decodeUtf8 con, T.decodeUtf8 col) + o -> + error $ "unexpected datatype returned for postgres o="++show o helperU = do - rows <- getAll id + rows <- getAll .| CL.consume return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd))) $ groupBy ((==) `on` fst) rows - helper = do - x <- CL.head - case x of - Nothing -> return [] - Just x'@((PersistText cname):_) -> do - col <- liftIO $ getColumn getter (entityDB def) x' (Map.lookup cname refMap) - let col' = case col of - Left e -> Left e - Right c -> Right $ Left c - cols <- helper - return $ col' : cols + processColumns = + CL.mapM $ \x'@((PersistText cname) : _) -> do + col <- liftIO $ getColumn getter (entityDB def) x' (Map.lookup cname refMap) + pure $ case col of + Left e -> Left e + Right c -> Right $ Left c -- | Check if a column name is listed as the "safe to remove" in the entity -- list. @@ -919,32 +924,60 @@ getAlters defs def (c1, u1) (c2, u2) = -- Don't drop constraints which were manually added. isManual (DBName x) = "__manual_" `T.isPrefixOf` x -getColumn :: (Text -> IO Statement) - -> DBName -> [PersistValue] - -> Maybe (DBName, DBName) - -> IO (Either Text Column) -getColumn getter tableName' [PersistText columnName, PersistText isNullable, PersistText typeName, defaultValue, numericPrecision, numericScale, maxlen] refName = - case d' of - Left s -> return $ Left s - Right d'' -> - let typeStr = case maxlen of - PersistInt64 n -> T.concat [typeName, "(", T.pack (show n), ")"] - _ -> typeName - in case getType typeStr of - Left s -> return $ Left s - Right t -> do - let cname = DBName columnName - ref <- getRef cname refName - return $ Right Column - { cName = cname - , cNull = isNullable == "YES" - , cSqlType = t - , cDefault = fmap stripSuffixes d'' - , cDefaultConstraintName = Nothing - , cMaxLen = Nothing - , cReference = ref - } +getColumn + :: (Text -> IO Statement) + -> DBName + -> [PersistValue] + -> Maybe (DBName, DBName) + -> IO (Either Text Column) +getColumn getter tableName' [PersistText columnName, PersistText isNullable, PersistText typeName, defaultValue, numericPrecision, numericScale, maxlen] refName = runExceptT $ do + d'' <- + case defaultValue of + PersistNull -> + pure Nothing + PersistText t -> + pure $ Just t + _ -> + throwError $ T.pack $ "Invalid default column: " ++ show defaultValue + + let typeStr = + case maxlen of + PersistInt64 n -> + T.concat [typeName, "(", T.pack (show n), ")"] + _ -> + typeName + t <- getType typeStr + let cname = DBName columnName + ref <- lift $ fmap join $ traverse (getRef cname) refName + return Column + { cName = cname + , cNull = isNullable == "YES" + , cSqlType = t + , cDefault = fmap stripSuffixes d'' + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = fmap (\(a,b,c,d) -> ColumnReference a b (mkCascade c d)) ref + } where + mkCascade updText delText = + FieldCascade + { fcOnUpdate = parseCascade updText + , fcOnDelete = parseCascade delText + } + parseCascade txt = + case txt of + "NO ACTION" -> + Nothing + "CASCADE" -> + Just Cascade + "SET NULL" -> + Just SetNull + "SET DEFAULT" -> + Just SetDefault + "RESTRICT" -> + Just Restrict + _ -> + error $ "Unexpected value in parseCascade: " <> show txt stripSuffixes t = loop' [ "::character varying" @@ -956,80 +989,90 @@ getColumn getter tableName' [PersistText columnName, PersistText isNullable, Per case T.stripSuffix p t of Nothing -> loop' ps Just t' -> t' - getRef _ Nothing = return Nothing - getRef cname (Just (_, refName')) = do - let sql = T.concat ["SELECT DISTINCT " - ,"ccu.table_name, " - ,"tc.constraint_name " - ,"FROM information_schema.constraint_column_usage ccu, " - ,"information_schema.key_column_usage kcu, " - ,"information_schema.table_constraints tc " - ,"WHERE tc.constraint_type='FOREIGN KEY' " - ,"AND kcu.constraint_name=tc.constraint_name " - ,"AND ccu.constraint_name=kcu.constraint_name " - ,"AND kcu.ordinal_position=1 " - ,"AND kcu.table_name=? " - ,"AND kcu.column_name=? " - ,"AND tc.constraint_name=?"] + + getRef cname (_, refName') = do + let sql = T.concat + [ "SELECT DISTINCT " + , "ccu.table_name, " + , "tc.constraint_name, " + , "rc.update_rule, " + , "rc.delete_rule " + , "FROM information_schema.constraint_column_usage ccu " + , "INNER JOIN information_schema.key_column_usage kcu " + , " ON ccu.constraint_name = kcu.constraint_name " + , "INNER JOIN information_schema.table_constraints tc " + , " ON tc.constraint_name = kcu.constraint_name " + , "LEFT JOIN information_schema.referential_constraints AS rc" + , " ON rc.constraint_name = ccu.constraint_name " + , "WHERE tc.constraint_type='FOREIGN KEY' " + , "AND kcu.ordinal_position=1 " + , "AND kcu.table_name=? " + , "AND kcu.column_name=? " + , "AND tc.constraint_name=?" + ] stmt <- getter sql - cntrs <- with (stmtQuery stmt [PersistText $ unDBName tableName' - ,PersistText $ unDBName cname - ,PersistText $ unDBName refName']) - (\src -> runConduit $ src .| CL.consume) + cntrs <- + with + (stmtQuery stmt + [ PersistText $ unDBName tableName' + , PersistText $ unDBName cname + , PersistText $ unDBName refName' + ] + ) + (\src -> runConduit $ src .| CL.consume) case cntrs of - [] -> return Nothing - [[PersistText table, PersistText constraint]] -> - return $ Just (DBName table, DBName constraint) + [] -> + return Nothing + [[PersistText table, PersistText constraint, PersistText updRule, PersistText delRule]] -> + return $ Just (DBName table, DBName constraint, updRule, delRule) xs -> - error $ mconcat - [ "Postgresql.getColumn: error fetching constraints. Expected a single result for foreign key query for table: " - , T.unpack (unDBName tableName') - , " and column: " - , T.unpack (unDBName cname) - , " but got: " - , show xs - ] - d' = case defaultValue of - PersistNull -> Right Nothing - PersistText t -> Right $ Just t - _ -> Left $ T.pack $ "Invalid default column: " ++ show defaultValue - getType "int4" = Right SqlInt32 - getType "int8" = Right SqlInt64 - getType "varchar" = Right SqlString - getType "text" = Right SqlString - getType "date" = Right SqlDay - getType "bool" = Right SqlBool - getType "timestamptz" = Right SqlDayTime - getType "float4" = Right SqlReal - getType "float8" = Right SqlReal - getType "bytea" = Right SqlBlob - getType "time" = Right SqlTime + error $ mconcat + [ "Postgresql.getColumn: error fetching constraints. Expected a single result for foreign key query for table: " + , T.unpack (unDBName tableName') + , " and column: " + , T.unpack (unDBName cname) + , " but got: " + , show xs + ] + + getType "int4" = pure SqlInt32 + getType "int8" = pure SqlInt64 + getType "varchar" = pure SqlString + getType "text" = pure SqlString + getType "date" = pure SqlDay + getType "bool" = pure SqlBool + getType "timestamptz" = pure SqlDayTime + getType "float4" = pure SqlReal + getType "float8" = pure SqlReal + getType "bytea" = pure SqlBlob + getType "time" = pure SqlTime getType "numeric" = getNumeric numericPrecision numericScale - getType a = Right $ SqlOther a - - getNumeric (PersistInt64 a) (PersistInt64 b) = Right $ SqlNumeric (fromIntegral a) (fromIntegral b) - getNumeric PersistNull PersistNull = Left $ T.concat - [ "No precision and scale were specified for the column: " - , columnName - , " in table: " - , unDBName tableName' - , ". Postgres defaults to a maximum scale of 147,455 and precision of 16383," - , " which is probably not what you intended." - , " Specify the values as numeric(total_digits, digits_after_decimal_place)." - ] - getNumeric a b = Left $ T.concat - [ "Can not get numeric field precision for the column: " - , columnName - , " in table: " - , unDBName tableName' - , ". Expected an integer for both precision and scale, " - , "got: " - , T.pack $ show a - , " and " - , T.pack $ show b - , ", respectively." - , " Specify the values as numeric(total_digits, digits_after_decimal_place)." - ] + getType a = pure $ SqlOther a + + getNumeric (PersistInt64 a) (PersistInt64 b) = + pure $ SqlNumeric (fromIntegral a) (fromIntegral b) + getNumeric PersistNull PersistNull = throwError $ T.concat + [ "No precision and scale were specified for the column: " + , columnName + , " in table: " + , unDBName tableName' + , ". Postgres defaults to a maximum scale of 147,455 and precision of 16383," + , " which is probably not what you intended." + , " Specify the values as numeric(total_digits, digits_after_decimal_place)." + ] + getNumeric a b = throwError $ T.concat + [ "Can not get numeric field precision for the column: " + , columnName + , " in table: " + , unDBName tableName' + , ". Expected an integer for both precision and scale, " + , "got: " + , T.pack $ show a + , " and " + , T.pack $ show b + , ", respectively." + , " Specify the values as numeric(total_digits, digits_after_decimal_place)." + ] getColumn _ _ columnName _ = return $ Left $ T.pack $ "Invalid result from information_schema: " ++ show columnName @@ -1053,27 +1096,30 @@ findAlters defs edef col@(Column name isNull sqltype def _defConstraintName _max ([(name, Add' col)], cols) Just (Column _oldName isNull' sqltype' def' _defConstraintName' _maxLen' ref') -> let refDrop Nothing = [] - refDrop (Just (_, cname)) = [(name, DropReference cname)] + refDrop (Just ColumnReference {crConstraintName=cname}) = + [(name, DropReference cname)] + refAdd Nothing = [] - refAdd (Just (tname, a)) = - case find ((==tname) . entityDB) defs of + refAdd (Just colRef) = + case find ((== crTableName colRef) . entityDB) defs of Just refdef - | entityDB edef /= tname + | entityDB edef /= crTableName colRef && _oldName /= fieldDB (entityId edef) -> - [ ( tname + [ ( crTableName colRef , AddReference - a + (crConstraintName colRef) [name] (Util.dbIdColumnsEsc escape refdef) - noCascade + (crFieldCascade colRef) ) ] Just _ -> [] Nothing -> - error $ "could not find the entityDef for reftable[" ++ show tname ++ "]" + error $ "could not find the entityDef for reftable[" + ++ show (crTableName colRef) ++ "]" modRef = - if fmap snd ref == fmap snd ref' + if fmap crConstraintName ref == fmap crConstraintName ref' then [] else refDrop ref' ++ refAdd ref modNull = case (isNull, isNull') of @@ -1102,25 +1148,28 @@ findAlters defs edef col@(Column name isNull sqltype def _defConstraintName _max if def == def' || isJust (T.stripPrefix "nextval" =<< def') then [] - else case def of + else + case def of Nothing -> [(name, NoDefault)] Just s -> [(name, Default s)] - in (modRef ++ modDef ++ modNull ++ modType, - filter (\c -> cName c /= name) cols) + in + ( modRef ++ modDef ++ modNull ++ modType + , filter (\c -> cName c /= name) cols + ) -- | Get the references to be added to a table for the given column. getAddReference :: [EntityDef] -> EntityDef -> DBName - -> (DBName, DBName) + -> ColumnReference -> Maybe AlterDB -getAddReference allDefs entity cname (s, constraintName) = do +getAddReference allDefs entity cname cr@ColumnReference {crTableName = s, crConstraintName=constraintName} = do guard $ table /= s && cname /= fieldDB (entityId entity) pure $ AlterColumn table ( s - , AddReference constraintName [cname] id_ noCascade + , AddReference constraintName [cname] id_ (crFieldCascade cr) ) where table = entityDB entity @@ -1131,7 +1180,6 @@ getAddReference allDefs entity cname (s, constraintName) = do entDef <- find ((== s) . entityDB) allDefs return $ Util.dbIdColumnsEsc escape entDef - showColumn :: Column -> Text showColumn (Column n nu sqlType' def _defConstraintName _maxLen _ref) = T.concat [ escape n diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index afa861742..a2875798f 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -24,6 +24,7 @@ library , conduit >= 1.2.12 , containers >= 0.5 , monad-logger >= 0.3.25 + , mtl , postgresql-simple >= 0.6.1 && < 0.7 , postgresql-libpq >= 0.9.4.2 && < 0.10 , resourcet >= 1.1.9 diff --git a/persistent-postgresql/test/main.hs b/persistent-postgresql/test/main.hs index 4db6a5624..cde25208d 100644 --- a/persistent-postgresql/test/main.hs +++ b/persistent-postgresql/test/main.hs @@ -129,6 +129,7 @@ main = do , PgIntervalTest.pgIntervalMigrate ] PersistentTest.cleanDB + ForeignKey.cleanDB hspec $ do RenameTest.specsWith runConnAssert diff --git a/persistent-sqlite/ChangeLog.md b/persistent-sqlite/ChangeLog.md index 21f94083a..a9aa02bbe 100644 --- a/persistent-sqlite/ChangeLog.md +++ b/persistent-sqlite/ChangeLog.md @@ -2,6 +2,11 @@ ## (Unreleased) 2.11.0.0 +* Foreign Key improvements [#1121] (https://github.com/yesodweb/persistent/pull/1121) + * It is now supported to refer to a table with an auto generated Primary Kay + * It is now supported to refer to non-primary fields, using the keyword `References` + * It is now supported to have cascade options for simple/single-field Foreign Keys + * [#1060](https://github.com/yesodweb/persistent/pull/1060) * The QuasiQuoter now supports `OnDelete` and `OnUpdate` cascade options. * [#1131](https://github.com/yesodweb/persistent/pull/1131) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index 624b507e2..92b27186e 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -45,8 +45,6 @@ module Database.Persist.Sqlite , withRawSqlitePoolInfo_ ) where -import qualified Debug.Trace as Debug - import Control.Concurrent (threadDelay) import qualified Control.Exception as E import Control.Monad (forM_) @@ -581,8 +579,14 @@ sqlColumn noRef (Column name isNull typ def _cn _maxLen ref) = T.concat , mayDefault def , case ref of Nothing -> "" - Just (table, _) -> if noRef then "" else " REFERENCES " <> escape table + Just ColumnReference {crTableName=table, crFieldCascade=cascadeOpts} -> + if noRef then "" else " REFERENCES " <> escape table + <> onDelete cascadeOpts <> onUpdate cascadeOpts ] + where + + onDelete opts = maybe "" (T.append " ON DELETE " . renderCascadeAction) (fcOnDelete opts) + onUpdate opts = maybe "" (T.append " ON UPDATE " . renderCascadeAction) (fcOnUpdate opts) sqlForeign :: ForeignDef -> Text sqlForeign fdef = T.concat $ diff --git a/persistent-sqlite/test/main.hs b/persistent-sqlite/test/main.hs index 97dc5bcd4..261ba7709 100644 --- a/persistent-sqlite/test/main.hs +++ b/persistent-sqlite/test/main.hs @@ -135,7 +135,8 @@ main = do runConn $ do mapM_ setup - [ PersistentTest.testMigrate + [ ForeignKey.compositeMigrate + , PersistentTest.testMigrate , PersistentTest.noPrefixMigrate , PersistentTest.customPrefixMigrate , EmbedTest.embedMigrate @@ -145,7 +146,6 @@ main = do , MaxLenTest.maxlenMigrate , Recursive.recursiveMigrate , CompositeTest.compositeMigrate - , ForeignKey.compositeMigrate , MigrationTest.migrationMigrate , PersistUniqueTest.migration , RenameTest.migration @@ -157,6 +157,7 @@ main = do , LongIdentifierTest.migration ] PersistentTest.cleanDB + ForeignKey.cleanDB hspec $ do RenameTest.specsWith db diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs index f112c9bed..5dc5b39bb 100644 --- a/persistent-template/Database/Persist/TH.hs +++ b/persistent-template/Database/Persist/TH.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -12,6 +13,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveLift #-} + {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} -- | This module provides the tools for defining your database schema and using @@ -53,6 +55,7 @@ module Database.Persist.TH , fieldError , AtLeastOneUniqueKey(..) , OnlyOneUniqueKey(..) + , pkNewtype ) where -- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code @@ -60,6 +63,7 @@ module Database.Persist.TH import Prelude hiding ((++), take, concat, splitAt, exp) +import Control.Applicative import Data.Either import Control.Monad (forM, mzero, filterM, guard, unless) import Data.Aeson @@ -290,7 +294,7 @@ data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp instance Lift FieldSqlTypeExp where lift (FieldSqlTypeExp FieldDef{..} sqlTypeExp) = - [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldComments|] + [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldCascade fieldComments|] #if MIN_VERSION_template_haskell(2,16,0) liftTyped = unsafeTExpCoerce . lift #endif @@ -323,14 +327,29 @@ constructEntityMap :: [EntityDef] -> EntityMap constructEntityMap = M.fromList . fmap (\ent -> (entityHaskell ent, ent)) -data FTTypeConDescr = FTKeyCon deriving Show +data FTTypeConDescr = FTKeyCon + deriving Show -mEmbedded :: EmbedEntityMap -> FieldType -> Either (Maybe FTTypeConDescr) EmbedEntityDef -mEmbedded _ (FTTypeCon Just{} _) = Left Nothing -mEmbedded ents (FTTypeCon Nothing n) = - let name = HaskellName n - in maybe (Left Nothing) Right $ M.lookup name ents -mEmbedded ents (FTList x) = mEmbedded ents x +-- | Recurses through the 'FieldType'. Returns a 'Right' with the +-- 'EmbedEntityDef' if the 'FieldType' corresponds to an unqualified use of +-- a name and that name is present in the 'EmbedEntityMap' provided as +-- a first argument. +-- +-- If the 'FieldType' represents a @Key something@, this returns a @'Left +-- ('Just' 'FTKeyCon')@. +-- +-- If the 'FieldType' has a module qualified value, then it returns @'Left' +-- 'Nothing'@. +mEmbedded + :: EmbedEntityMap + -> FieldType + -> Either (Maybe FTTypeConDescr) EmbedEntityDef +mEmbedded _ (FTTypeCon Just{} _) = + Left Nothing +mEmbedded ents (FTTypeCon Nothing (HaskellName -> name)) = + maybe (Left Nothing) Right $ M.lookup name ents +mEmbedded ents (FTList x) = + mEmbedded ents x mEmbedded ents (FTApp x y) = -- Key converts an Record to a RecordId -- special casing this is obviously a hack @@ -347,13 +366,17 @@ setEmbedField entName allEntities field = field case mEmbedded allEntities (fieldType field) of Left _ -> case stripId $ fieldType field of - Nothing -> NoReference + Nothing -> + NoReference Just name -> case M.lookup (HaskellName name) allEntities of - Nothing -> NoReference - Just _ -> ForeignRef (HaskellName name) - -- This can get corrected in mkEntityDefSqlTypeExp - (FTTypeCon (Just "Data.Int") "Int64") + Nothing -> + NoReference + Just _ -> + ForeignRef + (HaskellName name) + -- This can get corrected in mkEntityDefSqlTypeExp + (FTTypeCon (Just "Data.Int") "Int64") Right em -> if embeddedHaskell em /= entName then EmbedRef em @@ -362,7 +385,8 @@ setEmbedField entName allEntities field = field else case fieldType field of FTList _ -> SelfReference _ -> error $ unpack $ unHaskellName entName <> ": a self reference must be a Maybe" - existing -> existing + existing -> + existing } mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp @@ -379,32 +403,39 @@ mkEntityDefSqlTypeExp emEntities entityMap ent = -- We just use SqlString, as the data will be serialized to JSON. defaultSqlTypeExp field = case mEmbedded emEntities ftype of - Right _ -> SqlType' SqlString - Left (Just FTKeyCon) -> SqlType' SqlString - Left Nothing -> case fieldReference field of - ForeignRef refName ft -> case M.lookup refName entityMap of - Nothing -> SqlTypeExp ft - -- A ForeignRef is blindly set to an Int64 in setEmbedField - -- correct that now - Just ent' -> case entityPrimary ent' of - Nothing -> SqlTypeExp ft - Just pdef -> case compositeFields pdef of - [] -> error "mkEntityDefSqlTypeExp: no composite fields" - [x] -> SqlTypeExp $ fieldType x - _ -> SqlType' $ SqlOther "Composite Reference" - CompositeRef _ -> SqlType' $ SqlOther "Composite Reference" - _ -> - case ftype of - -- In the case of lists, we always serialize to a string - -- value (via JSON). - -- - -- Normally, this would be determined automatically by - -- SqlTypeExp. However, there's one corner case: if there's - -- a list of entity IDs, the datatype for the ID has not - -- yet been created, so the compiler will fail. This extra - -- clause works around this limitation. - FTList _ -> SqlType' SqlString - _ -> SqlTypeExp ftype + Right _ -> + SqlType' SqlString + Left (Just FTKeyCon) -> + SqlType' SqlString + Left Nothing -> + case fieldReference field of + ForeignRef refName ft -> + case M.lookup refName entityMap of + Nothing -> SqlTypeExp ft + -- A ForeignRef is blindly set to an Int64 in setEmbedField + -- correct that now + Just ent' -> + case entityPrimary ent' of + Nothing -> SqlTypeExp ft + Just pdef -> + case compositeFields pdef of + [] -> error "mkEntityDefSqlTypeExp: no composite fields" + [x] -> SqlTypeExp $ fieldType x + _ -> SqlType' $ SqlOther "Composite Reference" + CompositeRef _ -> + SqlType' $ SqlOther "Composite Reference" + _ -> + case ftype of + -- In the case of lists, we always serialize to a string + -- value (via JSON). + -- + -- Normally, this would be determined automatically by + -- SqlTypeExp. However, there's one corner case: if there's + -- a list of entity IDs, the datatype for the ID has not + -- yet been created, so the compiler will fail. This extra + -- clause works around this limitation. + FTList _ -> SqlType' SqlString + _ -> SqlTypeExp ftype where ftype = fieldType field @@ -984,6 +1015,9 @@ keyString = unpack . keyText keyText :: EntityDef -> Text keyText t = unHaskellName (entityHaskell t) ++ "Key" +-- | Returns 'True' if the key definition has more than 1 field. +-- +-- @since 2.11.0.0 pkNewtype :: MkPersistSettings -> EntityDef -> Bool pkNewtype mps t = length (keyFields mps t) < 2 @@ -1104,11 +1138,11 @@ mkEntity entityMap mps t = do fpv <- mkFromPersistValues mps t utv <- mkUniqueToValues $ entityUniques t puk <- mkUniqueKeys t + let primaryField = entityId t + fields <- mapM (mkField mps t) $ primaryField : entityFields t fkc <- mapM (mkForeignKeysComposite mps t) $ entityForeigns t - let primaryField = entityId t - fields <- mapM (mkField mps t) $ primaryField : entityFields t toFieldNames <- mkToFieldNames $ entityUniques t (keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps t @@ -1335,7 +1369,8 @@ mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do ] mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec] -mkForeignKeysComposite mps t ForeignDef {..} = do +mkForeignKeysComposite mps t ForeignDef {..} = + if not foreignToPrimary then return [] else do let fieldName f = mkName $ unpack $ recName mps (entityHaskell t) f let fname = fieldName foreignConstraintNameHaskell let reftableString = unpack $ unHaskellName foreignRefTableHaskell @@ -1343,8 +1378,12 @@ mkForeignKeysComposite mps t ForeignDef {..} = do let tablename = mkName $ unpack $ entityText t recordName <- newName "record" - let fldsE = map (\((foreignName, _),_) -> VarE (fieldName foreignName) - `AppE` VarE recordName) foreignFields + let mkFldE ((foreignName, _),ff) = case ff of + (HaskellName {unHaskellName = "Id"}, DBName {unDBName = "id"}) + -> AppE (VarE $ mkName "toBackendKey") $ + VarE (fieldName foreignName) `AppE` VarE recordName + _ -> VarE (fieldName foreignName) `AppE` VarE recordName + let fldsE = map mkFldE foreignFields let mkKeyE = foldl' AppE (maybeExp foreignNullable $ ConE reftableKeyName) fldsE let fn = FunD fname [normalClause [VarP recordName] mkKeyE] @@ -1689,18 +1728,21 @@ liftAndFixKeys entityMap EntityDef{..} = |] liftAndFixKey :: EntityMap -> FieldDef -> Q Exp -liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef mcomments) = - [|FieldDef a b c $(sqlTyp') e f fieldRef' mcomments|] +liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef fc mcomments) = + [|FieldDef a b c $(sqlTyp') e f (fieldRef') fc mcomments|] where - (fieldRef', sqlTyp') = fromMaybe (fieldRef, lift sqlTyp) $ - case fieldRef of - ForeignRef refName _ft -> case M.lookup refName entityMap of - Nothing -> Nothing - Just ent -> - case fieldReference $ entityId ent of - fr@(ForeignRef _Name ft) -> Just (fr, lift $ SqlTypeExp ft) - _ -> Nothing - _ -> Nothing + (fieldRef', sqlTyp') = + fromMaybe (fieldRef, lift sqlTyp) $ + case fieldRef of + ForeignRef refName _ft -> do + ent <- M.lookup refName entityMap + case fieldReference $ entityId ent of + fr@(ForeignRef targetName ft) -> + Just (fr, lift $ SqlTypeExp ft) + _ -> + Nothing + _ -> + Nothing deriving instance Lift EntityDef diff --git a/persistent-template/test/main.hs b/persistent-template/test/main.hs index 84a5aae1c..95469713c 100644 --- a/persistent-template/test/main.hs +++ b/persistent-template/test/main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeApplications, DeriveGeneric #-} +{-# LANGUAGE TypeApplications, DeriveGeneric, RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -23,6 +23,7 @@ module Main module Main ) where +import Data.Int import Data.Proxy import Control.Applicative (Const (..)) import Data.Aeson @@ -34,6 +35,8 @@ import Test.Hspec.QuickCheck import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen (Gen) import GHC.Generics (Generic) +import qualified Data.List as List +import Data.Coerce import Database.Persist import Database.Persist.Sql @@ -45,12 +48,18 @@ import qualified SharedPrimaryKeyTest import qualified SharedPrimaryKeyTestImported share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [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 @@ -79,6 +88,21 @@ HasIdDef HasDefaultId name String +HasCustomSqlId + Id String sql=my_id + name String + +SharedPrimaryKey + Id (Key HasDefaultId) + name String + +SharedPrimaryKeyWithCascade + Id (Key HasDefaultId) OnDeleteCascade + name String + +SharedPrimaryKeyWithCascadeAndCustomName + Id (Key HasDefaultId) OnDeleteCascade sql=my_id + name String |] share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase| @@ -110,6 +134,154 @@ main :: IO () main = hspec $ do SharedPrimaryKeyTest.spec SharedPrimaryKeyTestImported.spec + describe "HasDefaultId" $ do + let FieldDef{..} = + entityId (entityDef (Proxy @HasDefaultId)) + it "should have usual db name" $ do + fieldDB `shouldBe` DBName "id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` HaskellName "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 FieldDef{..} = + entityId (entityDef (Proxy @HasCustomSqlId)) + it "should have custom db name" $ do + fieldDB `shouldBe` DBName "my_id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` HaskellName "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 FieldDef{..} = + entityId (entityDef (Proxy @HasIdDef)) + it "should have usual db name" $ do + fieldDB `shouldBe` DBName "id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` HaskellName "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) + FieldDef{..} = + entityId sharedDef + it "should have usual db name" $ do + fieldDB `shouldBe` DBName "id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` HaskellName "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 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) + + it "is a newtype" $ do + pkNewtype sqlSettings sharedDef + `shouldBe` + True + + describe "SharedPrimaryKeyWithCascade" $ do + let FieldDef{..} = + entityId (entityDef (Proxy @SharedPrimaryKeyWithCascade)) + it "should have usual db name" $ do + fieldDB `shouldBe` DBName "id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` HaskellName "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 ((HaskellName "person" ==) . fieldHaskell) + $ entityFields + $ simpleCascadeDef + simpleCascadeDef = + entityDef (Proxy :: Proxy HasSimpleCascadeRef) + expected = + FieldCascade + { fcOnDelete = Just Cascade + , fcOnUpdate = Nothing + } + describe "entityDef" $ do + it "works" $ do + simpleCascadeDef + `shouldBe` + EntityDef + { entityHaskell = HaskellName "HasSimpleCascadeRef" + , entityDB = DBName "HasSimpleCascadeRef" + , entityId = + FieldDef + { fieldHaskell = HaskellName "Id" + , fieldDB = DBName "id" + , fieldType = FTTypeCon Nothing "HasSimpleCascadeRefId" + , fieldSqlType = SqlInt64 + , fieldReference = + ForeignRef (HaskellName "HasSimpleCascadeRef") (FTTypeCon (Just "Data.Int") "Int64") + , fieldAttrs = [] + , fieldStrict = True + , fieldComments = Nothing + , fieldCascade = noCascade + } + , entityAttrs = [] + , entityFields = + [ FieldDef + { fieldHaskell = HaskellName "person" + , fieldDB = DBName "person" + , fieldType = FTTypeCon Nothing "PersonId" + , fieldSqlType = SqlInt64 + , fieldAttrs = [] + , fieldStrict = True + , fieldReference = + ForeignRef + (HaskellName "Person") + (FTTypeCon (Just "Data.Int") "Int64") + , fieldCascade = + FieldCascade { fcOnUpdate = Nothing, fcOnDelete = Just Cascade } + , fieldComments = Nothing + } + ] + , entityUniques = [] + , entityForeigns = [] + , entityDerives = ["Show", "Eq"] + , entityExtra = mempty + , entitySum = False + , entityComments = Nothing + } + 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) diff --git a/persistent-test/src/ForeignKey.hs b/persistent-test/src/ForeignKey.hs index 756952358..3bb3c66ed 100644 --- a/persistent-test/src/ForeignKey.hs +++ b/persistent-test/src/ForeignKey.hs @@ -1,66 +1,230 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications, UndecidableInstances #-} + module ForeignKey where +import Data.Proxy +import qualified Data.List as List 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 +SimpleCascadeChild + ref SimpleCascadeId OnDeleteCascade + deriving Show Eq + +SimpleCascade + name Int + deriving Show Eq + +Parent + name Int Primary name - Child - pname String +Child + pname Int Foreign Parent OnDeleteCascade OnUpdateCascade fkparent pname deriving Show Eq - ParentComposite - name String - lastName String +ParentImplicit + name Int + +ChildImplicit + pname Int + parentId ParentImplicitId noreference + Foreign ParentImplicit OnDeleteCascade OnUpdateCascade fkparent parentId + deriving Show Eq + +ParentComposite + name Int + lastName Int Primary name lastName - ChildComposite - pname String - plastName String +ChildComposite + pname Int + plastName Int Foreign ParentComposite OnDeleteCascade fkparent pname plastName deriving Show Eq - SelfReferenced - name String - pname String +SelfReferenced + name Int + pname Int Primary name Foreign SelfReferenced OnDeleteCascade fkparent pname deriving Show Eq + +A + aa Int + ab Int + U1 aa + +B + ba Int + bb Int + Foreign A OnDeleteCascade fkA ba References aa + deriving Show Eq + +AComposite + aa Int + ab Int + U2 aa ab + +BComposite + ba Int + bb Int + Foreign AComposite OnDeleteCascade fkAComposite ba bb References aa ab + deriving Show Eq + +BExplicit + ba AId noreference + Foreign A OnDeleteCascade fkAI ba References Id + deriving Show Eq + +Chain + name Int + previous ChainId Maybe noreference + Foreign Chain OnDeleteSetNull fkChain previous References Id + deriving Show Eq Ord + +Chain2 + name Int + previous Chain2Id Maybe noreference + Foreign Chain2 OnDeleteCascade fkChain previous References Id + 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 +specsWith runDb = fdescribe "foreign keys options" $ do + it "delete cascades" $ runDb $ do + kf <- insert $ Parent 1 + kc <- insert $ Child 1 + delete kf + cs <- selectList [] [] + let expected = [] :: [Entity Child] + cs @== expected + it "update cascades" $ runDb $ do + kf <- insert $ Parent 1 + kc <- insert $ Child 1 + update kf [ParentName =. 2] + cs <- selectList [] [] + fmap (childPname . entityVal) cs @== [2] + it "delete Composite cascades" $ runDb $ do + kf <- insert $ ParentComposite 1 2 + kc <- insert $ ChildComposite 1 2 + delete kf + cs <- selectList [] [] + let expected = [] :: [Entity ChildComposite] + cs @== expected + it "delete self referenced cascades" $ runDb $ do + kf <- insert $ SelfReferenced 1 1 + kc <- insert $ SelfReferenced 2 1 + delete kf + srs <- selectList [] [] + let expected = [] :: [Entity SelfReferenced] + srs @== expected + it "delete cascade works on simple references" $ runDb $ do + scId <- insert $ SimpleCascade 1 + sccId <- insert $ SimpleCascadeChild scId + Just _ <- get sccId + delete scId + mres <- get sccId + mxs <- selectList @SimpleCascadeChild [] [] + liftIO $ do + mres `shouldBe` Nothing + mxs `shouldBe` [] + it "delete cascades with explicit Reference" $ runDb $ do + kf <- insert $ A 1 40 + kc <- insert $ B 1 15 + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "delete cascades with explicit Composite Reference" $ runDb $ do + kf <- insert $ AComposite 1 20 + kc <- insert $ BComposite 1 20 + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "delete cascades with explicit Composite Reference" $ runDb $ do + kf <- insert $ AComposite 1 20 + kc <- insert $ BComposite 1 20 + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "delete cascades with explicit Id field" $ runDb $ do + kf <- insert $ A 1 20 + kc <- insert $ BExplicit kf + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "deletes sets null with self reference" $ runDb $ do + kf <- insert $ Chain 1 Nothing + kf' <- insert $ Chain 2 (Just kf) + delete kf + cs <- selectList [] [] + let expected = [Entity {entityKey = kf', entityVal = Chain 2 Nothing}] + List.sort cs @== List.sort expected + it "deletes cascades with self reference to the whole chain" $ runDb $ do + k1 <- insert $ Chain2 1 Nothing + k2 <- insert $ Chain2 2 (Just k1) + k3 <- insert $ Chain2 3 (Just k2) + delete k1 + cs <- selectList [] [] + let expected = [] :: [Entity Chain2] + cs @== expected + + describe "EntityDef" $ do + let ed = + entityDef (Proxy @SimpleCascadeChild) + isRefCol = + (HaskellName "ref" ==) . fieldHaskell + expected = FieldCascade + { fcOnUpdate = Nothing + , fcOnDelete = Just Cascade + } + Just refField = + List.find isRefCol (entityFields ed) + + it "parses into fieldCascade" $ do + fieldCascade refField `shouldBe` expected + + it "shouldn't have cascade in extras" $ do + entityExtra ed + `shouldBe` + mempty + +cleanDB :: (MonadIO m) => SqlPersistT m () +cleanDB = do + del @SimpleCascadeChild + del @SimpleCascade + del @Parent + del @ParentComposite + del @ParentImplicit + del @Child + del @ChildComposite + del @ChildImplicit + del @SelfReferenced + del @A + del @AComposite + del @B + del @BExplicit + del @BComposite + del @Chain + del @Chain2 + +del + :: forall a m. + ( PersistEntity a + , PersistEntityBackend a ~ SqlBackend + , MonadIO m + ) + => SqlPersistT m () +del = deleteWhere @_ @_ @a [] diff --git a/persistent-test/src/Init.hs b/persistent-test/src/Init.hs index ecb892e46..274d3480b 100644 --- a/persistent-test/src/Init.hs +++ b/persistent-test/src/Init.hs @@ -41,6 +41,7 @@ module Init ( , arbText , liftA2 , changeBackend + , Proxy(..) ) where -- needed for backwards compatibility @@ -66,6 +67,7 @@ import qualified Data.Text as T import Data.Time import Test.Hspec import Test.QuickCheck.Instances () +import Data.Proxy import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..)) diff --git a/persistent-test/src/PersistentTest.hs b/persistent-test/src/PersistentTest.hs index 629398a99..ab7ddad22 100644 --- a/persistent-test/src/PersistentTest.hs +++ b/persistent-test/src/PersistentTest.hs @@ -711,5 +711,3 @@ specsWith runDb = describe "persistent" $ do , ("blood", toJSON jsonEncoding2Blood) , ("id", toJSON key) ]) - - diff --git a/persistent-test/src/RenameTest.hs b/persistent-test/src/RenameTest.hs index e8ed14b0b..d407623e2 100644 --- a/persistent-test/src/RenameTest.hs +++ b/persistent-test/src/RenameTest.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications, UndecidableInstances #-} + module RenameTest where import qualified Data.Map as Map @@ -72,17 +73,23 @@ specsWith => RunDb backend m -> Spec specsWith runDb = describe "rename specs" $ do + describe "LowerCaseTable" $ do + it "LowerCaseTable has the right sql name" $ do + fieldDB (entityId (entityDef (Proxy @LowerCaseTable))) + `shouldBe` + DBName "my_id" + it "user specified id, insertKey, no default=" $ runDb $ do - let rec2 = IdTable "Foo2" Nothing - let rec1 = IdTable "Foo1" $ Just rec2 - let rec = IdTable "Foo" $ Just rec1 - now <- liftIO getCurrentTime - let key = IdTableKey $ utctDay now - insertKey key rec - Just rec' <- get key - rec' @== rec - (Entity key' _):_ <- selectList ([] :: [Filter (IdTableGeneric backend)]) [] - key' @== key + let rec2 = IdTable "Foo2" Nothing + let rec1 = IdTable "Foo1" $ Just rec2 + let rec = IdTable "Foo" $ Just rec1 + now <- liftIO getCurrentTime + let key = IdTableKey $ utctDay now + insertKey key rec + Just rec' <- get key + rec' @== rec + (Entity key' _):_ <- selectList ([] :: [Filter (IdTableGeneric backend)]) [] + key' @== key it "extra blocks" $ entityExtra (entityDef (Nothing :: Maybe LowerCaseTable)) @?= diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 63de661c9..10165b3d2 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -2,6 +2,10 @@ ## (Unreleased) 2.11.0.0 +* Foreign Key improvements [#1121] https://github.com/yesodweb/persistent/pull/1121 + * It is now supported to refer to a table with an auto generated Primary Kay + * It is now supported to refer to non-primary fields, using the keyword `References` + * It is now supported to have cascade options for simple/single-field Foreign Keys * Introduces a breaking change to the internal function `mkColumns`, which can now be passed a record of functions to override its default behavior. [#996](https://github.com/yesodweb/persistent/pull/996) * Added explicit `forall` notation to make most API functions play nice when using `TypeApplications`. (e.g. instead of `selectList @_ @_ @User [] []`, you can now write `selectList @User [] []`) [#1006](https://github.com/yesodweb/persistent/pull/1006) * [#1060](https://github.com/yesodweb/persistent/pull/1060) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index c27a0dcc8..33f95e498 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -144,7 +144,10 @@ CREATE TABLE email ( PRIMARY KEY (first_part, second_part) @ -You can specify 1 or more columns in the primary key. +Since the primary key for this table is part of the record, it's called a "natural key" in the SQL lingo. +As a key with multiple fields, it is also a "composite key." + +You can specify a @Primary@ key with a single field, too. = Overriding SQL @@ -193,6 +196,176 @@ userAttrs = do -- [["sad"],["sogood"]] @ += Foreign Keys + +If you define an entity and want to refer to it in another table, you can use the entity's Id type in a column directly. + +@ +Person + name Text + +Dog + name Text + owner PersonId +@ + +This automatically creates a foreign key reference from @Dog@ to @Person@. +The foreign key constraint means that, if you have a @PersonId@ on the @Dog@, the database guarantees that the corresponding @Person@ exists in the database. +If you try to delete a @Person@ out of the database that has a @Dog@, you'll receive an exception that a foreign key violation has occurred. + +== OnUpdate and OnDelete + +These options affects how a referring record behaves when the target record is changed. +There are several options: + +* 'Restrict' - This is the default. It prevents the action from occurring. +* 'Cascade' - this copies the change to the child record. If a parent record is deleted, then the child record will be deleted too. +* 'SetNull' - If the parent record is modified, then this sets the reference to @NULL@. This only works on @Maybe@ foreign keys. +* 'SetDefault' - This will set the column's value to the @default@ for the column, if specified. + +To specify the behavior for a reference, write @OnUpdate@ or @OnDelete@ followed by the action. + +@ +Record + -- If the referred Foo is deleted or updated, then this record will + -- also be deleted or updated. + fooId FooId OnDeleteCascade OnUpdateCascade + + -- If the referred Bar is deleted, then we'll set the reference to + -- 'Nothing'. If the referred Bar is updated, then we'll cascade the + -- update. + barId BarId Maybe OnDeleteSetNull OnUpdateCascade + + -- If the referred Baz is deleted, then we set to the default ID. + bazId BazId OnDeleteSetDefault default=1 +@ + +Let's demonstrate this with a shopping cart example. + +@ +User + name Text + +Cart + user UserId Maybe + +CartItem + cartId CartId + itemId ItemId + +Item + name Text + price Int +@ + +Let's consider how we want to handle deletions and updates. +If a @User@ is deleted or update, then we want to cascade the action to the associated @Cart@. + +@ +Cart + user UserId Maybe OnDeleteCascade OnUpdateCascade +@ + +If an @Item@ is deleted, then we want to set the @CartItem@ to refer to a special "deleted item" in the database. +If a @Cart@ is deleted, though, then we just want to delete the @CartItem@. + +@ +CartItem + cartId CartId OnDeleteCascade + itemId ItemId OnDeleteSetDefault default=1 +@ + +== @Foreign@ keyword + +The above example is a "simple" foreign key. It refers directly to the Id column, and it only works with a non-composite primary key. We can define more complicated foreign keys using the @Foreign@ keyword. + +A pseudo formal syntax for @Foreign@ is: + +@ +Foreign $(TargetEntity) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ] + +columns := column0 [column1 column2 .. columnX] +references := References $(target-columns) +target-columns := target-column0 [target-column1 target-columns2 .. target-columnX] +@ + +Columns are the columns as defined on this entity. +@target-columns@ are the columns as defined on the target entity. + +Let's look at some examples. + +=== Composite Primary Key References + +The most common use for this is to refer to a composite primary key. +Since composite primary keys take up more than one column, we can't refer to them with a single @persistent@ column. + +@ +Email + firstPart Text + secondPart Text + Primary firstPart secondPart + +User + name Text + emailFirstPart Text + emailSecondPart Text + + Foreign Email fk_user_email emailFirstPart emailSecondPart +@ + +If you omit the @References@ keyword, then it assumes that the foreign key reference is for the target table's primary key. +If we wanted to be fully redundant, we could specify the @References@ keyword. + +@ + Foreign Email fk_user_email emailFirstPart emailSecondPart References firstPart secondPart +@ + +We can specify delete/cascade behavior directly after the target table. + +@ + Foreign Email OnDeleteCascade OnUpdateCascade fk_user_email emailFirstPart emailSecondPart +@ + +Now, if the email is deleted or updated, the user will be deleted or updated to match. + +=== Non-Primary Key References + +SQL database backends allow you to create a foreign key to any column(s) with a Unique constraint. +Persistent does not check this, because you might be defining your uniqueness constraints outside of Persistent. +To do this, we must use the @References@ keyword. + +@ +User + name Text + email Text + + UniqueEmail email + +Notification + content Text + sentTo Text + + Foreign User fk_noti_user sentTo References email +@ + +If the target uniqueness constraint has multiple columns, then you must specify them independently. + +@ +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 +@ + = Documentation Comments The quasiquoter supports ordinary comments with @--@ and @#@. @@ -255,6 +428,8 @@ module Database.Persist.Quasi , associateLines , skipEmpty , LinesWithComments(..) + , splitExtras + , takeColsEx #endif ) where @@ -562,45 +737,48 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts fixForeignKeys (UnboundEntityDef foreigns ent) = ent { entityForeigns = map (fixForeignKey ent) foreigns } - -- check the count and the sqltypes match and update the foreignFields with the names of the primary columns + -- check the count and the sqltypes match and update the foreignFields with the names of the referenced columns fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef - fixForeignKey ent (UnboundForeignDef foreignFieldTexts fdef) = - let pentError = - error $ "could not find table " ++ show (foreignRefTableHaskell fdef) - ++ " fdef=" ++ show fdef ++ " allnames=" - ++ show (map (unHaskellName . entityHaskell . unboundEntityDef) unEnts) - ++ "\n\nents=" ++ show ents - pent = - fromMaybe pentError $ M.lookup (foreignRefTableHaskell fdef) entLookup - in - case entityPrimary pent of - Just pdef -> - if length foreignFieldTexts /= length (compositeFields pdef) - then - lengthError pdef - else - let - fds_ffs = - zipWith (toForeignFields pent) - foreignFieldTexts - (compositeFields pdef) - dbname = - unDBName (entityDB pent) - oldDbName = - unDBName (foreignRefTableDBName fdef) - in fdef - { foreignFields = map snd fds_ffs - , foreignNullable = setNull $ map fst fds_ffs - , foreignRefTableDBName = - DBName dbname - , foreignConstraintNameDBName = - DBName - . T.replace oldDbName dbname . unDBName - $ foreignConstraintNameDBName fdef - } - Nothing -> - error $ "no explicit primary key fdef="++show fdef++ " ent="++show ent + fixForeignKey ent (UnboundForeignDef foreignFieldTexts parentFieldTexts fdef) = + case mfdefs of + Just fdefs -> + if length foreignFieldTexts /= length fdefs + then + lengthError fdefs + else + let + fds_ffs = + zipWith toForeignFields + foreignFieldTexts + fdefs + dbname = + unDBName (entityDB pent) + oldDbName = + unDBName (foreignRefTableDBName fdef) + in fdef + { foreignFields = map snd fds_ffs + , foreignNullable = setNull $ map fst fds_ffs + , foreignRefTableDBName = + DBName dbname + , foreignConstraintNameDBName = + DBName + . T.replace oldDbName dbname . unDBName + $ foreignConstraintNameDBName fdef + } + Nothing -> + error $ "no primary key found fdef="++show fdef++ " ent="++show ent where + pentError = + error $ "could not find table " ++ show (foreignRefTableHaskell fdef) + ++ " fdef=" ++ show fdef ++ " allnames=" + ++ show (map (unHaskellName . entityHaskell . unboundEntityDef) unEnts) + ++ "\n\nents=" ++ show ents + pent = + fromMaybe pentError $ M.lookup (foreignRefTableHaskell fdef) entLookup + mfdefs = case parentFieldTexts of + [] -> entitiesPrimary pent + _ -> Just $ map (getFd pent . HaskellName) parentFieldTexts + setNull :: [FieldDef] -> Bool setNull [] = error "setNull: impossible!" setNull (fd:fds) = let nullSetting = isNull fd in @@ -609,31 +787,32 @@ fixForeignKeysAll unEnts = map fixForeignKeys unEnts ++ show (map (unHaskellName . fieldHaskell) (fd:fds)) isNull = (NotNullable /=) . nullable . fieldAttrs - toForeignFields pent fieldText pfd = - case chktypes fd haskellField (entityFields pent) pfh of + toForeignFields :: Text -> FieldDef + -> (FieldDef, (ForeignFieldDef, ForeignFieldDef)) + toForeignFields fieldText pfd = + case chktypes fd haskellField pfd of Just err -> error err Nothing -> (fd, ((haskellField, fieldDB fd), (pfh, pfdb))) where - fd = getFd (entityFields ent) haskellField + fd = getFd ent haskellField haskellField = HaskellName fieldText (pfh, pfdb) = (fieldHaskell pfd, fieldDB pfd) - chktypes :: FieldDef -> HaskellName -> [FieldDef] -> HaskellName -> Maybe String - chktypes ffld _fkey pflds pkey = + chktypes ffld _fkey pfld = if fieldType ffld == fieldType pfld then Nothing else Just $ "fieldType mismatch: " ++ show (fieldType ffld) ++ ", " ++ show (fieldType pfld) - where - pfld = getFd pflds pkey - entName = entityHaskell ent - getFd [] t = error $ "foreign key constraint for: " ++ show (unHaskellName entName) - ++ " unknown column: " ++ show t - getFd (f:fs) t + getFd :: EntityDef -> HaskellName -> FieldDef + getFd entity t = go (keyAndEntityFields entity) + where + go [] = error $ "foreign key constraint for: " ++ show (unHaskellName $ entityHaskell entity) + ++ " unknown column: " ++ show t + go (f:fs) | fieldHaskell f == t = f - | otherwise = getFd fs t + | otherwise = go fs - lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length (compositeFields pdef)) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef + lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length pdef) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef data UnboundEntityDef = UnboundEntityDef @@ -714,7 +893,9 @@ mkEntityDef ps name entattribs lines = idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite setComposite Nothing fd = fd - setComposite (Just c) fd = fd { fieldReference = CompositeRef c } + setComposite (Just c) fd = fd + { fieldReference = CompositeRef c + } just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x @@ -722,22 +903,23 @@ just1 (Just x) (Just y) = error $ "expected only one of: " `mappend` show x `mappend` " " `mappend` show y just1 x y = x `mplus` y - mkAutoIdField :: PersistSettings -> HaskellName -> Maybe DBName -> SqlType -> FieldDef -mkAutoIdField ps entName idName idSqlType = FieldDef - { fieldHaskell = HaskellName "Id" - -- this should be modeled as a Maybe - -- but that sucks for non-ID field - -- TODO: use a sumtype FieldDef | IdFieldDef - , fieldDB = fromMaybe (DBName $ psIdName ps) idName - , fieldType = FTTypeCon Nothing $ keyConName $ unHaskellName entName - , fieldSqlType = idSqlType - -- the primary field is actually a reference to the entity - , fieldReference = ForeignRef entName defaultReferenceTypeCon - , fieldAttrs = [] - , fieldStrict = True - , fieldComments = Nothing - } +mkAutoIdField ps entName idName idSqlType = + FieldDef + { fieldHaskell = HaskellName "Id" + -- this should be modeled as a Maybe + -- but that sucks for non-ID field + -- TODO: use a sumtype FieldDef | IdFieldDef + , fieldDB = fromMaybe (DBName $ psIdName ps) idName + , fieldType = FTTypeCon Nothing $ keyConName $ unHaskellName entName + , fieldSqlType = idSqlType + -- the primary field is actually a reference to the entity + , fieldReference = ForeignRef entName defaultReferenceTypeCon + , fieldAttrs = [] + , fieldStrict = True + , fieldComments = Nothing + , fieldCascade = noCascade + } defaultReferenceTypeCon :: FieldType defaultReferenceTypeCon = FTTypeCon (Just "Data.Int") "Int64" @@ -745,8 +927,11 @@ defaultReferenceTypeCon = FTTypeCon (Just "Data.Int") "Int64" keyConName :: Text -> Text keyConName entName = entName `mappend` "Id" - -splitExtras :: [Line] -> ([[Text]], M.Map Text [[Text]]) +splitExtras + :: [Line] + -> ( [[Text]] + , M.Map Text [[Text]] + ) splitExtras [] = ([], M.empty) splitExtras (Line indent [name]:rest) | not (T.null name) && isUpper (T.head name) = @@ -768,25 +953,28 @@ takeCols -> [Text] -> Maybe FieldDef takeCols _ _ ("deriving":_) = Nothing -takeCols onErr ps (n':typ:rest) +takeCols onErr ps (n':typ:rest') | not (T.null n) && isLower (T.head n) = case parseFieldType typ of Left err -> onErr typ err - Right ft -> Just FieldDef + Right ft -> Just $ FieldDef { fieldHaskell = HaskellName n - , fieldDB = DBName $ getDbName ps n rest + , fieldDB = DBName $ getDbName ps n attrs_ , fieldType = ft , fieldSqlType = SqlOther $ "SqlType unset for " `mappend` n - , fieldAttrs = rest + , fieldAttrs = attrs_ , fieldStrict = fromMaybe (psStrictFields ps) mstrict , fieldReference = NoReference , fieldComments = Nothing + , fieldCascade = cascade_ } where + (cascade_, attrs_) = parseCascade rest' (mstrict, n) | Just x <- T.stripPrefix "!" n' = (Just True, x) | Just x <- T.stripPrefix "~" n' = (Just False, x) | otherwise = (Nothing, n') + takeCols _ _ _ = Nothing getDbName :: PersistSettings -> Text -> [Text] -> Text @@ -811,19 +999,22 @@ 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) = fromMaybe (error "takeId: impossible!") $ setFieldDef $ - takeCols (\_ _ -> addDefaultIdType) ps (field:rest `mappend` setIdName) +takeId ps tableName (n:rest) = + setFieldDef + $ fromMaybe (error "takeId: impossible!") + $ takeCols (\_ _ -> addDefaultIdType) ps (field:rest) -- `mappend` setIdName) where field = case T.uncons n of - Nothing -> error "takeId: empty field" - Just (f, ield) -> toLower f `T.cons` ield - addDefaultIdType = takeColsEx ps (field : keyCon : rest `mappend` setIdName) - setFieldDef = fmap (\fd -> - let refFieldType = if fieldType fd == FTTypeCon Nothing keyCon - then defaultReferenceTypeCon - else fieldType fd - in fd { fieldReference = ForeignRef (HaskellName tableName) $ refFieldType - }) + Nothing -> error "takeId: empty field" + Just (f, ield) -> toLower f `T.cons` ield + addDefaultIdType = takeColsEx ps (field : keyCon : rest ) -- `mappend` setIdName) + setFieldDef fd = fd + { fieldReference = + ForeignRef (HaskellName tableName) $ + if fieldType fd == FTTypeCon Nothing keyCon + then defaultReferenceTypeCon + else fieldType fd + } keyCon = keyConName tableName -- this will be ignored if there is already an existing sql= -- TODO: I think there is a ! ignore syntax that would screw this up @@ -831,13 +1022,12 @@ takeId ps tableName (n:rest) = fromMaybe (error "takeId: impossible!") $ setFiel takeId _ tableName _ = error $ "empty Id field for " `mappend` show tableName -takeComposite :: [FieldDef] - -> [Text] - -> CompositeDef -takeComposite fields pkcols - = CompositeDef - (map (getDef fields) pkcols) - attrs +takeComposite + :: [FieldDef] + -> [Text] + -> CompositeDef +takeComposite fields pkcols = + CompositeDef (map (getDef fields) pkcols) attrs where (_, attrs) = break ("!" `T.isPrefixOf`) pkcols getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t @@ -900,15 +1090,17 @@ takeUniq _ tableName _ xs = ++ show xs data UnboundForeignDef = UnboundForeignDef - { _unboundFields :: [Text] -- ^ fields in other entity + { _unboundForeignFields :: [Text] -- ^ fields in the parent entity + , _unboundParentFields :: [Text] -- ^ fields in parent entity , _unboundForeignDef :: ForeignDef } -takeForeign :: PersistSettings - -> Text - -> [FieldDef] - -> [Text] - -> UnboundForeignDef +takeForeign + :: PersistSettings + -> Text + -> [FieldDef] + -> [Text] + -> UnboundForeignDef takeForeign ps tableName _defs = takeRefTable where errorPrefix :: String @@ -920,7 +1112,7 @@ takeForeign ps tableName _defs = takeRefTable where go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef go (n:rest) onDelete onUpdate | not (T.null n) && isLower (T.head n) - = UnboundForeignDef fields $ ForeignDef + = UnboundForeignDef fFields pFields $ ForeignDef { foreignRefTableHaskell = HaskellName refTableName , foreignRefTableDBName = @@ -939,21 +1131,88 @@ takeForeign ps tableName _defs = takeRefTable attrs , foreignNullable = False + , foreignToPrimary = + null pFields } where (fields,attrs) = break ("!" `T.isPrefixOf`) rest - go ((T.stripPrefix "OnDelete" -> Just onDelete) : rest) onDelete' onUpdate - = case (onDelete', readEither $ T.unpack onDelete) of - (Nothing, Right cascadingAction) -> go rest (Just cascadingAction) onUpdate - (Nothing, Left _) -> error $ errorPrefix ++ "could not parse OnDelete action" - (Just _, _) -> error $ errorPrefix ++ "found more than one OnDelete actions" - go ((T.stripPrefix "OnUpdate" -> Just onUpdate) : rest) onDelete onUpdate' - = case (onUpdate', readEither $ T.unpack onUpdate) of - (Nothing, Right cascadingAction) -> go rest onDelete (Just cascadingAction) - (Nothing, Left _) -> error $ errorPrefix ++ "could not parse OnUpdate action" - (Just _, _) -> error $ errorPrefix ++ "found more than one OnUpdate actions" + (fFields, pFields) = case break (== "References") fields of + (ffs, []) -> (ffs, []) + (ffs, _ : pfs) -> case (length ffs, length pfs) of + (flen, plen) | flen == plen -> (ffs, pfs) + (flen, plen) -> error $ errorPrefix ++ concat + [ "Found ", show flen, " foreign fields but " + , show plen, " parent fields" ] + + go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) onDelete' onUpdate = + case onDelete' of + Nothing -> + go rest (Just cascadingAction) onUpdate + Just _ -> + error $ errorPrefix ++ "found more than one OnDelete actions" + + go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) onDelete onUpdate' = + case onUpdate' of + Nothing -> + go rest 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 +data CascadePrefix = CascadeUpdate | CascadeDelete + +parseCascade :: [Text] -> (FieldCascade, [Text]) +parseCascade allTokens = + go [] Nothing Nothing allTokens + where + go acc mupd mdel tokens = + case tokens of + [] -> + ( FieldCascade + { fcOnDelete = mdel + , fcOnUpdate = mupd + } + , acc + ) + this : rest -> + case parseCascadeAction CascadeUpdate this of + Just cascUpd -> + case mupd of + Nothing -> + go acc (Just cascUpd) mdel rest + Just _ -> + nope "found more than one OnUpdate action" + Nothing -> + case parseCascadeAction CascadeDelete this of + Just cascDel -> + case mdel of + Nothing -> + go acc mupd (Just cascDel) rest + Just _ -> + nope "found more than one OnDelete action: " + Nothing -> + go (this : acc) mupd mdel rest + nope msg = + error $ msg <> ", tokens: " <> show allTokens + +parseCascadeAction + :: CascadePrefix + -> Text + -> Maybe CascadeAction +parseCascadeAction prfx text = do + cascadeStr <- T.stripPrefix ("On" <> toPrefix prfx) text + case readEither (T.unpack cascadeStr) of + Right a -> + Just a + Left _ -> + Nothing + where + toPrefix cp = + case cp of + CascadeUpdate -> "Update" + CascadeDelete -> "Delete" + takeDerives :: [Text] -> Maybe [Text] takeDerives ("deriving":rest) = Just rest takeDerives _ = Nothing diff --git a/persistent/Database/Persist/Sql/Internal.hs b/persistent/Database/Persist/Sql/Internal.hs index 9a19c7520..ece17e119 100644 --- a/persistent/Database/Persist/Sql/Internal.hs +++ b/persistent/Database/Persist/Sql/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} -- | Intended for creating new backends. module Database.Persist.Sql.Internal @@ -9,6 +10,7 @@ module Database.Persist.Sql.Internal , emptyBackendSpecificOverrides ) where +import Control.Applicative ((<|>)) import Data.Char (isSpace) import Data.Monoid (mappend, mconcat) import Data.Text (Text) @@ -87,12 +89,13 @@ mkColumns allDefs t overrides = , cDefaultConstraintName = Nothing , cMaxLen = maxLen $ fieldAttrs fd - , cReference = ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd) + , cReference = mkColumnReference fd } tableName :: DBName tableName = entityDB t + go :: FieldDef -> Column go fd = Column @@ -102,7 +105,7 @@ mkColumns allDefs t overrides = , cDefault = defaultAttribute $ fieldAttrs fd , cDefaultConstraintName = Nothing , cMaxLen = maxLen $ fieldAttrs fd - , cReference = ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd) + , cReference = mkColumnReference fd } maxLen :: [Attr] -> Maybe Integer @@ -117,6 +120,23 @@ mkColumns allDefs t overrides = refNameFn = fromMaybe refName (backendSpecificForeignKeyName overrides) + mkColumnReference :: FieldDef -> Maybe ColumnReference + mkColumnReference fd = + fmap + (\(tName, cName) -> + ColumnReference tName cName $ overrideNothings $ fieldCascade fd + ) + $ ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd) + + -- a 'Nothing' in the definition means that the QQ migration doesn't + -- specify behavior. the default is RESTRICT. setting this here + -- explicitly makes migrations run smoother. + overrideNothings (FieldCascade { fcOnUpdate = upd, fcOnDelete = del }) = + FieldCascade + { fcOnUpdate = upd <|> Just Restrict + , fcOnDelete = del <|> Just Restrict + } + ref :: DBName -> ReferenceDef -> [Attr] @@ -128,10 +148,10 @@ mkColumns allDefs t overrides = ref _ _ ("noreference":_) = Nothing ref c fe (a:as) | Just x <- T.stripPrefix "reference=" a = do - constraintName <- snd <$> (ref c fe as) + (_, constraintName) <- ref c fe as pure (DBName x, constraintName) | Just x <- T.stripPrefix "constraint=" a = do - tableName <- fst <$> (ref c fe as) + (tableName, _) <- ref c fe as pure (tableName, DBName x) ref c x (_:as) = ref c x as diff --git a/persistent/Database/Persist/Sql/Types.hs b/persistent/Database/Persist/Sql/Types.hs index f00339ad6..7fe74edd7 100644 --- a/persistent/Database/Persist/Sql/Types.hs +++ b/persistent/Database/Persist/Sql/Types.hs @@ -7,6 +7,8 @@ module Database.Persist.Sql.Types , OverflowNatural(..) ) where +import Database.Persist.Types.Base (FieldCascade) + import Control.Exception (Exception(..)) import Control.Monad.Logger (NoLoggingT) import Control.Monad.Trans.Reader (ReaderT (..)) @@ -25,7 +27,27 @@ data Column = Column , cDefault :: !(Maybe Text) , cDefaultConstraintName :: !(Maybe DBName) , cMaxLen :: !(Maybe Integer) - , cReference :: !(Maybe (DBName, DBName)) -- table name, constraint name + , cReference :: !(Maybe ColumnReference) + } + deriving (Eq, Ord, Show) + +-- | This value specifies how a field references another table. +-- +-- @since 2.11.0.0 +data ColumnReference = ColumnReference + { crTableName :: !DBName + -- ^ The table name that the + -- + -- @since 2.11.0.0 + , crConstraintName :: !DBName + -- ^ The name of the foreign key constraint. + -- + -- @since 2.11.0.0 + , crFieldCascade :: !FieldCascade + -- ^ Whether or not updates/deletions to the referenced table cascade + -- to this table. + -- + -- @since 2.11.0.0 } deriving (Eq, Ord, Show) diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 4788f7b81..8ef4bd075 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -139,6 +139,14 @@ data EntityDef = EntityDef } deriving (Show, Eq, Read, Ord) +entitiesPrimary :: EntityDef -> Maybe [FieldDef] +entitiesPrimary t = case fieldReference primaryField of + CompositeRef c -> Just $ (compositeFields c) + ForeignRef _ _ -> Just [primaryField] + _ -> Nothing + where + primaryField = entityId t + entityPrimary :: EntityDef -> Maybe CompositeDef entityPrimary t = case fieldReference (entityId t) of CompositeRef c -> Just c @@ -165,9 +173,21 @@ newtype DBName = DBName { unDBName :: Text } type Attr = Text +-- | A 'FieldType' describes a field parsed from the QuasiQuoter and is +-- used to determine the Haskell type in the generated code. +-- +-- @name Text@ parses into @FTTypeCon Nothing "Text"@ +-- +-- @name T.Text@ parses into @FTTypeCon (Just "T" "Text")@ +-- +-- @name (Jsonb User)@ parses into: +-- +-- @ +-- FTApp (FTTypeCon Nothing "Jsonb") (FTTypeCon Nothing "User") +-- @ data FieldType = FTTypeCon (Maybe Text) Text - -- ^ Optional module and name. + -- ^ Optional module and name. | FTApp FieldType FieldType | FTList FieldType deriving (Show, Eq, Read, Ord) @@ -196,6 +216,13 @@ data FieldDef = FieldDef -- ^ If this is 'True', then the Haskell datatype will have a strict -- record field. The default value for this is 'True'. , fieldReference :: !ReferenceDef + , fieldCascade :: !FieldCascade + -- ^ Defines how operations on the field cascade on to the referenced + -- tables. This doesn't have any meaning if the 'fieldReference' is set + -- to 'NoReference' or 'SelfReference'. The cascade option here should + -- be the same as the one obtained in the 'fieldReference'. + -- + -- @since 2.11.0 , fieldComments :: !(Maybe Text) -- ^ Optional comments for a 'Field'. There is not currently a way to -- attach comments to a field in the quasiquoter. @@ -300,12 +327,21 @@ data ForeignDef = ForeignDef , foreignFields :: ![(ForeignFieldDef, ForeignFieldDef)] -- this entity plus the primary entity , foreignAttrs :: ![Attr] , foreignNullable :: Bool + , foreignToPrimary :: Bool + -- ^ Determines if the reference is towards a Primary Key or not. + -- + -- @since 2.11.0 } deriving (Show, Eq, Read, Ord) -- | This datatype describes how a foreign reference field cascades deletes -- or updates. -- +-- This type is used in both parsing the model definitions and performing +-- migrations. A 'Nothing' in either of the field values means that the +-- user has not specified a 'CascadeAction'. An unspecified 'CascadeAction' +-- is defaulted to 'Restrict' when doing migrations. +-- -- @since 2.11.0 data FieldCascade = FieldCascade { fcOnUpdate :: !(Maybe CascadeAction) diff --git a/persistent/test/main.hs b/persistent/test/main.hs index e138a0aca..78a56605d 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -1,4 +1,4 @@ -{-# language RecordWildCards #-} +{-# language RecordWildCards, OverloadedStrings #-} import Test.Hspec import qualified Data.Text as T @@ -13,6 +13,99 @@ import Database.Persist.Types main :: IO () main = hspec $ do + describe "splitExtras" $ do + it "works" $ do + splitExtras [] + `shouldBe` + mempty + it "works2" $ do + splitExtras + [ Line 0 ["hello", "world"] + ] + `shouldBe` + ( [["hello", "world"]], mempty ) + it "works3" $ do + splitExtras + [ Line 0 ["hello", "world"] + , Line 2 ["foo", "bar", "baz"] + ] + `shouldBe` + ( [["hello", "world"], ["foo", "bar", "baz"]], mempty ) + it "works4" $ do + let foobarbarz = ["foo", "Bar", "baz"] + splitExtras + [ Line 0 ["Hello"] + , Line 2 foobarbarz + , Line 2 foobarbarz + ] + `shouldBe` + ( [] + , Map.fromList + [ ("Hello", [foobarbarz, foobarbarz]) + ] + ) + it "works5" $ do + let foobarbarz = ["foo", "Bar", "baz"] + splitExtras + [ Line 0 ["Hello"] + , Line 2 foobarbarz + , Line 4 foobarbarz + ] + `shouldBe` + ( [] + , Map.fromList + [ ("Hello", [foobarbarz, foobarbarz]) + ] + ) + describe "takeColsEx" $ do + let subject = takeColsEx upperCaseSettings + it "fails on a single word" $ do + subject ["asdf"] + `shouldBe` + Nothing + it "works if it has a name and a type" $ do + subject ["asdf", "Int"] + `shouldBe` + Just FieldDef + { fieldHaskell = HaskellName "asdf" + , fieldDB = DBName "asdf" + , fieldType = FTTypeCon Nothing "Int" + , fieldSqlType = SqlOther "SqlType unset for asdf" + , fieldAttrs = [] + , fieldStrict = True + , fieldReference = NoReference + , fieldCascade = noCascade + , fieldComments = Nothing + } + it "works if it has a name, type, and cascade" $ do + subject ["asdf", "Int", "OnDeleteCascade", "OnUpdateCascade"] + `shouldBe` + Just FieldDef + { fieldHaskell = HaskellName "asdf" + , fieldDB = DBName "asdf" + , fieldType = FTTypeCon Nothing "Int" + , fieldSqlType = SqlOther "SqlType unset for asdf" + , fieldAttrs = [] + , fieldStrict = True + , fieldReference = NoReference + , fieldCascade = FieldCascade (Just Cascade) (Just Cascade) + , fieldComments = Nothing + } + it "never tries to make a refernece" $ do + subject ["asdf", "UserId", "OnDeleteCascade"] + `shouldBe` + Just FieldDef + { fieldHaskell = HaskellName "asdf" + , fieldDB = DBName "asdf" + , fieldType = FTTypeCon Nothing "UserId" + , fieldSqlType = SqlOther "SqlType unset for asdf" + , fieldAttrs = [] + , fieldStrict = True + , fieldReference = NoReference + , fieldCascade = FieldCascade Nothing (Just Cascade) + , fieldComments = Nothing + } + describe "tokenization" $ do it "handles normal words" $ tokenize " foo bar baz" `shouldBe`