dbmigrations 0.8.2 → 0.9

raw patch · 20 files changed

+379/−426 lines, 20 filesdep +dbmigrationsPVP ok

version bump matches the API change (PVP)

Dependencies added: dbmigrations

API changes (from Hackage documentation)

Files

• dbmigrations.cabal +7/−20
• programs/Moo.hs +20/−0
• src/Database/Schema/Migrations.hs +15/−25
• src/Database/Schema/Migrations/Backend.hs +46/−33
• src/Database/Schema/Migrations/Backend/HDBC.hs +47/−33
• src/Database/Schema/Migrations/Filesystem.hs +27/−24
• src/Database/Schema/Migrations/Filesystem/Serialize.hs +4/−1
• src/Database/Schema/Migrations/Migration.hs +10/−18
• src/Database/Schema/Migrations/Store.hs +18/−17
• src/Moo.hs +0/−23
• src/Moo/CommandHandlers.hs +43/−51
• src/Moo/CommandInterface.hs +0/−9
• src/Moo/CommandUtils.hs +14/−43
• src/Moo/Core.hs +39/−38
• src/Moo/Main.hs +10/−15
• test/BackendTest.hs +45/−44
• test/FilesystemParseTest.hs +7/−5
• test/FilesystemSerializeTest.hs +1/−1
• test/FilesystemTest.hs +2/−1
• test/MigrationsTest.hs +24/−25

@@ -1,5 +1,5 @@ Name:                dbmigrations-Version:             0.8.2+Version:             0.9 Synopsis:            An implementation of relational database "migrations" Description:         A library and program for the creation,                      management, and installation of schema updates@@ -85,15 +85,15 @@           Database.Schema.Migrations.Backend.HDBC           Database.Schema.Migrations.Store           Moo.Main--  Other-Modules:-          Database.Schema.Migrations.CycleDetection-          Database.Schema.Migrations.Filesystem.Serialize           Moo.CommandHandlers           Moo.CommandInterface           Moo.CommandUtils           Moo.Core +  Other-Modules:+          Database.Schema.Migrations.CycleDetection+          Database.Schema.Migrations.Filesystem.Serialize+ test-suite dbmigrations-tests   default-language: Haskell2010   type: exitcode-stdio-1.0@@ -140,21 +140,8 @@   default-language: Haskell2010   Build-Depends:     base >= 4 && < 5,-    HDBC >= 2.2.1,-    time >= 1.4,-    random >= 1.0,-    containers >= 0.2,-    mtl >= 2.1,-    filepath >= 1.1,-    directory >= 1.0,-    fgl >= 5.4,-    template-haskell,-    yaml-light >= 0.1,-    bytestring >= 0.9,-    text >= 0.11,     configurator >= 0.2,-    HDBC-postgresql,-    HDBC-sqlite3+    dbmigrations    if impl(ghc >= 6.12.0)     ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields@@ -162,5 +149,5 @@   else     ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -  Hs-Source-Dirs:  src+  Hs-Source-Dirs:  programs   Main-is:         Moo.hs

@@ -0,0 +1,20 @@+module Main+    ( main+    )+where++import  Prelude  hiding (lookup)+import  System.Environment (getArgs)+import  System.Exit++import  Moo.Core+import  Moo.Main++main :: IO ()+main = do+  args <- getArgs+  (_, opts, _) <- procArgs args+  conf <- loadConfiguration $ _configFilePath opts+  case conf of+      Left e -> putStrLn e >> exitFailure+      Right c -> mainWithConf args c

@@ -21,13 +21,12 @@ import Database.Schema.Migrations.Migration     ( Migration(..)     , newMigration-    , MonadMigration     )  -- |Given a 'B.Backend' and a 'S.MigrationMap', query the backend and -- return a list of migration names which are available in the -- 'S.MigrationMap' but which are not installed in the 'B.Backend'.-missingMigrations :: (B.Backend b m) => b -> S.StoreData -> m [String]+missingMigrations :: B.Backend -> S.StoreData -> IO [String] missingMigrations backend storeData = do   let storeMigrationNames = map mId $ S.storeMigrations storeData   backendMigrations <- B.getMigrations backend@@ -36,34 +35,25 @@          (Set.fromList storeMigrationNames)          (Set.fromList backendMigrations) --- |Create a new migration and store it in the 'S.MigrationStore',--- with some of its fields initially set to defaults.-createNewMigration :: (MonadMigration m, S.MigrationStore s m)-                   => s -- ^ The 'S.MigrationStore' in which to create a new migration-                   -> String -- ^ The name of the new migration to create-                   -> [String] -- ^ The list of migration names on which the new migration should depend-                   -> m (Either String Migration)-createNewMigration store name deps = do+-- |Create a new migration and store it in the 'S.MigrationStore'.+createNewMigration :: S.MigrationStore -- ^ The 'S.MigrationStore' in which to create a new migration+                   -> Migration -- ^ The new migration+                   -> IO (Either String Migration)+createNewMigration store newM = do   available <- S.getMigrations store-  case name `elem` available of+  case mId newM `elem` available of     True -> do-      fullPath <- S.fullMigrationName store name+      fullPath <- S.fullMigrationName store (mId newM)       return $ Left $ "Migration " ++ (show fullPath) ++ " already exists"     False -> do-      new <- newMigration name-      let newWithDefaults = new { mDesc = Just "(Description here.)"-                                , mApply = "(Apply SQL here.)"-                                , mRevert = Just "(Revert SQL here.)"-                                , mDeps = deps-                                }-      S.saveMigration store newWithDefaults-      return $ Right newWithDefaults+      S.saveMigration store newM+      return $ Right newM  -- |Given a 'B.Backend', ensure that the backend is ready for use by -- bootstrapping it.  This entails installing the appropriate database -- elements to track installed migrations.  If the backend is already -- bootstrapped, this has no effect.-ensureBootstrappedBackend :: (B.Backend b m) => b -> m ()+ensureBootstrappedBackend :: B.Backend -> IO () ensureBootstrappedBackend backend = do   bsStatus <- B.isBootstrapped backend   case bsStatus of@@ -73,8 +63,8 @@ -- |Given a migration mapping computed from a MigrationStore, a -- backend, and a migration to apply, return a list of migrations to -- apply, in order.-migrationsToApply :: (B.Backend b m) => S.StoreData -> b-                  -> Migration -> m [Migration]+migrationsToApply :: S.StoreData -> B.Backend+                  -> Migration -> IO [Migration] migrationsToApply storeData backend migration = do   let graph = S.storeDataGraph storeData @@ -89,8 +79,8 @@ -- |Given a migration mapping computed from a MigrationStore, a -- backend, and a migration to revert, return a list of migrations to -- revert, in order.-migrationsToRevert :: (B.Backend b m) => S.StoreData -> b-                   -> Migration -> m [Migration]+migrationsToRevert :: S.StoreData -> B.Backend+                   -> Migration -> IO [Migration] migrationsToRevert storeData backend migration = do   let graph = S.storeDataGraph storeData 

