Fix migrations

persistent-mysql/Database/Persist/MySQL.hs

@@ -500,7 +500,7 @@ findTypeOfColumn allDefs name col =
         ((,) col)
         $ do
             entDef   <- find ((== name) . getEntityDBName) allDefs
-            fieldDef <- find ((== col)  . fieldDB) (getEntityFields entDef)
+            fieldDef <- find ((== col)  . fieldDB) (getEntityFieldsDatabase entDef)
             return (fieldType fieldDef)
 
 -- | Find out the maxlen of a column (default to 200)
@@ -509,7 +509,7 @@ findMaxLenOfColumn allDefs name col =
    maybe (col, 200)
          ((,) col) $ do
            entDef     <- find ((== name) . getEntityDBName) allDefs
-           fieldDef   <- find ((== col) . fieldDB) (getEntityFields entDef)
+           fieldDef   <- find ((== col) . fieldDB) (getEntityFieldsDatabase entDef)
            findMaxLenOfField fieldDef
 
 -- | Find out the maxlen of a field
@@ -1484,7 +1484,7 @@ mkBulkInsertQuery records fieldValues updates =
     firstField = case entityFieldNames of
         [] -> error "The entity you're trying to insert does not have any fields."
         (field:_) -> field
-    entityFieldNames = map fieldDbToText (getEntityFields entityDef')
+    entityFieldNames = map fieldDbToText (getEntityFieldsDatabase entityDef')
     tableName = T.pack . escapeE . getEntityDBName $ entityDef'
     copyUnlessValues = map snd fieldsToMaybeCopy
     recordValues = concatMap (map toPersistValue . toPersistFields) records
@@ -1521,7 +1521,7 @@ mkBulkInsertQuery records fieldValues updates =
 putManySql :: EntityDef -> Int -> Text
 putManySql ent n = putManySql' fields ent n
   where
-    fields = getEntityFields ent
+    fields = getEntityFieldsDatabase ent
 
 repsertManySql :: EntityDef -> Int -> Text
 repsertManySql ent n = putManySql' fields ent n

persistent-mysql/test/main.hs

@@ -1,24 +1,28 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE DataKinds, FlexibleInstances #-}
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 import MyInit
 
-import Data.Time (Day, UTCTime (..), TimeOfDay, timeToTimeOfDay, timeOfDayToTime)
-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
+import qualified Data.ByteString as BS
 import Data.Fixed
-import Test.QuickCheck
-import qualified Data.Text as T
 import Data.IntMap (IntMap)
-import qualified Data.ByteString as BS
+import qualified Data.Text as T
+import Data.Time (Day, TimeOfDay, UTCTime(..), timeOfDayToTime, timeToTimeOfDay)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+import Database.Persist.Sql
+import Test.QuickCheck
 
 import qualified CompositeTest
 import qualified CustomPersistFieldTest
@@ -35,26 +39,26 @@ import qualified MaxLenTest
 import qualified MigrationColumnLengthTest
 import qualified MigrationIdempotencyTest
 import qualified MigrationOnlyTest
-import qualified MpsNoPrefixTest
 import qualified MpsCustomPrefixTest
-import qualified PersistentTest
+import qualified MpsNoPrefixTest
 import qualified PersistUniqueTest
+import qualified PersistentTest
 -- FIXME: Not used... should it be?
 -- import qualified PrimaryTest
 import qualified RawSqlTest
 import qualified ReadWriteTest
 import qualified Recursive
 -- TODO: can't use this as MySQL can't do DEFAULT CURRENT_DATE
+import qualified CustomConstraintTest
+import qualified ForeignKey
+import qualified GeneratedColumnTestSQL
+import qualified ImplicitUuidSpec
+import qualified LongIdentifierTest
 import qualified RenameTest
 import qualified SumTypeTest
 import qualified TransactionLevelTest
 import qualified UniqueTest
 import qualified UpsertTest
-import qualified CustomConstraintTest
-import qualified LongIdentifierTest
-import qualified GeneratedColumnTestSQL
-import qualified ForeignKey
-import qualified ImplicitUuidSpec
 
 type Tuple a b = (a, b)
 
@@ -171,9 +175,11 @@ main = do
         Recursive.specsWith db
         SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate))
         MigrationOnlyTest.specsWith db
