git.iko.soy/squeal
on dev help sign in
changes
7c74234Eitan Chatav
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+115−41
compare with dev
unifiedsplit
@@ -5,8 +5,67 @@ Copyright: (c) Eitan Chatav, 2017
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
8−`Squeal.PostgreSQL.Migration` defines a `Migration` type to safely
8+This module defines a `Migration` type to safely
9−change the schema of your database over time.
9+change the schema of your database over time. Let's see an example!
10+
11+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
12+>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
13+>>> :{
14+type UsersTable =
15+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
16+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
17+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
18+ ]
19+:}
20+
21+>>> :{
22+type EmailsTable =
23+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
24+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
25+ ] :=>
26+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
27+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
28+ , "email" ::: 'NoDef :=> 'Null 'PGtext
29+ ]
30+:}
31+
32+>>> :{
33+let
34+ makeUsers :: Step IO '[] '["users" ::: UsersTable]
35+ makeUsers = Step
36+ { name = "make users table"
37+ , up = void . define $
38+ createTable #users
39+ ( serial `As` #id :*
40+ (text & notNull) `As` #name :* Nil )
41+ ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil )
42+ , down = void . define $ dropTable #users
43+ }
44+:}
45+
46+>>> :{
47+let
48+ makeEmails :: Step IO '["users" ::: UsersTable]
49+ '["users" ::: UsersTable, "emails" ::: EmailsTable]
50+ makeEmails = Step
51+ { name = "make emails table"
52+ , up = void . define $
53+ createTable #emails
54+ ( serial `As` #id :*
55+ (int & notNull) `As` #user_id :*
56+ text `As` #email :* Nil )
57+ ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
58+ foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
59+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
60+ , down = void . define $ dropTable #emails
61+ }
62+:}
63+
64+>>> let migration = makeUsers :>> makeEmails :>> Done
65+>>> withConnection "host=localhost port=5432 dbname=exampledb" (migrateUp migration)
66+NOTICE: relation "migration" already exists, skipping
67+>>> withConnection "host=localhost port=5432 dbname=exampledb" (migrateDown migration)
68+NOTICE: relation "migration" already exists, skipping
10-}
69-}
11
70
12{-# LANGUAGE
71{-# LANGUAGE
@@ -15,6 +74,7 @@ change the schema of your database over time.
15 , DataKinds
74 , DataKinds
16 , GADTs
75 , GADTs
17 , LambdaCase
76 , LambdaCase
77+ , PolyKinds
18 , OverloadedLabels
78 , OverloadedLabels
19 , TypeApplications
79 , TypeApplications
20 , FlexibleContexts
80 , FlexibleContexts
@@ -36,9 +96,11 @@ module Squeal.PostgreSQL.Migration
36 ) where
96 ) where
37
97
38import Control.Category
98import Control.Category
99+-- import Control.Exception.Lifted
39import Control.Monad
100import Control.Monad
40import Control.Monad.Base
101import Control.Monad.Base
41import Control.Monad.Trans.Control
102import Control.Monad.Trans.Control
103+import Data.Monoid
42import Generics.SOP (K(..))
104import Generics.SOP (K(..))
43import Data.Function ((&))
105import Data.Function ((&))
44import Data.Text (Text)
106import Data.Text (Text)
@@ -53,7 +115,7 @@ data Migration io schema0 schema1 where
53 :: Step io schema0 schema1
115 :: Step io schema0 schema1
54 -> Migration io schema1 schema2
116 -> Migration io schema1 schema2
55 -> Migration io schema0 schema2
117 -> Migration io schema0 schema2
56−infixl 7 :>>
118+infixr 7 :>>
57instance Category (Migration io) where
119instance Category (Migration io) where
58 id = Done
120 id = Done
59 (.) migration = \case
121 (.) migration = \case
@@ -69,7 +131,6 @@ data Step io schema0 schema1 = Step
69 , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Step`.
131 , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Step`.
70 }
132 }
71
133
72−
73-- | Run a `Migration` by creating the `MigrationTable`
134-- | Run a `Migration` by creating the `MigrationTable`
74-- if it does not exist and then in a transaction, for each each `Step`
135-- if it does not exist and then in a transaction, for each each `Step`
75-- query to see if the `Step` is executed. If not, then
136-- query to see if the `Step` is executed. If not, then
@@ -83,9 +144,10 @@ migrateUp
83 io ()
144 io ()
84migrateUp migration =
145migrateUp migration =
85 define createMigration
146 define createMigration
147+ & pqBind okResult
86 & pqThen (begin defaultMode)
148 & pqThen (begin defaultMode)
149+ & pqBind okResult
87− & pqThen (upSteps migration)
150+ & pqThen (upSteps migration & rollbackOrCommit)
88− & pqThen (void commit)
89 where
151 where
90
152
91 upSteps
153 upSteps
@@ -97,18 +159,7 @@ migrateUp migration =
97 io ()
159 io ()
98 upSteps = \case
160 upSteps = \case
99 Done -> return ()
161 Done -> return ()
100− step :>> steps -> onExceptionRollback $
101− upStep step
102− & pqThen (upSteps steps)
162+ step :>> steps -> upStep step & pqThen (upSteps steps)
103−
104− queryExecuted
105− :: MonadBase IO io
106− => Step io schema0 schema1 -> PQ
107− ("migration" ::: MigrationTable ': schema0)
108− ("migration" ::: MigrationTable ': schema0)
109− io RowNumber
110− queryExecuted =
111− ntuples <=< runQueryParams selectStep . Only . name
112
163
113 upStep
164 upStep
114 :: MonadBase IO io
165 :: MonadBase IO io
@@ -123,8 +174,20 @@ migrateUp migration =
123 then PQ (\ _ -> return (K ())) -- unsafely switch schemas
174 then PQ (\ _ -> return (K ())) -- unsafely switch schemas
124 else
175 else
125 pqEmbed (up step) -- safely switch schemas
176 pqEmbed (up step) -- safely switch schemas
126− & pqThen (manipulateParams insertStep (Only (name step)) & void))
177+ & pqThen (manipulateParams insertStep (Only (name step)))
178+ & pqBind okResult)
127− -- insert up step execution record
179+ -- insert execution record
180+
181+ queryExecuted
182+ :: MonadBase IO io
183+ => Step io schema0 schema1 -> PQ
184+ ("migration" ::: MigrationTable ': schema0)
185+ ("migration" ::: MigrationTable ': schema0)
186+ io RowNumber
187+ queryExecuted step = do
188+ result <- runQueryParams selectStep (Only (name step))
189+ okResult result
190+ ntuples result
128
191
129-- | Rewind a `Migration` by creating the `MigrationTable`
192-- | Rewind a `Migration` by creating the `MigrationTable`
130-- if it does not exist and then in a transaction, for each each `Step`
193-- if it does not exist and then in a transaction, for each each `Step`
@@ -139,19 +202,21 @@ migrateDown
139 io ()
202 io ()
140migrateDown migration =
203migrateDown migration =
141 define createMigration
204 define createMigration
205+ & pqBind okResult
142 & pqThen (begin defaultMode)
206 & pqThen (begin defaultMode)
207+ & pqBind okResult
143− & pqThen (downSteps migration)
208+ & pqThen (downSteps migration & rollbackOrCommit)
144− & pqThen (void commit)
145 where
209 where
146
210
147− queryExecuted
211+ downSteps
148− :: MonadBase IO io
212+ :: MonadBaseControl IO io
149− => Step io schema0 schema1 -> PQ
213+ => Migration io schema0 schema1 -> PQ
150− ("migration" ::: MigrationTable ': schema1)
151 ("migration" ::: MigrationTable ': schema1)
214 ("migration" ::: MigrationTable ': schema1)
152− io RowNumber
215+ ("migration" ::: MigrationTable ': schema0)
153− queryExecuted =
216+ io ()
154− ntuples <=< runQueryParams selectStep . Only . name
217+ downSteps = \case
218+ Done -> return ()
219+ step :>> steps -> downSteps steps & pqThen (downStep step)
155
220
156 downStep
221 downStep
157 :: MonadBase IO io
222 :: MonadBase IO io
@@ -166,20 +231,29 @@ migrateDown migration =
166 then PQ (\ _ -> return (K ())) -- unsafely switch schemas
231 then PQ (\ _ -> return (K ())) -- unsafely switch schemas
167 else
232 else
168 pqEmbed (down step) -- safely switch schemas
233 pqEmbed (down step) -- safely switch schemas
169− & pqThen (manipulateParams deleteStep (Only (name step)) & void))
234+ & pqThen (manipulateParams deleteStep (Only (name step)))
170− -- delete up step execution record
235+ -- delete execution record
236+ & pqBind okResult)
171
237
172− downSteps
238+ queryExecuted
173− :: MonadBaseControl IO io
239+ :: MonadBase IO io
174− => Migration io schema0 schema1 -> PQ
240+ => Step io schema0 schema1 -> PQ
175 ("migration" ::: MigrationTable ': schema1)
241 ("migration" ::: MigrationTable ': schema1)
176− ("migration" ::: MigrationTable ': schema0)
242+ ("migration" ::: MigrationTable ': schema1)
177− io ()
243+ io RowNumber
178− downSteps = \case
244+ queryExecuted step = do
179− Done -> return ()
245+ result <- runQueryParams selectStep (Only (name step))
180− step :>> steps -> onExceptionRollback $
246+ okResult result
181− downSteps steps
247+ ntuples result
182− & pqThen (downStep step)
248+
249+okResult :: MonadBase IO io => K Result results -> PQ schema schema io ()
250+okResult result = do
251+ status <- resultStatus result
252+ when (not (status `elem` [CommandOk, TuplesOk])) $ do
253+ errorMessageMaybe <- resultErrorMessage result
254+ case errorMessageMaybe of
255+ Nothing -> error "migrateDown: unknown error"
256+ Just msg -> error ("migrationDown: " <> show msg)
183
257
184-- | The `TableType` for a Squeal migration.
258-- | The `TableType` for a Squeal migration.
185type MigrationTable =
259type MigrationTable =
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+13
@@ -61,9 +61,12 @@ module Squeal.PostgreSQL.PQ
61 , nextRow
61 , nextRow
62 , firstRow
62 , firstRow
63 , liftResult
63 , liftResult
64+ , resultStatus
65+ , resultErrorMessage
64 -- * Re-export
66 -- * Re-export
65 , LibPQ.Connection
67 , LibPQ.Connection
66 , LibPQ.Result
68 , LibPQ.Result
69+ , LibPQ.ExecStatus (..)
67 ) where
70 ) where
68
71
69import Control.Exception.Lifted
72import Control.Exception.Lifted
@@ -588,3 +591,13 @@ liftResult
588 => (LibPQ.Result -> IO x)
591 => (LibPQ.Result -> IO x)
589 -> K LibPQ.Result results -> io x
592 -> K LibPQ.Result results -> io x
590liftResult f (K result) = liftBase $ f result
593liftResult f (K result) = liftBase $ f result
594+
595+-- | Returns the result status of the command.
596+resultStatus :: MonadBase IO io => K LibPQ.Result results -> io LibPQ.ExecStatus
597+resultStatus = liftResult LibPQ.resultStatus
598+
599+-- | Returns the error message most recently generated by an operation
600+-- on the connection.
601+resultErrorMessage
602+ :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)
603+resultErrorMessage = liftResult LibPQ.resultErrorMessage
squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+13−10
@@ -16,6 +16,7 @@ Squeal transaction control language.
16 , LambdaCase
16 , LambdaCase
17 , OverloadedStrings
17 , OverloadedStrings
18 , MultiParamTypeClasses
18 , MultiParamTypeClasses
19+ , ScopedTypeVariables
19 , TypeFamilies
20 , TypeFamilies
20 , TypeInType
21 , TypeInType
21#-}
22#-}
@@ -27,7 +28,7 @@ module Squeal.PostgreSQL.Transaction
27 , begin
28 , begin
28 , commit
29 , commit
29 , rollback
30 , rollback
30− , onExceptionRollback
31+ , rollbackOrCommit
31 -- * Transaction Mode
32 -- * Transaction Mode
32 , TransactionMode (..)
33 , TransactionMode (..)
33 , defaultMode
34 , defaultMode
@@ -54,7 +55,7 @@ import Squeal.PostgreSQL.Prettyprint
54import Squeal.PostgreSQL.PQ
55import Squeal.PostgreSQL.PQ
55import Squeal.PostgreSQL.Schema
56import Squeal.PostgreSQL.Schema
56
57
57−-- | Run a query or manipulation `transactionally`.
58+-- | Run a schema invariant computation `transactionally`.
58transactionally
59transactionally
59 :: (MonadBaseControl IO tx, MonadPQ schema tx)
60 :: (MonadBaseControl IO tx, MonadPQ schema tx)
60 => TransactionMode
61 => TransactionMode
@@ -66,7 +67,7 @@ transactionally mode tx = mask $ \restore -> do
66 _ <- commit
67 _ <- commit
67 return result
68 return result
68
69
69−-- | Run a query or manipulation `transactionally_` in `defaultMode`.
70+-- | Run a schema invariant computation `transactionally_` in `defaultMode`.
70transactionally_
71transactionally_
71 :: (MonadBaseControl IO tx, MonadPQ schema tx)
72 :: (MonadBaseControl IO tx, MonadPQ schema tx)
72 => tx x -- ^ run inside a transaction
73 => tx x -- ^ run inside a transaction
@@ -78,22 +79,24 @@ begin :: MonadPQ schema tx => TransactionMode -> tx (K Result NilRelation)
78begin mode = manipulate . UnsafeManipulation $
79begin mode = manipulate . UnsafeManipulation $
79 "BEGIN" <+> renderTransactionMode mode <> ";"
80 "BEGIN" <+> renderTransactionMode mode <> ";"
80
81
81−-- | @COMMIT@ a transaction.
82+-- | @COMMIT@ a schema invariant transaction.
82commit :: MonadPQ schema tx => tx (K Result NilRelation)
83commit :: MonadPQ schema tx => tx (K Result NilRelation)
83commit = manipulate $ UnsafeManipulation "COMMIT;"
84commit = manipulate $ UnsafeManipulation "COMMIT;"
84
85
85−-- | @ROLLBACK@ a query or manipulation transaction.
86+-- | @ROLLBACK@ a schema invariant transaction.
86rollback :: MonadPQ schema tx => tx (K Result NilRelation)
87rollback :: MonadPQ schema tx => tx (K Result NilRelation)
87rollback = manipulate $ UnsafeManipulation "ROLLBACK;"
88rollback = manipulate $ UnsafeManipulation "ROLLBACK;"
88
89
89−-- | @ROLLBACK@ a transaction upon exception.
90+-- | @ROLLBACK@ a transaction upon `Exception`, otherwise @COMMIT@.
90−onExceptionRollback
91+rollbackOrCommit
91 :: MonadBaseControl IO io
92 :: MonadBaseControl IO io
92 => PQ schema0 schema1 io x
93 => PQ schema0 schema1 io x
93 -> PQ schema0 schema1 io x
94 -> PQ schema0 schema1 io x
94−onExceptionRollback u = PQ $ \ conn -> mask $ \ restore ->
95+rollbackOrCommit u = PQ $ \ conn -> mask $ \ restore -> do
95− restore (runPQ u conn) `onException`
96+ x <- restore (runPQ u conn)
96− liftBase (LibPQ.exec (unK conn) "ROLLBACK")
97+ `onException` (liftBase (LibPQ.exec (unK conn) "ROLLBACK"))
98+ _ <- liftBase (LibPQ.exec (unK conn) "COMMIT")
99+ return x
97
100
98-- | The available transaction characteristics are the transaction `IsolationLevel`,
101-- | The available transaction characteristics are the transaction `IsolationLevel`,
99-- the transaction access mode (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.
102-- the transaction access mode (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.