7c74234 · squeal · git.iko.soy

git.iko.soy/squeal

changes

commit7c74234b6adae4fe50728fde586a4664c32ccf2f authorEitan Chatav <eitan.chatav@gmail.com> dateWed 14 Mar 2018, 17:16 (9 years ago) parent7487519

3 files changed+141−51

compare with dev

unifiedsplit

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+115−41 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+13 squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+13−10

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+115−41

@@ -5,8 +5,67 @@ Copyright: (c) Eitan Chatav, 2017

55Maintainer: eitan@morphism.tech

66Stability: experimental

8−`Squeal.PostgreSQL.Migration` defines a `Migration` type to safely

9−change the schema of your database over time.

8+This module defines a `Migration` type to safely

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

1069-}

1170

1271{-# LANGUAGE

@@ -15,6 +74,7 @@ change the schema of your database over time.

1574 , DataKinds

1675 , GADTs

1776 , LambdaCase

77+ , PolyKinds

1878 , OverloadedLabels

1979 , TypeApplications

2080 , FlexibleContexts

@@ -36,9 +96,11 @@ module Squeal.PostgreSQL.Migration

3696 ) where

3797

3898import Control.Category

99+-- import Control.Exception.Lifted

39100import Control.Monad

40101import Control.Monad.Base

41102import Control.Monad.Trans.Control

103+import Data.Monoid

42104import Generics.SOP (K(..))

43105import Data.Function ((&))

44106import Data.Text (Text)

@@ -53,7 +115,7 @@ data Migration io schema0 schema1 where

53115 :: Step io schema0 schema1

54116 -> Migration io schema1 schema2

55117 -> Migration io schema0 schema2

56−infixl 7 :>>

118+infixr 7 :>>

57119instance Category (Migration io) where

58120 id = Done

59121 (.) migration = \case

@@ -69,7 +131,6 @@ data Step io schema0 schema1 = Step

