@@ -17,12 +17,17 @@ module Squeal.PostgreSQL.Migration
1717 , migrateUp
1818 , migrateDown
1919 , MigrationTable
20+ , createMigration
21+ , insertStep
22+ , deleteStep
23+ , selectStep
2024 ) where
2125
2226import Control.Category
2327import Control.Monad
2428import Control.Monad.Base
2529import Control.Monad.Trans.Control
30+import Generics.SOP (K(..))
2631import Data.Function ((&))
2732import Prelude hiding (id, (.))
2833
@@ -52,71 +57,93 @@ instance Category (Migration io) where
5257
5358migrateUp
5459 :: MonadBaseControl IO io
55− => Migration io schema0 schema1
56− -> PQ schema0 schema1 io ()
60+ => Migration io schema0 schema1 -> PQ
61+ ("migration" ::: MigrationTable ': schema0)
62+ ("migration" ::: MigrationTable ': schema1)
63+ io ()
5764migrateUp migration = start & pqThen (upSteps migration & pqBind end)
5865
5966migrateDown
6067 :: MonadBaseControl IO io
61− => Migration io schema0 schema1
62− -> PQ schema1 schema0 io ()
68+ => Migration io schema0 schema1 -> PQ
69+ ("migration" ::: MigrationTable ': schema1)
70+ ("migration" ::: MigrationTable ': schema0)
71+ io ()
6372migrateDown migration = start & pqThen (downSteps migration & pqBind end)
6473
65−type MigrationTable = "schema_migrations" :::
74+type MigrationTable =
6675 '[ "unique_name" ::: 'Unique '["name"]] :=>
6776 '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
6877 , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
6978 ]
7079
71−createMigrations :: Definition '[] '[MigrationTable]
72−createMigrations = UnsafeDefinition $ renderDefinition $
73− createTableIfNotExists #schema_migrations
80+createMigration
81+ :: Has "migration" schema MigrationTable
82+ => Definition schema schema
83+createMigration =
84+ createTableIfNotExists #migration
7485 ( (text & notNull) `As` #name :*
75− (timestampWithTimeZone & notNull) `As` #executed_at :* Nil )
86+ (timestampWithTimeZone & notNull & default_ currentTimestamp)
87+ `As` #executed_at :* Nil )
7688 ( unique (Column #name :* Nil) `As` #unique_name :* Nil )
7789
78−insertMigration :: Manipulation '[MigrationTable] '[ 'NotNull 'PGtext] '[]
79−insertMigration = insertRow_ #schema_migrations
90+insertStep
91+ :: Has "migration" schema MigrationTable
92+ => Manipulation schema '[ 'NotNull 'PGtext] '[]
93+insertStep = insertRow_ #migration
8094 ( Set (param @1) `As` #name :*
8195 Default `As` #executed_at :* Nil )
8296
83−deleteMigration :: Manipulation '[MigrationTable] '[ 'NotNull 'PGtext] '[]
84−deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
97+deleteStep
98+ :: Has "migration" schema MigrationTable
99+ => Manipulation schema '[ 'NotNull 'PGtext ] '[]
100+deleteStep = deleteFrom_ #migration (#name .== param @1)
85101
86−selectMigration :: Query '[MigrationTable] '[ 'NotNull 'PGtext]
87− '["executed_at" ::: 'NotNull 'PGtimestamptz]
88−selectMigration = select
102+selectStep
103+ :: Has "migration" schema MigrationTable
104+ => Query schema '[ 'NotNull 'PGtext ]
105+ '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]
106+selectStep = select
89107 (#executed_at `As` #executed_at :* Nil)
90− ( from (table (#schema_migrations `As` #m))
108+ ( from (table (#migration `As` #m))
91109 & where_ (#name .== param @1))
92110
93−start :: MonadBase IO io => PQ schema schema io ()
94−start = define createMigrations_
111+start
112+ :: MonadBase IO io => PQ
113+ ("migration" ::: MigrationTable ': schema)
114+ ("migration" ::: MigrationTable ': schema)
115+ io ()
116+start = define createMigration
95117 & pqThen (begin (TransactionMode RepeatableRead ReadWrite) & void)
96− where
97− createMigrations_ :: Definition schema schema
98− createMigrations_ = UnsafeDefinition $
99− renderDefinition createMigrations
100118
101119upSteps
102120 :: MonadBaseControl IO io
103121 => Migration io schema0 schema1
104− -> PQ schema0 schema1 io ()
122+ -> PQ
123+ ("migration" ::: MigrationTable ': schema0)
124+ ("migration" ::: MigrationTable ': schema1)
125+ io ()
105126upSteps = \case
106127 Done -> return ()
107− step :>> steps ->
108− onExceptionRollback (up step)
109− & pqThen (upSteps steps)
128+ step :>> steps -> onExceptionRollback $
129+ pqEmbed (up step) & pqThen (upSteps steps)
110130
111131downSteps
112132 :: MonadBaseControl IO io
113− => Migration io schema0 schema1
114− -> PQ schema1 schema0 io ()
133+ => Migration io schema0 schema1 -> PQ
134+ ("migration" ::: MigrationTable ': schema1)
135+ ("migration" ::: MigrationTable ': schema0)
136+ io ()
115137downSteps = \case
116138 Done -> return ()
117− step :>> steps ->
118− downSteps steps
119− & pqThen (onExceptionRollback (down step))
139+ step :>> steps -> onExceptionRollback $
140+ downSteps steps & pqThen (pqEmbed (down step))
120141
121−end :: MonadBase IO io => result -> PQ schema schema io result
142+end :: MonadBase IO io => result -> PQ
143+ ("migration" ::: MigrationTable ': schema)
144+ ("migration" ::: MigrationTable ': schema)
145+ io result
122146end result = commit >> return result
147+
148+avoid :: Monad m => PQ schema0 schema1 m ()
149+avoid = PQ $ \ _ -> return (K ())