git.iko.soy/squeal
on dev help sign in
migration work
befc18fEitan Chatav
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+60−33
compare with dev
unifiedsplit
@@ -17,12 +17,17 @@ module Squeal.PostgreSQL.Migration
17 , migrateUp
17 , migrateUp
18 , migrateDown
18 , migrateDown
19 , MigrationTable
19 , MigrationTable
20+ , createMigration
21+ , insertStep
22+ , deleteStep
23+ , selectStep
20 ) where
24 ) where
21
25
22import Control.Category
26import Control.Category
23import Control.Monad
27import Control.Monad
24import Control.Monad.Base
28import Control.Monad.Base
25import Control.Monad.Trans.Control
29import Control.Monad.Trans.Control
30+import Generics.SOP (K(..))
26import Data.Function ((&))
31import Data.Function ((&))
27import Prelude hiding (id, (.))
32import Prelude hiding (id, (.))
28
33
@@ -52,71 +57,93 @@ instance Category (Migration io) where
52
57
53migrateUp
58migrateUp
54 :: MonadBaseControl IO io
59 :: MonadBaseControl IO io
55− => Migration io schema0 schema1
60+ => Migration io schema0 schema1 -> PQ
56− -> PQ schema0 schema1 io ()
61+ ("migration" ::: MigrationTable ': schema0)
62+ ("migration" ::: MigrationTable ': schema1)
63+ io ()
57migrateUp migration = start & pqThen (upSteps migration & pqBind end)
64migrateUp migration = start & pqThen (upSteps migration & pqBind end)
58
65
59migrateDown
66migrateDown
60 :: MonadBaseControl IO io
67 :: MonadBaseControl IO io
61− => Migration io schema0 schema1
68+ => Migration io schema0 schema1 -> PQ
62− -> PQ schema1 schema0 io ()
69+ ("migration" ::: MigrationTable ': schema1)
70+ ("migration" ::: MigrationTable ': schema0)
71+ io ()
63migrateDown migration = start & pqThen (downSteps migration & pqBind end)
72migrateDown migration = start & pqThen (downSteps migration & pqBind end)
64
73
65−type MigrationTable = "schema_migrations" :::
74+type MigrationTable =
66 '[ "unique_name" ::: 'Unique '["name"]] :=>
75 '[ "unique_name" ::: 'Unique '["name"]] :=>
67 '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
76 '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
68 , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
77 , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
69 ]
78 ]
70
79
71−createMigrations :: Definition '[] '[MigrationTable]
80+createMigration
72−createMigrations = UnsafeDefinition $ renderDefinition $
81+ :: Has "migration" schema MigrationTable
82+ => Definition schema schema
83+createMigration =
73− createTableIfNotExists #schema_migrations
84+ createTableIfNotExists #migration
74 ( (text & notNull) `As` #name :*
85 ( (text & notNull) `As` #name :*
75− (timestampWithTimeZone & notNull) `As` #executed_at :* Nil )
86+ (timestampWithTimeZone & notNull & default_ currentTimestamp)
87+ `As` #executed_at :* Nil )
76 ( unique (Column #name :* Nil) `As` #unique_name :* Nil )
88 ( unique (Column #name :* Nil) `As` #unique_name :* Nil )
77
89
90+insertStep
91+ :: Has "migration" schema MigrationTable
78−insertMigration :: Manipulation '[MigrationTable] '[ 'NotNull 'PGtext] '[]
92+ => Manipulation schema '[ 'NotNull 'PGtext] '[]
79−insertMigration = insertRow_ #schema_migrations
93+insertStep = insertRow_ #migration
80 ( Set (param @1) `As` #name :*
94 ( Set (param @1) `As` #name :*
81 Default `As` #executed_at :* Nil )
95 Default `As` #executed_at :* Nil )
82
96
97+deleteStep
98+ :: Has "migration" schema MigrationTable
83−deleteMigration :: Manipulation '[MigrationTable] '[ 'NotNull 'PGtext] '[]
99+ => Manipulation schema '[ 'NotNull 'PGtext ] '[]
84−deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
100+deleteStep = deleteFrom_ #migration (#name .== param @1)
85
101
86−selectMigration :: Query '[MigrationTable] '[ 'NotNull 'PGtext]
102+selectStep
103+ :: Has "migration" schema MigrationTable
104+ => Query schema '[ 'NotNull 'PGtext ]
87− '["executed_at" ::: 'NotNull 'PGtimestamptz]
105+ '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]
88−selectMigration = select
106+selectStep = select
89 (#executed_at `As` #executed_at :* Nil)
107 (#executed_at `As` #executed_at :* Nil)
90− ( from (table (#schema_migrations `As` #m))
108+ ( from (table (#migration `As` #m))
91 & where_ (#name .== param @1))
109 & where_ (#name .== param @1))
92
110
111+start
93−start :: MonadBase IO io => PQ schema schema io ()
112+ :: MonadBase IO io => PQ
113+ ("migration" ::: MigrationTable ': schema)
114+ ("migration" ::: MigrationTable ': schema)
115+ io ()
94−start = define createMigrations_
116+start = define createMigration
95 & pqThen (begin (TransactionMode RepeatableRead ReadWrite) & void)
117 & pqThen (begin (TransactionMode RepeatableRead ReadWrite) & void)
96− where
97− createMigrations_ :: Definition schema schema
98− createMigrations_ = UnsafeDefinition $
99− renderDefinition createMigrations
100
118
101upSteps
119upSteps
102 :: MonadBaseControl IO io
120 :: MonadBaseControl IO io
103 => Migration io schema0 schema1
121 => Migration io schema0 schema1
104− -> PQ schema0 schema1 io ()
122+ -> PQ
123+ ("migration" ::: MigrationTable ': schema0)
124+ ("migration" ::: MigrationTable ': schema1)
125+ io ()
105upSteps = \case
126upSteps = \case
106 Done -> return ()
127 Done -> return ()
107− step :>> steps ->
108− onExceptionRollback (up step)
128+ step :>> steps -> onExceptionRollback $
109− & pqThen (upSteps steps)
129+ pqEmbed (up step) & pqThen (upSteps steps)
110
130
111downSteps
131downSteps
112 :: MonadBaseControl IO io
132 :: MonadBaseControl IO io
113− => Migration io schema0 schema1
133+ => Migration io schema0 schema1 -> PQ
114− -> PQ schema1 schema0 io ()
134+ ("migration" ::: MigrationTable ': schema1)
135+ ("migration" ::: MigrationTable ': schema0)
136+ io ()
115downSteps = \case
137downSteps = \case
116 Done -> return ()
138 Done -> return ()
117− step :>> steps ->
139+ step :>> steps -> onExceptionRollback $
118− downSteps steps
140+ downSteps steps & pqThen (pqEmbed (down step))
119− & pqThen (onExceptionRollback (down step))
120
141
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
122end result = commit >> return result
146end result = commit >> return result
147+
148+avoid :: Monad m => PQ schema0 schema1 m ()
149+avoid = PQ $ \ _ -> return (K ())