@@ -31,33 +31,31 @@ type EmailsTable =
34− makeUsers :: Migration IO (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]
34+ makeUsers :: Migration Definition (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]
35 makeUsers = Migration
35 makeUsers = Migration
36 { name = "make users table"
36 { name = "make users table"
37− , up = void . define $
38− createTable #users
37+ , up = createTable #users
39 ( serial `as` #id :*
38 ( serial `as` #id :*
40 (text & notNullable) `as` #name )
39 (text & notNullable) `as` #name )
41 ( primaryKey #id `as` #pk_users )
40 ( primaryKey #id `as` #pk_users )
42− , down = void . define $ dropTable #users
41+ , down = dropTable #users
48− makeEmails :: Migration IO '["public" ::: '["users" ::: 'Table UsersTable]]
47+ makeEmails :: Migration Definition '["public" ::: '["users" ::: 'Table UsersTable]]
49 '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]]
48 '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]]
50 makeEmails = Migration
49 makeEmails = Migration
51 { name = "make emails table"
50 { name = "make emails table"
52− , up = void . define $
53− createTable #emails
51+ , up = createTable #emails
54 ( serial `as` #id :*
52 ( serial `as` #id :*
55 (int & notNullable) `as` #user_id :*
53 (int & notNullable) `as` #user_id :*
56 (text & nullable) `as` #email )
54 (text & nullable) `as` #email )
57 ( primaryKey #id `as` #pk_emails :*
55 ( primaryKey #id `as` #pk_emails :*
58 foreignKey #user_id #users #id
56 foreignKey #user_id #users #id
59 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
57 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
60− , down = void . define $ dropTable #emails
58+ , down = dropTable #emails
@@ -79,21 +77,47 @@ withConnection "host=localhost port=5432 dbname=exampledb" $
81+We can also create a simple executable using `defaultMain`.
83+>>> let main = defaultMain "host=localhost port=5432 dbname=exampledb" migrations
85+Invalid command: "". Use:
86+migrate to run all available migrations
87+rollback to rollback all available migrations
88+status to display migrations run and migrations left to run
89+>>> withArgs ["status"] main
90+Migrations already run:
92+Migrations left to run:
95+>>> withArgs ["migrate"] main
97+>>> withArgs ["rollback"] main
83−{-# LANGUAGE DataKinds #-}
101+ DataKinds
84−{-# LANGUAGE DeriveGeneric #-}
102+ , DeriveGeneric
85−{-# LANGUAGE FlexibleContexts #-}
103+ , FlexibleContexts
86−{-# LANGUAGE GADTs #-}
105+ , GADTs
87−{-# LANGUAGE LambdaCase #-}
106+ , LambdaCase
88−{-# LANGUAGE OverloadedLabels #-}
107+ , OverloadedLabels
89−{-# LANGUAGE OverloadedStrings #-}
108+ , OverloadedStrings
90−{-# LANGUAGE PolyKinds #-}
109+ , PolyKinds
110+ , QuantifiedConstraints
91−{-# LANGUAGE TypeApplications #-}
112+ , TypeApplications
92−{-# LANGUAGE TypeOperators #-}
113+ , TypeOperators
94module Squeal.PostgreSQL.Migration
116module Squeal.PostgreSQL.Migration
95 ( -- * Migration
117 ( -- * Migration
96 Migration (..)
118 Migration (..)
97 , migrateUp
121 , migrateUp
98 , migrateDown
122 , migrateDown
99 -- * Migration table
123 -- * Migration table
@@ -107,9 +131,9 @@ module Squeal.PostgreSQL.Migration
107 , MigrateCommand
131 , MigrateCommand
134+import Control.Category
110import Control.Monad
135import Control.Monad
111import Control.Monad.Base
136import Control.Monad.Base
112−import Control.Monad.Trans.Control
113import Data.ByteString (ByteString)
137import Data.ByteString (ByteString)
114import Data.Foldable (traverse_)
138import Data.Foldable (traverse_)
115import Data.Function ((&))
139import Data.Function ((&))
@@ -120,105 +144,132 @@ import Data.Time (UTCTime)
120import Generics.SOP (K (..))
144import Generics.SOP (K (..))
121import qualified Generics.SOP as SOP
145import qualified Generics.SOP as SOP
122import qualified GHC.Generics as GHC
146import qualified GHC.Generics as GHC
147+import Prelude hiding ((.), id)
123import Squeal.PostgreSQL
148import Squeal.PostgreSQL
124import System.Environment
149import System.Environment
126−-- | A `Migration` should contain an inverse pair of
151+-- | A `Migration` is a named "isomorphism" over a given category.
127−-- `up` and `down` instructions and a unique `name`.
128−data Migration io schemas0 schemas1 = Migration
152+data Migration p schemas0 schemas1 = Migration
129 { name :: Text -- ^ The `name` of a `Migration`.
153 { name :: Text -- ^ The `name` of a `Migration`.
130 -- Each `name` in a `Migration` should be unique.
154 -- Each `name` in a `Migration` should be unique.
131− , up :: PQ schemas0 schemas1 io () -- ^ The `up` instruction of a `Migration`.
155+ , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.
132− , down :: PQ schemas1 schemas0 io () -- ^ The `down` instruction of a `Migration`.
156+ , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.
133 } deriving (GHC.Generic)
157 } deriving (GHC.Generic)
135−-- | Run `Migration`s by creating the `MigrationsTable`
159+-- | `Unital` turns an indexed monad transformer into a category by
136−-- if it does not exist and then in a transaction, for each each `Migration`
160+-- restricting the return type to `()` and permuting the type variables.
137−-- query to see if the `Migration` is executed. If not, then
161+newtype Unital trans monad x0 x1 = Unital
138−-- execute the `Migration` and insert its row in the `MigrationsTable`.
162+ { runUnital :: trans x0 x1 monad () }
163+ deriving GHC.Generic
165+-- | A `pureMigration` turns a `Migration` involving only pure SQL
166+-- `Definition`s into a `Migration` that may involve `IO`.
168+ :: Migration Definition schema0 schema1
169+ -> Migration (Unital PQ IO) schema0 schema1
170+pureMigration migration = Migration
171+ { name = name migration
172+ , up = unitally . define $ up migration
173+ , down = unitally . define $ down migration
177+ ( IndexedMonadTransPQ trans
179+ , forall x0 x1. Monad (trans x0 x1 monad) )
180+ => Category (Unital trans monad) where
181+ id = Unital (return ())
182+ Unital g . Unital f = Unital $ pqThen g f
184+-- | unitally ignores the output of a computation, returning `()` and
185+-- wrapping it up in a `Unital`.
187+ :: Functor (trans x0 x1 monad)
188+ => trans x0 x1 monad ignore
189+ -> Unital trans monad x0 x1
190+unitally = Unital . void
192+class Migratory p where
139−migrateUp
193+ migrateUp
140− :: MonadBaseControl IO io
194+ :: AlignedList (Migration p) schemas0 schemas1
195+ -> PQ schemas0 schemas1 IO ()
141− => AlignedList (Migration io) schemas0 schemas1 -- ^ migrations to run
197+ :: AlignedList (Migration p) schemas0 schemas1
142− -> PQ schemas0 schemas1 io ()
198+ -> PQ schemas1 schemas0 IO ()
200+instance Migratory Definition where
201+ migrateUp = migrateUp . alignedMap pureMigration
202+ migrateDown = migrateDown . alignedMap pureMigration
204+instance Migratory (Unital PQ IO) where
143−migrateUp migration = unsafePQ $
206+ migrateUp migration = unsafePQ $
144− define createMigrations
207+ define createMigrations
145− & pqBind okResult
208+ & pqBind okResult
146− & pqThen (transactionallySchema_ (upMigrations migration))
209+ & pqThen (transactionallySchema_ (upMigrations migration))
149− upMigrations
213+ upMigrations
150− :: MonadBaseControl IO io
151− => AlignedList (Migration io) schemas0 schemas1
214+ :: AlignedList (Migration (Unital PQ IO)) schemas0 schemas1
152− -> PQ MigrationsSchemas MigrationsSchemas io ()
215+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
153− upMigrations = \case
216+ upMigrations = \case
154− Done -> return ()
217+ Done -> return ()
155− step :>> steps -> upMigration step & pqThen (upMigrations steps)
218+ step :>> steps -> upMigration step & pqThen (upMigrations steps)
157− upMigration
220+ upMigration
159− => Migration io schemas0 schemas1
221+ :: Migration (Unital PQ IO) schemas0 schemas1
160− -> PQ MigrationsSchemas MigrationsSchemas io ()
222+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
161− upMigration step =
223+ upMigration step =
162− queryExecuted step
224+ queryExecuted step
163− & pqBind ( \ executed -> unless (executed == 1)
225+ & pqBind ( \ executed -> unless (executed == 1)
164− $ unsafePQ (up step)
226+ $ unsafePQ (runUnital (up step))
165− & pqThen (manipulateParams insertMigration (Only (name step)))
227+ & pqThen (manipulateParams insertMigration (Only (name step)))
166− -- insert execution record
228+ -- insert execution record
167− & pqBind okResult )
229+ & pqBind okResult )
169− queryExecuted
231+ queryExecuted
171− => Migration io schemas0 schemas1
232+ :: Migration (Unital PQ IO) schemas0 schemas1
172− -> PQ MigrationsSchemas MigrationsSchemas io Row
233+ -> PQ MigrationsSchemas MigrationsSchemas IO Row
173− queryExecuted step = do
234+ queryExecuted step = do
174− result <- runQueryParams selectMigration (Only (name step))
235+ result <- runQueryParams selectMigration (Only (name step))
175− okResult result
236+ okResult result
176− ntuples result
237+ ntuples result
178−-- | Rewind `Migration`s by creating the `MigrationsTable`
179−-- if it does not exist and then in a transaction, for each each `Migration`
180−-- query to see if the `Migration` is executed. If it is, then
181−-- rewind the `Migration` and delete its row in the `MigrationsTable`.
183− :: MonadBaseControl IO io
184− => AlignedList (Migration io) schemas0 schemas1 -- ^ migrations to rewind
185− -> PQ schema1 schema0 io ()
186−migrateDown migrations = unsafePQ $
239+ migrateDown migrations = unsafePQ $
187− define createMigrations
240+ define createMigrations
188− & pqBind okResult
241+ & pqBind okResult
189− & pqThen (transactionallySchema_ (downMigrations migrations))
242+ & pqThen (transactionallySchema_ (downMigrations migrations))
192− downMigrations
246+ downMigrations
193− :: MonadBaseControl IO io
194− => AlignedList (Migration io) schemas0 schemas1
247+ :: AlignedList (Migration (Unital PQ IO)) schemas0 schemas1
195− -> PQ MigrationsSchemas MigrationsSchemas io ()
248+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
196− downMigrations = \case
249+ downMigrations = \case
197− Done -> return ()
250+ Done -> return ()
198− step :>> steps -> downMigrations steps & pqThen (downMigration step)
251+ step :>> steps -> downMigrations steps & pqThen (downMigration step)
200− downMigration
253+ downMigration
202− => Migration io schemas0 schemas1
254+ :: Migration (Unital PQ IO) schemas0 schemas1
203− -> PQ MigrationsSchemas MigrationsSchemas io ()
255+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
204− downMigration step =
256+ downMigration step =
205− queryExecuted step
257+ queryExecuted step
206− & pqBind ( \ executed -> unless (executed == 0)
258+ & pqBind ( \ executed -> unless (executed == 0)
207− $ unsafePQ (down step)
259+ $ unsafePQ (runUnital (down step))
208− & pqThen (manipulateParams deleteMigration (Only (name step)))
260+ & pqThen (manipulateParams deleteMigration (Only (name step)))
209− -- delete execution record
261+ -- delete execution record
210− & pqBind okResult )
262+ & pqBind okResult )
212− queryExecuted
264+ queryExecuted
214− => Migration io schemas0 schemas1
265+ :: Migration (Unital PQ IO) schemas0 schemas1
215− -> PQ MigrationsSchemas MigrationsSchemas io Row
266+ -> PQ MigrationsSchemas MigrationsSchemas IO Row
216− queryExecuted step = do
267+ queryExecuted step = do
217− result <- runQueryParams selectMigration (Only (name step))
268+ result <- runQueryParams selectMigration (Only (name step))
218− okResult result
269+ okResult result
219− ntuples result
270+ ntuples result
221−okResult :: MonadBase IO io => K Result results -> PQ schema schema io ()
272+okResult :: K Result results -> PQ schema schema IO ()
222okResult result = do
273okResult result = do
223 status <- resultStatus result
274 status <- resultStatus result
224 when (not (status `elem` [CommandOk, TuplesOk])) $ do
275 when (not (status `elem` [CommandOk, TuplesOk])) $ do
@@ -227,6 +278,9 @@ okResult result = do
227 Nothing -> error "migration: unknown error"
278 Nothing -> error "migration: unknown error"
228 Just msg -> error ("migration: " <> show msg)
279 Just msg -> error ("migration: " <> show msg)
281+unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x
282+unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK
230-- | The `TableType` for a Squeal migration.
284-- | The `TableType` for a Squeal migration.
231type MigrationsTable =
285type MigrationsTable =
232 '[ "migrations_unique_name" ::: 'Unique '["name"]] :=>
286 '[ "migrations_unique_name" ::: 'Unique '["name"]] :=>
@@ -282,18 +336,16 @@ selectMigrations = select_
282 (#name `as` #migrationName :* #executed_at `as` #migrationTime)
336 (#name `as` #migrationName :* #executed_at `as` #migrationTime)
283 (from (table #schema_migrations))
337 (from (table #schema_migrations))
285−unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x
286−unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK
288data MigrateCommand
339data MigrateCommand
289 = MigrateStatus
340 = MigrateStatus
290 | MigrateUp
341 | MigrateUp
291 | MigrateDown deriving (GHC.Generic, Show)
342 | MigrateDown deriving (GHC.Generic, Show)
293defaultMain
344defaultMain
294− :: ByteString
346+ => ByteString
295 -- ^ connection string
347 -- ^ connection string
296− -> AlignedList (Migration IO) db0 db1
348+ -> AlignedList (Migration p) db0 db1
297 -- ^ migrations
349 -- ^ migrations
299defaultMain connectTo migrations = do
351defaultMain connectTo migrations = do
@@ -302,16 +354,36 @@ defaultMain connectTo migrations = do
357+ performCommand :: MigrateCommand -> IO ()
358+ performCommand = \case
359+ MigrateStatus -> withConnection connectTo $
360+ suppressNotices >> migrateStatus
361+ MigrateUp -> withConnection connectTo $
362+ suppressNotices & pqThen (migrateUp migrations) & pqThen migrateStatus
363+ MigrateDown -> withConnection connectTo $
364+ suppressNotices & pqThen (migrateDown migrations) & pqThen migrateStatus
366+ migrateStatus :: PQ schema schema IO ()
367+ migrateStatus = unsafePQ $ do
368+ runNames <- getRunMigrationNames
369+ let names = extractList name migrations
370+ unrunNames = names \\ runNames
371+ liftBase $ displayRunned runNames >> displayUnrunned unrunNames
373+ suppressNotices :: PQ schema schema IO ()
374+ suppressNotices = void . manipulate $
375+ UnsafeManipulation "SET client_min_messages TO WARNING;"
305 readCommandFromArgs :: IO (Maybe MigrateCommand)
377 readCommandFromArgs :: IO (Maybe MigrateCommand)
306 readCommandFromArgs = getArgs >>= \case
378 readCommandFromArgs = getArgs >>= \case
307− ["migrate"] -> pure . Just $ MigrateUp
379+ ["migrate"] -> pure . Just $ MigrateUp
308 ["rollback"] -> pure . Just $ MigrateDown
380 ["rollback"] -> pure . Just $ MigrateDown
309− ["status"] -> pure . Just $ MigrateStatus
381+ ["status"] -> pure . Just $ MigrateStatus
310− _ -> displayUsage >> pure Nothing
382+ args -> displayUsage args >> pure Nothing
312− displayUsage :: IO ()
384+ displayUsage :: [String] -> IO ()
313− displayUsage = do
385+ displayUsage args = do
314− putStrLn "Invalid command. Use:"
386+ putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"
315 putStrLn "migrate to run all available migrations"
387 putStrLn "migrate to run all available migrations"
316 putStrLn "rollback to rollback all available migrations"
388 putStrLn "rollback to rollback all available migrations"
317 putStrLn "status to display migrations run and migrations left to run"
389 putStrLn "status to display migrations run and migrations left to run"
@@ -321,9 +393,9 @@ defaultMain connectTo migrations = do
321 fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery selectMigrations)) >>= getRows)
393 fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery selectMigrations)) >>= getRows)
323 displayListOfNames :: [Text] -> IO ()
395 displayListOfNames :: [Text] -> IO ()
324− displayListOfNames [] = T.putStrLn "\tNone"
396+ displayListOfNames [] = T.putStrLn " None"
325 displayListOfNames xs =
397 displayListOfNames xs =
326− let singleName n = T.putStrLn $ "\t- " <> n
398+ let singleName n = T.putStrLn $ " - " <> n
327 in traverse_ singleName xs
399 in traverse_ singleName xs
329 displayUnrunned :: [Text] -> IO ()
401 displayUnrunned :: [Text] -> IO ()
@@ -335,17 +407,3 @@ defaultMain connectTo migrations = do
335 displayRunned runned =
407 displayRunned runned =
336 T.putStrLn "Migrations already run:"
408 T.putStrLn "Migrations already run:"
337 >> displayListOfNames runned
409 >> displayListOfNames runned
339− performCommand :: MigrateCommand -> IO ()
340− performCommand = \case
341− MigrateStatus -> withConnection connectTo $ do
342− runNames <- getRunMigrationNames
343− let names = extractList name migrations
344− unrunNames = names \\ runNames
345− liftBase $ displayRunned runNames >> displayUnrunned unrunNames
347− withConnection connectTo (migrateUp migrations)
348− >> performCommand MigrateStatus
350− withConnection connectTo (migrateDown migrations)
351− >> performCommand MigrateStatus