sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 02:34:51 +09:00
Code Issues 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.IO.Class
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Data.Aeson
@ -45,6 +46,7 @@ import Database.Persist
import Database.Persist.BackendDataType (backendDataType, PersistDefault (..))
import Database.Persist.Migration
import Database.Persist.Schema (SchemaT, Migration)
import Database.Persist.Schema.SQL
import Database.Persist.Schema.Types hiding (Entity)
import Database.Persist.Schema.PostgreSQL (schemaBackend)
import Database.Persist.Sql (SqlBackend, toSqlKey, fromSqlKey)
@ -2707,6 +2709,12 @@ changes hLocal ctx =
migrateDB
:: (MonadSite m, SiteEnv m ~ App)
=> Host -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))
migrateDB hLocal ctx =
let f cs = fmap (, length cs) <$> runMigrations schemaBackend "" 1 cs
in f $ changes hLocal ctx
migrateDB hLocal ctx = runExceptT $ do
ExceptT $ flip runReaderT (schemaBackend, "") $ runExceptT $ do
foreigns <- lift findMisnamedForeigns
unless (null foreigns) $
throwE $ T.intercalate " ; " (map displayMisnamedForeign foreigns)
let migrations = changes hLocal ctx
(,length migrations) <$>
ExceptT (runMigrations schemaBackend "" 1 migrations)