diff --git a/Changelog.markdown b/Changelog.markdown --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,5 +1,10 @@ # Changelog +## 0.1.8.0 +* Added MigrationCommands allowing sequencing of migrations in the Haskell API +* Derived more datatypes for MigrationResult +* Bumped dependencies + ## 0.1.7.0 * Propagate migration and validation result to application exit code diff --git a/postgresql-simple-migration.cabal b/postgresql-simple-migration.cabal --- a/postgresql-simple-migration.cabal +++ b/postgresql-simple-migration.cabal @@ -1,5 +1,5 @@ name: postgresql-simple-migration -version: 0.1.7.0 +version: 0.1.8.0 synopsis: PostgreSQL Schema Migrations homepage: https://github.com/ameingast/postgresql-simple-migration Bug-reports: https://github.com/ameingast/postgresql-simple-migration/issues @@ -41,7 +41,7 @@ base64-bytestring >= 1.0 && < 1.1, bytestring >= 0.10 && < 0.11, cryptohash >= 0.11 && < 0.12, - directory >= 1.2 && < 1.3, + directory >= 1.2 && < 1.4, postgresql-simple >= 0.4 && < 0.6, time >= 1.4 && < 1.7 @@ -55,7 +55,7 @@ base64-bytestring >= 1.0 && < 1.1, bytestring >= 0.10 && < 0.11, cryptohash >= 0.11 && < 0.12, - directory >= 1.2 && < 1.3, + directory >= 1.2 && < 1.4, postgresql-simple >= 0.4 && < 0.6, time >= 1.4 && < 1.7, text >= 1.2 && < 1.3 @@ -70,5 +70,5 @@ build-depends: base >= 4.6 && < 5.0, bytestring >= 0.10 && < 0.11, postgresql-simple >= 0.4 && < 0.6, - hspec >= 2.2 && < 2.3, + hspec >= 2.2 && < 2.4, postgresql-simple-migration >= 0.1 && < 0.2 diff --git a/src/Database/PostgreSQL/Simple/Migration.hs b/src/Database/PostgreSQL/Simple/Migration.hs --- a/src/Database/PostgreSQL/Simple/Migration.hs +++ b/src/Database/PostgreSQL/Simple/Migration.hs @@ -12,6 +12,9 @@ -- For usage, see Readme.markdown. {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -19,6 +22,8 @@ ( -- * Migration actions runMigration + , runMigrations + , sequenceMigrations -- * Migration types , MigrationContext(..) @@ -41,9 +46,11 @@ import qualified Crypto.Hash.MD5 as MD5 (hash) import qualified Data.ByteString as BS (ByteString, readFile) import qualified Data.ByteString.Base64 as B64 (encode) +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 (..), @@ -68,28 +75,52 @@ 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 + [] -> return MigrationSuccess + c:cs -> do + r <- c + case r of + MigrationError s -> return (MigrationError s) + MigrationSuccess -> sequenceMigrations cs + -- | Executes all SQL-file based migrations located in the provided 'dir' -- in alphabetical order. executeDirectoryMigration :: Connection -> Bool -> FilePath -> IO (MigrationResult String) 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] @@ -140,6 +171,7 @@ -- * '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 +186,8 @@ 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 @@ -167,13 +201,8 @@ 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 @@ -222,8 +251,17 @@ -- ^ 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 @@ -242,7 +280,7 @@ -- ^ There was an error in script migration. | MigrationSuccess -- ^ All scripts have been executed successfully. - deriving (Show, Eq, Read, Ord) + deriving (Show, Eq, Read, Ord, Functor, Foldable, Traversable) -- | The 'MigrationContext' provides an execution context for migrations. data MigrationContext = MigrationContext