@@ -8,8 +8,13 @@ Stability: experimental
88This module defines a `Migration` type to safely
99change the schema of your database over time. Let's see an example!
1010
11+First turn on some extensions.
12+
1113>>> :set -XDataKinds -XOverloadedLabels
1214>>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators
15+
16+Next, let's define our `TableType`s.
17+
1318>>> :{
1419type UsersTable =
1520 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
@@ -20,7 +25,7 @@ type UsersTable =
2025
2126>>> :{
2227type EmailsTable =
23− '[ "pk_emails" ::: 'PrimaryKey '["id"]
28+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
2429 , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
2530 ] :=>
2631 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
@@ -29,91 +34,120 @@ type EmailsTable =
2934 ]
3035:}
3136
37+Now we can define some `Migration`s to make our tables.
38+
3239>>> :{
3340let
34− makeUsers :: Migration IO (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]
41+ makeUsers :: Migration Definition (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]
3542 makeUsers = Migration
3643 { name = "make users table"
37− , up = void . define $
38− createTable #users
44+ , up = createTable #users
3945 ( serial `as` #id :*
40− (text & notNullable) `as` #name )
46+ notNullable text `as` #name )
4147 ( primaryKey #id `as` #pk_users )
42− , down = void . define $ dropTable #users
48+ , down = dropTable #users
4349 }
4450:}
4551
4652>>> :{
4753let
48− makeEmails :: Migration IO '["public" ::: '["users" ::: 'Table UsersTable]]
54+ makeEmails :: Migration Definition '["public" ::: '["users" ::: 'Table UsersTable]]
4955 '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]]
5056 makeEmails = Migration
5157 { name = "make emails table"
52− , up = void . define $
53− createTable #emails
58+ , up = createTable #emails
5459 ( serial `as` #id :*
55− (int & notNullable) `as` #user_id :*
56− (text & nullable) `as` #email )
60+ notNullable int `as` #user_id :*
61+ nullable text `as` #email )
5762 ( primaryKey #id `as` #pk_emails :*
5863 foreignKey #user_id #users #id
5964 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
60− , down = void . define $ dropTable #emails
65+ , down = dropTable #emails
6166 }
6267:}
6368
64−Now that we have a couple migrations we can chain them together.
69+Now that we have a couple migrations we can chain them together into an `AlignedList`.
6570
6671>>> let migrations = makeUsers :>> makeEmails :>> Done
6772
68−>>> :{
69−let
70− numMigrations
71− :: Has "migrations" schemas MigrationsSchema
72− => PQ schemas schemas IO ()
73− numMigrations = do
74− result <- runQuery (select Star (from (table (#migrations ! #schema_migrations `as` #m))))
75− num <- ntuples result
76− liftIO $ print num
77−:}
73+Now run the migrations.
7874
75+>>> import Control.Monad.IO.Class
7976>>> :{
8077withConnection "host=localhost port=5432 dbname=exampledb" $
8178 manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
8279 -- suppress notices
80+ & pqThen (liftIO (putStrLn "Migrate"))
8381 & pqThen (migrateUp migrations)
84− & pqThen numMigrations
82+ & pqThen (liftIO (putStrLn "Rollback"))
8583 & pqThen (migrateDown migrations)
86− & pqThen numMigrations
8784:}
88−Row 2
89−Row 0
85+Migrate
86+Rollback
87+
88+We can also create a simple executable using `defaultMain`.
89+
90+>>> let main = defaultMain "host=localhost port=5432 dbname=exampledb" migrations
91+
92+>>> withArgs [] main
93+Invalid command: "". Use:
94+migrate to run all available migrations
95+rollback to rollback all available migrations
96+status to display migrations run and migrations left to run
97+
98+>>> withArgs ["status"] main
99+Migrations already run:
100+ None
101+Migrations left to run:
102+ - make users table
103+ - make emails table
104+
105+>>> withArgs ["migrate"] main
106+Migrations already run:
107+ - make users table
108+ - make emails table
109+Migrations left to run:
110+ None
111+
112+>>> withArgs ["rollback"] main
113+Migrations already run:
114+ None
115+Migrations left to run:
116+ - make users table
117+ - make emails table
118+
119+In addition to enabling `Migration`s using pure SQL `Definition`s for
120+the `up` and `down` instructions, you can also perform impure `IO` actions
121+by using a `Migration`s over the `Terminally` `PQ` `IO` category.
90122-}
91−{-# LANGUAGE DataKinds #-}
92−{-# LANGUAGE DeriveGeneric #-}
93−{-# LANGUAGE FlexibleContexts #-}
94−{-# LANGUAGE GADTs #-}
95−{-# LANGUAGE LambdaCase #-}
96−{-# LANGUAGE OverloadedLabels #-}
97−{-# LANGUAGE OverloadedStrings #-}
98−{-# LANGUAGE PolyKinds #-}
99−{-# LANGUAGE TypeApplications #-}
100−{-# LANGUAGE TypeOperators #-}
123+{-# LANGUAGE
124+ DataKinds
125+ , DeriveGeneric
126+ , FlexibleContexts
127+ , FlexibleInstances
128+ , GADTs
129+ , LambdaCase
130+ , OverloadedLabels
131+ , OverloadedStrings
132+ , PolyKinds
133+ , QuantifiedConstraints
134+ , RankNTypes
135+ , TypeApplications
136+ , TypeOperators
137+#-}
101138
102139module Squeal.PostgreSQL.Migration
103140 ( -- * Migration
104141 Migration (..)
105− , migrateUp
106− , migrateDown
107− -- * Migration table
142+ , Migratory (..)
143+ , Terminally (..)
144+ , terminally
145+ , pureMigration
108146 , MigrationsTable
109− , createMigrations
110− , insertMigration
111− , deleteMigration
112− , selectMigration
113− -- * CLI
114147 , defaultMain
115148 ) where
116149
150+import Control.Category
117151import Control.Monad
118152import Data.ByteString (ByteString)
119153import Data.Foldable (traverse_)
@@ -125,138 +159,169 @@ import Data.Time (UTCTime)
125159import Generics.SOP (K (..))
126160import qualified Generics.SOP as SOP
127161import qualified GHC.Generics as GHC
162+import Prelude hiding ((.), id)
128163import Squeal.PostgreSQL
129164import System.Environment
130−import UnliftIO (MonadUnliftIO, MonadIO (..))
165+import UnliftIO (MonadIO (..))
131166
132−-- | A `Migration` should contain an inverse pair of
133−-- `up` and `down` instructions and a unique `name`.
134−data Migration io schemas0 schemas1 = Migration
167+-- | A `Migration` is a named "isomorphism" over a given category.
168+-- It should contain an inverse pair of `up` and `down`
169+-- instructions and a unique `name`.
170+data Migration p schemas0 schemas1 = Migration
135171 { name :: Text -- ^ The `name` of a `Migration`.
136172 -- Each `name` in a `Migration` should be unique.
137− , up :: PQ schemas0 schemas1 io () -- ^ The `up` instruction of a `Migration`.
138− , down :: PQ schemas1 schemas0 io () -- ^ The `down` instruction of a `Migration`.
173+ , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.
174+ , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.
175+ } deriving (GHC.Generic)
176+
177+{- |
178+A `Migratory` @p@ is a `Category` for which one can execute or rewind
179+an `AlignedList` of `Migration`s over @p@. This includes the category of pure
180+SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
181+-}
182+class Category p => Migratory p where
183+
184+ {- |
185+ Run an `AlignedList` of `Migration`s.
186+ Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
187+ In a transaction for each each `Migration`, query to see if the `Migration` has been executed;
188+ if not, execute the `Migration` and insert a row in the `MigrationsTable`.
189+ -}
190+ migrateUp
191+ :: AlignedList (Migration p) schemas0 schemas1
192+ -> PQ schemas0 schemas1 IO ()
193+
194+ {- |
195+ Rewind an `AlignedList` of `Migration`s.
196+ Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
197+ In a transaction for each each `Migration`, query to see if the `Migration` has been executed;
198+ if so, rewind the `Migration` and delete its row in the `MigrationsTable`.
199+ -}
200+ migrateDown
201+ :: AlignedList (Migration p) schemas0 schemas1
202+ -> PQ schemas1 schemas0 IO ()
203+
204+instance Migratory Definition where
205+ migrateUp = migrateUp . alignedMap pureMigration
206+ migrateDown = migrateDown . alignedMap pureMigration
207+
208+{- | `Terminally` turns an indexed monad transformer and the monad it transforms
209+into a category by restricting the return type to @()@ and permuting the type variables.
210+This is similar to how applying a monad to @()@ yields a monoid.
211+Since a `Terminally` action has a trivial return value, the only reason
212+to run one is for the side effects, in particular database effects.
213+-}
214+newtype Terminally trans monad x0 x1 = Terminally
215+ { runTerminally :: trans x0 x1 monad () }
216+ deriving GHC.Generic
217+
218+instance
219+ ( IndexedMonadTransPQ trans
220+ , Monad monad
221+ , forall x0 x1. x0 ~ x1 => Monad (trans x0 x1 monad) )
222+ => Category (Terminally trans monad) where
223+ id = Terminally (return ())
224+ Terminally g . Terminally f = Terminally $ pqThen g f
225+
226+-- | `terminally` ignores the output of a computation, returning @()@ and
227+-- wrapping it up into a `Terminally`. You can lift an action in the base monad
228+-- by using @terminally . lift@.
229+terminally
230+ :: Functor (trans x0 x1 monad)
231+ => trans x0 x1 monad ignore
232+ -> Terminally trans monad x0 x1
233+terminally = Terminally . void
234+
235+-- | A `pureMigration` turns a `Migration` involving only pure SQL
236+-- `Definition`s into a `Migration` that may be combined with arbitrary `IO`.
237+pureMigration
238+ :: Migration Definition schema0 schema1
239+ -> Migration (Terminally PQ IO) schema0 schema1
240+pureMigration migration = Migration
241+ { name = name migration
242+ , up = terminally . define $ up migration
243+ , down = terminally . define $ down migration
139244 }
140245
141−-- | Run `Migration`s by creating the `MigrationsTable`
142−-- if it does not exist and then in a transaction, for each each `Migration`
143−-- query to see if the `Migration` is executed. If not, then
144−-- execute the `Migration` and insert its row in the `MigrationsTable`.
145−migrateUp
146− :: MonadUnliftIO io
147− => AlignedList (Migration io) schemas0 schemas1 -- ^ migrations to run
148− -> PQ
149− ("migrations" ::: MigrationsSchema ': schemas0)
150− ("migrations" ::: MigrationsSchema ': schemas1)
151− io ()
152−migrateUp migration =
153− define createMigrations
154− & pqBind okResult
155− & pqThen (transactionallySchema_ (upMigrations migration))
156− where
157−
158− upMigrations
159− :: MonadUnliftIO io
160− => AlignedList (Migration io) schemas0 schemas1
161− -> PQ
162− ("migrations" ::: MigrationsSchema ': schemas0)
163− ("migrations" ::: MigrationsSchema ': schemas1)
164− io ()
165− upMigrations = \case
166− Done -> return ()
167− step :>> steps -> upMigration step & pqThen (upMigrations steps)
168−
169− upMigration
170− :: MonadIO io
171− => Migration io schemas0 schemas1 -> PQ
172− ("migrations" ::: MigrationsSchema ': schemas0)
173− ("migrations" ::: MigrationsSchema ': schemas1)
174− io ()
175− upMigration step =
176− queryExecuted step
177− & pqBind (\ executed ->
178− if executed == 1 -- up step has already been executed
179− then PQ (\ _ -> return (K ())) -- unsafely switch schemas
180− else
181− pqEmbed (up step) -- safely switch schemas
182− & pqThen (manipulateParams insertMigration (Only (name step)))
183− -- insert execution record
184− & pqBind okResult)
185−
186− queryExecuted
187− :: MonadIO io
188− => Migration io schemas0 schemas1 -> PQ
189− ("migrations" ::: MigrationsSchema ': schemas0)
190− ("migrations" ::: MigrationsSchema ': schemas0)
191− io Row
192− queryExecuted step = do
193− result <- runQueryParams selectMigration (Only (name step))
194− okResult result
195− ntuples result
196−
197−-- | Rewind `Migration`s by creating the `MigrationsTable`
198−-- if it does not exist and then in a transaction, for each each `Migration`
199−-- query to see if the `Migration` is executed. If it is, then
200−-- rewind the `Migration` and delete its row in the `MigrationsTable`.
201−migrateDown
202− :: MonadUnliftIO io
203− => AlignedList (Migration io) schemas0 schemas1 -- ^ migrations to rewind
204− -> PQ
205− ("migrations" ::: MigrationsSchema ': schemas1)
206− ("migrations" ::: MigrationsSchema ': schemas0)
207− io ()
208−migrateDown migrations =
209− define createMigrations
210− & pqBind okResult
211− & pqThen (transactionallySchema_ (downMigrations migrations))
212− where
213−
214− downMigrations
215− :: MonadUnliftIO io
216− => AlignedList (Migration io) schemas0 schemas1 -> PQ
217− ("migrations" ::: MigrationsSchema ': schemas1)
218− ("migrations" ::: MigrationsSchema ': schemas0)
219− io ()
220− downMigrations = \case
221− Done -> return ()
222− step :>> steps -> downMigrations steps & pqThen (downMigration step)
223−
224− downMigration
225− :: MonadIO io
226− => Migration io schemas0 schemas1 -> PQ
227− ("migrations" ::: MigrationsSchema ': schemas1)
228− ("migrations" ::: MigrationsSchema ': schemas0)
229− io ()
230− downMigration step =
231− queryExecuted step
232− & pqBind (\ executed ->
233− if executed == 0 -- up step has not been executed
234− then PQ (\ _ -> return (K ())) -- unsafely switch schemas
235− else
236− pqEmbed (down step) -- safely switch schemas
237− & pqThen (manipulateParams deleteMigration (Only (name step)))
238− -- delete execution record
239− & pqBind okResult)
240−
241− queryExecuted
242− :: MonadIO io
243− => Migration io schemas0 schemas1 -> PQ
244− ("migrations" ::: MigrationsSchema ': schemas1)
245− ("migrations" ::: MigrationsSchema ': schemas1)
246− io Row
247− queryExecuted step = do
248− result <- runQueryParams selectMigration (Only (name step))
249− okResult result
250− ntuples result
251−
252−okResult :: MonadIO io => K Result results -> PQ schema schema io ()
246+instance Migratory (Terminally PQ IO) where
247+
248+ migrateUp migration = unsafePQ $
249+ define createMigrations
250+ & pqBind okResult
251+ & pqThen (transactionallySchema_ (upMigrations migration))
252+
253+ where
254+
255+ upMigrations
256+ :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
257+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
258+ upMigrations = \case
259+ Done -> return ()
260+ step :>> steps -> upMigration step & pqThen (upMigrations steps)
261+
262+ upMigration
263+ :: Migration (Terminally PQ IO) schemas0 schemas1
264+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
265+ upMigration step =
266+ queryExecuted step
267+ & pqBind ( \ executed -> unless (executed == 1)
268+ $ unsafePQ (runTerminally (up step))
269+ & pqThen (manipulateParams insertMigration (Only (name step)))
270+ -- insert execution record
271+ & pqBind okResult )
272+
273+ queryExecuted
274+ :: Migration (Terminally PQ IO) schemas0 schemas1
275+ -> PQ MigrationsSchemas MigrationsSchemas IO Row
276+ queryExecuted step = do
277+ result <- runQueryParams selectMigration (Only (name step))
278+ okResult result
279+ ntuples result
280+
281+ migrateDown migrations = unsafePQ $
282+ define createMigrations
283+ & pqBind okResult
284+ & pqThen (transactionallySchema_ (downMigrations migrations))
285+
286+ where
287+
288+ downMigrations
289+ :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
290+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
291+ downMigrations = \case
292+ Done -> return ()
293+ step :>> steps -> downMigrations steps & pqThen (downMigration step)
294+
295+ downMigration
296+ :: Migration (Terminally PQ IO) schemas0 schemas1
297+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
298+ downMigration step =
299+ queryExecuted step
300+ & pqBind ( \ executed -> unless (executed == 0)
301+ $ unsafePQ (runTerminally (down step))
302+ & pqThen (manipulateParams deleteMigration (Only (name step)))
303+ -- delete execution record
304+ & pqBind okResult )
305+
306+ queryExecuted
307+ :: Migration (Terminally PQ IO) schemas0 schemas1
308+ -> PQ MigrationsSchemas MigrationsSchemas IO Row
309+ queryExecuted step = do
310+ result <- runQueryParams selectMigration (Only (name step))
311+ okResult result
312+ ntuples result
313+
314+okResult :: K Result results -> PQ schema schema IO ()
253315okResult result = do
254316 status <- resultStatus result
255317 when (not (status `elem` [CommandOk, TuplesOk])) $ do
256318 errorMessageMaybe <- resultErrorMessage result
257319 case errorMessageMaybe of
258− Nothing -> error "migrateDown: unknown error"
259− Just msg -> error ("migrationDown: " <> show msg)
320+ Nothing -> error "migration: unknown error"
321+ Just msg -> error ("migration: " <> show msg)
322+
323+unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x
324+unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK
260325
261326-- | The `TableType` for a Squeal migration.
262327type MigrationsTable =
@@ -267,130 +332,122 @@ type MigrationsTable =
267332
268333data MigrationRow =
269334 MigrationRow { migrationName :: Text
270− , executedAt :: UTCTime }
335+ , migrationTime :: UTCTime }
271336 deriving (GHC.Generic, Show)
272337
273338instance SOP.Generic MigrationRow
274339instance SOP.HasDatatypeInfo MigrationRow
275340
276341type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]
342+type MigrationsSchemas = Public MigrationsSchema
277343
278344-- | Creates a `MigrationsTable` if it does not already exist.
279−createMigrations
280− :: Has "migrations" schemas MigrationsSchema
281− => Definition schemas schemas
345+createMigrations :: Definition MigrationsSchemas MigrationsSchemas
282346createMigrations =
283− createSchemaIfNotExists #migrations >>>
284− createTableIfNotExists (#migrations ! #schema_migrations)
347+ createTableIfNotExists #schema_migrations
285348 ( (text & notNullable) `as` #name :*
286349 (timestampWithTimeZone & notNullable & default_ currentTimestamp)
287350 `as` #executed_at )
288351 ( unique #name `as` #migrations_unique_name )
289352
290−-- | Inserts a `Migration` into the `MigrationsTable`
353+-- | Inserts a `Migration` into the `MigrationsTable`, returning
354+-- the time at which it was inserted.
291355insertMigration
292− :: Has "migrations" schemas MigrationsSchema
293− => Manipulation '[] schemas '[ 'NotNull 'PGtext] '[]
294−insertMigration = insertInto_ (#migrations ! #schema_migrations) . Values_ $
295− (param @1) `as` #name :* defaultAs #executed_at
356+ :: Manipulation_ MigrationsSchemas (Only Text) (P ("executed_at" ::: UTCTime))
357+insertMigration = insertInto #schema_migrations
358+ (Values_ ((param @1) `as` #name :* defaultAs #executed_at))
359+ OnConflictDoRaise (Returning #executed_at)
296360
297−-- | Deletes a `Migration` from the `MigrationsTable`
361+-- | Deletes a `Migration` from the `MigrationsTable`, returning
362+-- the time at which it was inserted.
298363deleteMigration
299− :: Has "migrations" schemas MigrationsSchema
300− => Manipulation '[] schemas '[ 'NotNull 'PGtext ] '[]
301−deleteMigration = deleteFrom_ (#migrations ! #schema_migrations) (#name .== param @1)
364+ :: Manipulation_ MigrationsSchemas (Only Text) (P ("executed_at" ::: UTCTime))
365+deleteMigration = deleteFrom #schema_migrations
366+ NoUsing (#name .== param @1) (Returning #executed_at)
302367
303368-- | Selects a `Migration` from the `MigrationsTable`, returning
304−-- the time at which it was executed.
369+-- the time at which it was inserted.
305370selectMigration
306− :: Has "migrations" schemas MigrationsSchema
307− => Query '[] '[] schemas '[ 'NotNull 'PGtext ]
308− '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]
309−selectMigration = select_
310− (#executed_at `as` #executed_at)
311− ( from (table ((#migrations ! #schema_migrations) `as` #m))
312− & where_ (#name .== param @1))
313−
314−fetchAllMigrations
315− :: Query '[] '[] '["migrations" ::: MigrationsSchema] '[] (RowPG MigrationRow)
316−fetchAllMigrations =
317− select_ ( #name `as` #migrationName
318− :* #executed_at `as` #executedAt)
319− (from (table (#migrations ! #schema_migrations)))
320−
321−unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x
322−unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK
323−
324−data Command = Display
325− | AllUp
326− | AllDown
327− deriving (GHC.Generic, Show)
328−
371+ :: Query_ MigrationsSchemas (Only Text) (P ("executed_at" ::: UTCTime))
372+selectMigration = select_ #executed_at
373+ $ from (table (#schema_migrations))
374+ & where_ (#name .== param @1)
375+
376+selectMigrations :: Query_ MigrationsSchemas () MigrationRow
377+selectMigrations = select_
378+ (#name `as` #migrationName :* #executed_at `as` #migrationTime)
379+ (from (table #schema_migrations))
380+
381+data MigrateCommand
382+ = MigrateStatus
383+ | MigrateUp
384+ | MigrateDown deriving (GHC.Generic, Show)
385+
386+{- | `defaultMain` creates a simple executable
387+from a connection string and a list of `Migration`s. -}
329388defaultMain
330− :: ByteString
389+ :: Migratory p
390+ => ByteString
331391 -- ^ connection string
332− -> AlignedList (Migration IO) db0 db1
392+ -> AlignedList (Migration p) db0 db1
333393 -- ^ migrations
334394 -> IO ()
335395defaultMain connectTo migrations = do
336396 command <- readCommandFromArgs
337− maybe (pure ()) (performCommand connectTo migrations) command
338−
339−readCommandFromArgs :: IO (Maybe Command)
340−readCommandFromArgs = do
341− args <- getArgs
342− case args of
343− ["db:migrate"] -> pure . Just $ AllUp
344− ["db:rollback"] -> pure . Just $ AllDown
345− ["db:status"] -> pure . Just $ Display
346− _ -> displayUsage >> pure Nothing
347−
348−displayUsage :: IO ()
349−displayUsage = do
350− putStrLn "Invalid command. Use:"
351− putStrLn "db:migrate to run all available migrations"
352− putStrLn "db:rollback to rollback all available migrations"
353− putStrLn "db:status to display migrations run and migrations left to run"
354−
355−type RunMigrationName = Text
356−
357−getRunMigrationNames :: (MonadIO m) => PQ db0 db0 m [RunMigrationName]
358−getRunMigrationNames =
359− fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery fetchAllMigrations)) >>= getRows)
360−
361−displayListOfNames :: [Text] -> IO ()
362−displayListOfNames [] = T.putStrLn "\tNone"
363−displayListOfNames xs =
364− let singleName n = T.putStrLn $ "\t- " <> n
365− in traverse_ singleName xs
366−
367−displayUnrunned :: [RunMigrationName] -> IO ()
368−displayUnrunned unrunned =
369− T.putStrLn "Migrations left to run:"
370− >> displayListOfNames unrunned
371−
372−displayRunned :: [RunMigrationName] -> IO ()
373−displayRunned runned =
374− T.putStrLn "Migrations already run:"
375− >> displayListOfNames runned
376−
377−performCommand
378− :: ByteString
379− -- ^ Connection string
380− -> AlignedList (Migration IO) db0 db1
381− -- ^ Known migrations
382− -> Command
383− -- ^ Operation to perform
384− -> IO ()
385−performCommand connectTo migrations Display =
386− withConnection connectTo $ do
387− runNames <- getRunMigrationNames
388− let names = extractList name migrations
389− unrunNames = names \\ runNames
390− liftIO $ displayRunned runNames >> displayUnrunned unrunNames
391−performCommand connectTo migrations AllUp =
392− withConnection connectTo (migrateUp migrations)
393− >> performCommand connectTo migrations Display
394−performCommand connectTo migrations AllDown =
395− withConnection connectTo (migrateDown migrations)
396− >> performCommand connectTo migrations Display
397+ maybe (pure ()) performCommand command
398+
399+ where
400+
401+ performCommand :: MigrateCommand -> IO ()
402+ performCommand = \case
403+ MigrateStatus -> withConnection connectTo $
404+ suppressNotices >> migrateStatus
405+ MigrateUp -> withConnection connectTo $
406+ suppressNotices & pqThen (migrateUp migrations) & pqThen migrateStatus
407+ MigrateDown -> withConnection connectTo $
408+ suppressNotices & pqThen (migrateDown migrations) & pqThen migrateStatus
409+
410+ migrateStatus :: PQ schema schema IO ()
411+ migrateStatus = unsafePQ $ do
412+ runNames <- getRunMigrationNames
413+ let names = extractList name migrations
414+ unrunNames = names \\ runNames
415+ liftIO $ displayRunned runNames >> displayUnrunned unrunNames
416+
417+ suppressNotices :: PQ schema schema IO ()
418+ suppressNotices = void . manipulate $
419+ UnsafeManipulation "SET client_min_messages TO WARNING;"
420+
421+ readCommandFromArgs :: IO (Maybe MigrateCommand)
422+ readCommandFromArgs = getArgs >>= \case
423+ ["migrate"] -> pure . Just $ MigrateUp
424+ ["rollback"] -> pure . Just $ MigrateDown
425+ ["status"] -> pure . Just $ MigrateStatus
426+ args -> displayUsage args >> pure Nothing
427+
428+ displayUsage :: [String] -> IO ()
429+ displayUsage args = do
430+ putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"
431+ putStrLn "migrate to run all available migrations"
432+ putStrLn "rollback to rollback all available migrations"
433+ putStrLn "status to display migrations run and migrations left to run"
434+
435+ getRunMigrationNames :: (MonadIO m) => PQ db0 db0 m [Text]
436+ getRunMigrationNames =
437+ fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery selectMigrations)) >>= getRows)
438+
439+ displayListOfNames :: [Text] -> IO ()
440+ displayListOfNames [] = T.putStrLn " None"
441+ displayListOfNames xs =
442+ let singleName n = T.putStrLn $ " - " <> n
443+ in traverse_ singleName xs
444+
445+ displayUnrunned :: [Text] -> IO ()
446+ displayUnrunned unrunned =
447+ T.putStrLn "Migrations left to run:"
448+ >> displayListOfNames unrunned
449+
450+ displayRunned :: [Text] -> IO ()
451+ displayRunned runned =
452+ T.putStrLn "Migrations already run:"
453+ >> displayListOfNames runned