git.iko.soy/squeal
on dev help sign in
migration structure
20f989fEitan Chatav
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+39
compare with dev
unifiedsplit
@@ -34,6 +34,7 @@ module Squeal.PostgreSQL.Definition
34 , (>>>)
34 , (>>>)
35 -- * Create
35 -- * Create
36 , createTable
36 , createTable
37+ , createTableIfNotExists
37 , TableConstraintExpression (..)
38 , TableConstraintExpression (..)
38 , Column (..)
39 , Column (..)
39 , check
40 , check
@@ -140,6 +141,44 @@ createTable table columns constraints = UnsafeDefinition $
140 renderConstraint (constraint `As` alias) =
141 renderConstraint (constraint `As` alias) =
141 "CONSTRAINT" <+> renderAlias alias <+> renderTableConstraintExpression constraint
142 "CONSTRAINT" <+> renderAlias alias <+> renderTableConstraintExpression constraint
142
143
144+-- | `createTable` adds a table to the schema.
145+--
146+-- >>> :set -XOverloadedLabels
147+-- >>> :{
148+-- renderDefinition $
149+-- createTable #tab (int `As` #a :* real `As` #b :* Nil) Nil
150+-- :}
151+-- "CREATE TABLE tab (a int, b real);"
152+createTableIfNotExists
153+ :: ( KnownSymbol table
154+ , columns ~ (col ': cols)
155+ , SOP.SListI columns
156+ , SOP.SListI constraints )
157+ => Alias table -- ^ the name of the table to add
158+ -> NP (Aliased TypeExpression) columns
159+ -- ^ the names and datatype of each column
160+ -> NP (Aliased (TableConstraintExpression schema columns)) constraints
161+ -- ^ constraints that must hold for the table
162+ -> Definition schema (Create table (constraints :=> columns) schema)
163+createTableIfNotExists table columns constraints = UnsafeDefinition $
164+ "CREATE TABLE IF NOT EXISTS" <+> renderAlias table
165+ <+> parenthesized
166+ ( renderCommaSeparated renderColumnDef columns
167+ <> ( case constraints of
168+ Nil -> ""
169+ _ -> ", " <>
170+ renderCommaSeparated renderConstraint constraints ) )
171+ <> ";"
172+ where
173+ renderColumnDef :: Aliased TypeExpression x -> ByteString
174+ renderColumnDef (ty `As` column) =
175+ renderAlias column <+> renderTypeExpression ty
176+ renderConstraint
177+ :: Aliased (TableConstraintExpression schema columns) constraint
178+ -> ByteString
179+ renderConstraint (constraint `As` alias) =
180+ "CONSTRAINT" <+> renderAlias alias <+> renderTableConstraintExpression constraint
181+
143-- | Data types are a way to limit the kind of data that can be stored in a
182-- | Data types are a way to limit the kind of data that can be stored in a
144-- table. For many applications, however, the constraint they provide is
183-- table. For many applications, however, the constraint they provide is
145-- too coarse. For example, a column containing a product price should
184-- too coarse. For example, a column containing a product price should
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+99−31
@@ -1,51 +1,119 @@
1{-# LANGUAGE
1{-# LANGUAGE
2 ScopedTypeVariables
2 ScopedTypeVariables
3 , OverloadedStrings
3 , OverloadedStrings
4+ , DataKinds
5+ , GADTs
6+ , LambdaCase
7+ , OverloadedLabels
8+ , TypeApplications
9+ , FlexibleContexts
10+ , TypeOperators
4#-}
11#-}
5
12
6module Squeal.PostgreSQL.Migration
13module Squeal.PostgreSQL.Migration
7− ( Migration
14+ ( Migration (..)
8− , up
15+ , Step (..)
9− , MigrationResult
16+ , skip
17+ , migrateUp
18+ , migrateDown
19+ , MigrationTable
10 ) where
20 ) where
11
21
12import Control.Category
22import Control.Category
13−import Control.Exception.Lifted
14import Control.Monad
23import Control.Monad
24+import Control.Monad.Base
25+import Control.Monad.Trans.Control
15import Data.Function ((&))
26import Data.Function ((&))
16−import Generics.SOP
17import Prelude hiding (id, (.))
27import Prelude hiding (id, (.))
18
28
19−import qualified Database.PostgreSQL.LibPQ as LibPQ
29+import Squeal.PostgreSQL.Definition
20−
30+import Squeal.PostgreSQL.Expression
31+import Squeal.PostgreSQL.Manipulation
21import Squeal.PostgreSQL.PQ
32import Squeal.PostgreSQL.PQ
33+import Squeal.PostgreSQL.Schema
22import Squeal.PostgreSQL.Transaction
34import Squeal.PostgreSQL.Transaction
23
35
24−data Migration schema0 schema1 = Migration
36+data Step io schema0 schema1 = Step
25− { migrateUp :: PQ schema0 schema1 IO MigrationResult
37+ { up :: PQ schema0 schema1 io ()
26− , migrateDown :: PQ schema1 schema0 IO MigrationResult
38+ , down :: PQ schema1 schema0 io ()
27 }
39 }
28
40
41+skip :: Monad io => Step io schema schema -> Step io schema schema
42+skip _ = Step (return ()) (return ())
43+
44+data Migration io schema0 schema1 where
45+ Done :: Migration io schema schema
46+ (:>>)
47+ :: Step io schema0 schema1
48+ -> Migration io schema1 schema2
49+ -> Migration io schema0 schema2
50+infixl 7 :>>
29−instance Category Migration where
51+instance Category (Migration io) where
30− id = Migration (return MigrationSuccess) (return MigrationSuccess)
52+ id = Done
31− migration1 . migration0 = Migration
53+ (.) migration = \case
32− { migrateUp = migrateUp migration0 & pqThen (migrateUp migration1)
54+ Done -> migration
33− , migrateDown = migrateDown migration1 & pqThen (migrateDown migration0)
55+ step :>> steps -> step :>> (steps >>> migration)
34− }
56+
35−
57+migrateUp
36−up
58+ :: MonadBaseControl IO io
37− :: Migration schema0 schema1
59+ => Migration io schema0 schema1
38− -> K Connection schema0
60+ -> PQ schema0 schema1 io ()
39− -> IO (K MigrationResult schema1)
61+migrateUp migration = start & pqThen (upSteps migration & pqBind end)
40−up (Migration mUp _) = runPQ $
62+
63+migrateDown
64+ :: MonadBaseControl IO io
65+ => Migration io schema0 schema1
66+ -> PQ schema1 schema0 io ()
67+migrateDown migration = start & pqThen (downSteps migration & pqBind end)
68+
69+type MigrationTable = "schema_migrations" :::
70+ '[ "unique_name" ::: 'Unique '["name"]] :=>
71+ '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
72+ , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
73+ ]
74+
75+createMigrations :: Definition '[] '[MigrationTable]
76+createMigrations = UnsafeDefinition $ renderDefinition $
77+ createTableIfNotExists #schema_migrations
78+ ( (text & notNull) `As` #name :*
79+ (timestampWithTimeZone & notNull) `As` #executed_at :* Nil )
80+ ( unique (Column #name :* Nil) `As` #unique_name :* Nil )
81+
82+insertMigration :: Manipulation '[MigrationTable] '[ 'NotNull 'PGtext] '[]
83+insertMigration = insertRow_ #schema_migrations
84+ ( Set (param @1) `As` #name :*
85+ Default `As` #executed_at :* Nil )
86+
87+deleteMigration :: Manipulation '[MigrationTable] '[ 'NotNull 'PGtext] '[]
88+deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
89+
90+start :: MonadBase IO io => PQ schema schema io ()
91+start = define createMigrations_
41− begin (TransactionMode RepeatableRead ReadWrite)
92+ & pqThen (begin (TransactionMode RepeatableRead ReadWrite) & void)
42− & pqThen (restorably mUp)
43− & pqBind ( \ result ->
44− commit >> return result
45− )
46 where
93 where
47− restorably u = PQ $ \ conn -> mask $ \ restore ->
94+ createMigrations_ :: Definition schema schema
48− restore (runPQ u conn) `onException` LibPQ.exec (unK conn) "ROLLBACK"
95+ createMigrations_ = UnsafeDefinition $
96+ renderDefinition createMigrations
97+
98+upSteps
99+ :: MonadBaseControl IO io
100+ => Migration io schema0 schema1
101+ -> PQ schema0 schema1 io ()
102+upSteps = \case
103+ Done -> return ()
104+ step :>> steps ->
105+ onExceptionRollback (up step)
106+ & pqThen (upSteps steps)
107+
108+downSteps
109+ :: MonadBaseControl IO io
110+ => Migration io schema0 schema1
111+ -> PQ schema1 schema0 io ()
112+downSteps = \case
113+ Done -> return ()
114+ step :>> steps ->
115+ downSteps steps
116+ & pqThen (onExceptionRollback (down step))
49
117
50−data MigrationResult
118+end :: MonadBase IO io => result -> PQ schema schema io result
51− = MigrationSuccess
119+end result = commit >> return result
squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+7−2
@@ -23,6 +23,7 @@ module Squeal.PostgreSQL.Transaction
23 ) where
23 ) where
24
24
25import Control.Exception.Lifted
25import Control.Exception.Lifted
26+import Control.Monad.Base
26import Control.Monad.Trans.Control
27import Control.Monad.Trans.Control
27import Data.ByteString
28import Data.ByteString
28import Data.Monoid
29import Data.Monoid
@@ -60,9 +61,13 @@ commit = manipulate $ UnsafeManipulation "COMMIT;"
60rollback :: MonadPQ schema tx => tx (K Result NilRelation)
61rollback :: MonadPQ schema tx => tx (K Result NilRelation)
61rollback = manipulate $ UnsafeManipulation "ROLLBACK;"
62rollback = manipulate $ UnsafeManipulation "ROLLBACK;"
62
63
63−onExceptionRollback :: PQ schema0 schema1 IO x -> PQ schema0 schema1 IO x
64+onExceptionRollback
65+ :: MonadBaseControl IO io
66+ => PQ schema0 schema1 io x
67+ -> PQ schema0 schema1 io x
64onExceptionRollback u = PQ $ \ conn -> mask $ \ restore ->
68onExceptionRollback u = PQ $ \ conn -> mask $ \ restore ->
65− restore (runPQ u conn) `onException` LibPQ.exec (unK conn) "ROLLBACK"
69+ restore (runPQ u conn) `onException`
70+ liftBase (LibPQ.exec (unK conn) "ROLLBACK")
66
71
67data TransactionMode = TransactionMode
72data TransactionMode = TransactionMode
68 { isolationLevel :: IsolationLevel
73 { isolationLevel :: IsolationLevel