From 6fe995708d6c7ce5b050fc405cb3ab63ddef37cc Mon Sep 17 00:00:00 2001 From: Joe Hermaszewski Date: Tue, 24 Jan 2017 17:58:54 +0000 Subject: [PATCH 1/4] Add MigrationCommands Closes #13 --- src/Database/PostgreSQL/Simple/Migration.hs | 46 ++++++++++++++++++++- 1 file changed, 45 insertions(+), 1 deletion(-) diff --git a/src/Database/PostgreSQL/Simple/Migration.hs b/src/Database/PostgreSQL/Simple/Migration.hs index c9f04a4..1bf9488 100644 --- a/src/Database/PostgreSQL/Simple/Migration.hs +++ b/src/Database/PostgreSQL/Simple/Migration.hs @@ -22,6 +22,8 @@ module Database.PostgreSQL.Simple.Migration ( -- * Migration actions runMigration + , runMigrations + , sequenceMigrations -- * Migration types , MigrationContext(..) @@ -73,13 +75,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. @@ -145,6 +177,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 -> @@ -159,6 +192,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 @@ -227,8 +262,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 From 22c591451a7b81f9c419464de9cff154ebc04e0c Mon Sep 17 00:00:00 2001 From: Joe Hermaszewski Date: Tue, 24 Jan 2017 18:05:40 +0000 Subject: [PATCH 2/4] Rewrite goScripts and go in terms of sequenceMigration --- src/Database/PostgreSQL/Simple/Migration.hs | 19 ++++--------------- 1 file changed, 4 insertions(+), 15 deletions(-) diff --git a/src/Database/PostgreSQL/Simple/Migration.hs b/src/Database/PostgreSQL/Simple/Migration.hs index 1bf9488..8e36a48 100644 --- a/src/Database/PostgreSQL/Simple/Migration.hs +++ b/src/Database/PostgreSQL/Simple/Migration.hs @@ -119,14 +119,8 @@ executeDirectoryMigration :: Connection -> Bool -> FilePath -> IO (MigrationResu executeDirectoryMigration con verbose dir = scriptsInDirectory dir >>= go where - go [] = return MigrationSuccess - go (f:fs) = do - r <- executeMigration con verbose f =<< BS.readFile (dir ++ "/" ++ f) - case r of - MigrationError _ -> - return r - MigrationSuccess -> - go fs + go fs = sequenceMigrations (executeMigrationFile <$> fs) + executeMigrationFile f = executeMigration con verbose f =<< BS.readFile (dir ++ "/" ++ f) -- | Lists all files in the given 'FilePath' 'dir' in alphabetical order. scriptsInDirectory :: FilePath -> IO [String] @@ -207,13 +201,8 @@ executeValidation con verbose cmd = case cmd of when verbose $ putStrLn $ "Checksum mismatch:\t" ++ name return (MigrationError $ "Checksum mismatch: " ++ name) - goScripts _ [] = return MigrationSuccess - goScripts path (x:xs) = - (validate x =<< BS.readFile (path ++ "/" ++ x)) >>= \case - e@(MigrationError _) -> - return e - MigrationSuccess -> - goScripts path xs + goScripts path xs = sequenceMigrations (goScript path <$> xs) + goScript path x = validate x =<< BS.readFile (path ++ "/" ++ x) -- | Checks the status of the script with the given name 'name'. -- If the script has already been executed, the checksum of the script From 9c286a83dca64d7fea4e484a96e7a1214f71a50f Mon Sep 17 00:00:00 2001 From: Joe Hermaszewski Date: Tue, 24 Jan 2017 18:25:27 +0000 Subject: [PATCH 3/4] Import Monoid class --- src/Database/PostgreSQL/Simple/Migration.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Database/PostgreSQL/Simple/Migration.hs b/src/Database/PostgreSQL/Simple/Migration.hs index 8e36a48..9c3f8c5 100644 --- a/src/Database/PostgreSQL/Simple/Migration.hs +++ b/src/Database/PostgreSQL/Simple/Migration.hs @@ -50,7 +50,7 @@ import Data.Foldable (Foldable) import Data.Traversable (Traversable) import Data.List (isPrefixOf, sort) #if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mconcat) +import Data.Monoid (Monoid (..)) #endif import Data.Time (LocalTime) import Database.PostgreSQL.Simple (Connection, Only (..), From 5acb8fd57de13953fb665609b56845aadff37ea3 Mon Sep 17 00:00:00 2001 From: Joe Hermaszewski Date: Tue, 24 Jan 2017 19:07:41 +0000 Subject: [PATCH 4/4] s/pure/return --- src/Database/PostgreSQL/Simple/Migration.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Database/PostgreSQL/Simple/Migration.hs b/src/Database/PostgreSQL/Simple/Migration.hs index 9c3f8c5..c38747c 100644 --- a/src/Database/PostgreSQL/Simple/Migration.hs +++ b/src/Database/PostgreSQL/Simple/Migration.hs @@ -106,11 +106,11 @@ runMigrations verbose con commands = -- | Run a sequence of contexts, stopping on the first failure sequenceMigrations :: Monad m => [m (MigrationResult e)] -> m (MigrationResult e) sequenceMigrations = \case - [] -> pure MigrationSuccess + [] -> return MigrationSuccess c:cs -> do r <- c case r of - MigrationError s -> pure (MigrationError s) + MigrationError s -> return (MigrationError s) MigrationSuccess -> sequenceMigrations cs -- | Executes all SQL-file based migrations located in the provided 'dir'