@@ -11,11 +11,13 @@
1111#-}
1212
1313module Squeal.PostgreSQL.Migration
14− ( Migration (..)
15− , Step (..)
16− , skip
14+ ( -- * Migration
15+ Migration (..)
1716 , migrateUp
1817 , migrateDown
18+ -- * Step
19+ , Step (..)
20+ -- * MigrationTable
1921 , MigrationTable
2022 , createMigration
2123 , insertStep
@@ -29,19 +31,22 @@ import Control.Monad.Base
2931import Control.Monad.Trans.Control
3032import Generics.SOP (K(..))
3133import Data.Function ((&))
34+import Data.Text (Text)
3235import Prelude hiding (id, (.))
3336
3437import Squeal.PostgreSQL
3538import Squeal.PostgreSQL.Transaction
3639
40+-- | A `Step` of a `Migration`, should contain an inverse pair of
41+-- `up` and `down` instructions.
3742data Step io schema0 schema1 = Step
38− { up :: PQ schema0 schema1 io ()
39− , down :: PQ schema1 schema0 io ()
43+ { name :: Text -- ^ The `name` of a `Step`.
44+ -- Each `name` in a `Migration` should be unique.
45+ , up :: PQ schema0 schema1 io () -- ^ The `up` instruction of a `Step`.
46+ , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Step`.
4047 }
4148
42−skip :: Monad io => Step io schema schema -> Step io schema schema
43−skip _ = Step (return ()) (return ())
44−
49+-- | A `Migration` is a chain of `Step`s
4550data Migration io schema0 schema1 where
4651 Done :: Migration io schema schema
4752 (:>>)
@@ -55,28 +60,126 @@ instance Category (Migration io) where
5560 Done -> migration
5661 step :>> steps -> step :>> (steps >>> migration)
5762
63+
64+-- | Run a `Migration` by creating the `MigrationTable`
65+-- if it does not exist and then for each each `Step`
66+-- query to see if the `Step` is executed. If not, then
67+-- execute the `Step` and insert its row in `MigrationTable`.
5868migrateUp
5969 :: MonadBaseControl IO io
60− => Migration io schema0 schema1 -> PQ
70+ => Migration io schema0 schema1 -- ^ migration to run
71+ -> PQ
6172 ("migration" ::: MigrationTable ': schema0)
6273 ("migration" ::: MigrationTable ': schema1)
6374 io ()
64−migrateUp migration = start & pqThen (upSteps migration & pqBind end)
65−
75+migrateUp migration =
76+ define createMigration
77+ & pqThen (begin (TransactionMode RepeatableRead ReadWrite))
78+ & pqThen (upSteps migration)
79+ & pqThen (void commit)
80+ where
81+
82+ upSteps
83+ :: MonadBaseControl IO io
84+ => Migration io schema0 schema1
85+ -> PQ
86+ ("migration" ::: MigrationTable ': schema0)
87+ ("migration" ::: MigrationTable ': schema1)
88+ io ()
89+ upSteps = \case
90+ Done -> return ()
91+ step :>> steps -> onExceptionRollback $
92+ upStep step
93+ & pqThen (upSteps steps)
94+
95+ queryExecuted
96+ :: MonadBase IO io
97+ => Step io schema0 schema1 -> PQ
98+ ("migration" ::: MigrationTable ': schema0)
99+ ("migration" ::: MigrationTable ': schema0)
100+ io RowNumber
101+ queryExecuted =
102+ ntuples <=< runQueryParams selectStep . Only . name
103+
104+ upStep
105+ :: MonadBase IO io
106+ => Step io schema0 schema1 -> PQ
107+ ("migration" ::: MigrationTable ': schema0)
108+ ("migration" ::: MigrationTable ': schema1)
109+ io ()
110+ upStep step =
111+ queryExecuted step
112+ & pqBind (\ (RowNumber executed) ->
113+ if executed == 1 -- up step has already been executed
114+ then PQ (\ _ -> return (K ())) -- unsafely switch schemas
115+ else
116+ pqEmbed (up step) -- safely switch schemas
117+ & pqThen (manipulateParams insertStep (Only (name step)) & void))
118+ -- insert up step execution record
119+
120+-- | Rewind a `Migration` by creating the `MigrationTable`
121+-- if it does not exist and then for each each `Step`
122+-- query to see if the `Step` is executed. If it is, then
123+-- rewind the `Step` and delete its row in `MigrationTable`.
66124migrateDown
67125 :: MonadBaseControl IO io
68− => Migration io schema0 schema1 -> PQ
69− ("migration" ::: MigrationTable ': schema1)
70− ("migration" ::: MigrationTable ': schema0)
71− io ()
72−migrateDown migration = start & pqThen (downSteps migration & pqBind end)
73−
126+ => Migration io schema0 schema1 -- ^ migration to rewind
127+ -> PQ
128+ ("migration" ::: MigrationTable ': schema1)
129+ ("migration" ::: MigrationTable ': schema0)
130+ io ()
131+migrateDown migration =
132+ define createMigration
133+ & pqThen (begin (TransactionMode RepeatableRead ReadWrite) & void)
134+ & pqThen (downSteps migration)
135+ & pqThen (void commit)
136+ where
137+
138+ queryExecuted
139+ :: MonadBase IO io
140+ => Step io schema0 schema1 -> PQ
141+ ("migration" ::: MigrationTable ': schema1)
142+ ("migration" ::: MigrationTable ': schema1)
143+ io RowNumber
144+ queryExecuted =
145+ ntuples <=< runQueryParams selectStep . Only . name
146+
147+ downStep
148+ :: MonadBase IO io
149+ => Step io schema0 schema1 -> PQ
150+ ("migration" ::: MigrationTable ': schema1)
151+ ("migration" ::: MigrationTable ': schema0)
152+ io ()
153+ downStep step =
154+ queryExecuted step
155+ & pqBind (\ (RowNumber executed) ->
156+ if executed == 0 -- up step has not been executed
157+ then PQ (\ _ -> return (K ())) -- unsafely switch schemas
158+ else
159+ pqEmbed (down step) -- safely switch schemas
160+ & pqThen (manipulateParams deleteStep (Only (name step)) & void))
161+ -- delete up step execution record
162+
163+ downSteps
164+ :: MonadBaseControl IO io
165+ => Migration io schema0 schema1 -> PQ
166+ ("migration" ::: MigrationTable ': schema1)
167+ ("migration" ::: MigrationTable ': schema0)
168+ io ()
169+ downSteps = \case
170+ Done -> return ()
171+ step :>> steps -> onExceptionRollback $
172+ downSteps steps
173+ & pqThen (downStep step)
174+
175+-- | The `TableType` for a Squeal migration.
74176type MigrationTable =
75177 '[ "unique_name" ::: 'Unique '["name"]] :=>
76178 '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
77179 , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
78180 ]
79181
182+-- | Creates a `MigrationTable` if it does not already exist.
80183createMigration
81184 :: Has "migration" schema MigrationTable
82185 => Definition schema schema
@@ -87,6 +190,7 @@ createMigration =
87190 `As` #executed_at :* Nil )
88191 ( unique (Column #name :* Nil) `As` #unique_name :* Nil )
89192
193+-- | Inserts a `Step` into the `MigrationTable`
90194insertStep
91195 :: Has "migration" schema MigrationTable
92196 => Manipulation schema '[ 'NotNull 'PGtext] '[]
@@ -94,11 +198,14 @@ insertStep = insertRow_ #migration
94198 ( Set (param @1) `As` #name :*
95199 Default `As` #executed_at :* Nil )
96200
201+-- | Deletes a `Step` from the `MigrationTable`
97202deleteStep
98203 :: Has "migration" schema MigrationTable
99204 => Manipulation schema '[ 'NotNull 'PGtext ] '[]
100205deleteStep = deleteFrom_ #migration (#name .== param @1)
101206
207+-- | Selects a `Step` from the `MigrationTable`, returning
208+-- the time at which it was executed.
102209selectStep
103210 :: Has "migration" schema MigrationTable
104211 => Query schema '[ 'NotNull 'PGtext ]
@@ -107,43 +214,3 @@ selectStep = select
107214 (#executed_at `As` #executed_at :* Nil)
108215 ( from (table (#migration `As` #m))
109216 & where_ (#name .== param @1))
110−
111−start
112− :: MonadBase IO io => PQ
113− ("migration" ::: MigrationTable ': schema)
114− ("migration" ::: MigrationTable ': schema)
115− io ()
116−start = define createMigration
117− & pqThen (begin (TransactionMode RepeatableRead ReadWrite) & void)
118−
119−upSteps
120− :: MonadBaseControl IO io
121− => Migration io schema0 schema1
122− -> PQ
123− ("migration" ::: MigrationTable ': schema0)
124− ("migration" ::: MigrationTable ': schema1)
125− io ()
126−upSteps = \case
127− Done -> return ()
128− step :>> steps -> onExceptionRollback $
129− pqEmbed (up step) & pqThen (upSteps steps)
130−
131−downSteps
132− :: MonadBaseControl IO io
133− => Migration io schema0 schema1 -> PQ
134− ("migration" ::: MigrationTable ': schema1)
135− ("migration" ::: MigrationTable ': schema0)
136− io ()
137−downSteps = \case
138− Done -> return ()
139− step :>> steps -> onExceptionRollback $
140− downSteps steps & pqThen (pqEmbed (down step))
141−
142−end :: MonadBase IO io => result -> PQ
143− ("migration" ::: MigrationTable ': schema)
144− ("migration" ::: MigrationTable ': schema)
145− io result
146−end result = commit >> return result
147−
148−avoid :: Monad m => PQ schema0 schema1 m ()
149−avoid = PQ $ \ _ -> return (K ())