Support a user defined name for the schema_migrations table

Added runMigration' and runMigrations'. These two function support an
extra parameter over the non-prime ones. This param is the name of the
scschema_migrations table that the user has selected.

Adding two new functions like this means there are no breaking changes
for existing users.

Author: andrevdm

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

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'.

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 <con>"
+    putStrLn "      init <con> {migrations table name}"
     putStrLn "                  Initialize the database. Required to be run"
     putStrLn "                  at least once."
-    putStrLn "      migrate <con> <directory>"
+    putStrLn "                  {migrations table name} is the optiona name."
+    putStrLn "                  for the migrations table. This defaults to"
+    putStrLn "                  `schema_migrations`."
+    putStrLn "      migrate <con> <directory> {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 <con> <directory>"
+    putStrLn "                  {migrations table name} is the optiona name."
+    putStrLn "                  for the migrations table. This defaults to"
+    putStrLn "                  `schema_migrations`."
+    putStrLn "      validate <con> <directory> {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 <con> parameter is based on libpq connection string"
     putStrLn "      syntax. Detailled information is available here:"
     putStrLn "      <http://www.postgresql.org/docs/9.3/static/libpq-connect.html>"
 
 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)