-            (Just
-                $ runMigrationSilent MigrationOnlyTest.migrateAll1
-                >> runMigrationSilent MigrationOnlyTest.migrateAll2
+            (Just $ do
+                void $ rawExecute "DROP TABLE IF EXISTS referencing;" []
+                void $ rawExecute "DROP TABLE IF EXISTS two_field;" []
+                void $ runMigrationSilent MigrationOnlyTest.migrateAll1
+                void $ runMigrationSilent MigrationOnlyTest.migrateAll2
             )
         PersistentTest.specsWith db
         PersistentTest.filterOrSpecs db

persistent-postgresql/Database/Persist/Postgresql.hs

@@ -398,7 +398,7 @@ insertSql' ent vals =
     sql = T.concat
         [ "INSERT INTO "
         , escapeE $ getEntityDBName ent
-        , if null (getEntityFields ent)
+        , if null (getEntityFieldsDatabase ent)
             then " DEFAULT VALUES"
             else T.concat
                 [ "("
@@ -1738,7 +1738,7 @@ mockMigration mig = do
 putManySql :: EntityDef -> Int -> Text
 putManySql ent n = putManySql' conflictColumns fields ent n
   where
-    fields = getEntityFields ent
+    fields = getEntityFieldsDatabase ent
     conflictColumns = concatMap (map (escapeF . snd) . uniqueFields) (getEntityUniques ent)
 
 repsertManySql :: EntityDef -> Int -> Text
@@ -1928,7 +1928,7 @@ mkBulkUpsertQuery records conn fieldValues updates filters uniqDef =
     firstField = case entityFieldNames of
         [] -> error "The entity you're trying to insert does not have any fields."
         (field:_) -> field
-    entityFieldNames = map fieldDbToText (getEntityFields entityDef')
+    entityFieldNames = map fieldDbToText (getEntityFieldsDatabase entityDef')
     nameOfTable = escapeE . getEntityDBName $ entityDef'
     copyUnlessValues = map snd fieldsToMaybeCopy
     recordValues = concatMap (map toPersistValue . toPersistFields) records

persistent-postgresql/test/PgInit.hs

@@ -107,8 +107,6 @@ import qualified Data.Text.Encoding as TE
 import Test.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=))
 import Test.QuickCheck
 
-import Web.PathPieces
-import Web.Internal.HttpApiData
 import Control.Monad (unless, (>=>))
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Logger

persistent-sqlite/Database/Persist/Sqlite.hs

@@ -375,7 +375,7 @@ insertSql' ent vals =
     notGenerated =
         isNothing . fieldGenerated
     cols =
-        filter notGenerated $ getEntityFields ent
+        filter notGenerated $ getEntityFieldsDatabase ent
 
 execute' :: Sqlite.Connection -> Sqlite.Statement -> [PersistValue] -> IO Int64
 execute' conn stmt vals = flip finally (liftIO $ Sqlite.reset conn stmt) $ do
@@ -497,7 +497,7 @@ safeToRemove :: EntityDef -> FieldNameDB -> Bool
 safeToRemove def (FieldNameDB colName)
     = any (elem FieldAttrSafeToRemove . fieldAttrs)
     $ filter ((== FieldNameDB colName) . fieldDB)
-    $ getEntityFields def
+    $ getEntityFieldsDatabase def
 
 getCopyTable :: [EntityDef]
              -> (Text -> IO Statement)
@@ -674,7 +674,7 @@ escape s =
 putManySql :: EntityDef -> Int -> Text
 putManySql ent n = putManySql' conflictColumns fields ent n
   where
-    fields = getEntityFields ent
+    fields = getEntityFieldsDatabase ent
     conflictColumns = concatMap (map (escapeF . snd) . uniqueFields) (getEntityUniques ent)
 
 repsertManySql :: EntityDef -> Int -> Text

persistent-test/src/MigrationOnlyTest.hs

@@ -1,11 +1,14 @@
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeApplications, UndecidableInstances #-}
+
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
 module MigrationOnlyTest (specsWith, migrateAll1, migrateAll2) where
 
 import qualified Data.Text as T
 
 import Database.Persist.TH
 import Init
+import Database.Persist.EntityDef
 
 share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll1"] [persistLowerCase|
 TwoField1 sql=two_field
@@ -33,6 +36,26 @@ specsWith
     -> Maybe (ReaderT backend m a)
     -> Spec
 specsWith runDb mmigrate = describe "MigrationOnly field" $ do
+    let
+        edef =
+            entityDef $ Proxy @TwoField
+    describe "getEntityFields" $ do
+        let
+            fields =
+                getEntityFields edef
+        it "should have two fields" $ do
+            length fields `shouldBe` 2
+        it "should not have any migration only fields" $ do
+            fields `shouldSatisfy` all isHaskellField
+
+    describe "getEntityFieldsDatabase" $ do
+        let
+            fields =
+                getEntityFieldsDatabase edef
+        it "should have three fields" $ do
+            length fields `shouldBe` 3
+        it "should have at one migration only field" $ do
+            length (filter (not . isHaskellField) fields) `shouldBe` 1
     it "doesn't have the field in the Haskell entity" $ asIO $ runDb $ do
         sequence_ mmigrate
         sequence_ mmigrate

persistent-test/src/PersistentTestModels.hs

@@ -18,7 +18,7 @@ import Data.Text (append)
 -- just need to ensure this compiles
 import PersistentTestModelsImports()
 
-share [mkPersist persistSettings { mpsGeneric = True },  mkMigrate "testMigrate", mkDeleteCascade persistSettings, mkSave "_ignoredSave"] [persistUpperCase|
+share [mkPersist persistSettings { mpsGeneric = True },  mkMigrate "testMigrate", mkDeleteCascade persistSettings] [persistUpperCase|
 
 -- Dedented comment
   -- Header-level comment

persistent-test/src/Recursive.hs

@@ -1,16 +1,21 @@
 {-# LANGUAGE UndecidableInstances #-}
+
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
 module Recursive (specsWith, recursiveMigrate, cleanup) where
 
 import Init
 
 share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "recursiveMigrate"] [persistLowerCase|
+
 SubType
   object [MenuObject]
   deriving Show Eq
+
 MenuObject
   sub SubType Maybe
   deriving Show Eq
+
 |]
 
 cleanup

persistent/ChangeLog.md

@@ -2,6 +2,15 @@
 
 ## 2.13.0.0 (unreleased)
 
+* [#1252](https://github.com/yesodweb/persistent/pull/1252)
+    * `mkMigrate` now defers to `mkEntityDefList` and `migrateModels` instead of
+      fixing the foreign key references itself.
+    * `mkSave` was deprecated - the function did not fix foreign key references.
+      Please use `mkEntityDefList` instead.
+    * `EntityDef` will now include fields marked `MigrationOnly` and
+      `SafeToRemove`. Beforehand, those were filtered out, and `mkMigrate`
+      applied. The function `getEntityFields` wll only return fields defined on
+      the Haskell type - for all columns, see `getEntityFieldsDatabase`.
 * [#1225](https://github.com/yesodweb/persistent/pull/1225)
     * The fields and constructor for `SqlBackend` are no longer exported by
       default. They are available from an internal module,

persistent/Database/Persist/EntityDef.hs

@@ -10,6 +10,7 @@ module Database.Persist.EntityDef
     , getEntityHaskellName
     , getEntityDBName
     , getEntityFields
+    , getEntityFieldsDatabase
     , getEntityForeignDefs
     , getEntityUniques
     , getEntityId
@@ -30,6 +31,7 @@ import Data.Text (Text)
 import Data.Map (Map)
 
 import Database.Persist.EntityDef.Internal
+import Database.Persist.FieldDef (isHaskellField)
 
 import Database.Persist.Types.Base
     ( UniqueDef
@@ -92,11 +94,29 @@ getEntityForeignDefs = entityForeigns
 -- will return the key columns if you used the @Primary@ syntax for defining the
 -- primary key.
 --
+-- This does not return fields that are marked 'SafeToRemove' or 'MigrationOnly'
+-- - so it only returns fields that are represented in the Haskell type. If you
+-- need those fields, use 'getEntityFieldsDatabase'.
+--
 -- @since 2.13.0.0
 getEntityFields
     :: EntityDef
     -> [FieldDef]
-getEntityFields = entityFields
+getEntityFields = filter isHaskellField . entityFields
+
+-- | This returns all of the 'FieldDef' defined for the 'EntityDef', including
+-- those fields that are marked as 'MigrationOnly' (and therefore only present
+-- in the database) or 'SafeToRemove' (and a migration will drop the column if
+-- it exists in the database).
+--
+-- For all the fields that are present on the Haskell-type, see
+-- 'getEntityFields'.
+--
+-- @since 2.13.0.0
+getEntityFieldsDatabase
+    :: EntityDef
+    -> [FieldDef]
+getEntityFieldsDatabase = entityFields
 
 -- |
 --
@@ -125,12 +145,19 @@ getEntityKeyFields
     -> [FieldDef]
 getEntityKeyFields = entityKeyFields
 
+-- | TODO
+--
+-- @since 2.13.0.0
 setEntityFields :: [FieldDef] -> EntityDef -> EntityDef
 setEntityFields fd ed = ed { entityFields = fd }
 
+-- | Perform a mapping function over all of the entity fields, as determined by
+-- 'getEntityFieldsDatabase'.
+--
+-- @since 2.13.0.0
 overEntityFields
     :: ([FieldDef] -> [FieldDef])
     -> EntityDef
     -> EntityDef
 overEntityFields f ed =
-    setEntityFields (f (getEntityFields ed)) ed
+    setEntityFields (f (getEntityFieldsDatabase ed)) ed

persistent/Database/Persist/FieldDef.hs

@@ -6,6 +6,7 @@ module Database.Persist.FieldDef
       FieldDef
       -- ** Helpers
     , isFieldNotGenerated
+    , isHaskellField
       -- * 'FieldCascade'
     , FieldCascade(..)
     , renderFieldCascade
@@ -15,3 +16,8 @@ module Database.Persist.FieldDef
     ) where
 
 import Database.Persist.FieldDef.Internal
+
+import Database.Persist.Types.Base
+    ( isHaskellField
+    )
+