diff --git a/MOO.TXT b/MOO.TXT --- a/MOO.TXT +++ b/MOO.TXT @@ -74,10 +74,12 @@ Confirm: create migration 'hello-world' (No dependencies) Are you sure? (yn): y - Migration created successfully: ".../hello-world.txt" + Migration created successfully: ".../hello-world.yml" + New migration will be stored with .yml extension. Older .txt migrations are supported. + 6. Edit the migration you created. In this case, moo created a file - $DBM_MIGRATION_STORE/hello_world.txt that looks like this: + $DBM_MIGRATION_STORE/hello_world.yml that looks like this: Description: (Description here.) Created: 2015-02-18 00:50:12.041176 UTC diff --git a/dbmigrations.cabal b/dbmigrations.cabal --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -1,5 +1,5 @@ Name: dbmigrations -Version: 2.0.0 +Version: 2.1.0 Synopsis: An implementation of relational database "migrations" Description: A library and program for the creation, management, and installation of schema updates @@ -79,20 +79,25 @@ directory >= 1.0, fgl >= 5.4, template-haskell, - yaml-light >= 0.1, + yaml, bytestring >= 0.9, + string-conversions >= 0.4, text >= 0.11, configurator >= 0.2, split >= 0.2.2, - HUnit >= 1.2 + HUnit >= 1.2, + aeson < 2, + unordered-containers Hs-Source-Dirs: src Exposed-Modules: Database.Schema.Migrations Database.Schema.Migrations.Backend Database.Schema.Migrations.Backend.HDBC + Database.Schema.Migrations.CycleDetection Database.Schema.Migrations.Dependencies Database.Schema.Migrations.Filesystem + Database.Schema.Migrations.Filesystem.Serialize Database.Schema.Migrations.Migration Database.Schema.Migrations.Store Database.Schema.Migrations.Test.BackendTest @@ -102,10 +107,6 @@ Moo.Core Moo.Main - Other-Modules: - Database.Schema.Migrations.CycleDetection - Database.Schema.Migrations.Filesystem.Serialize - test-suite dbmigrations-tests default-language: Haskell2010 type: exitcode-stdio-1.0 @@ -119,8 +120,9 @@ directory >= 1.0, fgl >= 5.4, template-haskell, - yaml-light >= 0.1, + yaml, bytestring >= 0.9, + string-conversions >= 0.4, MissingH, HDBC >= 2.2.1, HUnit >= 1.2, @@ -139,7 +141,6 @@ FilesystemTest MigrationsTest StoreTest - TestDriver InMemoryStore LinearMigrationsTest ConfigurationTest @@ -150,8 +151,8 @@ else ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields - Hs-Source-Dirs: src,test - Main-is: TestDriver.hs + Hs-Source-Dirs: test + Main-is: Main.hs Executable moo default-language: Haskell2010 diff --git a/src/Database/Schema/Migrations.hs b/src/Database/Schema/Migrations.hs --- a/src/Database/Schema/Migrations.hs +++ b/src/Database/Schema/Migrations.hs @@ -9,6 +9,7 @@ ) where +import Data.Text ( Text ) import qualified Data.Set as Set import Data.Maybe ( catMaybes ) @@ -25,7 +26,7 @@ -- |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 -> S.StoreData -> IO [String] +missingMigrations :: B.Backend -> S.StoreData -> IO [Text] missingMigrations backend storeData = do let storeMigrationNames = map mId $ S.storeMigrations storeData backendMigrations <- B.getMigrations backend diff --git a/src/Database/Schema/Migrations/Backend.hs b/src/Database/Schema/Migrations/Backend.hs --- a/src/Database/Schema/Migrations/Backend.hs +++ b/src/Database/Schema/Migrations/Backend.hs @@ -1,16 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} module Database.Schema.Migrations.Backend ( Backend(..) , rootMigrationName ) where +import Data.Text ( Text ) + import Database.Schema.Migrations.Migration ( Migration(..) ) -- |Backend instances should use this as the name of the migration -- returned by getBootstrapMigration; this migration is special -- because it cannot be reverted. -rootMigrationName :: String +rootMigrationName :: Text rootMigrationName = "root" -- |A Backend represents a database engine backend such as MySQL or @@ -55,7 +58,7 @@ -- does not supply a revert instruction, this has no effect -- other than bookkeeping. - , getMigrations :: IO [String] + , getMigrations :: IO [Text] -- ^ Returns a list of installed migration names from the -- backend. @@ -71,4 +74,4 @@ } instance Show Backend where - show _ = show "dbmigrations backend" + show _ = "dbmigrations backend" diff --git a/src/Database/Schema/Migrations/Backend/HDBC.hs b/src/Database/Schema/Migrations/Backend/HDBC.hs --- a/src/Database/Schema/Migrations/Backend/HDBC.hs +++ b/src/Database/Schema/Migrations/Backend/HDBC.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Database.Schema.Migrations.Backend.HDBC ( hdbcBackend ) @@ -22,22 +23,25 @@ , newMigration ) +import Data.Text ( Text ) +import Data.String.Conversions ( cs, (<>) ) + import Control.Applicative ( (<$>) ) import Data.Time.Clock (getCurrentTime) -migrationTableName :: String +migrationTableName :: Text migrationTableName = "installed_migrations" -createSql :: String -createSql = "CREATE TABLE " ++ migrationTableName ++ " (migration_id TEXT)" +createSql :: Text +createSql = "CREATE TABLE " <> migrationTableName <> " (migration_id TEXT)" -revertSql :: String -revertSql = "DROP TABLE " ++ migrationTableName +revertSql :: Text +revertSql = "DROP TABLE " <> migrationTableName -- |General Backend constructor for all HDBC connection implementations. hdbcBackend :: (IConnection conn) => conn -> Backend hdbcBackend conn = - Backend { isBootstrapped = elem migrationTableName <$> getTables conn + Backend { isBootstrapped = elem (cs migrationTableName) <$> getTables conn , getBootstrapMigration = do ts <- getCurrentTime @@ -49,22 +53,22 @@ } , applyMigration = \m -> do - runRaw conn (mApply m) - run conn ("INSERT INTO " ++ migrationTableName ++ + runRaw conn (cs $ mApply m) + _ <- run conn (cs $ "INSERT INTO " <> migrationTableName <> " (migration_id) VALUES (?)") [toSql $ mId m] return () , revertMigration = \m -> do case mRevert m of Nothing -> return () - Just query -> runRaw conn query + Just query -> runRaw conn (cs query) -- Remove migration from installed_migrations in either case. - run conn ("DELETE FROM " ++ migrationTableName ++ + _ <- run conn (cs $ "DELETE FROM " <> migrationTableName <> " WHERE migration_id = ?") [toSql $ mId m] return () , getMigrations = do - results <- quickQuery' conn ("SELECT migration_id FROM " ++ migrationTableName) [] + results <- quickQuery' conn (cs $ "SELECT migration_id FROM " <> migrationTableName) [] return $ map (fromSql . head) results , commitBackend = commit conn diff --git a/src/Database/Schema/Migrations/Dependencies.hs b/src/Database/Schema/Migrations/Dependencies.hs --- a/src/Database/Schema/Migrations/Dependencies.hs +++ b/src/Database/Schema/Migrations/Dependencies.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-} -- |This module types and functions for representing a dependency -- graph of arbitrary objects and functions for querying such graphs -- to get dependency and reverse dependency information. @@ -11,7 +11,9 @@ ) where +import Data.Text ( Text ) import Data.Maybe ( fromJust ) +import Data.Monoid ( (<>) ) import Data.Graph.Inductive.Graph ( Graph(..), nodes, edges, Node, suc, pre, lab ) import Data.Graph.Inductive.PatriciaTree ( Gr ) @@ -21,9 +23,9 @@ -- and a list of other objects upon which they depend. class (Eq a, Ord a) => Dependable a where -- |The identifiers of the objects on which @a@ depends. - depsOf :: a -> [String] + depsOf :: a -> [Text] -- |The identifier of a 'Dependable' object. - depId :: a -> String + depId :: a -> Text -- |A 'DependencyGraph' represents a collection of objects together -- with a graph of their dependency relationships. This is intended @@ -31,14 +33,14 @@ data DependencyGraph a = DG { depGraphObjectMap :: [(a, Int)] -- ^ A mapping of 'Dependable' objects to -- their graph vertex indices. - , depGraphNameMap :: [(String, Int)] + , depGraphNameMap :: [(Text, Int)] -- ^ A mapping of 'Dependable' object -- identifiers to their graph vertex -- indices. - , depGraph :: Gr String String + , depGraph :: Gr Text Text -- ^ A directed 'Gr' (graph) of the -- 'Dependable' objects' dependency - -- relationships, with 'String' vertex and + -- relationships, with 'Text' vertex and -- edge labels. } @@ -65,14 +67,14 @@ n = [ (fromJust $ lookup o ids, depId o) | o <- objects ] e = [ ( fromJust $ lookup o ids , fromJust $ lookup d ids - , depId o ++ " -> " ++ depId d) | o <- objects, d <- depsOf' o ] + , depId o <> " -> " <> depId d) | o <- objects, d <- depsOf' o ] depsOf' o = map (\i -> fromJust $ lookup i objMap) $ depsOf o objMap = map (\o -> (depId o, o)) objects ids = zip objects [1..] names = map (\(o,i) -> (depId o, i)) ids -type NextNodesFunc = Gr String String -> Node -> [Node] +type NextNodesFunc = Gr Text Text -> Node -> [Node] cleanLDups :: (Eq a) => [a] -> [a] cleanLDups [] = [] @@ -82,16 +84,16 @@ -- |Given a dependency graph and an ID, return the IDs of objects that -- the object depends on. IDs are returned with least direct -- dependencies first (i.e., the apply order). -dependencies :: (Dependable d) => DependencyGraph d -> String -> [String] +dependencies :: (Dependable d) => DependencyGraph d -> Text -> [Text] dependencies g m = reverse $ cleanLDups $ dependenciesWith suc g m -- |Given a dependency graph and an ID, return the IDs of objects that -- depend on it. IDs are returned with least direct reverse -- dependencies first (i.e., the revert order). -reverseDependencies :: (Dependable d) => DependencyGraph d -> String -> [String] +reverseDependencies :: (Dependable d) => DependencyGraph d -> Text -> [Text] reverseDependencies g m = reverse $ cleanLDups $ dependenciesWith pre g m -dependenciesWith :: (Dependable d) => NextNodesFunc -> DependencyGraph d -> String -> [String] +dependenciesWith :: (Dependable d) => NextNodesFunc -> DependencyGraph d -> Text -> [Text] dependenciesWith nextNodes dg@(DG _ nMap theGraph) name = let lookupId = fromJust $ lookup name nMap depNodes = nextNodes theGraph lookupId diff --git a/src/Database/Schema/Migrations/Filesystem.hs b/src/Database/Schema/Migrations/Filesystem.hs --- a/src/Database/Schema/Migrations/Filesystem.hs +++ b/src/Database/Schema/Migrations/Filesystem.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, OverloadedStrings #-} -- |This module provides a type for interacting with a -- filesystem-backed 'MigrationStore'. module Database.Schema.Migrations.Filesystem @@ -9,12 +9,14 @@ ) where -import Prelude hiding ( catch ) +import Prelude import System.Directory ( getDirectoryContents, doesFileExist ) -import System.FilePath ( (), takeExtension, dropExtension - , takeFileName, takeBaseName ) -import Data.ByteString.Char8 ( unpack ) +import System.FilePath ( (), takeExtension, dropExtension, takeBaseName ) +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.ByteString.Char8 as BSC +import Data.String.Conversions ( cs, (<>) ) import Data.Typeable ( Typeable ) import Data.Time.Clock ( UTCTime ) @@ -23,9 +25,11 @@ import Control.Applicative ( (<$>) ) import Control.Monad ( filterM ) -import Control.Exception ( IOException, Exception(..), throw, catch ) +import Control.Exception ( Exception(..), throw, catch ) -import Data.Yaml.YamlLight +import Data.Aeson as J (Object, Value(String, Null)) +import Data.HashMap.Strict as M (toList) +import Data.Yaml import Database.Schema.Migrations.Migration ( Migration(..) @@ -34,7 +38,7 @@ import Database.Schema.Migrations.Filesystem.Serialize import Database.Schema.Migrations.Store -type FieldProcessor = String -> Migration -> Maybe Migration +type FieldProcessor = Text -> Migration -> Maybe Migration data FilesystemStoreSettings = FSStore { storePath :: FilePath } @@ -47,11 +51,14 @@ throwFS = throw . FilesystemStoreError filenameExtension :: String -filenameExtension = ".txt" +filenameExtension = ".yml" +filenameExtensionTxt :: String +filenameExtensionTxt = ".txt" + filesystemStore :: FilesystemStoreSettings -> MigrationStore filesystemStore s = - MigrationStore { fullMigrationName = fsFullMigrationName s + MigrationStore { fullMigrationName = fmap addNewMigrationExtension . fsFullMigrationName s , loadMigration = \theId -> migrationFromFile s theId @@ -60,37 +67,50 @@ 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 ] + return [ cs $ dropExtension short | (short, _) <- existing ] , saveMigration = \m -> do filename <- fsFullMigrationName s $ mId m - writeFile filename $ serializeMigration m + BSC.writeFile (cs $ addNewMigrationExtension filename) $ serializeMigration m } -fsFullMigrationName :: FilesystemStoreSettings -> FilePath -> IO FilePath -fsFullMigrationName s name = return $ storePath s name ++ filenameExtension +addNewMigrationExtension :: FilePath -> FilePath +addNewMigrationExtension path = path <> filenameExtension -isMigrationFilename :: FilePath -> Bool -isMigrationFilename path = takeExtension path == filenameExtension +addMigrationExtension :: FilePath -> String -> FilePath +addMigrationExtension path ext = path <> ext +-- |Build path to migrations without extension. +fsFullMigrationName :: FilesystemStoreSettings -> Text -> IO FilePath +fsFullMigrationName s name = return $ storePath s cs name + +isMigrationFilename :: String -> Bool +isMigrationFilename path = (cs $ takeExtension path) `elem` [filenameExtension, filenameExtensionTxt] + -- |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 :: FilesystemStoreSettings -> String -> IO (Either String Migration) +migrationFromFile :: FilesystemStoreSettings -> Text -> IO (Either String Migration) migrationFromFile store name = - fsFullMigrationName store name >>= migrationFromPath + fsFullMigrationName store (cs name) >>= migrationFromPath -- |Given a filesystem path, read and parse the file as a migration -- return the 'Migration' if successful. Otherwise return a parsing -- error message. migrationFromPath :: FilePath -> IO (Either String Migration) migrationFromPath path = do - let name = takeBaseName $ takeFileName path + let name = cs $ takeBaseName path (Right <$> process name) `catch` (\(FilesystemStoreError s) -> return $ Left $ "Could not parse migration " ++ path ++ ":" ++ s) where + readMigrationFile = do + ymlExists <- doesFileExist (addNewMigrationExtension path) + if ymlExists + then decodeFileThrow (addNewMigrationExtension path) `catch` (\(e::ParseException) -> throwFS $ show e) + else decodeFileThrow (addMigrationExtension path filenameExtensionTxt) `catch` (\(e::ParseException) -> throwFS $ show e) + process name = do - yaml <- parseYamlFile path `catch` (\(e::IOException) -> throwFS $ show e) + yaml <- readMigrationFile -- Convert yaml structure into basic key/value map let fields = getFields yaml @@ -104,14 +124,16 @@ Just m -> return m _ -> throwFS $ "Error in " ++ (show path) ++ ": missing required field(s): " ++ (show missing) -getFields :: YamlLight -> [(String, String)] -getFields (YMap mp) = map toPair $ Map.assocs mp +getFields :: J.Object -> [(Text, Text)] +getFields mp = map toPair $ M.toList mp where - toPair (YStr k, YStr v) = (unpack k, unpack v) + toPair :: (Text, Value) -> (Text, Text) + toPair (k, J.String v) = (cs k, cs v) + toPair (k, J.Null) = (cs k, cs ("" :: String)) toPair (k, v) = throwFS $ "Error in YAML input; expected string key and string value, got " ++ (show (k, v)) getFields _ = throwFS "Error in YAML input; expected mapping" -missingFields :: [(String, String)] -> [String] +missingFields :: [(Text, Text)] -> [Text] missingFields fs = [ k | k <- requiredFields, not (k `elem` inputStrings) ] where @@ -119,19 +141,19 @@ -- |Given a migration and a list of parsed migration fields, update -- the migration from the field values for recognized fields. -migrationFromFields :: Migration -> [(String, String)] -> Maybe Migration +migrationFromFields :: Migration -> [(Text, Text)] -> Maybe Migration migrationFromFields m [] = Just m migrationFromFields m ((name, value):rest) = do processor <- lookup name fieldProcessors newM <- processor value m migrationFromFields newM rest -requiredFields :: [String] +requiredFields :: [Text] requiredFields = [ "Apply" , "Depends" ] -fieldProcessors :: [(String, FieldProcessor)] +fieldProcessors :: [(Text, FieldProcessor)] fieldProcessors = [ ("Created", setTimestamp ) , ("Description", setDescription ) , ("Apply", setApply ) @@ -146,8 +168,8 @@ _ -> fail "expected one valid parse" return $ m { mTimestamp = Just ts } -readTimestamp :: String -> [(UTCTime, String)] -readTimestamp = reads +readTimestamp :: Text -> [(UTCTime, String)] +readTimestamp = reads . cs setDescription :: FieldProcessor setDescription desc m = Just $ m { mDesc = Just desc } @@ -159,4 +181,4 @@ setRevert revert m = Just $ m { mRevert = Just revert } setDepends :: FieldProcessor -setDepends depString m = Just $ m { mDeps = words depString } +setDepends depString m = Just $ m { mDeps = T.words depString } diff --git a/src/Database/Schema/Migrations/Filesystem/Serialize.hs b/src/Database/Schema/Migrations/Filesystem/Serialize.hs --- a/src/Database/Schema/Migrations/Filesystem/Serialize.hs +++ b/src/Database/Schema/Migrations/Filesystem/Serialize.hs @@ -1,17 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} module Database.Schema.Migrations.Filesystem.Serialize ( serializeMigration ) where +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import Data.Text ( Text ) +import qualified Data.Text as T +import Data.String.Conversions ( cs ) import Data.Time () -- for UTCTime Show instance import Data.Maybe ( catMaybes ) -import Data.List ( intercalate ) +import Data.Monoid ( (<>) ) import Database.Schema.Migrations.Migration ( Migration(..) ) -type FieldSerializer = Migration -> Maybe String +type FieldSerializer = Migration -> Maybe ByteString fieldSerializers :: [FieldSerializer] fieldSerializers = [ serializeDesc @@ -25,48 +31,48 @@ serializeDesc m = case mDesc m of Nothing -> Nothing - Just desc -> Just $ "Description: " ++ desc + Just desc -> Just . cs $ "Description: " <> desc serializeTimestamp :: FieldSerializer serializeTimestamp m = case mTimestamp m of Nothing -> Nothing - Just ts -> Just $ "Created: " ++ (show ts) + Just ts -> Just $ "Created: " <> (cs . show $ ts) serializeDepends :: FieldSerializer -serializeDepends m = Just $ "Depends: " ++ (intercalate " " $ mDeps m) +serializeDepends m = Just . cs $ "Depends: " <> (T.intercalate " " $ mDeps m) serializeRevert :: FieldSerializer serializeRevert m = case mRevert m of Nothing -> Nothing - Just revert -> Just $ "Revert: |\n" ++ + Just revert -> Just $ "Revert: |\n" <> (serializeMultiline revert) serializeApply :: FieldSerializer -serializeApply m = Just $ "Apply: |\n" ++ (serializeMultiline $ mApply m) +serializeApply m = Just $ "Apply: |\n" <> (serializeMultiline $ mApply m) -commonPrefix :: String -> String -> String -commonPrefix a b = map fst $ takeWhile (uncurry (==)) (zip a b) +commonPrefix :: Text -> Text -> Text +commonPrefix a b = cs . map fst $ takeWhile (uncurry (==)) (T.zip a b) -commonPrefixLines :: [String] -> String +commonPrefixLines :: [Text] -> Text commonPrefixLines [] = "" commonPrefixLines theLines = foldl1 commonPrefix theLines -serializeMultiline :: String -> String +serializeMultiline :: Text -> ByteString serializeMultiline s = - let sLines = lines s - prefix = case commonPrefixLines sLines of + let sLines = T.lines s + prefix = case T.head $ commonPrefixLines sLines of -- If the lines already have a common prefix that -- begins with whitespace, no new prefix is -- necessary. - (' ':_) -> "" + ' ' -> "" -- Otherwise, use a new prefix of two spaces. _ -> " " - in unlines $ map (prefix ++) sLines + in cs . T.unlines $ map (prefix <>) sLines -serializeMigration :: Migration -> String -serializeMigration m = intercalate "\n" fields +serializeMigration :: Migration -> ByteString +serializeMigration m = BS.intercalate "\n" fields where fields = catMaybes [ f m | f <- fieldSerializers ] diff --git a/src/Database/Schema/Migrations/Migration.hs b/src/Database/Schema/Migrations/Migration.hs --- a/src/Database/Schema/Migrations/Migration.hs +++ b/src/Database/Schema/Migrations/Migration.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Database.Schema.Migrations.Migration ( Migration(..) , newMigration @@ -7,15 +8,16 @@ import Database.Schema.Migrations.Dependencies +import Data.Text ( Text ) import Data.Time () -- for UTCTime Show instance import qualified Data.Time.Clock as Clock data Migration = Migration { mTimestamp :: Maybe Clock.UTCTime - , mId :: String - , mDesc :: Maybe String - , mApply :: String - , mRevert :: Maybe String - , mDeps :: [String] + , mId :: Text + , mDesc :: Maybe Text + , mApply :: Text + , mRevert :: Maybe Text + , mDeps :: [Text] } deriving (Eq, Show, Ord) @@ -23,7 +25,7 @@ depsOf = mDeps depId = mId -emptyMigration :: String -> Migration +emptyMigration :: Text -> Migration emptyMigration name = Migration { mTimestamp = Nothing , mId = name @@ -33,7 +35,7 @@ , mDeps = [] } -newMigration :: String -> Migration +newMigration :: Text -> Migration newMigration theId = (emptyMigration theId) { mApply = "(Apply SQL here.)" diff --git a/src/Database/Schema/Migrations/Store.hs b/src/Database/Schema/Migrations/Store.hs --- a/src/Database/Schema/Migrations/Store.hs +++ b/src/Database/Schema/Migrations/Store.hs @@ -23,6 +23,7 @@ ) where +import Data.Text ( Text ) import Data.Maybe ( isJust ) import Control.Monad ( mzero ) import Control.Applicative ( (<$>) ) @@ -41,7 +42,7 @@ -- |A mapping from migration name to 'Migration'. This is exported -- for testing purposes, but you'll want to interface with this -- through the encapsulating 'StoreData' type. -type MigrationMap = Map.Map String Migration +type MigrationMap = Map.Map Text Migration data StoreData = StoreData { storeDataMapping :: MigrationMap , storeDataGraph :: DependencyGraph Migration @@ -51,17 +52,17 @@ -- 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) + MigrationStore { loadMigration :: Text -> IO (Either String Migration) -- ^ Load a migration from the store. , saveMigration :: Migration -> IO () -- ^ Save a migration to the store. - , getMigrations :: IO [String] + , getMigrations :: IO [Text] -- ^ Return a list of all available migrations' -- names. - , fullMigrationName :: String -> IO String + , fullMigrationName :: Text -> IO FilePath -- ^ Return the full representation of a given -- migration name; mostly for filesystem stores, -- where the full representation includes the store @@ -69,7 +70,7 @@ } -- |A type for types of validation errors for migration maps. -data MapValidationError = DependencyReferenceError String String +data MapValidationError = DependencyReferenceError Text Text -- ^ A migration claims a dependency on a -- migration that does not exist. | DependencyGraphError String @@ -96,7 +97,7 @@ -- |A convenience function for looking up a 'Migration' by name in the -- specified 'StoreData'. -storeLookup :: StoreData -> String -> Maybe Migration +storeLookup :: StoreData -> Text -> Maybe Migration storeLookup storeData migrationName = Map.lookup migrationName $ storeDataMapping storeData @@ -153,6 +154,6 @@ -- |Finds migrations that no other migration depends on (effectively finds all -- vertices with in-degree equal to zero). -leafMigrations :: StoreData -> [String] +leafMigrations :: StoreData -> [Text] leafMigrations s = [l | (n, l) <- labNodes g, indeg g n == 0] where g = depGraph $ storeDataGraph s diff --git a/src/Database/Schema/Migrations/Test/BackendTest.hs b/src/Database/Schema/Migrations/Test/BackendTest.hs --- a/src/Database/Schema/Migrations/Test/BackendTest.hs +++ b/src/Database/Schema/Migrations/Test/BackendTest.hs @@ -9,6 +9,8 @@ , tests ) where +import Data.ByteString ( ByteString ) + import Control.Monad ( forM_ ) import Test.HUnit @@ -30,7 +32,7 @@ withTransaction :: c -> (c -> IO a) -> IO a -- | Retrieves a list of all tables in the current database/scheme. - getTables :: c -> IO [String] + getTables :: c -> IO [ByteString] catchAll :: c -> (IO a -> IO a -> IO a) @@ -102,7 +104,7 @@ m2 = (newMigration "third") { mApply = "INVALID SQL" } -- Apply the migrations, ignore exceptions - ignoreSqlExceptions conn $ withTransaction conn $ \conn' -> do + _ <- ignoreSqlExceptions conn $ withTransaction conn $ \conn' -> do let backend' = makeBackend conn' applyMigration backend' m1 applyMigration backend' m2 @@ -129,7 +131,7 @@ -- Revert the migrations, ignore exceptions; the revert will fail, -- but withTransaction will roll back. - ignoreSqlExceptions conn $ withTransaction conn $ \conn' -> do + _ <- ignoreSqlExceptions conn $ withTransaction conn $ \conn' -> do let backend' = makeBackend conn' revertMigration backend' m2 revertMigration backend' m1 diff --git a/src/Moo/CommandHandlers.hs b/src/Moo/CommandHandlers.hs --- a/src/Moo/CommandHandlers.hs +++ b/src/Moo/CommandHandlers.hs @@ -3,6 +3,8 @@ {-# LANGUAGE OverloadedStrings #-} module Moo.CommandHandlers where +import Data.String.Conversions (cs, (<>)) + import Moo.Core import Moo.CommandUtils import Control.Monad ( when, forM_ ) @@ -23,10 +25,10 @@ store <- asks _appStore linear <- asks _appLinearMigrations timestamp <- asks _appTimestampFilenames - timeString <- (++"_") <$> liftIO getCurrentTimestamp + timeString <- (<>"_") <$> liftIO getCurrentTimestamp let [migrationId] = if timestamp - then fmap (timeString++) required + then fmap (timeString<>) required else required noAsk <- _noAsk <$> asks _appOptions @@ -34,15 +36,15 @@ fullPath <- fullMigrationName store migrationId when (isJust $ storeLookup storeData migrationId) $ do - putStrLn $ "Migration " ++ (show fullPath) ++ " already exists" + putStrLn $ "Migration " <> (show fullPath) ++ " already exists" exitWith (ExitFailure 1) -- Default behavior: ask for dependencies if linear mode is disabled deps <- if linear then (return $ leafMigrations storeData) else if noAsk then (return []) else do - putStrLn $ "Selecting dependencies for new \ - \migration: " ++ migrationId + putStrLn . cs $ "Selecting dependencies for new \ + \migration: " <> migrationId interactiveAskDeps storeData result <- if noAsk then (return True) else @@ -90,7 +92,7 @@ putStrLn "Database is up to date." exitSuccess putStrLn "Migrations to install:" - forM_ migrationNames (putStrLn . (" " ++)) + forM_ migrationNames (putStrLn . cs . (" " <>)) reinstallCommand :: CommandHandler reinstallCommand storeData = do @@ -102,8 +104,8 @@ ensureBootstrappedBackend backend >> commitBackend backend m <- lookupMigration storeData migrationId - revert m storeData backend - apply m storeData backend True + _ <- revert m storeData backend + _ <- apply m storeData backend True case isTesting of False -> do @@ -119,7 +121,7 @@ ensureBootstrappedBackend backend >> commitBackend backend ms <- getMigrations backend forM_ ms $ \m -> - when (not $ m == rootMigrationName) $ putStrLn m + when (not $ m == rootMigrationName) $ putStrLn . cs $ m applyCommand :: CommandHandler applyCommand storeData = do @@ -130,7 +132,7 @@ withBackend $ \backend -> do ensureBootstrappedBackend backend >> commitBackend backend m <- lookupMigration storeData migrationId - apply m storeData backend True + _ <- apply m storeData backend True case isTesting of False -> do commitBackend backend @@ -148,7 +150,7 @@ withBackend $ \backend -> do ensureBootstrappedBackend backend >> commitBackend backend m <- lookupMigration storeData migrationId - revert m storeData backend + _ <- revert m storeData backend case isTesting of False -> do @@ -170,7 +172,7 @@ -- If the migration is already installed, remove it as part of -- the test when (not $ migrationId `elem` migrationNames) $ - do revert m storeData backend + do _ <- revert m storeData backend return () applied <- apply m storeData backend True forM_ (reverse applied) $ \migration -> do diff --git a/src/Moo/CommandUtils.hs b/src/Moo/CommandUtils.hs --- a/src/Moo/CommandUtils.hs +++ b/src/Moo/CommandUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} module Moo.CommandUtils ( apply , confirmCreation @@ -9,7 +9,10 @@ , getCurrentTimestamp ) where -import Control.Applicative +import Data.Text ( Text ) +import qualified Data.Text as T +import Data.String.Conversions ( cs, (<>) ) + import Control.Exception ( finally ) import Control.Monad ( when, forM_, unless ) import Control.Monad.Reader ( asks ) @@ -30,9 +33,9 @@ ) import Moo.Core -getCurrentTimestamp :: IO String +getCurrentTimestamp :: IO Text getCurrentTimestamp = - replace ":" "-" . replace " " "_" . take 19 . show <$> getCurrentTime + cs . replace ":" "-" . replace " " "_" . take 19 . show <$> getCurrentTime apply :: Migration -> StoreData -> Backend -> Bool -> IO [Migration] apply m storeData backend complain = do @@ -47,12 +50,12 @@ where nothingToDo = when complain $ - putStrLn $ "Nothing to do; " ++ - mId m ++ + putStrLn . cs $ "Nothing to do; " <> + mId m <> " already installed." applyIt conn it = do - putStr $ "Applying: " ++ mId it ++ "... " + putStr . cs $ "Applying: " <> mId it <> "... " applyMigration conn it putStrLn "done." @@ -68,22 +71,22 @@ where nothingToDo = - putStrLn $ "Nothing to do; " ++ - mId m ++ + putStrLn . cs $ "Nothing to do; " <> + mId m <> " not installed." revertIt conn it = do - putStr $ "Reverting: " ++ mId it ++ "... " + putStr . cs $ "Reverting: " <> mId it <> "... " revertMigration conn it putStrLn "done." -lookupMigration :: StoreData -> String -> IO Migration +lookupMigration :: StoreData -> Text -> IO Migration lookupMigration storeData name = do let theMigration = storeLookup storeData name case theMigration of Nothing -> do - putStrLn $ "No such migration: " ++ name + putStrLn . cs $ "No such migration: " <> name exitWith (ExitFailure 1) Just m' -> return m' @@ -97,13 +100,13 @@ -- Given a migration name and selected dependencies, get the user's -- confirmation that a migration should be created. -confirmCreation :: String -> [String] -> IO Bool +confirmCreation :: Text -> [Text] -> IO Bool confirmCreation migrationId deps = do putStrLn "" - putStrLn $ "Confirm: create migration '" ++ migrationId ++ "'" + putStrLn . cs $ "Confirm: create migration '" <> migrationId <> "'" if null deps then putStrLn " (No dependencies)" else putStrLn "with dependencies:" - forM_ deps $ \d -> putStrLn $ " " ++ d + forM_ deps $ \d -> putStrLn . cs $ " " <> d prompt "Are you sure?" [ ('y', (True, Nothing)) , ('n', (False, Nothing)) ] @@ -162,7 +165,7 @@ -- Interactively ask the user about which dependencies should be used -- when creating a new migration. -interactiveAskDeps :: StoreData -> IO [String] +interactiveAskDeps :: StoreData -> IO [Text] interactiveAskDeps storeData = do -- For each migration in the store, starting with the most recently -- added, ask the user if it should be added to a dependency list @@ -174,10 +177,10 @@ -- 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. -interactiveAskDeps' :: StoreData -> [String] -> IO [String] +interactiveAskDeps' :: StoreData -> [Text] -> IO [Text] interactiveAskDeps' _ [] = return [] interactiveAskDeps' storeData (name:rest) = do - result <- prompt ("Depend on '" ++ name ++ "'?") askDepsChoices + result <- prompt ("Depend on '" ++ cs name ++ "'?") askDepsChoices if result == Done then return [] else case result of Yes -> do @@ -189,12 +192,12 @@ let Just m = storeLookup storeData name -- print out description, timestamp, deps when (isJust $ mDesc m) - (putStrLn $ " Description: " ++ + (putStrLn . cs $ " Description: " <> fromJust (mDesc m)) putStrLn $ " Created: " ++ show (mTimestamp m) unless (null $ mDeps m) - (putStrLn $ " Deps: " ++ - intercalate "\n " (mDeps m)) + (putStrLn . cs $ " Deps: " <> + T.intercalate "\n " (mDeps m)) -- ask again interactiveAskDeps' storeData (name:rest) Quit -> do diff --git a/src/Moo/Core.hs b/src/Moo/Core.hs --- a/src/Moo/Core.hs +++ b/src/Moo/Core.hs @@ -13,7 +13,8 @@ , envStoreName , loadConfiguration) where -import Control.Applicative +import Data.Text ( Text ) + import Control.Monad.Reader (ReaderT) import qualified Data.Configurator as C import Data.Configurator.Types (Config, Configured) @@ -34,8 +35,8 @@ -- |Application state which can be accessed by any command handler. data AppState = AppState { _appOptions :: CommandOptions , _appCommand :: Command - , _appRequiredArgs :: [String] - , _appOptionalArgs :: [String] + , _appRequiredArgs :: [Text] + , _appOptionalArgs :: [Text] , _appBackend :: Backend , _appStore :: MigrationStore , _appStoreData :: StoreData diff --git a/src/Moo/Main.hs b/src/Moo/Main.hs --- a/src/Moo/Main.hs +++ b/src/Moo/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Moo.Main ( mainWithParameters , ExecutableParameters (..) @@ -12,6 +13,8 @@ import Control.Monad.Reader (forM_, runReaderT, when) import Database.HDBC (SqlError, catchSql, seErrorMsg) import Prelude hiding (lookup) +import Data.Text (Text) +import Data.String.Conversions (cs) import System.Environment (getProgName) import System.Exit (ExitCode (ExitFailure), exitWith) @@ -77,8 +80,8 @@ Right storeData -> do let st = AppState { _appOptions = opts , _appCommand = command - , _appRequiredArgs = required - , _appOptionalArgs = ["" :: String] + , _appRequiredArgs = map cs required + , _appOptionalArgs = ["" :: Text] , _appBackend = _parametersBackend parameters , _appStore = store , _appStoreData = storeData diff --git a/test/Common.hs b/test/Common.hs --- a/test/Common.hs +++ b/test/Common.hs @@ -8,6 +8,8 @@ ) where +import Data.Text ( Text ) + import CommonTH import System.FilePath ( () ) import Language.Haskell.TH.Syntax (lift) @@ -25,8 +27,8 @@ depId = tdId depsOf = tdDeps -data TestDependable = TD { tdId :: String - , tdDeps :: [String] +data TestDependable = TD { tdId :: Text + , tdDeps :: [Text] } deriving (Show, Eq, Ord) diff --git a/test/DependencyTest.hs b/test/DependencyTest.hs --- a/test/DependencyTest.hs +++ b/test/DependencyTest.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} module DependencyTest ( tests ) where +import Data.Text ( Text ) + import Test.HUnit import Data.Graph.Inductive.Graph ( Graph(..) ) @@ -39,7 +42,7 @@ mkDepGraphTest (input, expected) = expected ~=? mkDepGraph input data Direction = Forward | Reverse deriving (Show) -type DependencyTestCase = ([TestDependable], String, Direction, [String]) +type DependencyTestCase = ([TestDependable], Text, Direction, [Text]) dependencyTestCases :: [DependencyTestCase] dependencyTestCases = [ ([TD "first" []], "first", Forward, []) diff --git a/test/FilesystemParseTest.hs b/test/FilesystemParseTest.hs --- a/test/FilesystemParseTest.hs +++ b/test/FilesystemParseTest.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module FilesystemParseTest ( tests ) @@ -6,6 +7,7 @@ import Test.HUnit import Data.Time.Clock ( UTCTime ) import System.FilePath ( () ) +import Data.String.Conversions ( cs ) import Common @@ -84,34 +86,33 @@ , Right (valid_full { mId = "valid_no_timestamp", mTimestamp = Nothing })) , ("invalid_missing_required_fields" , Left $ "Could not parse migration " ++ - (fp "invalid_missing_required_fields.txt") ++ + (fp "invalid_missing_required_fields") ++ ":Error in " ++ - (show $ fp "invalid_missing_required_fields.txt") ++ + (show $ fp "invalid_missing_required_fields") ++ ": missing required field(s): " ++ "[\"Depends\"]") , ("invalid_field_name" , Left $ "Could not parse migration " ++ - (fp "invalid_field_name.txt") ++ + (fp "invalid_field_name") ++ ":Error in " ++ - (show $ fp "invalid_field_name.txt") ++ + (show $ fp "invalid_field_name") ++ ": unrecognized field found") , ("invalid_syntax" , Left $ "Could not parse migration " ++ - (fp "invalid_syntax.txt") ++ - ":user error (syntax error: line 7, " ++ - "column 0)") + (fp "invalid_syntax") ++ + ":InvalidYaml (Just (YamlParseException {yamlProblem = \"could not find expected ':'\", yamlContext = \"while scanning a simple key\", yamlProblemMark = YamlMark {yamlIndex = 130, yamlLine = 6, yamlColumn = 0}}))") , ("invalid_timestamp" , Left $ "Could not parse migration " ++ - (fp "invalid_timestamp.txt") ++ + (fp "invalid_timestamp") ++ ":Error in " ++ - (show $ fp "invalid_timestamp.txt") ++ + (show $ fp "invalid_timestamp") ++ ": unrecognized field found") ] mkParsingTest :: MigrationParsingTestCase -> IO Test mkParsingTest (fname, expected) = do let store = FSStore { storePath = testStorePath } - actual <- migrationFromFile store fname + actual <- migrationFromFile store (cs fname) return $ test $ expected ~=? actual migrationParsingTests :: IO [Test] diff --git a/test/FilesystemSerializeTest.hs b/test/FilesystemSerializeTest.hs --- a/test/FilesystemSerializeTest.hs +++ b/test/FilesystemSerializeTest.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} module FilesystemSerializeTest ( tests ) where import Test.HUnit +import Data.ByteString ( ByteString ) +import Data.String.Conversions ( (<>), cs ) import Data.Time.Clock ( UTCTime ) import Database.Schema.Migrations.Filesystem.Serialize @@ -12,7 +15,7 @@ tests :: [Test] tests = serializationTests -mkSerializationTest :: (Migration, String) -> Test +mkSerializationTest :: (Migration, ByteString) -> Test mkSerializationTest (m, expectedString) = test $ expectedString ~=? serializeMigration m tsStr :: String @@ -31,9 +34,9 @@ , mRevert = Just "DROP TABLE test;" } -serializationTestCases :: [(Migration, String)] -serializationTestCases = [ (valid_full, "Description: A valid full migration.\n\ - \Created: " ++ tsStr ++ "\n\ +serializationTestCases :: [(Migration, ByteString)] +serializationTestCases = [ (valid_full, cs $ "Description: A valid full migration.\n\ + \Created: " <> tsStr <> "\n\ \Depends: another_migration\n\ \Apply: |\n\ \ CREATE TABLE test (\n\ @@ -42,7 +45,7 @@ \Revert: |\n\ \ DROP TABLE test;\n") , (valid_full { mDesc = Nothing } - , "Created: " ++ tsStr ++ "\n\ + , cs $ "Created: " <> tsStr <> "\n\ \Depends: another_migration\n\ \Apply: |\n\ \ CREATE TABLE test (\n\ @@ -51,8 +54,8 @@ \Revert: |\n\ \ DROP TABLE test;\n") , (valid_full { mDeps = ["one", "two"] } - , "Description: A valid full migration.\n\ - \Created: " ++ tsStr ++ "\n\ + , cs $ "Description: A valid full migration.\n\ + \Created: " <> tsStr <> "\n\ \Depends: one two\n\ \Apply: |\n\ \ CREATE TABLE test (\n\ @@ -61,8 +64,8 @@ \Revert: |\n\ \ DROP TABLE test;\n") , (valid_full { mRevert = Nothing } - , "Description: A valid full migration.\n\ - \Created: " ++ tsStr ++ "\n\ + , cs $ "Description: A valid full migration.\n\ + \Created: " <> tsStr <> "\n\ \Depends: another_migration\n\ \Apply: |\n\ \ CREATE TABLE test (\n\ diff --git a/test/FilesystemTest.hs b/test/FilesystemTest.hs --- a/test/FilesystemTest.hs +++ b/test/FilesystemTest.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module FilesystemTest ( tests ) diff --git a/test/InMemoryStore.hs b/test/InMemoryStore.hs --- a/test/InMemoryStore.hs +++ b/test/InMemoryStore.hs @@ -1,10 +1,13 @@ module InMemoryStore (inMemoryStore) where +import Data.Text ( Text ) +import Data.String.Conversions ( cs ) + import Control.Concurrent.MVar import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Store -type InMemoryData = [(String, Migration)] +type InMemoryData = [(Text, Migration)] -- |Builds simple in-memory store that uses 'MVar' to preserve a list of -- migrations. @@ -15,10 +18,10 @@ loadMigration = loadMigrationInMem store , saveMigration = saveMigrationInMem store , getMigrations = getMigrationsInMem store - , fullMigrationName = return + , fullMigrationName = return . cs } -loadMigrationInMem :: MVar InMemoryData -> String -> IO (Either String Migration) +loadMigrationInMem :: MVar InMemoryData -> Text -> IO (Either String Migration) loadMigrationInMem store migId = withMVar store $ \migrations -> do let mig = lookup migId migrations return $ case mig of @@ -28,5 +31,5 @@ saveMigrationInMem :: MVar InMemoryData -> Migration -> IO () saveMigrationInMem store m = modifyMVar_ store $ return . ((mId m, m):) -getMigrationsInMem :: MVar InMemoryData -> IO [String] +getMigrationsInMem :: MVar InMemoryData -> IO [Text] getMigrationsInMem store = withMVar store $ return . fmap fst diff --git a/test/LinearMigrationsTest.hs b/test/LinearMigrationsTest.hs --- a/test/LinearMigrationsTest.hs +++ b/test/LinearMigrationsTest.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module LinearMigrationsTest (tests) where import InMemoryStore @@ -5,6 +6,7 @@ import Common import Control.Monad.Reader (runReaderT) +import Data.Text (Text) import Data.Either (isRight) import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Store @@ -60,13 +62,13 @@ runReaderT (newCommand $ _appStoreData state) state loadMigration store migrationId -addTestMigrationWithDeps :: AppState -> [String] -> IO () +addTestMigrationWithDeps :: AppState -> [Text] -> IO () addTestMigrationWithDeps state deps = do let store = _appStore state let [migrationId] = _appRequiredArgs state saveMigration store (newMigration migrationId) { mDeps = deps } -prepareState :: String -> IO AppState +prepareState :: Text -> IO AppState prepareState m = do store <- inMemoryStore Right storeData <- loadMigrations store @@ -82,12 +84,12 @@ , _appTimestampFilenames = False } -prepareStateWith :: AppState -> String -> IO AppState +prepareStateWith :: AppState -> Text -> IO AppState prepareStateWith state m = do Right storeData <- loadMigrations $ _appStore state return state { _appRequiredArgs = [m], _appStoreData = storeData } -prepareNormalState :: String -> IO AppState +prepareNormalState :: Text -> IO AppState prepareNormalState m = do state <- prepareState m return $ state { _appLinearMigrations = False } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,51 @@ +module Main where +import Prelude +import Test.HUnit +import System.Exit +import System.IO ( stderr ) + +import qualified DependencyTest +import qualified MigrationsTest +import qualified FilesystemSerializeTest +import qualified FilesystemParseTest +import qualified FilesystemTest +import qualified CycleDetectionTest +import qualified StoreTest +import qualified LinearMigrationsTest +import qualified ConfigurationTest + +import Control.Exception ( SomeException(..) ) + +loadTests :: IO [Test] +loadTests = do + + ioTests <- sequence [ do fspTests <- FilesystemParseTest.tests + return $ "Filesystem Parsing" ~: test fspTests + , do fsTests <- FilesystemTest.tests + return $ "Filesystem general" ~: test fsTests + , do linTests <- LinearMigrationsTest.tests + return $ "Linear migrations" ~: test linTests + , do cfgTests <- ConfigurationTest.tests + return $ "Configuration tests" ~: test cfgTests + ] + return $ concat [ ioTests + , DependencyTest.tests + , FilesystemSerializeTest.tests + , MigrationsTest.tests + , CycleDetectionTest.tests + , StoreTest.tests + ] + +tempDatabase :: String +tempDatabase = "dbmigrations_test" + +ignoreException :: SomeException -> IO () +ignoreException _ = return () + +main :: IO () +main = do + tests <- loadTests + (testResults, _) <- runTestText (putTextToHandle stderr False) $ test tests + if errors testResults + failures testResults > 0 + then exitFailure + else exitSuccess diff --git a/test/MigrationsTest.hs b/test/MigrationsTest.hs --- a/test/MigrationsTest.hs +++ b/test/MigrationsTest.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances,GeneralizedNewtypeDeriving,MultiParamTypeClasses,FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances,GeneralizedNewtypeDeriving,MultiParamTypeClasses,FlexibleInstances,OverloadedStrings #-} module MigrationsTest ( tests ) diff --git a/test/StoreTest.hs b/test/StoreTest.hs --- a/test/StoreTest.hs +++ b/test/StoreTest.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module StoreTest ( tests ) diff --git a/test/TestDriver.hs b/test/TestDriver.hs deleted file mode 100644 --- a/test/TestDriver.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Main where -import Prelude -import Test.HUnit -import System.Exit -import System.IO ( stderr ) - -import qualified DependencyTest -import qualified MigrationsTest -import qualified FilesystemSerializeTest -import qualified FilesystemParseTest -import qualified FilesystemTest -import qualified CycleDetectionTest -import qualified StoreTest -import qualified LinearMigrationsTest -import qualified ConfigurationTest - -import Control.Exception ( SomeException(..) ) - -loadTests :: IO [Test] -loadTests = do - - ioTests <- sequence [ do fspTests <- FilesystemParseTest.tests - return $ "Filesystem Parsing" ~: test fspTests - , do fsTests <- FilesystemTest.tests - return $ "Filesystem general" ~: test fsTests - , do linTests <- LinearMigrationsTest.tests - return $ "Linear migrations" ~: test linTests - , do cfgTests <- ConfigurationTest.tests - return $ "Configuration tests" ~: test cfgTests - ] - return $ concat [ ioTests - , DependencyTest.tests - , FilesystemSerializeTest.tests - , MigrationsTest.tests - , CycleDetectionTest.tests - , StoreTest.tests - ] - -tempDatabase :: String -tempDatabase = "dbmigrations_test" - -ignoreException :: SomeException -> IO () -ignoreException _ = return () - -main :: IO () -main = do - tests <- loadTests - (testResults, _) <- runTestText (putTextToHandle stderr False) $ test tests - if errors testResults + failures testResults > 0 - then exitFailure - else exitSuccess