dbmigrations-mysql (empty) → 2.0.0
raw patch · 7 files changed
+514/−0 lines, 7 filesdep +HUnitdep +basedep +dbmigrationssetup-changed
Dependencies added: HUnit, base, dbmigrations, dbmigrations-mysql, mysql, mysql-simple, process, split, time
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- dbmigrations-mysql.cabal +87/−0
- programs/MooMySQL.hs +27/−0
- src/Database/Schema/Migrations/Backend/MySQL.hs +108/−0
- test/BackendTest.hs +184/−0
- test/TestDriver.hs +76/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dbmigrations-mysql.cabal view
@@ -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 <cygnus@foobox.com>+Maintainer: Jonathan Daugherty <cygnus@foobox.com>+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
+ programs/MooMySQL.hs view
@@ -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+
+ src/Database/Schema/Migrations/Backend/MySQL.hs view
@@ -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
+ test/BackendTest.hs view
@@ -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
+ test/TestDriver.hs view
@@ -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