diff --git a/MOO.TXT b/MOO.TXT --- a/MOO.TXT +++ b/MOO.TXT @@ -6,7 +6,7 @@ "moo", is responsible for creating, installing, and reverting migrations in your database backend. -At present, PostgreSQL and Sqlite3 are the only supported database +At present, MySQL, PostgreSQL and Sqlite3 are the only supported database backends. The moo tool works by creating migration files in a specific location, @@ -25,6 +25,42 @@ migrations is tracked by way of a migration table that is installed into your database. +WARNING TO MYSQL USERS +---------------------- + +If you are using this library with MySQL, beware of the following +caveat! + +Unlike PostgreSQL and SQLite, MySQL does not support transactional +Data Definition Language (DDL) statements such as CREATE TABLE. Since +dbmigrations is designed around the assumption that it's useful and +important to make migrations atomic, and since most migrations will have +at least some DDL in them, this means that dbmigrations cannot make +atomicity guarantees about your migrations if you are using MySQL as +your backend. The MySQL docs have this to say: + +http://dev.mysql.com/doc/refman/5.7/en/cannot-roll-back.html + +This means that features like moo's "--test" flag will not do what you +expect, that mistakes in migrations will be tough to fix in development, +and that a problem in a migration in a production deployment COULD +HOSE YOUR DATABASE and BREAK RUNNING APPLICATIONS. Note that MySQL's +DDL statements cause an implicit commit, so any errors after each DDL +statement will have to be corrected by hand! + +It is the author's opinion that this makes MySQL unfit for production +use and that you should strongly consider using some other backend such +as PostgreSQL which has much more robust support for transactional DDL. + +You might be wondering why support for MySQL is included if it can be +so dangerous to use. Some users have requested and contributed support +for it, and of course we can't always choose to use a different backend +for preexisting systems. In those cases at least dbmigrations doesn't +make your problem any worse than it already is, provided you heed this +disclaimer. :) + +You have been warned! + Getting started --------------- @@ -34,11 +70,13 @@ directory you created in step 1. 3. Set an environment variable DBM_DATABASE_TYPE to a supported - backend. Valid values are "postgresql" and "sqlite3". + backend. Valid values are "mysql", "postgresql" and "sqlite3". 4. Set an environment variable DBM_DATABASE to a database connection string that is appropriate for the value of DBM_DATABASE_TYPE you - chose. + chose. The contents of this depend on the value of + DBM_DATABASE_TYPE, see the "Environment" documentation section for + more information. 5. Run "moo upgrade". This command will not actually install any migrations, since you have not created any, but it will attempt to @@ -195,9 +233,9 @@ DBM_DATABASE_TYPE - The type of database you'll be managing. The only supported value - at present is "postgresql". This will determine the format of - DBM_DATABASE. + The type of database you'll be managing. Supported values + at present are "mysql", "postgresql" and "sqlite3". This will + determine the format of DBM_DATABASE. DBM_DATABASE @@ -216,6 +254,15 @@ The format of this value is a filesystem path to the Sqlite3 database to be used. + + DBM_DATABASE_TYPE=mysql: + + For MySQL, DBM_DATABASE should be a value of key value pairs, + where each pair is formed by `key=value`, and each pair separated + by a semicolon. Required keys are `host`, `user` and `database`, + and you can optionally supply `port` and `password`. + + Example: DBM_DATABASE="host=localhost; user=root; database=cows" DBM_MIGRATION_STORE diff --git a/dbmigrations.cabal b/dbmigrations.cabal --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -1,5 +1,5 @@ Name: dbmigrations -Version: 1.0 +Version: 1.1 Synopsis: An implementation of relational database "migrations" Description: A library and program for the creation, management, and installation of schema updates @@ -11,8 +11,9 @@ transactions for safety. This package is written to support any - HDBC-supported database, although at present only - PostgreSQL is fully supported. + HDBC-supported database. This package supports + SQLite, PostgreSQL, and MySQL. Please see MOO.TXT + for warnings about MySQL! To get started, see the included 'README.md' and 'MOO.TXT' files and the usage output for the @@ -73,7 +74,10 @@ text >= 0.11, configurator >= 0.2, HDBC-postgresql, - HDBC-sqlite3 + HDBC-sqlite3, + mysql >= 0.1.1.8, + mysql-simple >= 0.2.2.5, + split >= 0.2.2 Hs-Source-Dirs: src Exposed-Modules: @@ -83,6 +87,7 @@ Database.Schema.Migrations.Filesystem Database.Schema.Migrations.Backend Database.Schema.Migrations.Backend.HDBC + Database.Schema.Migrations.Backend.MySQL Database.Schema.Migrations.Store Moo.Main Moo.CommandHandlers @@ -115,7 +120,10 @@ HUnit >= 1.2, process >= 1.1, configurator >= 0.2, - text >= 0.11 + text >= 0.11, + mysql-simple >= 0.2.2.5, + mysql >= 0.1.1.8, + split >= 0.2.2 other-modules: BackendTest diff --git a/src/Database/Schema/Migrations/Backend/MySQL.hs b/src/Database/Schema/Migrations/Backend/MySQL.hs new file mode 100644 --- /dev/null +++ b/src/Database/Schema/Migrations/Backend/MySQL.hs @@ -0,0 +1,78 @@ +module Database.Schema.Migrations.Backend.MySQL (mysqlBackend) where + +import Control.Monad (when) +import Database.MySQL.Simple +import Database.Schema.Migrations.Backend + (Backend(..), rootMigrationName) +import Database.Schema.Migrations.Migration + (Migration(..), newMigration) +import Data.Time.Clock (getCurrentTime) +import Data.String (fromString) +import Data.Maybe (listToMaybe) +import qualified Database.MySQL.Base as Base + +mysqlBackend :: Connection -> Backend +mysqlBackend conn = + Backend {isBootstrapped = + fmap ((Just migrationTableName ==) . listToMaybe . fmap fromOnly) + (query conn + (fromString "SELECT table_name FROM information_schema.tables WHERE table_name = ? AND table_schema = database()") + (Only migrationTableName) :: IO [Only String]) + ,getBootstrapMigration = + do ts <- getCurrentTime + return ((newMigration rootMigrationName) {mApply = createSql + ,mRevert = + Just revertSql + ,mDesc = + Just "Migration table installation" + ,mTimestamp = Just ts}) + ,applyMigration = + \m -> + do execute_ conn (fromString (mApply m)) + discardResults conn + execute conn + (fromString + ("INSERT INTO " ++ + migrationTableName ++ + " (migration_id) VALUES (?)")) + (Only (mId m)) + return () + ,revertMigration = + \m -> + do case mRevert m of + Nothing -> return () + Just sql -> + do execute_ conn (fromString sql) + return () + discardResults conn + -- Remove migration from installed_migrations in either case. + execute + conn + (fromString + ("DELETE FROM " ++ + migrationTableName ++ " WHERE migration_id = ?")) + (Only (mId m)) + return () + ,getMigrations = + do results <- + query_ conn + (fromString + ("SELECT migration_id FROM " ++ migrationTableName)) + return (map fromOnly results) + ,commitBackend = commit conn + ,rollbackBackend = rollback conn + ,disconnectBackend = close conn} + +discardResults :: Connection -> IO () +discardResults conn = + do more <- Base.nextResult conn + when more (discardResults conn) + +migrationTableName :: String +migrationTableName = "installed_migrations" + +createSql :: String +createSql = "CREATE TABLE " ++ migrationTableName ++ " (migration_id TEXT)" + +revertSql :: String +revertSql = "DROP TABLE " ++ migrationTableName diff --git a/src/Moo/Core.hs b/src/Moo/Core.hs --- a/src/Moo/Core.hs +++ b/src/Moo/Core.hs @@ -14,6 +14,8 @@ , envStoreName , loadConfiguration) where +import Data.List.Split (wordsBy) +import Data.Char (isSpace) import Control.Applicative ((<$>), (<*>)) import Control.Monad.Reader (ReaderT) import qualified Data.Configurator as C @@ -24,12 +26,14 @@ import Database.HDBC.Sqlite3 (connectSqlite3) import System.Environment (getEnvironment) import Data.Maybe (isJust, fromMaybe) - +import qualified Database.MySQL.Simple as MySQL +import qualified Database.MySQL.Base as MySQLB import Database.Schema.Migrations () import Database.Schema.Migrations.Store (MigrationStore, StoreData) import Database.Schema.Migrations.Backend import Database.Schema.Migrations.Backend.HDBC +import Database.Schema.Migrations.Backend.MySQL -- |The monad in which the application runs. type AppT a = ReaderT AppState IO a @@ -180,7 +184,33 @@ databaseTypes :: [(String, String -> IO Backend)] databaseTypes = [ ("postgresql", fmap hdbcBackend . connectPostgreSQL) , ("sqlite3", fmap hdbcBackend . connectSqlite3) + , ("mysql", fmap mysqlBackend . connectMySQL) ] + +-- A slightly hacky connection string parser for MySQL, because mysql-simple +-- doesn't come with one. +connectMySQL :: String -> IO MySQL.Connection +connectMySQL connectionString = + let kvs = + [(map toLower (trimlr k),trimlr v) | kvPair <- + wordsBy (== ';') connectionString :: [String] + , let (k,v) = case wordsBy (== '=') kvPair of + (k:v:_) -> (k,v) + [k] -> (k,"") + [] -> error "impossible"] + trimlr = takeWhile (not . isSpace) . dropWhile isSpace + connInfo = + MySQL.ConnectInfo + <$> lookup "host" kvs + <*> pure (read (fromMaybe "3306" (lookup "port" kvs))) + <*> lookup "user" kvs + <*> pure (fromMaybe "" (lookup "password" kvs)) + <*> lookup "database" kvs + <*> pure [MySQLB.MultiStatements] + <*> pure "" + <*> pure Nothing + in MySQL.connect (fromMaybe (error "Invalid connection string. Expected form: host=hostname; user=username; port=portNumber; database=dbname; password=pwd.") + connInfo) envDatabaseType :: String envDatabaseType = "DBM_DATABASE_TYPE" diff --git a/test/BackendTest.hs b/test/BackendTest.hs --- a/test/BackendTest.hs +++ b/test/BackendTest.hs @@ -1,15 +1,58 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + module BackendTest where import Test.HUnit +import Control.Exception (Handler(..), catches) import Control.Monad ( forM_ ) -import Database.Schema.Migrations.Backend.HDBC +import Database.Schema.Migrations.Backend.HDBC (hdbcBackend) +import Database.Schema.Migrations.Backend.MySQL import Database.Schema.Migrations.Migration ( Migration(..), newMigration ) import Database.Schema.Migrations.Backend ( Backend(..) ) -import Database.HDBC ( IConnection(..), catchSql, withTransaction ) +import qualified Database.HDBC as HDBC +import qualified Database.MySQL.Simple as MySQL +import qualified Database.MySQL.Base as MySQL -tests :: (IConnection a) => a -> IO () +data BackendConnection + = forall a. HDBC.IConnection a => HDBCConnection a + | MySQLConnection MySQL.Connection + +migrationBackend :: BackendConnection -> Backend +migrationBackend (HDBCConnection c) = hdbcBackend c +migrationBackend (MySQLConnection c) = mysqlBackend c + +commit :: BackendConnection -> IO () +commit (HDBCConnection c) = HDBC.commit c +commit (MySQLConnection c) = MySQL.commit c + +getTables :: BackendConnection -> IO [String] +getTables (HDBCConnection c) = HDBC.getTables c +getTables (MySQLConnection c) = + fmap (map MySQL.fromOnly) + (MySQL.query_ c "SHOW TABLES") + +catchSql_ :: IO a -> IO a -> IO a +catchSql_ act handler = + act `catches` + [Handler (\(_ :: MySQL.FormatError) -> handler) + ,Handler (\(_ :: MySQL.QueryError) -> handler) + ,Handler (\(_ :: MySQL.MySQLError) -> handler) + ,Handler (\(_ :: MySQL.ResultError) -> handler) + ,Handler (\(_ :: HDBC.SqlError) -> handler)] + +withTransaction + :: BackendConnection -> (BackendConnection -> IO a) -> IO a +withTransaction (HDBCConnection c) transaction = + HDBC.withTransaction c + (transaction . HDBCConnection) +withTransaction (MySQLConnection c) transaction = + MySQL.withTransaction c + (transaction (MySQLConnection c)) +tests :: BackendConnection -> IO () tests conn = do let acts = [ isBootstrappedFalseTest , bootstrapTest @@ -24,52 +67,52 @@ commit conn act conn -bootstrapTest :: (IConnection a) => a -> IO () +bootstrapTest :: BackendConnection -> IO () bootstrapTest conn = do - let backend = hdbcBackend conn + let backend = migrationBackend conn bs <- getBootstrapMigration backend applyMigration backend bs assertEqual "installed_migrations table exists" ["installed_migrations"] =<< getTables conn assertEqual "successfully bootstrapped" [mId bs] =<< getMigrations backend -isBootstrappedTrueTest :: (IConnection a) => a -> IO () +isBootstrappedTrueTest :: BackendConnection -> IO () isBootstrappedTrueTest conn = do - result <- isBootstrapped $ hdbcBackend conn + result <- isBootstrapped $ migrationBackend conn assertBool "Bootstrapped check" result -isBootstrappedFalseTest :: (IConnection a) => a -> IO () +isBootstrappedFalseTest :: BackendConnection -> IO () isBootstrappedFalseTest conn = do - result <- isBootstrapped $ hdbcBackend conn + result <- isBootstrapped $ migrationBackend conn assertBool "Bootstrapped check" $ not result ignoreSqlExceptions :: IO a -> IO (Maybe a) -ignoreSqlExceptions act = (act >>= return . Just) `catchSql` - (\_ -> return Nothing) +ignoreSqlExceptions act = (act >>= return . Just) `catchSql_` + (return Nothing) -applyMigrationSuccess :: (IConnection a) => a -> IO () +applyMigrationSuccess :: BackendConnection -> IO () applyMigrationSuccess conn = do - let backend = hdbcBackend conn + let backend = migrationBackend conn let m1 = (newMigration "validMigration") { mApply = "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int);" } -- Apply the migrations, ignore exceptions - withTransaction conn $ \conn' -> applyMigration (hdbcBackend conn') m1 + withTransaction conn $ \conn' -> applyMigration (migrationBackend conn') m1 -- Check that none of the migrations were installed assertEqual "Installed migrations" ["root", "validMigration"] =<< getMigrations backend assertEqual "Installed tables" ["installed_migrations", "valid1", "valid2"] =<< getTables conn -- |Does a failure to apply a migration imply a transaction rollback? -applyMigrationFailure :: (IConnection a) => a -> IO () +applyMigrationFailure :: BackendConnection -> IO () applyMigrationFailure conn = do - let backend = hdbcBackend conn + let backend = migrationBackend conn let m1 = (newMigration "second") { mApply = "CREATE TABLE validButTemporary (a int)" } m2 = (newMigration "third") { mApply = "INVALID SQL" } -- Apply the migrations, ignore exceptions ignoreSqlExceptions $ withTransaction conn $ \conn' -> do - let backend' = hdbcBackend conn' + let backend' = migrationBackend conn' applyMigration backend' m1 applyMigration backend' m2 @@ -77,9 +120,9 @@ assertEqual "Installed migrations" ["root"] =<< getMigrations backend assertEqual "Installed tables" ["installed_migrations"] =<< getTables conn -revertMigrationFailure :: (IConnection a) => a -> IO () +revertMigrationFailure :: BackendConnection -> IO () revertMigrationFailure conn = do - let backend = hdbcBackend conn + let backend = migrationBackend conn let m1 = (newMigration "second") { mApply = "CREATE TABLE validRMF (a int)" , mRevert = Just "DROP TABLE validRMF"} @@ -96,7 +139,7 @@ -- Revert the migrations, ignore exceptions; the revert will fail, -- but withTransaction will roll back. ignoreSqlExceptions $ withTransaction conn $ \conn' -> do - let backend' = hdbcBackend conn' + let backend' = migrationBackend conn' revertMigration backend' m2 revertMigration backend' m1 @@ -104,9 +147,9 @@ assertEqual "successfully roll back failed revert" installedBeforeRevert =<< getMigrations backend -revertMigrationNothing :: (IConnection a) => a -> IO () +revertMigrationNothing :: BackendConnection -> IO () revertMigrationNothing conn = do - let backend = hdbcBackend conn + let backend = migrationBackend conn let m1 = (newMigration "second") { mApply = "SELECT 1" , mRevert = Nothing } @@ -123,10 +166,10 @@ installed <- getMigrations backend assertBool "Check that the migration was reverted" $ not $ "second" `elem` installed -revertMigrationJust :: (IConnection a) => a -> IO () +revertMigrationJust :: BackendConnection -> IO () revertMigrationJust conn = do let name = "revertable" - backend = hdbcBackend conn + backend = migrationBackend conn let m1 = (newMigration name) { mApply = "CREATE TABLE the_test_table (a int)" , mRevert = Just "DROP TABLE the_test_table" } diff --git a/test/TestDriver.hs b/test/TestDriver.hs --- a/test/TestDriver.hs +++ b/test/TestDriver.hs @@ -17,22 +17,27 @@ import qualified ConfigurationTest import Control.Monad ( forM ) -import Control.Exception ( finally, catch, SomeException ) +import Control.Exception ( finally, catch, try, SomeException(..) ) +import Data.String (fromString) import Database.HDBC ( IConnection(disconnect) ) import Database.HDBC.Sqlite3 ( connectSqlite3 ) import qualified Database.HDBC.PostgreSQL as PostgreSQL +import qualified Database.MySQL.Simple as MySQL loadTests :: IO [Test] loadTests = do sqliteConn <- connectSqlite3 ":memory:" - pgConn <- setupPostgresDb + --pgConn <- setupPostgresDb + mysqlConn <- setupMySQLDb - let backends = [ ("Sqlite", (BackendTest.tests sqliteConn) `finally` + let backends = [ ("Sqlite", (BackendTest.tests (BackendTest.HDBCConnection sqliteConn)) `finally` (disconnect sqliteConn)) - , ("PostgreSQL", (BackendTest.tests pgConn) `finally` - (disconnect pgConn >> teardownPostgresDb)) + -- , ("PostgreSQL", (BackendTest.tests (BackendTest.HDBCConnection pgConn)) `finally` + -- (disconnect pgConn >> teardownPostgresDb)) + , ("MySQL", (BackendTest.tests (BackendTest.MySQLConnection mysqlConn)) `finally` + (MySQL.close mysqlConn >> teardownMySQLDb)) ] backendTests <- forM backends $ \(name, testAct) -> do @@ -56,8 +61,8 @@ , StoreTest.tests ] -tempPgDatabase :: String -tempPgDatabase = "dbmigrations_test" +tempDatabase :: String +tempDatabase = "dbmigrations_test" ignoreException :: SomeException -> IO () ignoreException _ = return () @@ -67,21 +72,37 @@ teardownPostgresDb `catch` ignoreException -- create database - status <- system $ "createdb " ++ tempPgDatabase + status <- system $ "createdb " ++ tempDatabase case status of ExitSuccess -> return () - ExitFailure _ -> error $ "Failed to create PostgreSQL database " ++ (show tempPgDatabase) + ExitFailure _ -> error $ "Failed to create PostgreSQL database " ++ (show tempDatabase) -- return test db connection - PostgreSQL.connectPostgreSQL $ "dbname=" ++ tempPgDatabase + PostgreSQL.connectPostgreSQL $ "dbname=" ++ tempDatabase teardownPostgresDb :: IO () teardownPostgresDb = do - -- create database - status <- system $ "dropdb " ++ tempPgDatabase ++ " 2>/dev/null" + -- drop database + status <- system $ "dropdb " ++ tempDatabase ++ " 2>/dev/null" case status of ExitSuccess -> return () - ExitFailure _ -> error $ "Failed to drop PostgreSQL database " ++ (show tempPgDatabase) + ExitFailure _ -> error $ "Failed to drop PostgreSQL database " ++ (show tempDatabase) + +setupMySQLDb :: IO MySQL.Connection +setupMySQLDb = do + teardownMySQLDb `catch` ignoreException + conn <- MySQL.connect MySQL.defaultConnectInfo + MySQL.execute_ conn (fromString ("CREATE DATABASE " ++ tempDatabase)) + MySQL.execute_ conn (fromString ("USE " ++ tempDatabase)) + pure conn + +teardownMySQLDb :: IO () +teardownMySQLDb = do + conn <- MySQL.connect MySQL.defaultConnectInfo + e <- try (MySQL.execute_ conn (fromString ("DROP DATABASE " ++ tempDatabase))) + case e of + Left ex@SomeException{} -> error ("Failed to drop test MySQL database: " ++ show ex) + Right _ -> return () main :: IO () main = do