@@ -88,17 +88,16 @@ withConnection "host=localhost port=5432 dbname=exampledb" $
8888Row 2
8989Row 0
9090-}
91−
92−{-# LANGUAGE
93− DataKinds
94− , GADTs
95− , LambdaCase
96− , PolyKinds
97− , OverloadedLabels
98− , TypeApplications
99− , FlexibleContexts
100− , TypeOperators
101−#-}
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 #-}
102101
103102module Squeal.PostgreSQL.Migration
104103 ( -- * Migration
@@ -111,23 +110,32 @@ module Squeal.PostgreSQL.Migration
111110 , insertMigration
112111 , deleteMigration
113112 , selectMigration
113+ -- * CLI
114+ , defaultMain
114115 ) where
115116
116−import Control.Monad
117−import Control.Monad.Base
118−import Control.Monad.Trans.Control
119−import Generics.SOP (K(..))
120−import Data.Function ((&))
121−import Data.Text (Text)
122−
123−import Squeal.PostgreSQL
117+import Control.Monad
118+import Control.Monad.Base
119+import Control.Monad.Trans.Control
120+import Data.ByteString (ByteString)
121+import Data.Foldable (traverse_)
122+import Data.Function ((&))
123+import Data.List ((\\))
124+import Data.Text (Text)
125+import qualified Data.Text.IO as T (putStrLn)
126+import Data.Time (UTCTime)
127+import Generics.SOP (K (..))
128+import qualified Generics.SOP as SOP
129+import qualified GHC.Generics as GHC
130+import Squeal.PostgreSQL
131+import System.Environment
124132
125133-- | A `Migration` should contain an inverse pair of
126134-- `up` and `down` instructions and a unique `name`.
127135data Migration io schemas0 schemas1 = Migration
128136 { name :: Text -- ^ The `name` of a `Migration`.
129137 -- Each `name` in a `Migration` should be unique.
130− , up :: PQ schemas0 schemas1 io () -- ^ The `up` instruction of a `Migration`.
138+ , up :: PQ schemas0 schemas1 io () -- ^ The `up` instruction of a `Migration`.
131139 , down :: PQ schemas1 schemas0 io () -- ^ The `down` instruction of a `Migration`.
132140 }
133141
@@ -248,7 +256,7 @@ okResult result = do
248256 when (not (status `elem` [CommandOk, TuplesOk])) $ do
249257 errorMessageMaybe <- resultErrorMessage result
250258 case errorMessageMaybe of
251− Nothing -> error "migrateDown: unknown error"
259+ Nothing -> error "migrateDown: unknown error"
252260 Just msg -> error ("migrationDown: " <> show msg)
253261
254262-- | The `TableType` for a Squeal migration.
@@ -258,6 +266,14 @@ type MigrationsTable =
258266 , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
259267 ]
260268
269+data MigrationRow =
270+ MigrationRow { migrationName :: Text
271+ , executedAt :: UTCTime }
272+ deriving (GHC.Generic, Show)
273+
274+instance SOP.Generic MigrationRow
275+instance SOP.HasDatatypeInfo MigrationRow
276+
261277type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]
262278
263279-- | Creates a `MigrationsTable` if it does not already exist.
@@ -295,3 +311,87 @@ selectMigration = select_
295311 (#executed_at `as` #executed_at)
296312 ( from (table ((#migrations ! #schema_migrations) `as` #m))
297313 & where_ (#name .== param @1))
314+
315+fetchAllMigrations
316+ :: Query '[] '[] '["migrations" ::: MigrationsSchema] '[] (RowPG MigrationRow)
317+fetchAllMigrations =
318+ select_ ( #name `as` #migrationName
319+ :* #executed_at `as` #executedAt)
320+ (from (table (#migrations ! #schema_migrations)))
321+
322+unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x
323+unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK
324+
325+data Command = Display
326+ | AllUp
327+ | AllDown
328+ deriving (GHC.Generic, Show)
329+
330+defaultMain
331+ :: ByteString
332+ -- ^ connection string
333+ -> AlignedList (Migration IO) db0 db1
334+ -- ^ migrations
335+ -> IO ()
336+defaultMain connectTo migrations = do
337+ command <- readCommandFromArgs
338+ maybe (pure ()) (performCommand connectTo migrations) command
339+
340+readCommandFromArgs :: IO (Maybe Command)
341+readCommandFromArgs = do
342+ args <- getArgs
343+ case args of
344+ ["db:migrate"] -> pure . Just $ AllUp
345+ ["db:rollback"] -> pure . Just $ AllDown
346+ ["db:status"] -> pure . Just $ Display
347+ _ -> displayUsage >> pure Nothing
348+
349+displayUsage :: IO ()
350+displayUsage = do
351+ putStrLn "Invalid command. Use:"
352+ putStrLn "db:migrate to run all available migrations"
353+ putStrLn "db:rollback to rollback all available migrations"
354+ putStrLn "db:status to display migrations run and migrations left to run"
355+
356+type RunMigrationName = Text
357+
358+getRunMigrationNames :: (MonadBase IO m) => PQ db0 db0 m [RunMigrationName]
359+getRunMigrationNames =
360+ fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery fetchAllMigrations)) >>= getRows)
361+
362+displayListOfNames :: [Text] -> IO ()
363+displayListOfNames [] = T.putStrLn "\tNone"
364+displayListOfNames xs =
365+ let singleName n = T.putStrLn $ "\t- " <> n
366+ in traverse_ singleName xs
367+
368+displayUnrunned :: [RunMigrationName] -> IO ()
369+displayUnrunned unrunned =
370+ T.putStrLn "Migrations left to run:"
371+ >> displayListOfNames unrunned
372+
373+displayRunned :: [RunMigrationName] -> IO ()
374+displayRunned runned =
375+ T.putStrLn "Migrations already run:"
376+ >> displayListOfNames runned
377+
378+performCommand
379+ :: ByteString
380+ -- ^ Connection string
381+ -> AlignedList (Migration IO) db0 db1
382+ -- ^ Known migrations
383+ -> Command
384+ -- ^ Operation to perform
385+ -> IO ()
386+performCommand connectTo migrations Display =
387+ withConnection connectTo $ do
388+ runNames <- getRunMigrationNames
389+ let names = extractList name migrations
390+ unrunNames = names \\ runNames
391+ liftBase $ displayRunned runNames >> displayUnrunned unrunNames
392+performCommand connectTo migrations AllUp =
393+ withConnection connectTo (migrateUp migrations)
394+ >> performCommand connectTo migrations Display
395+performCommand connectTo migrations AllDown =
396+ withConnection connectTo (migrateDown migrations)
397+ >> performCommand connectTo migrations Display