@@ -31,33 +31,31 @@ type EmailsTable =
3131
3232>>> :{
3333let
34− makeUsers :: Migration IO (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]
34+ makeUsers :: Migration Definition (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]
3535 makeUsers = Migration
3636 { name = "make users table"
37− , up = void . define $
38− createTable #users
37+ , up = createTable #users
3938 ( serial `as` #id :*
4039 (text & notNullable) `as` #name )
4140 ( primaryKey #id `as` #pk_users )
42− , down = void . define $ dropTable #users
41+ , down = dropTable #users
4342 }
4443:}
4544
4645>>> :{
4746let
48− makeEmails :: Migration IO '["public" ::: '["users" ::: 'Table UsersTable]]
47+ makeEmails :: Migration Definition '["public" ::: '["users" ::: 'Table UsersTable]]
4948 '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]]
5049 makeEmails = Migration
5150 { name = "make emails table"
52− , up = void . define $
53− createTable #emails
51+ , up = createTable #emails
5452 ( serial `as` #id :*
5553 (int & notNullable) `as` #user_id :*
5654 (text & nullable) `as` #email )
5755 ( primaryKey #id `as` #pk_emails :*
5856 foreignKey #user_id #users #id
5957 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
60− , down = void . define $ dropTable #emails
58+ , down = dropTable #emails
6159 }
6260:}
6361
@@ -79,21 +77,47 @@ withConnection "host=localhost port=5432 dbname=exampledb" $
7977:}
8078Migrate
8179Rollback
80+
81+We can also create a simple executable using `defaultMain`.
82+
83+>>> let main = defaultMain "host=localhost port=5432 dbname=exampledb" migrations
84+>>> withArgs [] main
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:
91+ None
92+Migrations left to run:
93+ - make users table
94+ - make emails table
95+>>> withArgs ["migrate"] main
96+asdf
97+>>> withArgs ["rollback"] main
98+asdf
8299-}
83−{-# LANGUAGE DataKinds #-}
84−{-# LANGUAGE DeriveGeneric #-}
85−{-# LANGUAGE FlexibleContexts #-}
86−{-# LANGUAGE GADTs #-}
87−{-# LANGUAGE LambdaCase #-}
88−{-# LANGUAGE OverloadedLabels #-}
89−{-# LANGUAGE OverloadedStrings #-}
90−{-# LANGUAGE PolyKinds #-}
91−{-# LANGUAGE TypeApplications #-}
92−{-# LANGUAGE TypeOperators #-}
100+{-# LANGUAGE
101+ DataKinds
102+ , DeriveGeneric
103+ , FlexibleContexts
104+ , FlexibleInstances
105+ , GADTs
106+ , LambdaCase
107+ , OverloadedLabels
108+ , OverloadedStrings
109+ , PolyKinds
110+ , QuantifiedConstraints
111+ , RankNTypes
112+ , TypeApplications
113+ , TypeOperators
114+#-}
93115
94116module Squeal.PostgreSQL.Migration
95117 ( -- * Migration
96118 Migration (..)
119+ , Unital
120+ , unitally
97121 , migrateUp
98122 , migrateDown
99123 -- * Migration table
@@ -107,9 +131,9 @@ module Squeal.PostgreSQL.Migration
107131 , MigrateCommand
108132 ) where
109133
134+import Control.Category
110135import Control.Monad
111136import Control.Monad.Base
112−import Control.Monad.Trans.Control
113137import Data.ByteString (ByteString)
114138import Data.Foldable (traverse_)
115139import Data.Function ((&))
@@ -120,105 +144,132 @@ import Data.Time (UTCTime)
120144import Generics.SOP (K (..))
121145import qualified Generics.SOP as SOP
122146import qualified GHC.Generics as GHC
147+import Prelude hiding ((.), id)
123148import Squeal.PostgreSQL
124149import System.Environment
125150
126−-- | A `Migration` should contain an inverse pair of
127−-- `up` and `down` instructions and a unique `name`.
128−data Migration io schemas0 schemas1 = Migration
151+-- | A `Migration` is a named "isomorphism" over a given category.
152+data Migration p schemas0 schemas1 = Migration
129153 { name :: Text -- ^ The `name` of a `Migration`.
130154 -- Each `name` in a `Migration` should be unique.
131− , up :: PQ schemas0 schemas1 io () -- ^ The `up` instruction of a `Migration`.
132− , down :: PQ schemas1 schemas0 io () -- ^ The `down` instruction of a `Migration`.
155+ , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.
156+ , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.
133157 } deriving (GHC.Generic)
134158
135−-- | Run `Migration`s by creating the `MigrationsTable`
136−-- if it does not exist and then in a transaction, for each each `Migration`
137−-- query to see if the `Migration` is executed. If not, then
138−-- execute the `Migration` and insert its row in the `MigrationsTable`.
139−migrateUp
140− :: MonadBaseControl IO io
141− => AlignedList (Migration io) schemas0 schemas1 -- ^ migrations to run
142− -> PQ schemas0 schemas1 io ()
143−migrateUp migration = unsafePQ $
144− define createMigrations
145− & pqBind okResult
146− & pqThen (transactionallySchema_ (upMigrations migration))
147− where
148−
149− upMigrations
150− :: MonadBaseControl IO io
151− => AlignedList (Migration io) schemas0 schemas1
152− -> PQ MigrationsSchemas MigrationsSchemas io ()
153− upMigrations = \case
154− Done -> return ()
155− step :>> steps -> upMigration step & pqThen (upMigrations steps)
156−
157− upMigration
158− :: MonadBase IO io
159− => Migration io schemas0 schemas1
160− -> PQ MigrationsSchemas MigrationsSchemas io ()
161− upMigration step =
162− queryExecuted step
163− & pqBind ( \ executed -> unless (executed == 1)
164− $ unsafePQ (up step)
165− & pqThen (manipulateParams insertMigration (Only (name step)))
166− -- insert execution record
167− & pqBind okResult )
168−
169− queryExecuted
170− :: MonadBase IO io
171− => Migration io schemas0 schemas1
172− -> PQ MigrationsSchemas MigrationsSchemas io Row
173− queryExecuted step = do
174− result <- runQueryParams selectMigration (Only (name step))
175− okResult result
176− ntuples result
177−
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`.
182−migrateDown
183− :: MonadBaseControl IO io
184− => AlignedList (Migration io) schemas0 schemas1 -- ^ migrations to rewind
185− -> PQ schema1 schema0 io ()
186−migrateDown migrations = unsafePQ $
187− define createMigrations
188− & pqBind okResult
189− & pqThen (transactionallySchema_ (downMigrations migrations))
190− where
191−
192− downMigrations
193− :: MonadBaseControl IO io
194− => AlignedList (Migration io) schemas0 schemas1
195− -> PQ MigrationsSchemas MigrationsSchemas io ()
196− downMigrations = \case
197− Done -> return ()
198− step :>> steps -> downMigrations steps & pqThen (downMigration step)
199−
200− downMigration
201− :: MonadBase IO io
202− => Migration io schemas0 schemas1
203− -> PQ MigrationsSchemas MigrationsSchemas io ()
204− downMigration step =
205− queryExecuted step
206− & pqBind ( \ executed -> unless (executed == 0)
207− $ unsafePQ (down step)
208− & pqThen (manipulateParams deleteMigration (Only (name step)))
209− -- delete execution record
210− & pqBind okResult )
211−
212− queryExecuted
213− :: MonadBase IO io
214− => Migration io schemas0 schemas1
215− -> PQ MigrationsSchemas MigrationsSchemas io Row
216− queryExecuted step = do
217− result <- runQueryParams selectMigration (Only (name step))
218− okResult result
219− ntuples result
220−
221−okResult :: MonadBase IO io => K Result results -> PQ schema schema io ()
159+-- | `Unital` turns an indexed monad transformer into a category by
160+-- restricting the return type to `()` and permuting the type variables.
161+newtype Unital trans monad x0 x1 = Unital
162+ { runUnital :: trans x0 x1 monad () }
163+ deriving GHC.Generic
164+
165+-- | A `pureMigration` turns a `Migration` involving only pure SQL
166+-- `Definition`s into a `Migration` that may involve `IO`.
167+pureMigration
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
174+ }
175+
176+instance
177+ ( IndexedMonadTransPQ trans
178+ , Monad monad
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
183+
184+-- | unitally ignores the output of a computation, returning `()` and
185+-- wrapping it up in a `Unital`.
186+unitally
187+ :: Functor (trans x0 x1 monad)
188+ => trans x0 x1 monad ignore
189+ -> Unital trans monad x0 x1
190+unitally = Unital . void
191+
192+class Migratory p where
193+ migrateUp
194+ :: AlignedList (Migration p) schemas0 schemas1
195+ -> PQ schemas0 schemas1 IO ()
196+ migrateDown
197+ :: AlignedList (Migration p) schemas0 schemas1
198+ -> PQ schemas1 schemas0 IO ()
199+
200+instance Migratory Definition where
201+ migrateUp = migrateUp . alignedMap pureMigration
202+ migrateDown = migrateDown . alignedMap pureMigration
203+
204+instance Migratory (Unital PQ IO) where
205+
206+ migrateUp migration = unsafePQ $
207+ define createMigrations
208+ & pqBind okResult
209+ & pqThen (transactionallySchema_ (upMigrations migration))
210+
211+ where
212+
213+ upMigrations
214+ :: AlignedList (Migration (Unital PQ IO)) schemas0 schemas1
215+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
216+ upMigrations = \case
217+ Done -> return ()
218+ step :>> steps -> upMigration step & pqThen (upMigrations steps)
219+
220+ upMigration
221+ :: Migration (Unital PQ IO) schemas0 schemas1
222+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
223+ upMigration step =
224+ queryExecuted step
225+ & pqBind ( \ executed -> unless (executed == 1)
226+ $ unsafePQ (runUnital (up step))
227+ & pqThen (manipulateParams insertMigration (Only (name step)))
228+ -- insert execution record
229+ & pqBind okResult )
230+
231+ queryExecuted
232+ :: Migration (Unital PQ IO) schemas0 schemas1
233+ -> PQ MigrationsSchemas MigrationsSchemas IO Row
234+ queryExecuted step = do
235+ result <- runQueryParams selectMigration (Only (name step))
236+ okResult result
237+ ntuples result
238+
239+ migrateDown migrations = unsafePQ $
240+ define createMigrations
241+ & pqBind okResult
242+ & pqThen (transactionallySchema_ (downMigrations migrations))
243+
244+ where
245+
246+ downMigrations
247+ :: AlignedList (Migration (Unital PQ IO)) schemas0 schemas1
248+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
249+ downMigrations = \case
250+ Done -> return ()
251+ step :>> steps -> downMigrations steps & pqThen (downMigration step)
252+
253+ downMigration
254+ :: Migration (Unital PQ IO) schemas0 schemas1
255+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
256+ downMigration step =
257+ queryExecuted step
258+ & pqBind ( \ executed -> unless (executed == 0)
259+ $ unsafePQ (runUnital (down step))
260+ & pqThen (manipulateParams deleteMigration (Only (name step)))
261+ -- delete execution record
262+ & pqBind okResult )
263+
264+ queryExecuted
265+ :: Migration (Unital PQ IO) schemas0 schemas1
266+ -> PQ MigrationsSchemas MigrationsSchemas IO Row
267+ queryExecuted step = do
268+ result <- runQueryParams selectMigration (Only (name step))
269+ okResult result
270+ ntuples result
271+
272+okResult :: K Result results -> PQ schema schema IO ()
222273okResult result = do
223274 status <- resultStatus result
224275 when (not (status `elem` [CommandOk, TuplesOk])) $ do
@@ -227,6 +278,9 @@ okResult result = do
227278 Nothing -> error "migration: unknown error"
228279 Just msg -> error ("migration: " <> show msg)
229280
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
283+
230284-- | The `TableType` for a Squeal migration.
231285type MigrationsTable =
232286 '[ "migrations_unique_name" ::: 'Unique '["name"]] :=>
@@ -282,18 +336,16 @@ selectMigrations = select_
282336 (#name `as` #migrationName :* #executed_at `as` #migrationTime)
283337 (from (table #schema_migrations))
284338
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
287−
288339data MigrateCommand
289340 = MigrateStatus
290341 | MigrateUp
291342 | MigrateDown deriving (GHC.Generic, Show)
292343
293344defaultMain
294− :: ByteString
345+ :: Migratory p
346+ => ByteString
295347 -- ^ connection string
296− -> AlignedList (Migration IO) db0 db1
348+ -> AlignedList (Migration p) db0 db1
297349 -- ^ migrations
298350 -> IO ()
299351defaultMain connectTo migrations = do
@@ -302,16 +354,36 @@ defaultMain connectTo migrations = do
302354
303355 where
304356
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
365+
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
372+
373+ suppressNotices :: PQ schema schema IO ()
374+ suppressNotices = void . manipulate $
375+ UnsafeManipulation "SET client_min_messages TO WARNING;"
376+
305377 readCommandFromArgs :: IO (Maybe MigrateCommand)
306378 readCommandFromArgs = getArgs >>= \case
307− ["migrate"] -> pure . Just $ MigrateUp
379+ ["migrate"] -> pure . Just $ MigrateUp
308380 ["rollback"] -> pure . Just $ MigrateDown
309− ["status"] -> pure . Just $ MigrateStatus
310− _ -> displayUsage >> pure Nothing
381+ ["status"] -> pure . Just $ MigrateStatus
382+ args -> displayUsage args >> pure Nothing
311383
312− displayUsage :: IO ()
313− displayUsage = do
314− putStrLn "Invalid command. Use:"
384+ displayUsage :: [String] -> IO ()
385+ displayUsage args = do
386+ putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"
315387 putStrLn "migrate to run all available migrations"
316388 putStrLn "rollback to rollback all available migrations"
317389 putStrLn "status to display migrations run and migrations left to run"
@@ -321,9 +393,9 @@ defaultMain connectTo migrations = do
321393 fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery selectMigrations)) >>= getRows)
322394
323395 displayListOfNames :: [Text] -> IO ()
324− displayListOfNames [] = T.putStrLn "\tNone"
396+ displayListOfNames [] = T.putStrLn " None"
325397 displayListOfNames xs =
326− let singleName n = T.putStrLn $ "\t- " <> n
398+ let singleName n = T.putStrLn $ " - " <> n
327399 in traverse_ singleName xs
328400
329401 displayUnrunned :: [Text] -> IO ()
@@ -335,17 +407,3 @@ defaultMain connectTo migrations = do
335407 displayRunned runned =
336408 T.putStrLn "Migrations already run:"
337409 >> displayListOfNames runned
338−
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
346− MigrateUp ->
347− withConnection connectTo (migrateUp migrations)
348− >> performCommand MigrateStatus
349− MigrateDown ->
350− withConnection connectTo (migrateDown migrations)
351− >> performCommand MigrateStatus