diff --git a/postgresql-simple-migration.cabal b/postgresql-simple-migration.cabal index fcc78e7..2a41756 100644 --- a/postgresql-simple-migration.cabal +++ b/postgresql-simple-migration.cabal @@ -1,5 +1,5 @@ name: postgresql-simple-migration -version: 0.1.14.0 +version: 0.1.14.1 synopsis: PostgreSQL Schema Migrations homepage: https://github.com/ameingast/postgresql-simple-migration Bug-reports: https://github.com/ameingast/postgresql-simple-migration/issues diff --git a/src/Database/PostgreSQL/Simple/Migration.hs b/src/Database/PostgreSQL/Simple/Migration.hs index 2873a1b..40f922a 100644 --- a/src/Database/PostgreSQL/Simple/Migration.hs +++ b/src/Database/PostgreSQL/Simple/Migration.hs @@ -21,12 +21,15 @@ module Database.PostgreSQL.Simple.Migration ( -- * Migration actions - runMigration + runMigration' + , runMigration , runMigrations + , runMigrations' , sequenceMigrations -- * Migration types , MigrationContext(..) + , MigrationContext'(..) , MigrationCommand(..) , MigrationResult(..) , ScriptName @@ -45,6 +48,7 @@ import Control.Applicative ((<$>), (<*>)) import Control.Monad (void, when) import qualified Crypto.Hash.MD5 as MD5 (hash) import qualified Data.ByteString as BS (ByteString, readFile) +import qualified Data.ByteString.Char8 as BS8 (unpack) import qualified Data.ByteString.Base64 as B64 (encode) import Data.Foldable (Foldable) import Data.List (isPrefixOf, sort) @@ -71,19 +75,23 @@ import System.Directory (getDirectoryContents) -- -- It is recommended to wrap 'runMigration' inside a database transaction. runMigration :: MigrationContext -> IO (MigrationResult String) -runMigration (MigrationContext cmd verbose con) = case cmd of +runMigration (MigrationContext cmd verbose con) = + runMigration' (MigrationContext' cmd verbose con "schema_migrations") + +runMigration' :: MigrationContext' -> IO (MigrationResult String) +runMigration' (MigrationContext' cmd verbose con tableName) = case cmd of MigrationInitialization -> - initializeSchema con verbose >> return MigrationSuccess + initializeSchema con tableName verbose >> return MigrationSuccess MigrationDirectory path -> - executeDirectoryMigration con verbose path + executeDirectoryMigration con tableName verbose path MigrationScript name contents -> - executeMigration con verbose name contents + executeMigration con tableName verbose name contents MigrationFile name path -> - executeMigration con verbose name =<< BS.readFile path + executeMigration con tableName verbose name =<< BS.readFile path MigrationValidation validationCmd -> - executeValidation con verbose validationCmd + executeValidation con tableName verbose validationCmd MigrationCommands commands -> - runMigrations verbose con commands + runMigrations' verbose con commands tableName -- | Execute a sequence of migrations -- @@ -100,8 +108,27 @@ runMigrations -> [MigrationCommand] -- ^ The commands to run -> IO (MigrationResult String) -runMigrations verbose con commands = - sequenceMigrations [runMigration (MigrationContext c verbose con) | c <- commands] +runMigrations verbose con commands = runMigrations' verbose con commands "schema_migrations" + +-- | 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 + -> BS.ByteString + -- ^ The schema_migrations table name + -> IO (MigrationResult String) +runMigrations' verbose con commands tableName = + sequenceMigrations [runMigration' (MigrationContext' c verbose con tableName) | c <- commands] -- | Run a sequence of contexts, stopping on the first failure sequenceMigrations :: Monad m => [m (MigrationResult e)] -> m (MigrationResult e) @@ -115,12 +142,12 @@ sequenceMigrations = \case -- | 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 = +executeDirectoryMigration :: Connection -> BS.ByteString -> Bool -> FilePath -> IO (MigrationResult String) +executeDirectoryMigration con tableName verbose dir = scriptsInDirectory dir >>= go where go fs = sequenceMigrations (executeMigrationFile <$> fs) - executeMigrationFile f = executeMigration con verbose f =<< BS.readFile (dir ++ "/" ++ f) + executeMigrationFile f = executeMigration con tableName verbose f =<< BS.readFile (dir ++ "/" ++ f) -- | Lists all files in the given 'FilePath' 'dir' in alphabetical order. scriptsInDirectory :: FilePath -> IO [String] @@ -130,10 +157,10 @@ scriptsInDirectory dir = -- | Executes a generic SQL migration for the provided script 'name' with -- content 'contents'. -executeMigration :: Connection -> Bool -> ScriptName -> BS.ByteString -> IO (MigrationResult String) -executeMigration con verbose name contents = do +executeMigration :: Connection -> BS.ByteString -> Bool -> ScriptName -> BS.ByteString -> IO (MigrationResult String) +executeMigration con tableName verbose name contents = do let checksum = md5Hash contents - checkScript con name checksum >>= \case + checkScript con tableName name checksum >>= \case ScriptOk -> do when verbose $ putStrLn $ "Ok:\t" ++ name return MigrationSuccess @@ -146,15 +173,15 @@ executeMigration con verbose name contents = do when verbose $ putStrLn $ "Fail:\t" ++ name return (MigrationError name) where - q = "insert into schema_migrations(filename, checksum) values(?, ?)" + q = "insert into " <> Query tableName <> "(filename, checksum) values(?, ?)" -- | Initializes the database schema with a helper table containing -- meta-information about executed migrations. -initializeSchema :: Connection -> Bool -> IO () -initializeSchema con verbose = do +initializeSchema :: Connection -> BS.ByteString -> Bool -> IO () +initializeSchema con tableName verbose = do when verbose $ putStrLn "Initializing schema" void $ execute_ con $ mconcat - [ "create table if not exists schema_migrations " + [ "create table if not exists " <> Query tableName <> " " , "( filename varchar(512) not null" , ", checksum varchar(32) not null" , ", executed_at timestamp without time zone not null default now() " @@ -172,12 +199,14 @@ initializeSchema con verbose = do -- * '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 +executeValidation :: Connection -> BS.ByteString -> Bool -> MigrationCommand -> IO (MigrationResult String) +executeValidation con tableName' verbose cmd = + let tableName = BS8.unpack tableName' in + case cmd of MigrationInitialization -> - existsTable con "schema_migrations" >>= \r -> return $ if r + existsTable con tableName >>= \r -> return $ if r then MigrationSuccess - else MigrationError "No such table: schema_migrations" + else MigrationError $ "No such table: " <> tableName MigrationDirectory path -> scriptsInDirectory path >>= goScripts path MigrationScript name contents -> @@ -187,10 +216,10 @@ executeValidation con verbose cmd = case cmd of MigrationValidation _ -> return MigrationSuccess MigrationCommands cs -> - sequenceMigrations (executeValidation con verbose <$> cs) + sequenceMigrations (executeValidation con tableName' verbose <$> cs) where validate name contents = - checkScript con name (md5Hash contents) >>= \case + checkScript con tableName' name (md5Hash contents) >>= \case ScriptOk -> do when verbose $ putStrLn $ "Ok:\t" ++ name return MigrationSuccess @@ -209,8 +238,8 @@ executeValidation con verbose cmd = case cmd of -- is compared against the one that was executed. -- If there is no matching script entry in the database, the script -- will be executed and its meta-information will be recorded. -checkScript :: Connection -> ScriptName -> Checksum -> IO CheckScriptResult -checkScript con name checksum = +checkScript :: Connection -> BS.ByteString -> ScriptName -> Checksum -> IO CheckScriptResult +checkScript con tableName name checksum = query con q (Only name) >>= \case [] -> return ScriptNotExecuted @@ -220,7 +249,7 @@ checkScript con name checksum = return (ScriptModified actualChecksum) where q = mconcat - [ "select checksum from schema_migrations " + [ "select checksum from " <> Query tableName <> " " , "where filename = ? limit 1" ] @@ -289,20 +318,32 @@ data MigrationResult a -- | The 'MigrationContext' provides an execution context for migrations. data MigrationContext = MigrationContext - { migrationContextCommand :: MigrationCommand + { migrationContextCommand :: !MigrationCommand + -- ^ The action that will be performed by 'runMigration' + , migrationContextVerbose :: !Bool + -- ^ Verbosity of the library. + , migrationContextConnection :: !Connection + -- ^ The PostgreSQL connection to use for migrations. + } + +-- | The 'MigrationContext'' provides an execution context for migrations, with additional options to MigrationContext +data MigrationContext' = MigrationContext' + { migrationContextCommand' :: !MigrationCommand -- ^ The action that will be performed by 'runMigration' - , migrationContextVerbose :: Bool + , migrationContextVerbose' :: !Bool -- ^ Verbosity of the library. - , migrationContextConnection :: Connection + , migrationContextConnection' :: !Connection -- ^ The PostgreSQL connection to use for migrations. + , migrationTableName :: !BS.ByteString + -- ^ The name of the table that stores the migrations } -- | Produces a list of all executed 'SchemaMigration's. -getMigrations :: Connection -> IO [SchemaMigration] -getMigrations = flip query_ q +getMigrations :: Connection -> BS.ByteString -> IO [SchemaMigration] +getMigrations con tableName = query_ con q where q = mconcat [ "select filename, checksum, executed_at " - , "from schema_migrations order by executed_at asc" + , "from " <> Query tableName <> " order by executed_at asc" ] -- | A product type representing a single, executed 'SchemaMigration'. diff --git a/src/Main.hs b/src/Main.hs index 92a2551..1e81324 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -21,14 +21,15 @@ module Main ( import Control.Applicative #endif import Control.Exception +import qualified Data.ByteString as BS (ByteString) import qualified Data.ByteString.Char8 as BS8 (pack) import Database.PostgreSQL.Simple (SqlError (..), connectPostgreSQL, withTransaction) import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), - MigrationContext (..), + MigrationContext' (..), MigrationResult (..), - runMigration) + runMigration') import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) @@ -69,26 +70,29 @@ run :: Maybe Command -> Bool-> IO () run Nothing _ = printUsage >> exitFailure run (Just cmd) verbose = handleResult =<< case cmd of - Initialize url -> do + Initialize url tableName -> do con <- connectPostgreSQL (BS8.pack url) - withTransaction con $ runMigration $ MigrationContext - MigrationInitialization verbose con - Migrate url dir -> do + withTransaction con $ runMigration' $ MigrationContext' + MigrationInitialization verbose con tableName + Migrate url dir tableName -> do con <- connectPostgreSQL (BS8.pack url) - withTransaction con $ runMigration $ MigrationContext - (MigrationDirectory dir) verbose con - Validate url dir -> do + withTransaction con $ runMigration' $ MigrationContext' + (MigrationDirectory dir) verbose con tableName + Validate url dir tableName -> do con <- connectPostgreSQL (BS8.pack url) - withTransaction con $ runMigration $ MigrationContext - (MigrationValidation (MigrationDirectory dir)) verbose con + withTransaction con $ runMigration' $ MigrationContext' + (MigrationValidation (MigrationDirectory dir)) verbose con tableName where handleResult MigrationSuccess = exitSuccess handleResult (MigrationError _) = exitFailure parseCommand :: [String] -> Maybe Command -parseCommand ("init":url:_) = Just (Initialize url) -parseCommand ("migrate":url:dir:_) = Just (Migrate url dir) -parseCommand ("validate":url:dir:_) = Just (Validate url dir) +parseCommand ("init":url:tableName:_) = Just (Initialize url (BS8.pack tableName)) +parseCommand ("migrate":url:dir:tableName:_) = Just (Migrate url dir (BS8.pack tableName)) +parseCommand ("validate":url:dir:tableName:_) = Just (Validate url dir (BS8.pack tableName)) +parseCommand ("init":url:_) = Just (Initialize url "schema_migrations") +parseCommand ("migrate":url:dir:_) = Just (Migrate url dir "schema_migrations") +parseCommand ("validate":url:dir:_) = Just (Validate url dir "schema_migrations") parseCommand _ = Nothing printUsage :: IO () @@ -98,25 +102,34 @@ printUsage = do putStrLn " -h Print help text" putStrLn " -q Enable quiet mode" putStrLn " Commands:" - putStrLn " init " + putStrLn " init {migrations table name}" putStrLn " Initialize the database. Required to be run" putStrLn " at least once." - putStrLn " migrate " + putStrLn " {migrations table name} is the optiona name." + putStrLn " for the migrations table. This defaults to" + putStrLn " `schema_migrations`." + putStrLn " migrate {migrations table name}" putStrLn " Execute all SQL scripts in the provided" putStrLn " directory in alphabetical order." putStrLn " Scripts that have already been executed are" putStrLn " ignored. If a script was changed since the" putStrLn " time of its last execution, an error is" putStrLn " raised." - putStrLn " validate " + putStrLn " {migrations table name} is the optiona name." + putStrLn " for the migrations table. This defaults to" + putStrLn " `schema_migrations`." + putStrLn " validate {migrations table name}" putStrLn " Validate all SQL scripts in the provided" putStrLn " directory." + putStrLn " {migrations table name} is the optiona name." + putStrLn " for the migrations table. This defaults to" + putStrLn " `schema_migrations`." putStrLn " The parameter is based on libpq connection string" putStrLn " syntax. Detailled information is available here:" putStrLn " " data Command - = Initialize String - | Migrate String FilePath - | Validate String FilePath + = Initialize String BS.ByteString + | Migrate String FilePath BS.ByteString + | Validate String FilePath BS.ByteString deriving (Show, Eq, Read, Ord)