diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2009, Jonathan Daugherty. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of the contributors may not be used to endorse or + promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dbmigrations-mysql.cabal b/dbmigrations-mysql.cabal new file mode 100644 --- /dev/null +++ b/dbmigrations-mysql.cabal @@ -0,0 +1,87 @@ +Name: dbmigrations-mysql +Version: 2.0.0 +Synopsis: The dbmigrations tool built for MySQL databases +Description: This package contains the executable to work with + the dbmigrations package when the database backend + is MySQL. See the package dbmigrations for details + about the dbmigrations project in general. + + To get started, see the 'README.md' + (https://github.com/jtdaugherty/dbmigrations/blob/master/README.md) + and 'MOO.TXT' + (https://github.com/jtdaugherty/dbmigrations/blob/master/MOO.TXT) + files included in the dbmigrations package and the + usage output for the 'moo-sqlite' command. + +Category: Database +Author: Jonathan Daugherty +Maintainer: Jonathan Daugherty +Build-Type: Simple +License: BSD3 +License-File: LICENSE +Cabal-Version: >= 1.10 + +Source-Repository head + type: git + location: git://github.com/jtdaugherty/dbmigrations-mysql.git + +Library + default-language: Haskell2010 + if impl(ghc >= 6.12.0) + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind + else + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + + Build-Depends: + base >= 4 && < 5, + dbmigrations >= 2, + time >= 1.4, + mysql >= 0.1.2, + mysql-simple >= 0.2.2.5, + split >= 0.2.2 + + Hs-Source-Dirs: src + Exposed-Modules: + Database.Schema.Migrations.Backend.MySQL + +Executable moo-mysql + default-language: Haskell2010 + Build-Depends: + base >= 4 && < 5, + dbmigrations-mysql, + dbmigrations >= 2 + + if impl(ghc >= 6.12.0) + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind + else + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields + + Hs-Source-Dirs: programs + Main-is: MooMySQL.hs + +test-suite dbmigrations-mysql-tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + Build-Depends: + base >= 4 && < 5, + dbmigrations >= 2, + dbmigrations-mysql >= 2, + mysql-simple >= 0.2.2.5, + mysql >= 0.1.1.8, + process >= 1.1, + HUnit >= 1.2 + + other-modules: + BackendTest + TestDriver + + if impl(ghc >= 6.12.0) + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind -Wwarn + else + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields + + Hs-Source-Dirs: test + Main-is: TestDriver.hs diff --git a/programs/MooMySQL.hs b/programs/MooMySQL.hs new file mode 100644 --- /dev/null +++ b/programs/MooMySQL.hs @@ -0,0 +1,27 @@ +module Main + ( main + ) +where + +import Prelude hiding (lookup) +import System.Environment (getArgs) +import System.Exit + +import Database.Schema.Migrations.Backend.MySQL +import Moo.Core +import Moo.Main + +main :: IO () +main = do + args <- getArgs + (_, opts, _) <- procArgs args + loadedConf <- loadConfiguration $ _configFilePath opts + case loadedConf of + Left e -> putStrLn e >> exitFailure + Right conf -> do + let connectionString = _connectionString conf + connection <- connectMySQL connectionString + let backend = mysqlBackend connection + parameters = makeParameters conf backend + mainWithParameters args parameters + 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,108 @@ +module Database.Schema.Migrations.Backend.MySQL + ( connectMySQL + , 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.List.Split (wordsBy) +import Data.Char (isSpace, toLower) +import Data.Time.Clock (getCurrentTime) +import Data.String (fromString) +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Database.MySQL.Base as Base +import qualified Database.MySQL.Simple as Simple + +-- A slightly hacky connection string parser for MySQL, because mysql-simple +-- doesn't come with one. +connectMySQL :: String -> IO Base.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 = + Simple.ConnectInfo + <$> lookup "host" kvs + <*> pure (read (fromMaybe "3306" (lookup "port" kvs))) + <*> lookup "user" kvs + <*> pure (fromMaybe "" (lookup "password" kvs)) + <*> lookup "database" kvs + <*> pure [Base.MultiStatements] + <*> pure "" + <*> pure Nothing + in Simple.connect (fromMaybe (error "Invalid connection string. Expected form: host=hostname; user=username; port=portNumber; database=dbname; password=pwd.") + connInfo) + +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/test/BackendTest.hs b/test/BackendTest.hs new file mode 100644 --- /dev/null +++ b/test/BackendTest.hs @@ -0,0 +1,184 @@ +{-# 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.MySQL +import Database.Schema.Migrations.Migration ( Migration(..), newMigration ) +import Database.Schema.Migrations.Backend ( Backend(..) ) + +import qualified Database.MySQL.Simple as MySQL +import qualified Database.MySQL.Base as MySQL + +data BackendConnection + = MySQLConnection MySQL.Connection + +migrationBackend :: BackendConnection -> Backend +migrationBackend (MySQLConnection c) = mysqlBackend c + +commit :: BackendConnection -> IO () +commit (MySQLConnection c) = MySQL.commit c + +getTables :: BackendConnection -> IO [String] +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)] + +withTransaction + :: BackendConnection -> (BackendConnection -> IO a) -> IO a +withTransaction (MySQLConnection c) transaction = + MySQL.withTransaction c + (transaction (MySQLConnection c)) + +tests :: BackendConnection -> IO () +tests conn = do + let acts = [ isBootstrappedFalseTest + , bootstrapTest + , isBootstrappedTrueTest + -- applyMigrationFailure intentionally disabled, see below + -- , applyMigrationFailure + , applyMigrationSuccess + , revertMigrationFailure + , revertMigrationNothing + , revertMigrationJust + ] + forM_ acts $ \act -> do + commit conn + act conn + +bootstrapTest :: BackendConnection -> IO () +bootstrapTest conn = do + 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 :: BackendConnection -> IO () +isBootstrappedTrueTest conn = do + result <- isBootstrapped $ migrationBackend conn + assertBool "Bootstrapped check" result + +isBootstrappedFalseTest :: BackendConnection -> IO () +isBootstrappedFalseTest conn = do + result <- isBootstrapped $ migrationBackend conn + assertBool "Bootstrapped check" $ not result + +ignoreSqlExceptions :: IO a -> IO (Maybe a) +ignoreSqlExceptions act = (act >>= return . Just) `catchSql_` + (return Nothing) + +applyMigrationSuccess :: BackendConnection -> IO () +applyMigrationSuccess conn = do + 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 (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? +-- +-- !! This test is intentionally disabled because MySQL does not support +-- transactions with regard to DDL statements!! +-- (see MYSQL-AND-TRANSACTIONAL-DDL.TXT) +-- +-- applyMigrationFailure :: BackendConnection -> IO () +-- applyMigrationFailure conn = do +-- 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' = migrationBackend conn' +-- applyMigration backend' m1 +-- applyMigration backend' m2 +-- +-- -- Check that none of the migrations were installed +-- assertEqual "Installed migrations" ["root"] =<< getMigrations backend +-- assertEqual "Installed tables" ["installed_migrations"] =<< getTables conn + +revertMigrationFailure :: BackendConnection -> IO () +revertMigrationFailure conn = do + let backend = migrationBackend conn + + let m1 = (newMigration "second") { mApply = "CREATE TABLE validRMF (a int)" + , mRevert = Just "DROP TABLE validRMF"} + m2 = (newMigration "third") { mApply = "DO 0" -- MySQL noop + , mRevert = Just "INVALID REVERT SQL"} + + applyMigration backend m1 + applyMigration backend m2 + + installedBeforeRevert <- getMigrations backend + + commitBackend backend + + -- Revert the migrations, ignore exceptions; the revert will fail, + -- but withTransaction will roll back. + ignoreSqlExceptions $ withTransaction conn $ \conn' -> do + let backend' = migrationBackend conn' + revertMigration backend' m2 + revertMigration backend' m1 + + -- Check that none of the migrations were reverted + assertEqual "successfully roll back failed revert" installedBeforeRevert + =<< getMigrations backend + +revertMigrationNothing :: BackendConnection -> IO () +revertMigrationNothing conn = do + let backend = migrationBackend conn + + let m1 = (newMigration "second") { mApply = "DO 0" -- MySQL noop + , mRevert = Nothing } + + applyMigration backend m1 + + installedAfterApply <- getMigrations backend + assertBool "Check that the migration was applied" $ "second" `elem` installedAfterApply + + -- Revert the migration, which should do nothing EXCEPT remove it + -- from the installed list + revertMigration backend m1 + + installed <- getMigrations backend + assertBool "Check that the migration was reverted" $ not $ "second" `elem` installed + +revertMigrationJust :: BackendConnection -> IO () +revertMigrationJust conn = do + let name = "revertable" + backend = migrationBackend conn + + let m1 = (newMigration name) { mApply = "CREATE TABLE the_test_table (a int)" + , mRevert = Just "DROP TABLE the_test_table" } + + applyMigration backend m1 + + installedAfterApply <- getMigrations backend + assertBool "Check that the migration was applied" $ name `elem` installedAfterApply + + -- Revert the migration, which should do nothing EXCEPT remove it + -- from the installed list + revertMigration backend m1 + + installed <- getMigrations backend + assertBool "Check that the migration was reverted" $ not $ name `elem` installed diff --git a/test/TestDriver.hs b/test/TestDriver.hs new file mode 100644 --- /dev/null +++ b/test/TestDriver.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Database.Schema.Migrations.Backend.MySQL +import Database.Schema.Migrations.Test.BackendTest as BackendTest + +import Control.Exception (catch, catches, finally, try, Handler(..), SomeException(..) ) +import Data.String (fromString) +import qualified Database.MySQL.Base as MySQLBase +import qualified Database.MySQL.Simple as MySQLSimple +import System.Exit +import System.IO ( stderr ) +import Test.HUnit + +data MySQLBackendConnection = MySQLConnection MySQLSimple.Connection + +instance BackendConnection MySQLBackendConnection where + supportsTransactionalDDL = const False + makeBackend (MySQLConnection c) = mysqlBackend c + commit (MySQLConnection c) = MySQLSimple.commit c + withTransaction (MySQLConnection c) transaction = + MySQLSimple.withTransaction c (transaction (MySQLConnection c)) + getTables (MySQLConnection c) = + fmap (map MySQLSimple.fromOnly) + (MySQLSimple.query_ c "SHOW TABLES") + catchAll (MySQLConnection _) act handler = + act `catches` + [ Handler (\(_ :: MySQLSimple.FormatError) -> handler) + , Handler (\(_ :: MySQLSimple.QueryError) -> handler) + , Handler (\(_ :: MySQLBase.MySQLError) -> handler) + , Handler (\(_ :: MySQLSimple.ResultError) -> handler) + ] + +loadTests :: IO [Test] +loadTests = do + + mysqlConn <- setupMySQLDb + + let backendConnection :: MySQLBackendConnection = MySQLConnection mysqlConn + + testAct = (BackendTest.tests backendConnection) + `finally` + (MySQLSimple.close mysqlConn >> teardownMySQLDb) + + return [ ("MySQL backend tests") ~: test testAct ] + +tempDatabase :: String +tempDatabase = "dbmigrations_test" + +ignoreException :: SomeException -> IO () +ignoreException _ = return () + +setupMySQLDb :: IO MySQLSimple.Connection +setupMySQLDb = do + teardownMySQLDb `catch` ignoreException + conn <- MySQLSimple.connect MySQLSimple.defaultConnectInfo + MySQLSimple.execute_ conn (fromString ("CREATE DATABASE " ++ tempDatabase)) + MySQLSimple.execute_ conn (fromString ("USE " ++ tempDatabase)) + pure conn + +teardownMySQLDb :: IO () +teardownMySQLDb = do + conn <- MySQLSimple.connect MySQLSimple.defaultConnectInfo + e <- try (MySQLSimple.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 + tests_ <- loadTests + (testResults, _) <- runTestText (putTextToHandle stderr False) $ test tests_ + if errors testResults + failures testResults > 0 + then exitFailure + else exitSuccess