69131 , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Step`.

70132 }

71133

72−

73134-- | Run a `Migration` by creating the `MigrationTable`

74135-- if it does not exist and then in a transaction, for each each `Step`

75136-- query to see if the `Step` is executed. If not, then

@@ -83,9 +144,10 @@ migrateUp

83144 io ()

84145migrateUp migration =

85146 define createMigration

147+ & pqBind okResult

86148 & pqThen (begin defaultMode)

87− & pqThen (upSteps migration)

88− & pqThen (void commit)

149+ & pqBind okResult

150+ & pqThen (upSteps migration & rollbackOrCommit)

89151 where

90152

91153 upSteps

@@ -97,18 +159,7 @@ migrateUp migration =

97159 io ()

98160 upSteps = \case

99161 Done -> return ()

100− step :>> steps -> onExceptionRollback $

101− upStep step

102− & 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

162+ step :>> steps -> upStep step & pqThen (upSteps steps)

112163

113164 upStep

114165 :: MonadBase IO io

@@ -123,8 +174,20 @@ migrateUp migration =

123174 then PQ (\ _ -> return (K ())) -- unsafely switch schemas

124175 else

125176 pqEmbed (up step) -- safely switch schemas

126− & pqThen (manipulateParams insertStep (Only (name step)) & void))

127− -- insert up step execution record

177+ & pqThen (manipulateParams insertStep (Only (name step)))

178+ & pqBind okResult)

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

128191

129192-- | Rewind a `Migration` by creating the `MigrationTable`

130193-- if it does not exist and then in a transaction, for each each `Step`

@@ -139,19 +202,21 @@ migrateDown

139202 io ()

140203migrateDown migration =

141204 define createMigration

205+ & pqBind okResult

142206 & pqThen (begin defaultMode)

143− & pqThen (downSteps migration)

144− & pqThen (void commit)

207+ & pqBind okResult

208+ & pqThen (downSteps migration & rollbackOrCommit)

145209 where

146210

147− queryExecuted

148− :: MonadBase IO io

149− => Step io schema0 schema1 -> PQ

150− ("migration" ::: MigrationTable ': schema1)

211+ downSteps

212+ :: MonadBaseControl IO io

213+ => Migration io schema0 schema1 -> PQ

151214 ("migration" ::: MigrationTable ': schema1)

152− io RowNumber

153− queryExecuted =

154− ntuples <=< runQueryParams selectStep . Only . name

215+ ("migration" ::: MigrationTable ': schema0)

216+ io ()

217+ downSteps = \case

218+ Done -> return ()

219+ step :>> steps -> downSteps steps & pqThen (downStep step)

155220

156221 downStep

157222 :: MonadBase IO io

@@ -166,20 +231,29 @@ migrateDown migration =

166231 then PQ (\ _ -> return (K ())) -- unsafely switch schemas

167232 else

168233 pqEmbed (down step) -- safely switch schemas

169− & pqThen (manipulateParams deleteStep (Only (name step)) & void))

170− -- delete up step execution record

234+ & pqThen (manipulateParams deleteStep (Only (name step)))

235+ -- delete execution record

236+ & pqBind okResult)

171237

172− downSteps

173− :: MonadBaseControl IO io

174− => Migration io schema0 schema1 -> PQ

238+ queryExecuted

239+ :: MonadBase IO io

240+ => Step io schema0 schema1 -> PQ

175241 ("migration" ::: MigrationTable ': schema1)

176− ("migration" ::: MigrationTable ': schema0)

177− io ()

178− downSteps = \case

179− Done -> return ()

180− step :>> steps -> onExceptionRollback $

181− downSteps steps

182− & pqThen (downStep step)

242+ ("migration" ::: MigrationTable ': schema1)

243+ io RowNumber

244+ queryExecuted step = do

245+ result <- runQueryParams selectStep (Only (name step))

246+ okResult result

247+ ntuples result

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)

183257

184258-- | The `TableType` for a Squeal migration.

185259type MigrationTable =

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+13

@@ -61,9 +61,12 @@ module Squeal.PostgreSQL.PQ

6161 , nextRow

6262 , firstRow

6363 , liftResult

64+ , resultStatus

65+ , resultErrorMessage

6466 -- * Re-export

6567 , LibPQ.Connection

6668 , LibPQ.Result

69+ , LibPQ.ExecStatus (..)

6770 ) where

6871

6972import Control.Exception.Lifted

@@ -588,3 +591,13 @@ liftResult

588591 => (LibPQ.Result -> IO x)

589592 -> K LibPQ.Result results -> io x

590593liftResult 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.

1616 , LambdaCase

1717 , OverloadedStrings

1818 , MultiParamTypeClasses

19+ , ScopedTypeVariables

1920 , TypeFamilies

2021 , TypeInType

2122#-}

@@ -27,7 +28,7 @@ module Squeal.PostgreSQL.Transaction

2728 , begin

2829 , commit

2930 , rollback

30− , onExceptionRollback

31+ , rollbackOrCommit

3132 -- * Transaction Mode

3233 , TransactionMode (..)

3334 , defaultMode

@@ -54,7 +55,7 @@ import Squeal.PostgreSQL.Prettyprint

5455import Squeal.PostgreSQL.PQ

5556import Squeal.PostgreSQL.Schema

5657

57−-- | Run a query or manipulation `transactionally`.

58+-- | Run a schema invariant computation `transactionally`.

5859transactionally

5960 :: (MonadBaseControl IO tx, MonadPQ schema tx)

6061 => TransactionMode

@@ -66,7 +67,7 @@ transactionally mode tx = mask $ \restore -> do

6667 _ <- commit

6768 return result

6869

69−-- | Run a query or manipulation `transactionally_` in `defaultMode`.

70+-- | Run a schema invariant computation `transactionally_` in `defaultMode`.

7071transactionally_

7172 :: (MonadBaseControl IO tx, MonadPQ schema tx)

7273 => tx x -- ^ run inside a transaction

@@ -78,22 +79,24 @@ begin :: MonadPQ schema tx => TransactionMode -> tx (K Result NilRelation)

7879begin mode = manipulate . UnsafeManipulation $

7980 "BEGIN" <+> renderTransactionMode mode <> ";"

8081

81−-- | @COMMIT@ a transaction.

82+-- | @COMMIT@ a schema invariant transaction.

8283commit :: MonadPQ schema tx => tx (K Result NilRelation)

8384commit = manipulate $ UnsafeManipulation "COMMIT;"

8485

85−-- | @ROLLBACK@ a query or manipulation transaction.

86+-- | @ROLLBACK@ a schema invariant transaction.

8687rollback :: MonadPQ schema tx => tx (K Result NilRelation)

8788rollback = manipulate $ UnsafeManipulation "ROLLBACK;"

8889

89−-- | @ROLLBACK@ a transaction upon exception.

90−onExceptionRollback

90+-- | @ROLLBACK@ a transaction upon `Exception`, otherwise @COMMIT@.

91+rollbackOrCommit

9192 :: MonadBaseControl IO io

9293 => PQ schema0 schema1 io x

9394 -> PQ schema0 schema1 io x

94−onExceptionRollback u = PQ $ \ conn -> mask $ \ restore ->

95− restore (runPQ u conn) `onException`

96− liftBase (LibPQ.exec (unK conn) "ROLLBACK")

95+rollbackOrCommit u = PQ $ \ conn -> mask $ \ restore -> do

96+ x <- restore (runPQ u conn)

97+ `onException` (liftBase (LibPQ.exec (unK conn) "ROLLBACK"))

98+ _ <- liftBase (LibPQ.exec (unK conn) "COMMIT")

99+ return x

97100

98101-- | The available transaction characteristics are the transaction `IsolationLevel`,

99102-- the transaction access mode (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.