@@ -1,51 +1,119 @@
11{-# LANGUAGE
22 ScopedTypeVariables
33 , OverloadedStrings
4+ , DataKinds
5+ , GADTs
6+ , LambdaCase
7+ , OverloadedLabels
8+ , TypeApplications
9+ , FlexibleContexts
10+ , TypeOperators
411#-}
512
613module Squeal.PostgreSQL.Migration
7− ( Migration
8− , up
9− , MigrationResult
14+ ( Migration (..)
15+ , Step (..)
16+ , skip
17+ , migrateUp
18+ , migrateDown
19+ , MigrationTable
1020 ) where
1121
1222import Control.Category
13−import Control.Exception.Lifted
1423import Control.Monad
24+import Control.Monad.Base
25+import Control.Monad.Trans.Control
1526import Data.Function ((&))
16−import Generics.SOP
1727import Prelude hiding (id, (.))
1828
19−import qualified Database.PostgreSQL.LibPQ as LibPQ
20−
29+import Squeal.PostgreSQL.Definition
30+import Squeal.PostgreSQL.Expression
31+import Squeal.PostgreSQL.Manipulation
2132import Squeal.PostgreSQL.PQ
33+import Squeal.PostgreSQL.Schema
2234import Squeal.PostgreSQL.Transaction
2335
24−data Migration schema0 schema1 = Migration
25− { migrateUp :: PQ schema0 schema1 IO MigrationResult
26− , migrateDown :: PQ schema1 schema0 IO MigrationResult
36+data Step io schema0 schema1 = Step
37+ { up :: PQ schema0 schema1 io ()
38+ , down :: PQ schema1 schema0 io ()
2739 }
2840
29−instance Category Migration where
30− id = Migration (return MigrationSuccess) (return MigrationSuccess)
31− migration1 . migration0 = Migration
32− { migrateUp = migrateUp migration0 & pqThen (migrateUp migration1)
33− , migrateDown = migrateDown migration1 & pqThen (migrateDown migration0)
34− }
35−
36−up
37− :: Migration schema0 schema1
38− -> K Connection schema0
39− -> IO (K MigrationResult schema1)
40−up (Migration mUp _) = runPQ $
41− begin (TransactionMode RepeatableRead ReadWrite)
42− & pqThen (restorably mUp)
43− & pqBind ( \ result ->
44− commit >> return result
45− )
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 :>>
51+instance Category (Migration io) where
52+ id = Done
53+ (.) migration = \case
54+ Done -> migration
55+ step :>> steps -> step :>> (steps >>> migration)
56+
57+migrateUp
58+ :: MonadBaseControl IO io
59+ => Migration io schema0 schema1
60+ -> PQ schema0 schema1 io ()
61+migrateUp migration = start & pqThen (upSteps migration & pqBind end)
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_
92+ & pqThen (begin (TransactionMode RepeatableRead ReadWrite) & void)
4693 where
47− restorably u = PQ $ \ conn -> mask $ \ restore ->
48− restore (runPQ u conn) `onException` LibPQ.exec (unK conn) "ROLLBACK"
94+ createMigrations_ :: Definition schema schema
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))
49117
50−data MigrationResult
51− = MigrationSuccess
118+end :: MonadBase IO io => result -> PQ schema schema io result
119+end result = commit >> return result