forge/Vervis
1
0
Fork 0
Code Pull requests Activity

DB: Migration: Check for surprisingly named foreign constraints, fail if found

Browse source 
Because finding them may be a sign of undetected error in the migration plan,
so it's best to stop and find it
This commit is contained in:
fr33domlover 2022-09-26 12:48:21 +00:00
parent 0e6a9d3269
commit 206d140b95
1 changed files with 11 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
src/Vervis/Migration.hs
View file

@ -24,6 +24,7 @@ import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Data.Aeson import Data.Aeson
@ -45,6 +46,7 @@ import Database.Persist
import Database.Persist.BackendDataType (backendDataType, PersistDefault (..)) import Database.Persist.BackendDataType (backendDataType, PersistDefault (..))
import Database.Persist.Migration import Database.Persist.Migration
import Database.Persist.Schema (SchemaT, Migration) import Database.Persist.Schema (SchemaT, Migration)
import Database.Persist.Schema.SQL
import Database.Persist.Schema.Types hiding (Entity) import Database.Persist.Schema.Types hiding (Entity)
import Database.Persist.Schema.PostgreSQL (schemaBackend) import Database.Persist.Schema.PostgreSQL (schemaBackend)
import Database.Persist.Sql (SqlBackend, toSqlKey, fromSqlKey) import Database.Persist.Sql (SqlBackend, toSqlKey, fromSqlKey)
@ -2707,6 +2709,12 @@ changes hLocal ctx =
migrateDB migrateDB
:: (MonadSite m, SiteEnv m ~ App) :: (MonadSite m, SiteEnv m ~ App)
=> Host -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int)) => Host -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))
migrateDB hLocal ctx = migrateDB hLocal ctx = runExceptT $ do
let f cs = fmap (, length cs) <$> runMigrations schemaBackend "" 1 cs ExceptT $ flip runReaderT (schemaBackend, "") $ runExceptT $ do
in f $ changes hLocal ctx foreigns <- lift findMisnamedForeigns
unless (null foreigns) $
throwE $ T.intercalate " ; " (map displayMisnamedForeign foreigns)
let migrations = changes hLocal ctx
(,length migrations) <$>
ExceptT (runMigrations schemaBackend "" 1 migrations)