Add MigrationCommands

Author: expipiplus1

src/Database/PostgreSQL/Simple/Migration.hs

@@ -19,6 +19,8 @@ module Database.PostgreSQL.Simple.Migration
     (
     -- * Migration actions
     runMigration
+    , runMigrations
+    , sequenceMigrations
 
     -- * Migration types
     , MigrationContext(..)
@@ -68,13 +70,43 @@ runMigration (MigrationContext cmd verbose con) = case cmd of
     MigrationInitialization ->
         initializeSchema con verbose >> return MigrationSuccess
     MigrationDirectory path ->
-       executeDirectoryMigration con verbose path
+        executeDirectoryMigration con verbose path
     MigrationScript name contents ->
         executeMigration con verbose name contents
     MigrationFile name path ->
         executeMigration con verbose name =<< BS.readFile path
     MigrationValidation validationCmd ->
         executeValidation con verbose validationCmd
+    MigrationCommands commands ->
+        runMigrations verbose con commands
+
+-- | Execute a sequence of migrations
+--
+-- Returns 'MigrationSuccess' if all of the provided 'MigrationCommand's
+-- execute without error. If an error occurs, execution is stopped and the
+-- 'MigrationError' is returned.
+--
+-- It is recommended to wrap 'runMigrations' inside a database transaction.
+runMigrations
+    :: Bool
+       -- ^ Run in verbose mode
+    -> Connection
+       -- ^ The postgres connection to use
+    -> [MigrationCommand]
+       -- ^ The commands to run
+    -> IO (MigrationResult String)
+runMigrations verbose con commands =
+    sequenceMigrations [runMigration (MigrationContext c verbose con) | c <- commands]
+
+-- | Run a sequence of contexts, stopping on the first failure
+sequenceMigrations :: Monad m => [m (MigrationResult e)] -> m (MigrationResult e)
+sequenceMigrations = \case
+    []   -> pure MigrationSuccess
+    c:cs -> do
+      r <- c
+      case r of
+        MigrationError s -> pure (MigrationError s)
+        MigrationSuccess -> sequenceMigrations cs
 
 -- | Executes all SQL-file based migrations located in the provided 'dir'
 -- in alphabetical order.
@@ -140,6 +172,7 @@ initializeSchema con verbose = do
 -- * 'MigrationScript': validate the presence and checksum of the given script.
 -- * 'MigrationFile': validate the presence and checksum of the given file.
 -- * 'MigrationValidation': always succeeds.
+-- * 'MigrationCommands': validates all the sub-commands stopping at the first failure.
 executeValidation :: Connection -> Bool -> MigrationCommand -> IO (MigrationResult String)
 executeValidation con verbose cmd = case cmd of
     MigrationInitialization ->
@@ -154,6 +187,8 @@ executeValidation con verbose cmd = case cmd of
         validate name =<< BS.readFile path
     MigrationValidation _ ->
         return MigrationSuccess
+    MigrationCommands cs ->
+        sequenceMigrations (executeValidation con verbose <$> cs)
     where
         validate name contents =
             checkScript con name (md5Hash contents) >>= \case
@@ -222,8 +257,17 @@ data MigrationCommand
     -- ^ Executes a migration based on the provided bytestring.
     | MigrationValidation MigrationCommand
     -- ^ Validates the provided MigrationCommand.
+    | MigrationCommands [MigrationCommand]
+    -- ^ Performs a series of 'MigrationCommand's in sequence.
     deriving (Show, Eq, Read, Ord)
 
+instance Monoid MigrationCommand where
+  mempty = MigrationCommands []
+  mappend (MigrationCommands xs) (MigrationCommands ys) = MigrationCommands (xs ++ ys)
+  mappend (MigrationCommands xs) y = MigrationCommands (xs ++ [y])
+  mappend x (MigrationCommands ys) = MigrationCommands (x : ys)
+  mappend x y = MigrationCommands [x, y]
+
 -- | A sum-type denoting the result of a single migration.
 data CheckScriptResult
     = ScriptOk