From 21a23c46b71f967ab9e8ee8e0863db02d5775b9e Mon Sep 17 00:00:00 2001
From: "leon.smith@obsidian.systems" <leon.smith@obsidian.systems>
Date: Mon, 13 Jan 2020 15:07:01 -0500
Subject: [PATCH] Enhance Database.Beam.Migrate.Simple

---
 beam-migrate/Database/Beam/Migrate/Simple.hs | 56 +++++++++++++++++---
 1 file changed, 48 insertions(+), 8 deletions(-)

diff --git a/beam-migrate/Database/Beam/Migrate/Simple.hs b/beam-migrate/Database/Beam/Migrate/Simple.hs
index 1be16c2d5..67bf8c880 100644
--- a/beam-migrate/Database/Beam/Migrate/Simple.hs
+++ b/beam-migrate/Database/Beam/Migrate/Simple.hs
@@ -2,6 +2,10 @@
 -- | Utility functions for common use cases
 module Database.Beam.Migrate.Simple
   ( autoMigrate
+  , planMigration
+  , describeMigrationPlan
+  , executeMigrationPlan
+  , autoMigrateVerbose
   , simpleSchema
   , simpleMigration
   , runSimpleMigration
@@ -211,18 +215,54 @@ autoMigrate :: (Database be db, Fail.MonadFail m)
             => BeamMigrationBackend be m
             -> CheckedDatabaseSettings be db
             -> m ()
-autoMigrate BeamMigrationBackend { backendActionProvider = actions
-                                 , backendGetDbConstraints = getCs }
+autoMigrate b@(BeamMigrationBackend {})
             db =
+  do cmds <- planMigration b db
+     executeMigrationPlan b cmds
+
+planMigration :: (Database be db, Fail.MonadFail m)
+              => BeamMigrationBackend be m
+              -> CheckedDatabaseSettings be db
+              -> m [MigrationCommand be]
+planMigration BeamMigrationBackend { backendActionProvider = actions
+                                   , backendGetDbConstraints = getCs }
+              db =
   do actual <- getCs
      let expected = collectChecks db
      case finalSolution (heuristicSolver actions actual expected) of
-       Candidates {} -> Fail.fail "autoMigrate: Could not determine migration"
-       Solved cmds ->
-         -- Check if any of the commands are irreversible
-         case foldMap migrationCommandDataLossPossible cmds of
-           MigrationKeepsData -> mapM_ (runNoReturn . migrationCommand) cmds
-           _ -> Fail.fail "autoMigrate: Not performing automatic migration due to data loss"
+       Candidates {} -> Fail.fail "planMigration: Could not determine migration"
+       Solved cmds -> return cmds
+
+describeMigrationPlan :: Sql92DisplaySyntax (BeamSqlBackendSyntax be)
+                      => [MigrationCommand be]
+                      -> [String]
+describeMigrationPlan = map $ \cmd -> safety cmd <> displaySyntax (migrationCommand cmd)
+  where
+    safety cmd = case migrationCommandDataLossPossible cmd of
+      MigrationLosesData -> "<UNSAFE> "
+      MigrationKeepsData -> "         "
+
+executeMigrationPlan :: Fail.MonadFail m
+                     => BeamMigrationBackend be m
+                     -> [MigrationCommand be]
+                     -> m ()
+executeMigrationPlan (BeamMigrationBackend {}) cmds =
+     -- Check if any of the commands are irreversible
+     case foldMap migrationCommandDataLossPossible cmds of
+       MigrationKeepsData -> mapM_ (runNoReturn . migrationCommand) cmds
+       _ -> Fail.fail "executeMigrationPlan: Not performing automatic migration due to data loss"
+
+autoMigrateVerbose :: ( Database be db, Sql92DisplaySyntax (BeamSqlBackendSyntax be), MonadIO m
+                      , Fail.MonadFail m
+                      )
+                   => BeamMigrationBackend be m
+                   -> CheckedDatabaseSettings be db
+                   -> m ()
+autoMigrateVerbose b@(BeamMigrationBackend {})
+                   db =
+  do cmds <- planMigration b db
+     liftIO $ putStr $ unlines $ describeMigrationPlan cmds
+     executeMigrationPlan b cmds
 
 -- | Given a migration backend, a handle to a database, and a checked database,
 -- attempt to find a schema. This should always return 'Just', unless the