@@ -1,4 +1,3 @@-{-# LANGUAGE MultiParamTypeClasses #-} module Database.Schema.Migrations.Backend     ( Backend(..)     , rootMigrationName@@ -20,39 +19,53 @@ -- migrations.  A Backend also supplies the migration necessary to -- "bootstrap" a backend so that it can track which migrations are -- installed.-class (Monad m) => Backend b m where-    -- |The migration necessary to bootstrap a database with this-    -- connection interface.  This might differ slightly from one-    -- backend to another.-    getBootstrapMigration :: b -> m Migration+data Backend =+    Backend { getBootstrapMigration :: IO Migration+            -- ^ The migration necessary to bootstrap a database with+            -- this connection interface. This might differ slightly+            -- from one backend to another. -    -- |Returns whether the backend has been bootstrapped.  A backend-    -- has been bootstrapped if is capable of tracking which-    -- migrations have been installed; the "bootstrap migration"-    -- provided by getBootstrapMigration should suffice to bootstrap-    -- the backend.-    isBootstrapped :: b -> m Bool+            , isBootstrapped :: IO Bool+            -- ^ Returns whether the backend has been bootstrapped. A+            -- backend has been bootstrapped if is capable of tracking+            -- which migrations have been installed; the "bootstrap+            -- migration" provided by getBootstrapMigration should+            -- suffice to bootstrap the backend. -    -- |Apply the specified migration on the backend.  applyMigration-    -- does NOT assume control of the transaction, since it expects-    -- the transaction to (possibly) cover more than one-    -- applyMigration operation.  The caller is expected to call-    -- commit at the appropriate time.  If the application fails, the-    -- underlying SqlError is raised and a manual rollback may be-    -- necessary; for this, see withTransaction from HDBC.-    applyMigration :: b -> Migration -> m ()+            , applyMigration :: Migration -> IO ()+            -- ^ Apply the specified migration on the backend.+            -- applyMigration does NOT assume control of the+            -- transaction, since it expects the transaction to+            -- (possibly) cover more than one applyMigration operation.+            -- The caller is expected to call commit at the appropriate+            -- time. If the application fails, the underlying SqlError+            -- is raised and a manual rollback may be necessary; for+            -- this, see withTransaction from HDBC. -    -- |Revert the specified migration from the backend and record-    -- this action in the table which tracks installed migrations.-    -- revertMigration does NOT assume control of the transaction,-    -- since it expects the transaction to (possibly) cover more than-    -- one revertMigration operation.  The caller is expected to call-    -- commit at the appropriate time.  If the revert fails, the-    -- underlying SqlError is raised and a manual rollback may be-    -- necessary; for this, see withTransaction from HDBC.  If the-    -- specified migration does not supply a revert instruction, this-    -- has no effect other than bookkeeping.-    revertMigration :: b -> Migration -> m ()+            , revertMigration :: Migration -> IO ()+            -- ^ Revert the specified migration from the backend and+            -- record this action in the table which tracks installed+            -- migrations. revertMigration does NOT assume control of+            -- the transaction, since it expects the transaction to+            -- (possibly) cover more than one revertMigration operation.+            -- The caller is expected to call commit at the appropriate+            -- time. If the revert fails, the underlying SqlError is+            -- raised and a manual rollback may be necessary; for this,+            -- see withTransaction from HDBC. If the specified migration+            -- does not supply a revert instruction, this has no effect+            -- other than bookkeeping. -    -- |Returns a list of installed migration names from the backend.-    getMigrations :: b -> m [String]+            , getMigrations :: IO [String]+            -- ^ Returns a list of installed migration names from the+            -- backend.++            , commitBackend :: IO ()+            -- ^ Commit changes to the backend.++            , rollbackBackend :: IO ()+            -- ^ Revert changes made to the backend since the current+            -- transaction began.++            , disconnectBackend :: IO ()+            -- ^ Disconnect from the backend.+            }

@@ -1,10 +1,17 @@-{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Schema.Migrations.Backend.HDBC-    ()+    ( hdbcBackend+    ) where -import Database.HDBC ( quickQuery', fromSql, toSql, IConnection(getTables, run, runRaw) )+import Database.HDBC+  ( quickQuery'+  , fromSql+  , toSql+  , IConnection(getTables, run, runRaw)+  , commit+  , rollback+  , disconnect+  )  import Database.Schema.Migrations.Backend     ( Backend(..)@@ -16,6 +23,7 @@     )  import Control.Applicative ( (<$>) )+import Data.Time.Clock (getCurrentTime)  migrationTableName :: String migrationTableName = "installed_migrations"@@ -26,36 +34,42 @@ revertSql :: String revertSql = "DROP TABLE " ++ migrationTableName --- |General Backend instance for all IO-driven HDBC connection--- implementations.  You can provide a connection-specific instance if--- need be; this implementation is provided with the hope that you--- won't /have/ to do that.-instance (IConnection conn) => Backend conn IO where-    isBootstrapped conn = elem migrationTableName <$> getTables conn+-- |General Backend constructor for all HDBC connection implementations.+hdbcBackend :: (IConnection conn) => conn -> Backend+hdbcBackend conn =+    Backend { isBootstrapped = elem migrationTableName <$> getTables conn+            , getBootstrapMigration =+                  do+                    ts <- getCurrentTime+                    return $ (newMigration rootMigrationName)+                        { mApply = createSql+                        , mRevert = Just revertSql+                        , mDesc = Just "Migration table installation"+                        , mTimestamp = Just ts+                        } -    getBootstrapMigration _ =-        do-          m <- newMigration rootMigrationName-          return $ m { mApply = createSql-                     , mRevert = Just revertSql-                     , mDesc = Just "Migration table installation"-                     }+            , applyMigration = \m -> do+                runRaw conn (mApply m)+                run conn ("INSERT INTO " ++ migrationTableName +++                          " (migration_id) VALUES (?)") [toSql $ mId m]+                return () -    applyMigration conn m = do-      runRaw conn (mApply m)-      run conn ("INSERT INTO " ++ migrationTableName ++-                " (migration_id) VALUES (?)") [toSql $ mId m]-      return ()+            , revertMigration = \m -> do+                  case mRevert m of+                    Nothing -> return ()+                    Just query -> runRaw conn query+                  -- Remove migration from installed_migrations in either case.+                  run conn ("DELETE FROM " ++ migrationTableName +++                            " WHERE migration_id = ?") [toSql $ mId m]+                  return () -    revertMigration conn m = do-        case mRevert m of-          Nothing -> return ()-          Just query -> runRaw conn query-        -- Remove migration from installed_migrations in either case.-        run conn ("DELETE FROM " ++ migrationTableName ++-                  " WHERE migration_id = ?") [toSql $ mId m]-        return ()+            , getMigrations = do+                results <- quickQuery' conn ("SELECT migration_id FROM " ++ migrationTableName) []+                return $ map (fromSql . head) results -    getMigrations conn = do-      results <- quickQuery' conn ("SELECT migration_id FROM " ++ migrationTableName) []-      return $ map (fromSql . head) results+            , commitBackend = commit conn++            , rollbackBackend = rollback conn++            , disconnectBackend = disconnect conn+            }

@@ -1,10 +1,11 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} -- |This module provides a type for interacting with a -- filesystem-backed 'MigrationStore'. module Database.Schema.Migrations.Filesystem-    ( FilesystemStore(..)+    ( FilesystemStoreSettings(..)     , migrationFromFile     , migrationFromPath+    , filesystemStore     ) where @@ -13,7 +14,6 @@ import System.Directory ( getDirectoryContents, doesFileExist ) import System.FilePath ( (</>), takeExtension, dropExtension                        , takeFileName, takeBaseName )-import Control.Monad.Trans ( MonadIO, liftIO ) import Data.ByteString.Char8 ( unpack )  import Data.Typeable ( Typeable )@@ -36,7 +36,7 @@  type FieldProcessor = String -> Migration -> Maybe Migration -data FilesystemStore = FSStore { storePath :: FilePath }+data FilesystemStoreSettings = FSStore { storePath :: FilePath }  data FilesystemStoreError = FilesystemStoreError String                             deriving (Show, Typeable)@@ -49,32 +49,36 @@ filenameExtension :: String filenameExtension = ".txt" -instance (MonadIO m) => MigrationStore FilesystemStore m where-    fullMigrationName s name =-        return $ storePath s </> name ++ filenameExtension+filesystemStore :: FilesystemStoreSettings -> MigrationStore+filesystemStore s =+    MigrationStore { fullMigrationName = fsFullMigrationName s -    loadMigration s theId = liftIO $ migrationFromFile s theId+                   , loadMigration = \theId -> migrationFromFile s theId -    getMigrations s = do-      contents <- liftIO $ getDirectoryContents $ storePath s-      let migrationFilenames = [ f | f <- contents, isMigrationFilename f ]-          fullPaths = [ (f, storePath s </> f) | f <- migrationFilenames ]-      existing <- liftIO $ filterM (\(_, full) -> doesFileExist full) fullPaths-      return [ dropExtension short | (short, _) <- existing ]+                   , getMigrations = do+                       contents <- getDirectoryContents $ storePath s+                       let migrationFilenames = [ f | f <- contents, isMigrationFilename f ]+                           fullPaths = [ (f, storePath s </> f) | f <- migrationFilenames ]+                       existing <- filterM (\(_, full) -> doesFileExist full) fullPaths+                       return [ dropExtension short | (short, _) <- existing ] -    saveMigration s m = do-      filename <- fullMigrationName s $ mId m-      liftIO $ writeFile filename $ serializeMigration m+                   , saveMigration = \m -> do+                       filename <- fsFullMigrationName s $ mId m+                       writeFile filename $ serializeMigration m+                   } +fsFullMigrationName :: FilesystemStoreSettings -> FilePath -> IO FilePath+fsFullMigrationName s name = return $ storePath s </> name ++ filenameExtension+ isMigrationFilename :: FilePath -> Bool isMigrationFilename path = takeExtension path == filenameExtension  -- |Given a store and migration name, read and parse the associated -- migration and return the migration if successful.  Otherwise return -- a parsing error message.-migrationFromFile :: FilesystemStore -> String -> IO (Either String Migration)+migrationFromFile :: FilesystemStoreSettings -> String -> IO (Either String Migration) migrationFromFile store name =-    fullMigrationName store name >>= migrationFromPath+    fsFullMigrationName store name >>= migrationFromPath  -- |Given a filesystem path, read and parse the file as a migration -- return the 'Migration' if successful.  Otherwise return a parsing@@ -94,10 +98,10 @@        case length missing of         0 -> do-          newM <- newMigration ""+          let newM = newMigration name           case migrationFromFields newM fields of             Nothing -> throwFS $ "Error in " ++ (show path) ++ ": unrecognized field found"-            Just m -> return $ m { mId = name }+            Just m -> return m         _ -> throwFS $ "Error in " ++ (show path) ++ ": missing required field(s): " ++ (show missing)  getFields :: YamlLight -> [(String, String)]@@ -123,8 +127,7 @@   migrationFromFields newM rest  requiredFields :: [String]-requiredFields = [ "Created"-                 , "Apply"+requiredFields = [ "Apply"                  , "Depends"                  ] @@ -141,7 +144,7 @@   ts <- case readTimestamp value of           [(t, _)] -> return t           _ -> fail "expected one valid parse"-  return $ m { mTimestamp = ts }+  return $ m { mTimestamp = Just ts }  readTimestamp :: String -> [(UTCTime, String)] readTimestamp = reads

@@ -28,7 +28,10 @@       Just desc -> Just $ "Description: " ++ desc  serializeTimestamp :: FieldSerializer-serializeTimestamp m = Just $ "Created: " ++ (show $ mTimestamp m)+serializeTimestamp m =+    case mTimestamp m of+        Nothing -> Nothing+        Just ts -> Just $ "Created: " ++ (show ts)  serializeDepends :: FieldSerializer serializeDepends m = Just $ "Depends: " ++ (intercalate " " $ mDeps m)

@@ -1,6 +1,5 @@ module Database.Schema.Migrations.Migration     ( Migration(..)-    , MonadMigration(..)     , newMigration     ) where@@ -10,7 +9,7 @@ import Data.Time () -- for UTCTime Show instance import qualified Data.Time.Clock as Clock -data Migration = Migration { mTimestamp :: Clock.UTCTime+data Migration = Migration { mTimestamp :: Maybe Clock.UTCTime                            , mId :: String                            , mDesc :: Maybe String                            , mApply :: String@@ -23,19 +22,12 @@     depsOf = mDeps     depId = mId -class (Monad m) => MonadMigration m where-    getCurrentTime :: m Clock.UTCTime--instance MonadMigration IO where-    getCurrentTime = Clock.getCurrentTime--newMigration :: (MonadMigration m) => String -> m Migration-newMigration theId = do-  curTime <- getCurrentTime-  return $ Migration { mTimestamp = curTime-                     , mId = theId-                     , mDesc = Nothing-                     , mApply = ""-                     , mRevert = Nothing-                     , mDeps = []-                     }+newMigration :: String -> Migration+newMigration theId =+  Migration { mTimestamp = Nothing+            , mId = theId+            , mApply = "(Apply SQL here.)"+            , mRevert = Nothing+            , mDesc = Nothing+            , mDeps = []+            }

@@ -45,25 +45,26 @@                            , storeDataGraph :: DependencyGraph Migration                            } --- |A type class for types which represent a storage facility (and a--- monad context in which to operate on the store).  A MigrationStore--- is a facility in which new migrations can be created, and from--- which existing migrations can be loaded.-class (Monad m) => MigrationStore s m where-    -- |Load a migration from the store.-    loadMigration :: s -> String -> m (Either String Migration)+-- |The type of migration storage facilities. A MigrationStore is a+-- facility in which new migrations can be created, and from which+-- existing migrations can be loaded.+data MigrationStore =+    MigrationStore { loadMigration :: String -> IO (Either String Migration)+                   -- ^ Load a migration from the store. -    -- |Save a migration to the store.-    saveMigration :: s -> Migration -> m ()+                   , saveMigration :: Migration -> IO ()+                   -- ^ Save a migration to the store. -    -- |Return a list of all available migrations' names.-    getMigrations :: s -> m [String]+                   , getMigrations :: IO [String]+                   -- ^ Return a list of all available migrations'+                   -- names. -    -- |Return the full representation of a given migration name;-    -- mostly for filesystem stores, where the full representation-    -- includes the store path.-    fullMigrationName :: s -> String -> m String-    fullMigrationName _ name = return name+                   , fullMigrationName :: String -> IO String+                   -- ^ Return the full representation of a given+                   -- migration name; mostly for filesystem stores,+                   -- where the full representation includes the store+                   -- path.+                   }  -- |A type for types of validation errors for migration maps. data MapValidationError = DependencyReferenceError String String@@ -101,7 +102,7 @@ -- loaded migrations, and return errors or a 'MigrationMap' on -- success.  Generally speaking, this will be the first thing you -- should call once you have constructed a 'MigrationStore'.-loadMigrations :: (MigrationStore s m) => s -> m (Either [MapValidationError] StoreData)+loadMigrations :: MigrationStore -> IO (Either [MapValidationError] StoreData) loadMigrations store = do   migrations <- getMigrations store   loadedWithErrors <- mapM (\name -> loadMigration store name) migrations

@@ -1,23 +0,0 @@-module Main-    ( main-    )-where--import  Control.Monad (liftM)-import  Data.Configurator-import  Prelude  hiding (lookup)-import  System.Environment (getArgs, getEnvironment)--import  Moo.Core-import  Moo.Main--loadConfiguration :: Maybe FilePath -> IO Configuration-loadConfiguration Nothing = liftM fromShellEnvironment getEnvironment-loadConfiguration (Just path) = fromConfigurator =<< load [Required path]--main :: IO ()-main = do-  args <- getArgs-  (_, opts, _) <- procArgs args-  conf <- loadConfiguration $ _configFilePath opts-  mainWithConf args conf

@@ -1,9 +1,9 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}- module Moo.CommandHandlers where +import Control.Applicative ((<$>)) import Moo.Core import Moo.CommandUtils import Control.Monad ( when, forM_ )@@ -11,19 +11,18 @@ import Control.Monad.Reader ( asks ) import System.Exit ( exitWith, ExitCode(..), exitSuccess ) import Control.Monad.Trans ( liftIO )-import Database.HDBC ( IConnection(commit, rollback))  import Database.Schema.Migrations.Store hiding (getMigrations) import Database.Schema.Migrations+import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Backend - newCommand :: CommandHandler newCommand storeData = do   required <- asks _appRequiredArgs   store    <- asks _appStore   let [migrationId] = required-  noAsk <- fmap _noAsk $ asks _appOptions+  noAsk <- _noAsk <$> asks _appOptions    liftIO $ do     fullPath <- fullMigrationName store migrationId@@ -45,7 +44,7 @@      case result of       True -> do-               status <- createNewMigration store migrationId deps+               status <- createNewMigration store $ (newMigration migrationId) { mDeps = deps }                case status of                  Left e -> putStrLn e >> (exitWith (ExitFailure 1))                  Right _ -> putStrLn $ "Migration created successfully: " ++@@ -53,126 +52,119 @@       False -> do                putStrLn "Migration creation cancelled." - upgradeCommand :: CommandHandler upgradeCommand storeData = do-  isTesting <-  fmap _test $ asks _appOptions-  withConnection $ \(AnyIConnection conn) -> do-        ensureBootstrappedBackend conn >> commit conn-        migrationNames <- missingMigrations conn storeData+  isTesting <-  _test <$> asks _appOptions+  withBackend $ \backend -> do+        ensureBootstrappedBackend backend >> commitBackend backend+        migrationNames <- missingMigrations backend storeData         when (null migrationNames) $ do                            putStrLn "Database is up to date."                            exitSuccess         forM_ migrationNames $ \migrationName -> do             m <- lookupMigration storeData migrationName-            apply m storeData conn False+            apply m storeData backend False         case isTesting of           True -> do-                 rollback conn+                 rollbackBackend backend                  putStrLn "Upgrade test successful."           False -> do-                 commit conn+                 commitBackend backend                  putStrLn "Database successfully upgraded." - upgradeListCommand :: CommandHandler upgradeListCommand storeData = do-  withConnection $ \(AnyIConnection conn) -> do-        ensureBootstrappedBackend conn >> commit conn-        migrationNames <- missingMigrations conn storeData+  withBackend $ \backend -> do+        ensureBootstrappedBackend backend >> commitBackend backend+        migrationNames <- missingMigrations backend storeData         when (null migrationNames) $ do                                putStrLn "Database is up to date."                                exitSuccess         putStrLn "Migrations to install:"         forM_ migrationNames (putStrLn . ("  " ++)) - reinstallCommand :: CommandHandler reinstallCommand storeData = do-  isTesting <-  fmap _test $ asks _appOptions+  isTesting <-  _test <$> asks _appOptions   required <- asks _appRequiredArgs   let [migrationId] = required -  withConnection $ \(AnyIConnection conn) -> do-      ensureBootstrappedBackend conn >> commit conn+  withBackend $ \backend -> do+      ensureBootstrappedBackend backend >> commitBackend backend       m <- lookupMigration storeData migrationId -      revert m storeData conn-      apply m storeData conn True+      revert m storeData backend+      apply m storeData backend True        case isTesting of         False -> do-          commit conn+          commitBackend backend           putStrLn "Migration successfully reinstalled."         True -> do-          rollback conn+          rollbackBackend backend           putStrLn "Reinstall test successful." - listCommand :: CommandHandler listCommand _ = do-  withConnection $ \(AnyIConnection conn) -> do-      ensureBootstrappedBackend conn >> commit conn-      ms <- getMigrations conn+  withBackend $ \backend -> do+      ensureBootstrappedBackend backend >> commitBackend backend+      ms <- getMigrations backend       forM_ ms $ \m ->           when (not $ m == rootMigrationName) $ putStrLn m - applyCommand :: CommandHandler applyCommand storeData = do-  isTesting <-  fmap _test $ asks _appOptions+  isTesting <-  _test <$> asks _appOptions   required  <- asks _appRequiredArgs   let [migrationId] = required -  withConnection $ \(AnyIConnection conn) -> do-        ensureBootstrappedBackend conn >> commit conn+  withBackend $ \backend -> do+        ensureBootstrappedBackend backend >> commitBackend backend         m <- lookupMigration storeData migrationId-        apply m storeData conn True+        apply m storeData backend True         case isTesting of           False -> do-            commit conn+            commitBackend backend             putStrLn "Successfully applied migrations."           True -> do-            rollback conn+            rollbackBackend backend             putStrLn "Migration installation test successful." - revertCommand :: CommandHandler revertCommand storeData = do-  isTesting <-  fmap _test $ asks _appOptions+  isTesting <-  _test <$> asks _appOptions   required <- asks _appRequiredArgs   let [migrationId] = required -  withConnection $ \(AnyIConnection conn) -> do-      ensureBootstrappedBackend conn >> commit conn+  withBackend $ \backend -> do+      ensureBootstrappedBackend backend >> commitBackend backend       m <- lookupMigration storeData migrationId-      revert m storeData conn+      revert m storeData backend        case isTesting of         False -> do-          commit conn+          commitBackend backend           putStrLn "Successfully reverted migrations."         True -> do-          rollback conn+          rollbackBackend backend           putStrLn "Migration uninstallation test successful." - testCommand :: CommandHandler testCommand storeData = do   required <- asks _appRequiredArgs   let [migrationId] = required -  withConnection $ \(AnyIConnection conn) -> do-        ensureBootstrappedBackend conn >> commit conn+  withBackend $ \backend -> do+        ensureBootstrappedBackend backend >> commitBackend backend         m <- lookupMigration storeData migrationId-        migrationNames <- missingMigrations conn storeData+        migrationNames <- missingMigrations backend storeData         -- If the migration is already installed, remove it as part of         -- the test         when (not $ migrationId `elem` migrationNames) $-             do revert m storeData conn+             do revert m storeData backend                 return ()-        applied <- apply m storeData conn True+        applied <- apply m storeData backend True         forM_ (reverse applied) $ \migration -> do-                             revert migration storeData conn-        rollback conn+                             revert migration storeData backend+        rollbackBackend backend         putStrLn "Successfully tested migrations."

@@ -13,7 +13,6 @@ import Moo.Core import System.Console.GetOpt - -- |The available commands; used to dispatch from the command line and -- used to generate usage output. -- |The available commands; used to dispatch from the command line and@@ -83,47 +82,39 @@ findCommand :: String -> Maybe Command findCommand name = listToMaybe [ c | c <- commands, _cName c == name ] - commandOptions :: [ OptDescr (CommandOptions -> IO CommandOptions) ] commandOptions =  [ optionConfigFile                   , optionTest                   , optionNoAsk                   ] - optionConfigFile :: OptDescr (CommandOptions -> IO CommandOptions) optionConfigFile = Option "c" ["config-file"]                    (ReqArg (\arg opt ->                              return opt { _configFilePath = Just arg }) "FILE")                    "Specify location of configuration file" - optionTest :: OptDescr (CommandOptions -> IO CommandOptions) optionTest = Option "t" ["test"]              (NoArg (\opt -> return opt { _test = True }))              "Perform the action then rollback when finished" - optionNoAsk :: OptDescr (CommandOptions -> IO CommandOptions) optionNoAsk = Option "n" ["no-ask"]               (NoArg (\opt -> return opt { _noAsk = True }))               "Do not interactively ask any questions, just do it" - getCommandArgs :: [String] -> IO ( CommandOptions, [String] ) getCommandArgs args = do   let (actions, required, _) =  getOpt RequireOrder commandOptions args   opts <- foldl (>>=) defaultOptions actions   return ( opts, required ) - defaultOptions :: IO CommandOptions defaultOptions = return $ CommandOptions Nothing False False - commandOptionUsage :: String commandOptionUsage = usageInfo "Options:" commandOptions-  usageString :: Command -> String usageString command =

@@ -1,12 +1,12 @@ {-# LANGUAGE FlexibleContexts #-}- module Moo.CommandUtils        ( apply        , confirmCreation        , interactiveAskDeps        , lookupMigration        , revert-       , withConnection+       , withBackend+       , makeBackend        ) where  import Control.Exception ( bracket )@@ -14,18 +14,13 @@ import Control.Monad.Reader ( asks ) import Control.Monad.Trans ( liftIO ) import Data.List ( intercalate, sortBy )-import Data.Maybe ( fromJust, isNothing, isJust )+import Data.Maybe ( fromJust, isJust ) import System.Exit ( exitWith, ExitCode(..) ) import System.IO ( stdout, hFlush, hGetBuffering                  , hSetBuffering, stdin, BufferMode(..) )-import Database.HDBC ( IConnection, disconnect ) - import Database.Schema.Migrations ( migrationsToApply, migrationsToRevert )-import Database.Schema.Migrations.Backend ( Backend-                                          , applyMigration-                                          , revertMigration-                                          )+import Database.Schema.Migrations.Backend (Backend(..)) import Database.Schema.Migrations.Migration ( Migration(..) ) import Database.Schema.Migrations.Store ( StoreData                                         , storeLookup@@ -33,9 +28,7 @@                                         ) import Moo.Core --apply :: (IConnection b, Backend b IO)-         => Migration -> StoreData -> b -> Bool -> IO [Migration]+apply :: Migration -> StoreData -> Backend -> Bool -> IO [Migration] apply m storeData backend complain = do   -- Get the list of migrations to apply   toApply <- migrationsToApply storeData backend m@@ -57,9 +50,7 @@         applyMigration conn it         putStrLn "done." --revert :: (IConnection b, Backend b IO)-          => Migration -> StoreData -> b -> IO [Migration]+revert :: Migration -> StoreData -> Backend -> IO [Migration] revert m storeData backend = do   -- Get the list of migrations to revert   toRevert <- liftIO $ migrationsToRevert storeData backend m@@ -90,37 +81,26 @@       exitWith (ExitFailure 1)     Just m' -> return m' - -- Given a database type string and a database connection string, -- return a database connection or raise an error if the database -- connection cannot be established, or if the database type is not -- supported.-makeConnection :: String -> DbConnDescriptor -> IO AnyIConnection-makeConnection dbType (DbConnDescriptor connStr) =+makeBackend :: String -> DbConnDescriptor -> IO Backend+makeBackend dbType (DbConnDescriptor connStr) =     case lookup dbType databaseTypes of       Nothing -> error $ "Unsupported database type " ++ show dbType ++                  " (supported types: " ++                  intercalate "," (map fst databaseTypes) ++ ")"-      Just mkConnection -> mkConnection connStr-+      Just mkBackend -> mkBackend connStr  -- Given an action that needs a database connection, connect to the -- database using the application configuration and invoke the action -- with the connection.  Return its result.-withConnection :: (AnyIConnection -> IO a) -> AppT a-withConnection act = do-  mDbPath <- asks _appDatabaseConnStr-  when (isNothing mDbPath) $ error $ "Error: Database connection string not \-                                     \specified, please set " ++ envDatabaseName-  mDbType <- asks _appDatabaseType-  when (isNothing mDbType) $-       error $ "Error: Database type not specified, " ++-                 "please set " ++ envDatabaseType ++-                 " (supported types: " ++-                 intercalate "," (map fst databaseTypes) ++ ")"-  liftIO $ bracket (makeConnection (fromJust mDbType) (fromJust mDbPath))-             (\(AnyIConnection conn) -> disconnect conn) act-+withBackend :: (Backend -> IO a) -> AppT a+withBackend act = do+  dbPath <- asks _appDatabaseConnStr+  dbType <- asks _appDatabaseType+  liftIO $ bracket (makeBackend dbType dbPath) disconnectBackend act  -- Given a migration name and selected dependencies, get the user's -- confirmation that a migration should be created.@@ -135,7 +115,6 @@                          , ('n', (False, Nothing))                          ] - -- Prompt the user for a choice, given a prompt and a list of possible -- choices.  Let the user get help for the available choices, and loop -- until the user makes a valid choice.@@ -157,7 +136,6 @@       helpChar = if hasHelp choiceMap then "h" else ""       choiceMapWithHelp = choiceMap ++ [('h', (undefined, Just "this help"))] - -- Given a PromptChoices, build a multi-line help string for those -- choices using the description information in the choice list. mkPromptHelp :: PromptChoices a -> String@@ -165,18 +143,15 @@     intercalate "" [ [c] ++ ": " ++ fromJust msg ++ "\n" |                      (c, (_, msg)) <- choices, isJust msg ] - -- Does the specified prompt choice list have any help messages in it? hasHelp :: PromptChoices a -> Bool hasHelp = (> 0) . length . filter hasMsg     where hasMsg (_, (_, m)) = isJust m - -- A general type for a set of choices that the user can make at a -- prompt. type PromptChoices a = [(Char, (a, Maybe String))] - -- Get an input character in non-buffered mode, then restore the -- original buffering setting. unbufferedGetChar :: IO Char@@ -187,13 +162,11 @@   hSetBuffering stdin bufferingMode   return c - -- The types for choices the user can make when being prompted for -- dependencies. data AskDepsChoice = Yes | No | View | Done | Quit                      deriving (Eq) - -- Interactively ask the user about which dependencies should be used -- when creating a new migration. interactiveAskDeps :: StoreData -> IO [String]@@ -205,7 +178,6 @@       where         compareTimestamps m1 m2 = compare (mTimestamp m2) (mTimestamp m1) - -- Recursive function to prompt the user for dependencies and let the -- user view information about potential dependencies.  Returns a list -- of migration names which were selected.@@ -236,7 +208,6 @@             putStrLn "cancelled."             exitWith (ExitFailure 1)           Done -> return []-  -- The choices the user can make when being prompted for dependencies. askDepsChoices :: PromptChoices AskDepsChoice

@@ -1,5 +1,4 @@ {-# LANGUAGE ExistentialQuantification #-}- module Moo.Core where  import Control.Applicative ((<$>), (<*>))@@ -7,67 +6,73 @@ import qualified Data.Configurator as C import Data.Configurator.Types (Config) import qualified Data.Text as T-import Database.HDBC (IConnection) import Database.HDBC.PostgreSQL (connectPostgreSQL) import Database.HDBC.Sqlite3 (connectSqlite3)+import System.Environment (getEnvironment)  import Database.Schema.Migrations ()-import Database.Schema.Migrations.Backend.HDBC ()-import Database.Schema.Migrations.Filesystem (FilesystemStore)-import Database.Schema.Migrations.Store (StoreData)-+import Database.Schema.Migrations.Store (MigrationStore, StoreData)+import Database.Schema.Migrations.Backend+import Database.Schema.Migrations.Backend.HDBC  -- |The monad in which the application runs. type AppT a = ReaderT AppState IO a - -- |The type of actions that are invoked to handle specific commands type CommandHandler = StoreData -> AppT () - -- |Application state which can be accessed by any command handler. data AppState = AppState { _appOptions         :: CommandOptions                          , _appCommand         :: Command                          , _appRequiredArgs    :: [String]                          , _appOptionalArgs    :: [String]-                         , _appStore           :: FilesystemStore-                         , _appDatabaseConnStr :: Maybe DbConnDescriptor-                         , _appDatabaseType    :: Maybe String+                         , _appStore           :: MigrationStore+                         , _appDatabaseConnStr :: DbConnDescriptor+                         , _appDatabaseType    :: String                          , _appStoreData       :: StoreData                          }  type ShellEnvironment = [(String, String)]  data Configuration = Configuration-    { _connectionString   :: Maybe String-    , _databaseType       :: Maybe String-    , _migrationStorePath :: Maybe FilePath+    { _connectionString   :: String+    , _databaseType       :: String+    , _migrationStorePath :: FilePath     } -fromShellEnvironment :: ShellEnvironment -> Configuration-fromShellEnvironment env = Configuration connectionString-                                         databaseType-                                         migrationStorePath+loadConfiguration :: Maybe FilePath -> IO (Either String Configuration)+loadConfiguration pth = do+    mCfg <- case pth of+        Nothing -> fromShellEnvironment <$> getEnvironment+        Just path -> fromConfigurator =<< C.load [C.Required path]++    case mCfg of+        Nothing -> do+            case pth of+                Nothing -> return $ Left "Missing required environment variables"+                Just path -> return $ Left $ "Could not load configuration from " ++ path+        Just cfg -> return $ Right cfg++fromShellEnvironment :: ShellEnvironment -> Maybe Configuration+fromShellEnvironment env = Configuration <$> connectionString+                                         <*> databaseType+                                         <*> migrationStorePath     where       connectionString = envLookup envDatabaseName       databaseType = envLookup envDatabaseType       migrationStorePath = envLookup envStoreName       envLookup = (\evar -> lookup evar env) -fromConfigurator :: Config -> IO Configuration-fromConfigurator conf = Configuration <$> connectionString-                                      <*> databaseType-                                      <*> migrationStorePath-    where-      connectionString = configLookup envDatabaseName-      databaseType = configLookup envDatabaseType-      migrationStorePath = configLookup envStoreName-      configLookup = C.lookup conf . T.pack---- |Type wrapper for IConnection instances so the makeConnection--- function can return any type of connection.-data AnyIConnection = forall c. (IConnection c) => AnyIConnection c+fromConfigurator :: Config -> IO (Maybe Configuration)+fromConfigurator conf = do+    let configLookup = C.lookup conf . T.pack+    connectionString <- configLookup envDatabaseName+    databaseType <- configLookup envDatabaseType+    migrationStorePath <- configLookup envStoreName +    return $ Configuration <$> connectionString+                           <*> databaseType+                           <*> migrationStorePath  -- |CommandOptions are those options that can be specified at the command -- prompt to modify the behavior of a command.@@ -76,7 +81,6 @@                                      , _noAsk          :: Bool                                      } - -- |A command has a name, a number of required arguments' labels, a -- number of optional arguments' labels, and an action to invoke. data Command = Command { _cName           :: String@@ -87,22 +91,19 @@                        , _cHandler        :: CommandHandler                        } - -- |ConfigOptions are those options read from configuration file data ConfigData = ConfigData { _dbTypeStr     :: String                              , _dbConnStr     :: String                              , _fileStorePath :: String                              } - newtype DbConnDescriptor = DbConnDescriptor String - -- |The values of DBM_DATABASE_TYPE and their corresponding connection -- factory functions.-databaseTypes :: [(String, String -> IO AnyIConnection)]-databaseTypes = [ ("postgresql", fmap AnyIConnection . connectPostgreSQL)-                , ("sqlite3", fmap AnyIConnection . connectSqlite3)+databaseTypes :: [(String, String -> IO Backend)]+databaseTypes = [ ("postgresql", fmap hdbcBackend . connectPostgreSQL)+                , ("sqlite3", fmap hdbcBackend . connectSqlite3)                 ]  envDatabaseType :: String

@@ -8,16 +8,14 @@     ) where -import  Control.Monad (liftM) import  Control.Monad.Reader (forM_, runReaderT, when) import  Data.List (intercalate)-import  Data.Maybe (fromMaybe) import  Database.HDBC (SqlError, catchSql, seErrorMsg) import  Prelude  hiding (lookup) import  System.Environment (getProgName) import  System.Exit (ExitCode (ExitFailure), exitWith) -import  Database.Schema.Migrations.Filesystem (FilesystemStore (..))+import  Database.Schema.Migrations.Filesystem (filesystemStore, FilesystemStoreSettings(..)) import  Database.Schema.Migrations.Store import  Moo.CommandInterface import  Moo.Core@@ -45,7 +43,8 @@  usageSpecific :: Command -> IO a usageSpecific command = do-  putStrLn $ "Usage: initstore-fs " ++ usageString command+  pn <- getProgName+  putStrLn $ "Usage: " ++ pn ++ " " ++ usageString command   exitWith (ExitFailure 1)  procArgs :: Args -> IO (Command, CommandOptions, [String])@@ -64,14 +63,10 @@ mainWithConf args conf = do   (command, opts, required) <- procArgs args -  let mDbConnStr = _connectionString conf-  let mDbType = _databaseType conf-  let mStoreName = _migrationStorePath conf-  let  storePathStr =-         fromMaybe (error $ "Error: missing required environment variable " ++ envStoreName)-                   mStoreName--  let  store = FSStore { storePath = storePathStr }+  let dbConnStr = _connectionString conf+      dbType = _databaseType conf+      storePathStr = _migrationStorePath conf+      store = filesystemStore $ FSStore { storePath = storePathStr }    if length required < length ( _cRequired command) then       usageSpecific command else@@ -86,9 +81,9 @@                               , _appCommand = command                               , _appRequiredArgs = required                               , _appOptionalArgs = ["" :: String]-                              , _appDatabaseConnStr = liftM DbConnDescriptor mDbConnStr-                              , _appDatabaseType = mDbType-                              , _appStore = FSStore storePathStr+                              , _appDatabaseConnStr = DbConnDescriptor dbConnStr+                              , _appDatabaseType = dbType+                              , _appStore = store                               , _appStoreData = storeData                               }             runReaderT (_cHandler command storeData) st `catchSql` reportSqlError

@@ -3,7 +3,7 @@ import Test.HUnit import Control.Monad ( forM_ ) -import Database.Schema.Migrations.Backend.HDBC ()+import Database.Schema.Migrations.Backend.HDBC import Database.Schema.Migrations.Migration ( Migration(..), newMigration ) import Database.Schema.Migrations.Backend ( Backend(..) ) @@ -26,19 +26,20 @@  bootstrapTest :: (IConnection a) => a -> IO () bootstrapTest conn = do-  bs <- getBootstrapMigration conn-  applyMigration conn bs+  let backend = hdbcBackend conn+  bs <- getBootstrapMigration backend+  applyMigration backend bs   assertEqual "installed_migrations table exists" ["installed_migrations"] =<< getTables conn-  assertEqual "successfully bootstrapped" [mId bs] =<< getMigrations conn+  assertEqual "successfully bootstrapped" [mId bs] =<< getMigrations backend  isBootstrappedTrueTest :: (IConnection a) => a -> IO () isBootstrappedTrueTest conn = do-  result <- isBootstrapped conn+  result <- isBootstrapped $ hdbcBackend conn   assertBool "Bootstrapped check" result  isBootstrappedFalseTest :: (IConnection a) => a -> IO () isBootstrappedFalseTest conn = do-  result <- isBootstrapped conn+  result <- isBootstrapped $ hdbcBackend conn   assertBool "Bootstrapped check" $ not result  ignoreSqlExceptions :: IO a -> IO (Maybe a)@@ -47,97 +48,97 @@  applyMigrationSuccess :: (IConnection a) => a -> IO () applyMigrationSuccess conn = do-    m1 <- newMigration "validMigration"+    let backend = hdbcBackend conn -    let m1' = m1 { mApply = "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int);" }+    let m1 = (newMigration "validMigration") { mApply = "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int);" }      -- Apply the migrations, ignore exceptions-    withTransaction conn $ \conn' -> applyMigration conn' m1'+    withTransaction conn $ \conn' -> applyMigration (hdbcBackend conn') m1      -- Check that none of the migrations were installed-    assertEqual "Installed migrations" ["root", "validMigration"] =<< getMigrations conn+    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 conn = do-    m1 <- newMigration "second"-    m2 <- newMigration "third"+    let backend = hdbcBackend conn -    let m1' = m1 { mApply = "CREATE TABLE validButTemporary (a int)" }-    let m2' = m2 { mApply = "INVALID SQL" }+    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-                               applyMigration conn' m1'-                               applyMigration conn' m2'+        let backend' = hdbcBackend conn'+        applyMigration backend' m1+        applyMigration backend' m2      -- Check that none of the migrations were installed-    assertEqual "Installed migrations" ["root"] =<< getMigrations conn+    assertEqual "Installed migrations" ["root"] =<< getMigrations backend     assertEqual "Installed tables" ["installed_migrations"] =<< getTables conn  revertMigrationFailure :: (IConnection a) => a -> IO () revertMigrationFailure conn = do-    m1 <- newMigration "second"-    m2 <- newMigration "third"+    let backend = hdbcBackend conn -    let m1' = m1 { mApply = "CREATE TABLE validRMF (a int)"-                 , mRevert = Just "DROP TABLE validRMF"}-    let m2' = m2 { mApply = "SELECT * FROM validRMF"-                 , mRevert = Just "INVALID REVERT SQL"}+    let m1 = (newMigration "second") { mApply = "CREATE TABLE validRMF (a int)"+                                     , mRevert = Just "DROP TABLE validRMF"}+        m2 = (newMigration "third") { mApply = "SELECT * FROM validRMF"+                                    , mRevert = Just "INVALID REVERT SQL"} -    applyMigration conn m1'-    applyMigration conn m2'+    applyMigration backend m1+    applyMigration backend m2 -    installedBeforeRevert <- getMigrations conn+    installedBeforeRevert <- getMigrations backend -    commit conn+    commitBackend backend      -- Revert the migrations, ignore exceptions; the revert will fail,     -- but withTransaction will roll back.     ignoreSqlExceptions $ withTransaction conn $ \conn' -> do-      revertMigration conn' m2'-      revertMigration conn' m1'+        let backend' = hdbcBackend conn'+        revertMigration backend' m2+        revertMigration backend' m1      -- Check that none of the migrations were reverted     assertEqual "successfully roll back failed revert" installedBeforeRevert-        =<< getMigrations conn+        =<< getMigrations backend  revertMigrationNothing :: (IConnection a) => a -> IO () revertMigrationNothing conn = do-    m1 <- newMigration "second"+    let backend = hdbcBackend conn -    let m1' = m1 { mApply = "SELECT 1"-                 , mRevert = Nothing }+    let m1 = (newMigration "second") { mApply = "SELECT 1"+                                     , mRevert = Nothing } -    applyMigration conn m1'+    applyMigration backend m1 -    installedAfterApply <- getMigrations conn+    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 conn m1'+    revertMigration backend m1 -    installed <- getMigrations conn+    installed <- getMigrations backend     assertBool "Check that the migration was reverted" $ not $ "second" `elem` installed  revertMigrationJust :: (IConnection a) => a -> IO () revertMigrationJust conn = do     let name = "revertable"-    m1 <- newMigration name+        backend = hdbcBackend conn -    let m1' = m1 { mApply = "CREATE TABLE the_test_table (a int)"-                 , mRevert = Just "DROP TABLE the_test_table" }+    let m1 = (newMigration name) { mApply = "CREATE TABLE the_test_table (a int)"+                                 , mRevert = Just "DROP TABLE the_test_table" } -    applyMigration conn m1'+    applyMigration backend m1 -    installedAfterApply <- getMigrations conn+    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 conn m1'+    revertMigration backend m1 -    installed <- getMigrations conn+    installed <- getMigrations backend     assertBool "Check that the migration was reverted" $ not $ name `elem` installed

@@ -11,7 +11,7 @@  import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Filesystem-    ( FilesystemStore(..)+    ( FilesystemStoreSettings(..)     , migrationFromFile     ) @@ -29,7 +29,7 @@  valid_full :: Migration valid_full = Migration {-               mTimestamp = ts+               mTimestamp = Just ts              , mId = "valid_full"              , mDesc = Just "A valid full migration."              , mDeps = ["another_migration"]@@ -39,7 +39,7 @@  valid_full_comments :: Migration valid_full_comments = Migration {-                        mTimestamp = ts+                        mTimestamp = Just ts                       , mId = "valid_full"                       , mDesc = Just "A valid full migration."                       , mDeps = ["another_migration"]@@ -49,7 +49,7 @@  valid_full_colon :: Migration valid_full_colon = Migration {-                        mTimestamp = ts+                        mTimestamp = Just ts                       , mId = "valid_full"                       , mDesc = Just "A valid full migration."                       , mDeps = ["another_migration"]@@ -80,13 +80,15 @@                               , Right (valid_full { mId = "valid_no_desc", mDesc = Nothing }))                             , ("valid_no_revert"                               , Right (valid_full { mId = "valid_no_revert", mRevert = Nothing }))+                            , ("valid_no_timestamp"+                              , Right (valid_full { mId = "valid_no_timestamp", mTimestamp = Nothing }))                             , ("invalid_missing_required_fields"                               , Left $ "Could not parse migration " ++                                          (fp "invalid_missing_required_fields.txt") ++                                          ":Error in " ++                                          (show $ fp "invalid_missing_required_fields.txt") ++                                          ": missing required field(s): " ++-                                         "[\"Created\",\"Depends\"]")+                                         "[\"Depends\"]")                             , ("invalid_field_name"                               , Left $ "Could not parse migration " ++                                          (fp "invalid_field_name.txt") ++

@@ -23,7 +23,7 @@  valid_full :: Migration valid_full = Migration {-               mTimestamp = ts+               mTimestamp = Just ts              , mId = "valid_full"              , mDesc = Just "A valid full migration."              , mDeps = ["another_migration"]

@@ -15,7 +15,7 @@  getMigrationsTest :: IO Test getMigrationsTest = do-  let store = FSStore { storePath = testFile "migration_parsing" }+  let store = filesystemStore $ FSStore { storePath = testFile "migration_parsing" }       expected = Set.fromList [ "invalid_field_name"                               , "invalid_missing_required_fields"                               , "invalid_syntax"@@ -24,6 +24,7 @@                               , "valid_no_depends"                               , "valid_no_desc"                               , "valid_no_revert"+                              , "valid_no_timestamp"                               , "valid_with_comments"                               , "valid_with_comments2"                               , "valid_with_colon"

@@ -5,42 +5,40 @@ where  import Test.HUnit-import Control.Monad.Identity ( runIdentity, Identity )+import Control.Applicative ((<$>)) import qualified Data.Map as Map import Data.Time.Clock ( UTCTime )  import Database.Schema.Migrations-import Database.Schema.Migrations.Store+import Database.Schema.Migrations.Store hiding (getMigrations) import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Backend  tests :: [Test] tests = migrationsToApplyTests -type TestBackend = [Migration]--newtype TestM a = TestM (Identity a) deriving (Monad)--instance MonadMigration TestM where-    getCurrentTime = undefined--instance Backend TestBackend TestM where-    getBootstrapMigration _ = undefined-    isBootstrapped _ = return True-    applyMigration _ _ = undefined-    revertMigration _ _ = undefined-    getMigrations b = return $ map mId b+testBackend :: [Migration] -> Backend+testBackend testMs =+    Backend { getBootstrapMigration = undefined+            , isBootstrapped = return True+            , applyMigration = const undefined+            , revertMigration = const undefined+            , getMigrations = return $ mId <$> testMs+            , commitBackend = return ()+            , rollbackBackend = return ()+            , disconnectBackend = return ()+            }  -- |Given a backend and a store, what are the list of migrations -- missing in the backend that are available in the store?-type MissingMigrationTestCase = (MigrationMap, TestBackend, Migration,+type MissingMigrationTestCase = (MigrationMap, Backend, Migration,                                  [Migration])  ts :: UTCTime ts = read "2009-04-15 10:02:06 UTC"  blankMigration :: Migration-blankMigration = Migration { mTimestamp = ts+blankMigration = Migration { mTimestamp = Just ts                            , mId = undefined                            , mDesc = Nothing                            , mApply = ""@@ -49,11 +47,11 @@                            }  missingMigrationsTestcases :: [MissingMigrationTestCase]-missingMigrationsTestcases =  [ (m, [], one, [one])-                              , (m, [one], one, [])-                              , (m, [one], two, [two])-                              , (m, [one, two], one, [])-                              , (m, [one, two], two, [])+missingMigrationsTestcases =  [ (m, testBackend [], one, [one])+                              , (m, testBackend [one], one, [])+                              , (m, testBackend [one], two, [two])+                              , (m, testBackend [one, two], one, [])+                              , (m, testBackend [one, two], two, [])                               ]     where       one = blankMigration { mId = "one" }@@ -64,9 +62,10 @@ mkTest (mapping, backend, theMigration, expected) =   let Right graph = depGraphFromMapping mapping       storeData = StoreData mapping graph-      TestM act = migrationsToApply storeData backend theMigration-      result = runIdentity act-  in expected ~=? result+      result = migrationsToApply storeData backend theMigration+  in "a test" ~: do+      actual <- result+      return $ expected == actual  migrationsToApplyTests :: [Test] migrationsToApplyTests = map mkTest missingMigrationsTestcases