module Sqel.Migration.Transform where import qualified Data.Map as Map import Hasql.Statement (Statement) import Lens.Micro ((^.)) import Sqel (MkTableSchema (tableSchema)) import Sqel.Class.MigrationEffect (MigrationEffect (runStatement, runStatement_)) import Sqel.Data.Dd (Dd, DdType) import qualified Sqel.Data.Migration as Migration import Sqel.Data.Migration ( CompAction, CustomMigration (customMigration), Mig (Mig), Migration, MigrationActions (CustomActions), ) import Sqel.Data.PgTypeName (PgCompName, pattern PgTypeName) import Sqel.Data.Sql (sql, toSql) import Sqel.Data.SqlFragment (Insert (Insert), Select (Select)) import Sqel.Data.TableSchema (TableSchema) import Sqel.ReifyDd (ReifyDd) import Sqel.Sql.Type (createTable) import Sqel.Statement (plain, prepared, unprepared) import Sqel.Migration.Ddl (DdlTypes, ddTable) import Sqel.Migration.Run (autoKeys, runTypesMigration) import Sqel.Migration.Table (MigrationTables (withMigrationTables)) import Sqel.Migration.Type (TypeChanges (typeChanges)) data MigrateTransform m old new = MigrateTransform { forall (m :: * -> *) old new. MigrateTransform m old new -> [old] -> m [new] trans :: [old] -> m [new], forall (m :: * -> *) old new. MigrateTransform m old new -> Map PgCompName CompAction types :: Map PgCompName CompAction, forall (m :: * -> *) old new. MigrateTransform m old new -> TableSchema old schemaOld :: TableSchema old, forall (m :: * -> *) old new. MigrateTransform m old new -> TableSchema new schemaNew :: TableSchema new } class MkMigrateTransform m old new where migrateTransform :: Dd old -> Dd new -> ([DdType old] -> m [DdType new]) -> Migration ('Mig (DdType old) (DdType new) m (MigrateTransform m (DdType old) (DdType new))) instance ( DdlTypes 'True old (oldTable : oldTypes), DdlTypes 'True new (newTable : newTypes), TypeChanges oldTypes newTypes, MkTableSchema old, MkTableSchema new, ReifyDd old, ReifyDd new ) => MkMigrateTransform m old new where migrateTransform :: Dd old -> Dd new -> ([DdType old] -> m [DdType new]) -> Migration ('Mig (DdType old) (DdType new) m (MigrateTransform m (DdType old) (DdType new))) migrateTransform Dd old old Dd new new [DdType old] -> m [DdType new] f = forall (m :: * -> *) (old :: DdK) (new :: DdK) ext. MigrationTables m old new => MigrationActions ext -> Dd old -> Dd new -> Migration ('Mig (DdType old) (DdType new) m ext) withMigrationTables (forall ext. ext -> MigrationActions ext CustomActions MigrateTransform m (DdType old) (DdType new) actions) Dd old old Dd new new where actions :: MigrateTransform m (DdType old) (DdType new) actions = MigrateTransform { $sel:trans:MigrateTransform :: [DdType old] -> m [DdType new] trans = [DdType old] -> m [DdType new] f, $sel:types:MigrateTransform :: Map PgCompName CompAction types = forall k a. Ord k => [(k, a)] -> Map k a Map.fromList (forall (old :: [DdlTypeK]) (new :: [DdlTypeK]). TypeChanges old new => NP DdlType old -> NP DdlType new -> [(PgCompName, CompAction)] typeChanges NP DdlType oldTypes oldTypes NP DdlType newTypes newTypes), TableSchema (DdType old) TableSchema (DdType new) schemaNew :: TableSchema (DdType new) schemaOld :: TableSchema (DdType old) $sel:schemaNew:MigrateTransform :: TableSchema (DdType new) $sel:schemaOld:MigrateTransform :: TableSchema (DdType old) .. } schemaOld :: TableSchema (DdType old) schemaOld = forall (table :: DdK). MkTableSchema table => Dd table -> TableSchema (DdType table) tableSchema Dd old old schemaNew :: TableSchema (DdType new) schemaNew = forall (table :: DdK). MkTableSchema table => Dd table -> TableSchema (DdType table) tableSchema Dd new new (DdlType oldTable _, NP DdlType oldTypes oldTypes) = forall (s :: DdK) (table :: DdlTypeK) (types :: [DdlTypeK]). DdlTypes 'True s (table : types) => Dd s -> (DdlType table, NP DdlType types) ddTable Dd old old (DdlType newTable _, NP DdlType newTypes newTypes) = forall (s :: DdK) (table :: DdlTypeK) (types :: [DdlTypeK]). DdlTypes 'True s (table : types) => Dd s -> (DdlType table, NP DdlType types) ddTable Dd new new transformAndMigrate :: ∀ old new m . Monad m => MigrationEffect m => Set PgCompName -> MigrateTransform m old new -> m () transformAndMigrate :: forall old new (m :: * -> *). (Monad m, MigrationEffect m) => Set PgCompName -> MigrateTransform m old new -> m () transformAndMigrate Set PgCompName eligible MigrateTransform {Map PgCompName CompAction TableSchema old TableSchema new [old] -> m [new] schemaNew :: TableSchema new schemaOld :: TableSchema old types :: Map PgCompName CompAction trans :: [old] -> m [new] $sel:schemaNew:MigrateTransform :: forall (m :: * -> *) old new. MigrateTransform m old new -> TableSchema new $sel:schemaOld:MigrateTransform :: forall (m :: * -> *) old new. MigrateTransform m old new -> TableSchema old $sel:types:MigrateTransform :: forall (m :: * -> *) old new. MigrateTransform m old new -> Map PgCompName CompAction $sel:trans:MigrateTransform :: forall (m :: * -> *) old new. MigrateTransform m old new -> [old] -> m [new] ..} = do [old] oldRows <- forall (m :: * -> *) q a. MigrationEffect m => q -> Statement q [a] -> m [a] runStatement () Statement () [old] fetchOld [new] newRows <- [old] -> m [new] trans [old] oldRows forall (m :: * -> *). (Monad m, MigrationEffect m) => Set PgCompName -> Map PgCompName CompAction -> m () runTypesMigration Set PgCompName eligible Map PgCompName CompAction types Sql -> m () runPlain [sql|alter table ##{schemaOld ^. #pg . #name} rename to "##{oldName}-migration-temp"|] Sql -> m () runPlain (forall {k} (a :: k). PgTable a -> Sql createTable (TableSchema new schemaNew forall s a. s -> Getting a s a -> a ^. forall a. IsLabel "pg" a => a #pg)) forall (t :: * -> *) (f :: * -> *) a b. (Foldable t, Applicative f) => t a -> (a -> f b) -> f () for_ [new] newRows \ new row -> forall (m :: * -> *) q. MigrationEffect m => q -> Statement q () -> m () runStatement_ new row Statement new () insertNew where PgTypeName Text oldName = TableSchema old schemaOld forall s a. s -> Getting a s a -> a ^. forall a. IsLabel "pg" a => a #pg forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. IsLabel "name" a => a #name runPlain :: Sql -> m () runPlain = forall (m :: * -> *) q. MigrationEffect m => q -> Statement q () -> m () runStatement_ () forall b c a. (b -> c) -> (a -> b) -> a -> c . Sql -> Statement () () plain fetchOld :: Statement () [old] fetchOld :: Statement () [old] fetchOld = forall result d p. ResultShape d result => Sql -> Row d -> Params p -> Statement p result unprepared [sql|##{Select schemaOld}|] (TableSchema old schemaOld forall s a. s -> Getting a s a -> a ^. forall a. IsLabel "decoder" a => a #decoder) forall a. Monoid a => a mempty insertNew :: Statement new () insertNew :: Statement new () insertNew = forall d result p. ResultShape d result => Sql -> Row d -> Params p -> Statement p result prepared (forall a. ToSql a => a -> Sql toSql (forall a. a -> Insert a Insert (TableSchema new schemaNew forall s a. s -> Getting a s a -> a ^. forall a. IsLabel "pg" a => a #pg))) forall (f :: * -> *). Applicative f => f () unit (TableSchema new schemaNew forall s a. s -> Getting a s a -> a ^. forall a. IsLabel "encoder" a => a #encoder) instance ( Monad m, MigrationEffect m ) => CustomMigration m ('Mig old new m (MigrateTransform m old new)) where customMigration :: PgTypeName 'True -> Set PgCompName -> MigExt ('Mig old new m (MigrateTransform m old new)) -> m () customMigration PgTypeName 'True _ = forall old new (m :: * -> *). (Monad m, MigrationEffect m) => Set PgCompName -> MigrateTransform m old new -> m () transformAndMigrate customTypeKeys :: MigExt ('Mig old new m (MigrateTransform m old new)) -> m (Set (PgCompName, Bool)) customTypeKeys MigrateTransform {Map PgCompName CompAction types :: Map PgCompName CompAction $sel:types:MigrateTransform :: forall (m :: * -> *) old new. MigrateTransform m old new -> Map PgCompName CompAction types} = forall (f :: * -> *) a. Applicative f => a -> f a pure (Map PgCompName CompAction -> Set (PgCompName, Bool) autoKeys Map PgCompName CompAction types)