From b0ce76b55e43d7ce7ec80f8bcb8ee515f82c15f4 Mon Sep 17 00:00:00 2001 From: Kris Nuttycombe Date: Sat, 14 Feb 2026 15:53:09 -0700 Subject: [PATCH 01/10] Reformat with fourmolu prior to other modernizations. --- fourmolu.yaml | 15 + programs/Moo.hs | 5 +- src/Database/Schema/Migrations.hs | 107 ++++--- src/Database/Schema/Migrations/Backend.hs | 126 ++++---- .../Schema/Migrations/Backend/HDBC.hs | 120 ++++---- .../Schema/Migrations/CycleDetection.hs | 55 ++-- .../Schema/Migrations/Dependencies.hs | 196 +++++++------ src/Database/Schema/Migrations/Filesystem.hs | 183 ++++++------ .../Schema/Migrations/Filesystem/Serialize.hs | 83 +++--- src/Database/Schema/Migrations/Migration.hs | 55 ++-- src/Database/Schema/Migrations/Store.hs | 229 ++++++++------- .../Schema/Migrations/Test/BackendTest.hs | 205 +++++++------ src/Moo/CommandHandlers.hs | 247 ++++++++-------- src/Moo/CommandInterface.hs | 219 +++++++------- src/Moo/CommandUtils.hs | 277 ++++++++++-------- src/Moo/Core.hs | 263 +++++++++-------- src/Moo/Main.hs | 113 +++---- src/StoreManager.hs | 252 ++++++++-------- test/Common.hs | 35 +-- test/CommonTH.hs | 23 +- test/ConfigurationTest.hs | 134 +++++---- test/CycleDetectionTest.hs | 79 +++-- test/DependencyTest.hs | 156 +++++++--- test/FilesystemParseTest.hs | 193 +++++++----- test/FilesystemSerializeTest.hs | 124 ++++---- test/FilesystemTest.hs | 44 +-- test/InMemoryStore.hs | 39 +-- test/LinearMigrationsTest.hs | 129 ++++---- test/Main.hs | 60 ++-- test/MigrationsTest.hs | 97 +++--- test/StoreTest.hs | 185 +++++++----- 31 files changed, 2260 insertions(+), 1788 deletions(-) create mode 100644 fourmolu.yaml diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..ef571e8 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,15 @@ +indentation: 2 +column-limit: 80 # ignored until v12 / ghc-9.6 +function-arrows: leading +comma-style: leading # default +import-export-style: leading +indent-wheres: false # default +record-brace-space: true +newlines-between-decls: 1 # default +haddock-style: single-line +let-style: mixed +in-style: left-align +single-constraint-parens: never # ignored until v12 / ghc-9.6 +unicode: never # default +respectful: true # default +fixities: [] # default diff --git a/programs/Moo.hs b/programs/Moo.hs index 3e4d7b9..77fec11 100644 --- a/programs/Moo.hs +++ b/programs/Moo.hs @@ -1,6 +1,6 @@ module Main - ( main - ) + ( main + ) where import Prelude @@ -14,4 +14,3 @@ main = do \dbmigrations-mysql, or dbmigrations-sqlite. These packages contain \ \database-specific executables that replace the former moo executable from the \ \dbmigrations package." - diff --git a/src/Database/Schema/Migrations.hs b/src/Database/Schema/Migrations.hs index 252a2c6..40e98c2 100644 --- a/src/Database/Schema/Migrations.hs +++ b/src/Database/Schema/Migrations.hs @@ -1,44 +1,49 @@ --- |This module provides a high-level interface for the rest of this --- library. +-- | This module provides a high-level interface for the rest of this +-- library. module Database.Schema.Migrations - ( createNewMigration - , ensureBootstrappedBackend - , migrationsToApply - , migrationsToRevert - , missingMigrations - ) + ( createNewMigration + , ensureBootstrappedBackend + , migrationsToApply + , migrationsToRevert + , missingMigrations + ) where -import Data.Text ( Text ) +import Data.Maybe (catMaybes) import qualified Data.Set as Set -import Data.Maybe ( catMaybes ) +import Data.Text (Text) -import Database.Schema.Migrations.Dependencies - ( dependencies - , reverseDependencies - ) import qualified Database.Schema.Migrations.Backend as B -import qualified Database.Schema.Migrations.Store as S +import Database.Schema.Migrations.Dependencies + ( dependencies + , reverseDependencies + ) import Database.Schema.Migrations.Migration - ( Migration(..) - ) + ( Migration (..) + ) +import qualified Database.Schema.Migrations.Store as S --- |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'. +-- | 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 [Text] missingMigrations backend storeData = do let storeMigrationNames = map mId $ S.storeMigrations storeData backendMigrations <- B.getMigrations backend - return $ Set.toList $ Set.difference - (Set.fromList storeMigrationNames) - (Set.fromList backendMigrations) + return $ + Set.toList $ + Set.difference + (Set.fromList storeMigrationNames) + (Set.fromList backendMigrations) --- |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) +-- | 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 mId newM `elem` available of @@ -49,10 +54,10 @@ createNewMigration store newM = do 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. +-- | 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 -> IO () ensureBootstrappedBackend backend = do bsStatus <- B.isBootstrapped backend @@ -60,34 +65,42 @@ ensureBootstrappedBackend backend = do True -> return () False -> B.getBootstrapMigration backend >>= B.applyMigration backend --- |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 :: S.StoreData -> B.Backend - -> Migration -> IO [Migration] +-- | 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 + :: S.StoreData + -> B.Backend + -> Migration + -> IO [Migration] migrationsToApply storeData backend migration = do let graph = S.storeDataGraph storeData allMissing <- missingMigrations backend storeData - let deps = (dependencies graph $ mId migration) ++ [mId migration] - namesToInstall = [ e | e <- deps, e `elem` allMissing ] - loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToInstall + let + deps = (dependencies graph $ mId migration) ++ [mId migration] + namesToInstall = [e | e <- deps, e `elem` allMissing] + loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToInstall return loadedMigrations --- |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 :: S.StoreData -> B.Backend - -> Migration -> IO [Migration] +-- | 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 + :: S.StoreData + -> B.Backend + -> Migration + -> IO [Migration] migrationsToRevert storeData backend migration = do let graph = S.storeDataGraph storeData allInstalled <- B.getMigrations backend - let rDeps = (reverseDependencies graph $ mId migration) ++ [mId migration] - namesToRevert = [ e | e <- rDeps, e `elem` allInstalled ] - loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToRevert + let + rDeps = (reverseDependencies graph $ mId migration) ++ [mId migration] + namesToRevert = [e | e <- rDeps, e `elem` allInstalled] + loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToRevert return loadedMigrations diff --git a/src/Database/Schema/Migrations/Backend.hs b/src/Database/Schema/Migrations/Backend.hs index ffee25e..eb2af5e 100644 --- a/src/Database/Schema/Migrations/Backend.hs +++ b/src/Database/Schema/Migrations/Backend.hs @@ -1,77 +1,73 @@ {-# LANGUAGE OverloadedStrings #-} + module Database.Schema.Migrations.Backend - ( Backend(..) - , rootMigrationName - ) + ( Backend (..) + , rootMigrationName + ) where -import Data.Text ( Text ) +import Data.Text (Text) import Database.Schema.Migrations.Migration - ( 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. +-- | Backend instances should use this as the name of the migration +-- returned by getBootstrapMigration; this migration is special +-- because it cannot be reverted. rootMigrationName :: Text rootMigrationName = "root" --- |A Backend represents a database engine backend such as MySQL or --- SQLite. A Backend supplies relatively low-level functions for --- inspecting the backend's state, applying migrations, and reverting --- migrations. A Backend also supplies the migration necessary to --- "bootstrap" a backend so that it can track which migrations are --- installed. -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. - - , 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. - - , 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. - - , 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. - - , getMigrations :: IO [Text] - -- ^ 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. - } +-- | A Backend represents a database engine backend such as MySQL or +-- SQLite. A Backend supplies relatively low-level functions for +-- inspecting the backend's state, applying migrations, and reverting +-- migrations. A Backend also supplies the migration necessary to +-- "bootstrap" a backend so that it can track which migrations are +-- installed. +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. + , 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. + , 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. + , 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. + , getMigrations :: IO [Text] + -- ^ 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. + } instance Show Backend where - show _ = "dbmigrations backend" + show _ = "dbmigrations backend" diff --git a/src/Database/Schema/Migrations/Backend/HDBC.hs b/src/Database/Schema/Migrations/Backend/HDBC.hs index 55799bf..8e0c1cb 100644 --- a/src/Database/Schema/Migrations/Backend/HDBC.hs +++ b/src/Database/Schema/Migrations/Backend/HDBC.hs @@ -1,32 +1,33 @@ {-# LANGUAGE OverloadedStrings #-} + module Database.Schema.Migrations.Backend.HDBC - ( hdbcBackend - ) + ( hdbcBackend + ) where import Database.HDBC - ( quickQuery' - , fromSql - , toSql - , IConnection(getTables, run, runRaw) + ( IConnection (getTables, run, runRaw) , commit - , rollback , disconnect + , fromSql + , quickQuery' + , rollback + , toSql ) import Database.Schema.Migrations.Backend - ( Backend(..) - , rootMigrationName - ) + ( Backend (..) + , rootMigrationName + ) import Database.Schema.Migrations.Migration - ( Migration(..) - , newMigration - ) + ( Migration (..) + , newMigration + ) -import Data.Text ( Text ) -import Data.String.Conversions ( cs, (<>) ) +import Data.String.Conversions (cs, (<>)) +import Data.Text (Text) -import Control.Applicative ( (<$>) ) +import Control.Applicative ((<$>)) import Data.Time.Clock (getCurrentTime) migrationTableName :: Text @@ -38,42 +39,53 @@ createSql = "CREATE TABLE " <> migrationTableName <> " (migration_id TEXT)" revertSql :: Text revertSql = "DROP TABLE " <> migrationTableName --- |General Backend constructor for all HDBC connection implementations. -hdbcBackend :: (IConnection conn) => conn -> Backend +-- | General Backend constructor for all HDBC connection implementations. +hdbcBackend :: IConnection conn => conn -> Backend hdbcBackend conn = - Backend { isBootstrapped = elem (cs migrationTableName) <$> getTables conn - , getBootstrapMigration = - do - ts <- getCurrentTime - return $ (newMigration rootMigrationName) - { mApply = createSql - , mRevert = Just revertSql - , mDesc = Just "Migration table installation" - , mTimestamp = Just ts - } - - , applyMigration = \m -> do - 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 (cs query) - -- Remove migration from installed_migrations in either case. - _ <- run conn (cs $ "DELETE FROM " <> migrationTableName <> - " WHERE migration_id = ?") [toSql $ mId m] - return () - - , getMigrations = do - results <- quickQuery' conn (cs $ "SELECT migration_id FROM " <> migrationTableName) [] - return $ map (fromSql . head) results - - , commitBackend = commit conn - - , rollbackBackend = rollback conn - - , disconnectBackend = disconnect conn - } + Backend + { isBootstrapped = elem (cs migrationTableName) <$> getTables conn + , getBootstrapMigration = + do + ts <- getCurrentTime + return $ + (newMigration rootMigrationName) + { mApply = createSql + , mRevert = Just revertSql + , mDesc = Just "Migration table installation" + , mTimestamp = Just ts + } + , applyMigration = \m -> do + 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 (cs query) + -- Remove migration from installed_migrations in either case. + _ <- + run + conn + ( cs $ + "DELETE FROM " + <> migrationTableName + <> " WHERE migration_id = ?" + ) + [toSql $ mId m] + return () + , getMigrations = do + results <- + quickQuery' conn (cs $ "SELECT migration_id FROM " <> migrationTableName) [] + return $ map (fromSql . head) results + , commitBackend = commit conn + , rollbackBackend = rollback conn + , disconnectBackend = disconnect conn + } diff --git a/src/Database/Schema/Migrations/CycleDetection.hs b/src/Database/Schema/Migrations/CycleDetection.hs index 7dcb073..f93cd19 100644 --- a/src/Database/Schema/Migrations/CycleDetection.hs +++ b/src/Database/Schema/Migrations/CycleDetection.hs @@ -1,20 +1,20 @@ module Database.Schema.Migrations.CycleDetection - ( hasCycle - ) + ( hasCycle + ) where import Data.Graph.Inductive.Graph - ( Graph(..) - , Node - , nodes - , edges - ) + ( Graph (..) + , Node + , edges + , nodes + ) -import Control.Monad.State ( State, evalState, gets, get, put ) -import Control.Monad ( forM ) +import Control.Monad (forM) +import Control.Monad.State (State, evalState, get, gets, put) -import Data.Maybe ( fromJust ) -import Data.List ( findIndex ) +import Data.List (findIndex) +import Data.Maybe (fromJust) data Mark = White | Gray | Black type CycleDetectionState = [(Node, Mark)] @@ -28,10 +28,11 @@ getMark n = gets (fromJust . lookup n) replace :: [a] -> Int -> a -> [a] replace elems index val - | index > length elems = error "replacement index too large" - | otherwise = (take index elems) ++ - [val] ++ - (reverse $ take ((length elems) - (index + 1)) $ reverse elems) + | index > length elems = error "replacement index too large" + | otherwise = + (take index elems) + ++ [val] + ++ (reverse $ take ((length elems) - (index + 1)) $ reverse elems) setMark :: Int -> Mark -> State CycleDetectionState () setMark n mark = do @@ -42,23 +43,23 @@ setMark n mark = do hasCycle' :: Graph g => g a b -> State CycleDetectionState Bool hasCycle' g = do result <- forM (nodes g) $ \n -> do - m <- getMark n - case m of - White -> visit g n - _ -> return False + m <- getMark n + case m of + White -> visit g n + _ -> return False return $ or result visit :: Graph g => g a b -> Node -> State CycleDetectionState Bool visit g n = do setMark n Gray - result <- forM [ v | (u,v) <- edges g, u == n ] $ \node -> do - m <- getMark node - case m of - Gray -> return True - White -> visit g node - _ -> return False + result <- forM [v | (u, v) <- edges g, u == n] $ \node -> do + m <- getMark node + case m of + Gray -> return True + White -> visit g node + _ -> return False case or result of True -> return True False -> do - setMark n Black - return False + setMark n Black + return False diff --git a/src/Database/Schema/Migrations/Dependencies.hs b/src/Database/Schema/Migrations/Dependencies.hs index d596d58..1a76808 100644 --- a/src/Database/Schema/Migrations/Dependencies.hs +++ b/src/Database/Schema/Migrations/Dependencies.hs @@ -1,103 +1,131 @@ -{-# 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. +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | 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. module Database.Schema.Migrations.Dependencies - ( Dependable(..) - , DependencyGraph(..) - , mkDepGraph - , dependencies - , reverseDependencies - ) + ( Dependable (..) + , DependencyGraph (..) + , mkDepGraph + , dependencies + , reverseDependencies + ) 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 ) +import Data.Graph.Inductive.Graph + ( Graph (..) + , Node + , edges + , lab + , nodes + , pre + , suc + ) +import Data.Graph.Inductive.PatriciaTree (Gr) +import Data.Maybe (fromJust) +import Data.Monoid ((<>)) +import Data.Text (Text) -import Database.Schema.Migrations.CycleDetection ( hasCycle ) +import Database.Schema.Migrations.CycleDetection (hasCycle) --- |'Dependable' objects supply a representation of their identifiers, --- and a list of other objects upon which they depend. +-- | 'Dependable' objects supply a representation of their identifiers, +-- 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 -> [Text] - -- |The identifier of a 'Dependable' object. - depId :: a -> Text - --- |A 'DependencyGraph' represents a collection of objects together --- with a graph of their dependency relationships. This is intended --- to be used with instances of 'Dependable'. -data DependencyGraph a = DG { depGraphObjectMap :: [(a, Int)] - -- ^ A mapping of 'Dependable' objects to - -- their graph vertex indices. - , depGraphNameMap :: [(Text, Int)] - -- ^ A mapping of 'Dependable' object - -- identifiers to their graph vertex - -- indices. - , depGraph :: Gr Text Text - -- ^ A directed 'Gr' (graph) of the - -- 'Dependable' objects' dependency - -- relationships, with 'Text' vertex and - -- edge labels. - } - -instance (Eq a) => Eq (DependencyGraph a) where - g1 == g2 = ((nodes $ depGraph g1) == (nodes $ depGraph g2) && - (edges $ depGraph g1) == (edges $ depGraph g2)) - -instance (Show a) => Show (DependencyGraph a) where - show g = "(" ++ (show $ nodes $ depGraph g) ++ ", " ++ (show $ edges $ depGraph g) ++ ")" + -- | The identifiers of the objects on which @a@ depends. + depsOf :: a -> [Text] + + -- | The identifier of a 'Dependable' object. + depId :: a -> Text + +-- | A 'DependencyGraph' represents a collection of objects together +-- with a graph of their dependency relationships. This is intended +-- to be used with instances of 'Dependable'. +data DependencyGraph a = DG + { depGraphObjectMap :: [(a, Int)] + -- ^ A mapping of 'Dependable' objects to + -- their graph vertex indices. + , depGraphNameMap :: [(Text, Int)] + -- ^ A mapping of 'Dependable' object + -- identifiers to their graph vertex + -- indices. + , depGraph :: Gr Text Text + -- ^ A directed 'Gr' (graph) of the + -- 'Dependable' objects' dependency + -- relationships, with 'Text' vertex and + -- edge labels. + } + +instance Eq a => Eq (DependencyGraph a) where + g1 == g2 = + ( (nodes $ depGraph g1) == (nodes $ depGraph g2) + && (edges $ depGraph g1) == (edges $ depGraph g2) + ) + +instance Show a => Show (DependencyGraph a) where + show g = + "(" ++ (show $ nodes $ depGraph g) ++ ", " ++ (show $ edges $ depGraph g) ++ ")" -- XXX: provide details about detected cycles --- |Build a dependency graph from a list of 'Dependable's. Return the --- graph on success or return an error message if the graph cannot be --- constructed (e.g., if the graph contains a cycle). -mkDepGraph :: (Dependable a) => [a] -> Either String (DependencyGraph a) -mkDepGraph objects = if hasCycle theGraph - then Left "Invalid dependency graph; cycle detected" - else Right $ DG { depGraphObjectMap = ids - , depGraphNameMap = names - , depGraph = theGraph - } - where - theGraph = mkGraph n e - 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 ] - 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 + +-- | Build a dependency graph from a list of 'Dependable's. Return the +-- graph on success or return an error message if the graph cannot be +-- constructed (e.g., if the graph contains a cycle). +mkDepGraph :: Dependable a => [a] -> Either String (DependencyGraph a) +mkDepGraph objects = + if hasCycle theGraph + then Left "Invalid dependency graph; cycle detected" + else + Right $ + DG + { depGraphObjectMap = ids + , depGraphNameMap = names + , depGraph = theGraph + } + where + theGraph = mkGraph n e + 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 + ] + 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 Text Text -> Node -> [Node] -cleanLDups :: (Eq a) => [a] -> [a] +cleanLDups :: Eq a => [a] -> [a] cleanLDups [] = [] cleanLDups [e] = [e] -cleanLDups (e:es) = if e `elem` es then (cleanLDups es) else (e:cleanLDups es) +cleanLDups (e : es) = if e `elem` es then (cleanLDups es) else (e : cleanLDups es) --- |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 -> Text -> [Text] +-- | 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 -> 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 -> Text -> [Text] +-- | 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 -> Text -> [Text] reverseDependencies g m = reverse $ cleanLDups $ dependenciesWith pre g m -dependenciesWith :: (Dependable d) => NextNodesFunc -> DependencyGraph d -> Text -> [Text] +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 - recurse theNodes = map (dependenciesWith nextNodes dg) theNodes - getLabel node = fromJust $ lab theGraph node - labels = map getLabel depNodes - in labels ++ (concat $ recurse labels) + let + lookupId = fromJust $ lookup name nMap + depNodes = nextNodes theGraph lookupId + recurse theNodes = map (dependenciesWith nextNodes dg) theNodes + getLabel node = fromJust $ lab theGraph node + labels = map getLabel depNodes + in + labels ++ (concat $ recurse labels) diff --git a/src/Database/Schema/Migrations/Filesystem.hs b/src/Database/Schema/Migrations/Filesystem.hs index c646dcc..7c4e108 100644 --- a/src/Database/Schema/Migrations/Filesystem.hs +++ b/src/Database/Schema/Migrations/Filesystem.hs @@ -1,44 +1,49 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, LambdaCase, ScopedTypeVariables, OverloadedStrings #-} --- |This module provides a type for interacting with a --- filesystem-backed 'MigrationStore'. +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module provides a type for interacting with a +-- filesystem-backed 'MigrationStore'. module Database.Schema.Migrations.Filesystem - ( FilesystemStoreSettings(..) - , migrationFromFile - , migrationFromPath - , filesystemStore - ) + ( FilesystemStoreSettings (..) + , migrationFromFile + , migrationFromPath + , filesystemStore + ) where import Prelude -import System.Directory ( getDirectoryContents, doesFileExist ) -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.String.Conversions (cs, (<>)) +import Data.Text (Text) +import qualified Data.Text as T +import System.Directory (doesFileExist, getDirectoryContents) +import System.FilePath (dropExtension, takeBaseName, takeExtension, ()) -import Data.Typeable ( Typeable ) -import Data.Time.Clock ( UTCTime ) -import Data.Time ( defaultTimeLocale, formatTime, parseTimeM ) import qualified Data.Map as Map +import Data.Time (defaultTimeLocale, formatTime, parseTimeM) +import Data.Time.Clock (UTCTime) +import Data.Typeable (Typeable) -import Control.Monad ( filterM ) -import Control.Exception ( Exception(..), throw, catch ) +import Control.Exception (Exception (..), catch, throw) +import Control.Monad (filterM) import Data.Aeson import Data.Aeson.Types (typeMismatch) import qualified Data.Yaml as Yaml import GHC.Generics (Generic) -import Database.Schema.Migrations.Migration (Migration(..)) import Database.Schema.Migrations.Filesystem.Serialize +import Database.Schema.Migrations.Migration (Migration (..)) import Database.Schema.Migrations.Store -data FilesystemStoreSettings = FSStore { storePath :: FilePath } +data FilesystemStoreSettings = FSStore {storePath :: FilePath} data FilesystemStoreError = FilesystemStoreError String - deriving (Show, Typeable) + deriving (Show, Typeable) instance Exception FilesystemStoreError @@ -53,21 +58,20 @@ filenameExtensionTxt = ".txt" filesystemStore :: FilesystemStoreSettings -> MigrationStore filesystemStore s = - MigrationStore { fullMigrationName = fmap addNewMigrationExtension . fsFullMigrationName s - - , loadMigration = \theId -> migrationFromFile s theId - - , 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 [ cs $ dropExtension short | (short, _) <- existing ] - - , saveMigration = \m -> do - filename <- fsFullMigrationName s $ mId m - BSC.writeFile (cs $ addNewMigrationExtension filename) $ serializeMigration m - } + MigrationStore + { fullMigrationName = fmap addNewMigrationExtension . fsFullMigrationName s + , loadMigration = \theId -> migrationFromFile s theId + , 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 [cs $ dropExtension short | (short, _) <- existing] + , saveMigration = \m -> do + filename <- fsFullMigrationName s $ mId m + BSC.writeFile (cs $ addNewMigrationExtension filename) $ serializeMigration m + } addNewMigrationExtension :: FilePath -> FilePath addNewMigrationExtension path = path <> filenameExtension @@ -75,63 +79,71 @@ addNewMigrationExtension path = path <> filenameExtension addMigrationExtension :: FilePath -> String -> FilePath addMigrationExtension path ext = path <> ext --- |Build path to migrations without extension. +-- | 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 -> Text -> IO (Either String Migration) +-- | 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 -> Text -> IO (Either String Migration) migrationFromFile store name = - fsFullMigrationName store (cs 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. +-- | 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 = 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 Yaml.decodeFileThrow (addNewMigrationExtension path) `catch` (\(e::Yaml.ParseException) -> throwFS $ show e) - else Yaml.decodeFileThrow (addMigrationExtension path filenameExtensionTxt) `catch` (\(e::Yaml.ParseException) -> throwFS $ show e) - - process name = migrationYamlToMigration name <$> readMigrationFile + (Right <$> process name) + `catch` ( \(FilesystemStoreError s) -> return $ Left $ "Could not parse migration " ++ path ++ ":" ++ s + ) + where + readMigrationFile = do + ymlExists <- doesFileExist (addNewMigrationExtension path) + if ymlExists + then + Yaml.decodeFileThrow (addNewMigrationExtension path) + `catch` (\(e :: Yaml.ParseException) -> throwFS $ show e) + else + Yaml.decodeFileThrow (addMigrationExtension path filenameExtensionTxt) + `catch` (\(e :: Yaml.ParseException) -> throwFS $ show e) + + process name = migrationYamlToMigration name <$> readMigrationFile -- | TODO: re-use this for the generation side too data MigrationYaml = MigrationYaml - { myCreated :: Maybe UTCTimeYaml - , myDescription :: Maybe Text - , myApply :: Text - , myRevert :: Maybe Text - , myDepends :: DependsYaml - } - deriving Generic + { myCreated :: Maybe UTCTimeYaml + , myDescription :: Maybe Text + , myApply :: Text + , myRevert :: Maybe Text + , myDepends :: DependsYaml + } + deriving (Generic) instance FromJSON MigrationYaml where - parseJSON = genericParseJSON jsonOptions + parseJSON = genericParseJSON jsonOptions instance ToJSON MigrationYaml where - toJSON = genericToJSON jsonOptions - toEncoding = genericToEncoding jsonOptions + toJSON = genericToJSON jsonOptions + toEncoding = genericToEncoding jsonOptions jsonOptions :: Options -jsonOptions = defaultOptions +jsonOptions = + defaultOptions { fieldLabelModifier = drop 2 -- remove "my" prefix , omitNothingFields = True , rejectUnknownFields = True } migrationYamlToMigration :: Text -> MigrationYaml -> Migration -migrationYamlToMigration theId my = Migration +migrationYamlToMigration theId my = + Migration { mTimestamp = unUTCTimeYaml <$> myCreated my , mId = theId , mDesc = myDescription my @@ -141,37 +153,38 @@ migrationYamlToMigration theId my = Migration } newtype UTCTimeYaml = UTCTimeYaml - { unUTCTimeYaml :: UTCTime - } + { unUTCTimeYaml :: UTCTime + } instance FromJSON UTCTimeYaml where - parseJSON = withText "UTCTime" - $ maybe (fail "Unable to parse UTCTime") (pure . UTCTimeYaml) + parseJSON = + withText "UTCTime" $ + maybe (fail "Unable to parse UTCTime") (pure . UTCTimeYaml) . parseTimeM True defaultTimeLocale utcTimeYamlFormat . cs instance ToJSON UTCTimeYaml where - toJSON = toJSON . formatTime defaultTimeLocale utcTimeYamlFormat . unUTCTimeYaml - toEncoding = toEncoding . formatTime defaultTimeLocale utcTimeYamlFormat . unUTCTimeYaml + toJSON = toJSON . formatTime defaultTimeLocale utcTimeYamlFormat . unUTCTimeYaml + toEncoding = toEncoding . formatTime defaultTimeLocale utcTimeYamlFormat . unUTCTimeYaml -- Keeps things as the old Show/Read-based format, e.g "2009-04-15 10:02:06 UTC" utcTimeYamlFormat :: String utcTimeYamlFormat = "%F %T%Q UTC" newtype DependsYaml = DependsYaml - { unDependsYaml :: [Text] - } + { unDependsYaml :: [Text] + } instance FromJSON DependsYaml where - parseJSON = \case - Null -> pure $ DependsYaml [] - String t -> pure $ DependsYaml $ T.words t - x -> typeMismatch "Null or whitespace-separated String" x + parseJSON = \case + Null -> pure $ DependsYaml [] + String t -> pure $ DependsYaml $ T.words t + x -> typeMismatch "Null or whitespace-separated String" x instance ToJSON DependsYaml where - toJSON (DependsYaml ts) = case ts of - [] -> toJSON Null - _ -> toJSON $ T.unwords ts - toEncoding (DependsYaml ts) = case ts of - [] -> toEncoding Null - _ -> toEncoding $ T.unwords ts + toJSON (DependsYaml ts) = case ts of + [] -> toJSON Null + _ -> toJSON $ T.unwords ts + toEncoding (DependsYaml ts) = case ts of + [] -> toEncoding Null + _ -> toEncoding $ T.unwords ts diff --git a/src/Database/Schema/Migrations/Filesystem/Serialize.hs b/src/Database/Schema/Migrations/Filesystem/Serialize.hs index d5c4171..51b7e48 100644 --- a/src/Database/Schema/Migrations/Filesystem/Serialize.hs +++ b/src/Database/Schema/Migrations/Filesystem/Serialize.hs @@ -1,53 +1,59 @@ {-# LANGUAGE OverloadedStrings #-} + module Database.Schema.Migrations.Filesystem.Serialize - ( serializeMigration - ) + ( serializeMigration + ) where -import Data.ByteString ( ByteString ) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.Text ( Text ) + +-- for UTCTime Show instance +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) +import Data.String.Conversions (cs) +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.Monoid ( (<>) ) +import Data.Time () import Database.Schema.Migrations.Migration - ( Migration(..) - ) + ( Migration (..) + ) type FieldSerializer = Migration -> Maybe ByteString fieldSerializers :: [FieldSerializer] -fieldSerializers = [ serializeDesc - , serializeTimestamp - , serializeDepends - , serializeApply - , serializeRevert - ] +fieldSerializers = + [ serializeDesc + , serializeTimestamp + , serializeDepends + , serializeApply + , serializeRevert + ] serializeDesc :: FieldSerializer serializeDesc m = - case mDesc m of - Nothing -> Nothing - Just desc -> Just . cs $ "Description: " <> desc + case mDesc m of + Nothing -> Nothing + Just desc -> Just . cs $ "Description: " <> desc serializeTimestamp :: FieldSerializer serializeTimestamp m = - case mTimestamp m of - Nothing -> Nothing - Just ts -> Just $ "Created: " <> (cs . show $ ts) + case mTimestamp m of + Nothing -> Nothing + Just ts -> Just $ "Created: " <> (cs . show $ ts) serializeDepends :: FieldSerializer serializeDepends m = Just . cs $ "Depends: " <> (T.intercalate " " $ mDeps m) serializeRevert :: FieldSerializer serializeRevert m = - case mRevert m of - Nothing -> Nothing - Just revert -> Just $ "Revert: |\n" <> - (serializeMultiline revert) + case mRevert m of + Nothing -> Nothing + Just revert -> + Just $ + "Revert: |\n" + <> (serializeMultiline revert) serializeApply :: FieldSerializer serializeApply m = Just $ "Apply: |\n" <> (serializeMultiline $ mApply m) @@ -61,18 +67,19 @@ commonPrefixLines theLines = foldl1 commonPrefix theLines serializeMultiline :: Text -> ByteString serializeMultiline s = - 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 cs . T.unlines $ map (prefix <>) sLines + 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 + cs . T.unlines $ map (prefix <>) sLines serializeMigration :: Migration -> ByteString serializeMigration m = BS.intercalate "\n" fields - where - fields = catMaybes [ f m | f <- fieldSerializers ] + where + fields = catMaybes [f m | f <- fieldSerializers] diff --git a/src/Database/Schema/Migrations/Migration.hs b/src/Database/Schema/Migrations/Migration.hs index 8222323..a0e585f 100644 --- a/src/Database/Schema/Migrations/Migration.hs +++ b/src/Database/Schema/Migrations/Migration.hs @@ -1,43 +1,48 @@ {-# LANGUAGE OverloadedStrings #-} + module Database.Schema.Migrations.Migration - ( Migration(..) - , newMigration - , emptyMigration - ) + ( Migration (..) + , newMigration + , emptyMigration + ) where import Database.Schema.Migrations.Dependencies -import Data.Text ( Text ) -import Data.Time () -- for UTCTime Show instance +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 :: Text - , mDesc :: Maybe Text - , mApply :: Text - , mRevert :: Maybe Text - , mDeps :: [Text] - } - deriving (Eq, Show, Ord) +data Migration = Migration + { mTimestamp :: Maybe Clock.UTCTime + , mId :: Text + , mDesc :: Maybe Text + , mApply :: Text + , mRevert :: Maybe Text + , mDeps :: [Text] + } + deriving (Eq, Show, Ord) instance Dependable Migration where - depsOf = mDeps - depId = mId + depsOf = mDeps + depId = mId emptyMigration :: Text -> Migration emptyMigration name = - Migration { mTimestamp = Nothing - , mId = name - , mApply = "" - , mRevert = Nothing - , mDesc = Nothing - , mDeps = [] - } + Migration + { mTimestamp = Nothing + , mId = name + , mApply = "" + , mRevert = Nothing + , mDesc = Nothing + , mDeps = [] + } newMigration :: Text -> Migration -newMigration theId = - (emptyMigration theId) +newMigration theId = + (emptyMigration theId) { mApply = "(Apply SQL here.)" , mDesc = Just "(Describe migration here.)" } diff --git a/src/Database/Schema/Migrations/Store.hs b/src/Database/Schema/Migrations/Store.hs index e60247f..d7e73f0 100644 --- a/src/Database/Schema/Migrations/Store.hs +++ b/src/Database/Schema/Migrations/Store.hs @@ -1,123 +1,125 @@ {-# LANGUAGE MultiParamTypeClasses #-} --- |This module provides an abstraction for a /migration store/, a --- facility in which 'Migration's can be stored and from which they --- can be loaded. This module also provides functions for taking --- 'Migration's from a store and converting them into the appropriate --- intermediate types for use with the rest of this library. + +-- | This module provides an abstraction for a /migration store/, a +-- facility in which 'Migration's can be stored and from which they +-- can be loaded. This module also provides functions for taking +-- 'Migration's from a store and converting them into the appropriate +-- intermediate types for use with the rest of this library. module Database.Schema.Migrations.Store - ( MigrationStore(..) - , MapValidationError(..) - , StoreData(..) - , MigrationMap + ( MigrationStore (..) + , MapValidationError (..) + , StoreData (..) + , MigrationMap -- * High-level Store API - , loadMigrations - , storeMigrations - , storeLookup + , loadMigrations + , storeMigrations + , storeLookup -- * Miscellaneous Functions - , depGraphFromMapping - , validateMigrationMap - , validateSingleMigration - , leafMigrations - ) + , depGraphFromMapping + , validateMigrationMap + , validateSingleMigration + , leafMigrations + ) where -import Data.Text ( Text ) -import Data.Maybe ( isJust ) -import Control.Monad ( mzero ) -import Control.Applicative ( (<$>) ) +import Control.Applicative ((<$>)) +import Control.Monad (mzero) +import Data.Graph.Inductive.Graph (indeg, labNodes) import qualified Data.Map as Map -import Data.Graph.Inductive.Graph ( labNodes, indeg ) +import Data.Maybe (isJust) +import Data.Text (Text) -import Database.Schema.Migrations.Migration - ( Migration(..) - ) import Database.Schema.Migrations.Dependencies - ( DependencyGraph(..) - , mkDepGraph - , depsOf - ) - --- |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. + ( DependencyGraph (..) + , depsOf + , mkDepGraph + ) +import Database.Schema.Migrations.Migration + ( Migration (..) + ) + +-- | 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 Text Migration -data StoreData = StoreData { storeDataMapping :: MigrationMap - , storeDataGraph :: DependencyGraph 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 :: Text -> IO (Either String Migration) - -- ^ Load a migration from the store. - - , saveMigration :: Migration -> IO () - -- ^ Save a migration to the store. - - , getMigrations :: IO [Text] - -- ^ Return a list of all available migrations' - -- names. - - , fullMigrationName :: Text -> IO FilePath - -- ^ 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 Text Text - -- ^ A migration claims a dependency on a - -- migration that does not exist. - | DependencyGraphError String - -- ^ An error was encountered when - -- constructing the dependency graph for - -- this store. - | InvalidMigration String - -- ^ The specified migration is invalid. - deriving (Eq) +data StoreData = StoreData + { storeDataMapping :: MigrationMap + , storeDataGraph :: DependencyGraph 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 :: Text -> IO (Either String Migration) + -- ^ Load a migration from the store. + , saveMigration :: Migration -> IO () + -- ^ Save a migration to the store. + , getMigrations :: IO [Text] + -- ^ Return a list of all available migrations' + -- names. + , fullMigrationName :: Text -> IO FilePath + -- ^ 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 + = -- | A migration claims a dependency on a + -- migration that does not exist. + DependencyReferenceError Text Text + | -- | An error was encountered when + -- constructing the dependency graph for + -- this store. + DependencyGraphError String + | -- | The specified migration is invalid. + InvalidMigration String + deriving (Eq) instance Show MapValidationError where - show (DependencyReferenceError from to) = - "Migration " ++ (show from) ++ " references nonexistent dependency " ++ show to - show (DependencyGraphError msg) = - "There was an error constructing the dependency graph: " ++ msg - show (InvalidMigration msg) = - "There was an error loading a migration: " ++ msg - --- |A convenience function for extracting the list of 'Migration's --- extant in the specified 'StoreData'. + show (DependencyReferenceError from to) = + "Migration " ++ (show from) ++ " references nonexistent dependency " ++ show to + show (DependencyGraphError msg) = + "There was an error constructing the dependency graph: " ++ msg + show (InvalidMigration msg) = + "There was an error loading a migration: " ++ msg + +-- | A convenience function for extracting the list of 'Migration's +-- extant in the specified 'StoreData'. storeMigrations :: StoreData -> [Migration] storeMigrations storeData = - Map.elems $ storeDataMapping storeData + Map.elems $ storeDataMapping storeData --- |A convenience function for looking up a 'Migration' by name in the --- specified 'StoreData'. +-- | A convenience function for looking up a 'Migration' by name in the +-- specified 'StoreData'. storeLookup :: StoreData -> Text -> Maybe Migration storeLookup storeData migrationName = - Map.lookup migrationName $ storeDataMapping storeData + Map.lookup migrationName $ storeDataMapping storeData --- |Load migrations from the specified 'MigrationStore', validate the --- 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'. +-- | Load migrations from the specified 'MigrationStore', validate the +-- 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 -> IO (Either [MapValidationError] StoreData) loadMigrations store = do migrations <- getMigrations store loadedWithErrors <- mapM (\name -> loadMigration store name) migrations - let mMap = Map.fromList $ [ (mId e, e) | e <- loaded ] - validationErrors = validateMigrationMap mMap - (loaded, loadErrors) = sortResults loadedWithErrors ([], []) - allErrors = validationErrors ++ (InvalidMigration <$> loadErrors) + let + mMap = Map.fromList $ [(mId e, e) | e <- loaded] + validationErrors = validateMigrationMap mMap + (loaded, loadErrors) = sortResults loadedWithErrors ([], []) + allErrors = validationErrors ++ (InvalidMigration <$> loadErrors) - sortResults [] v = v - sortResults (Left e:rest) (ms, es) = sortResults rest (ms, e:es) - sortResults (Right m:rest) (ms, es) = sortResults rest (m:ms, es) + sortResults [] v = v + sortResults (Left e : rest) (ms, es) = sortResults rest (ms, e : es) + sortResults (Right m : rest) (ms, es) = sortResults rest (m : ms, es) case null allErrors of False -> return $ Left allErrors @@ -126,34 +128,41 @@ loadMigrations store = do -- StoreData. case depGraphFromMapping mMap of Left e -> return $ Left [DependencyGraphError e] - Right gr -> return $ Right StoreData { storeDataMapping = mMap - , storeDataGraph = gr - } - --- |Validate a migration map. Returns zero or more validation errors. + Right gr -> + return $ + Right + StoreData + { storeDataMapping = mMap + , storeDataGraph = gr + } + +-- | Validate a migration map. Returns zero or more validation errors. validateMigrationMap :: MigrationMap -> [MapValidationError] validateMigrationMap mMap = do validateSingleMigration mMap =<< snd <$> Map.toList mMap --- |Validate a single migration. Looks up the migration's --- dependencies in the specified 'MigrationMap' and returns a --- 'MapValidationError' for each one that does not exist in the map. +-- | Validate a single migration. Looks up the migration's +-- dependencies in the specified 'MigrationMap' and returns a +-- 'MapValidationError' for each one that does not exist in the map. validateSingleMigration :: MigrationMap -> Migration -> [MapValidationError] validateSingleMigration mMap m = do depId <- depsOf m - if isJust $ Map.lookup depId mMap then - mzero else + if isJust $ Map.lookup depId mMap + then + mzero + else return $ DependencyReferenceError (mId m) depId --- |Create a 'DependencyGraph' from a 'MigrationMap'; returns Left if --- the dependency graph cannot be constructed (e.g., due to a --- dependency cycle) or Right on success. Generally speaking, you --- won't want to use this directly; use 'loadMigrations' instead. +-- | Create a 'DependencyGraph' from a 'MigrationMap'; returns Left if +-- the dependency graph cannot be constructed (e.g., due to a +-- dependency cycle) or Right on success. Generally speaking, you +-- won't want to use this directly; use 'loadMigrations' instead. depGraphFromMapping :: MigrationMap -> Either String (DependencyGraph Migration) depGraphFromMapping mapping = mkDepGraph $ Map.elems mapping --- |Finds migrations that no other migration depends on (effectively finds all --- vertices with in-degree equal to zero). +-- | Finds migrations that no other migration depends on (effectively finds all +-- vertices with in-degree equal to zero). leafMigrations :: StoreData -> [Text] leafMigrations s = [l | (n, l) <- labNodes g, indeg g n == 0] - where g = depGraph $ storeDataGraph s + where + g = depGraph $ storeDataGraph s diff --git a/src/Database/Schema/Migrations/Test/BackendTest.hs b/src/Database/Schema/Migrations/Test/BackendTest.hs index a5a7c45..521a558 100644 --- a/src/Database/Schema/Migrations/Test/BackendTest.hs +++ b/src/Database/Schema/Migrations/Test/BackendTest.hs @@ -5,65 +5,65 @@ -- implementations. All backend specific executable packages are expected to -- have a test suite that runs this test. module Database.Schema.Migrations.Test.BackendTest - ( BackendConnection (..) - , tests - ) where + ( BackendConnection (..) + , tests + ) where -import Data.ByteString ( ByteString ) +import Data.ByteString (ByteString) -import Control.Monad ( forM_ ) +import Control.Monad (forM_) import Test.HUnit -import Database.Schema.Migrations.Migration ( Migration(..), newMigration ) -import Database.Schema.Migrations.Backend ( Backend(..) ) +import Database.Schema.Migrations.Backend (Backend (..)) +import Database.Schema.Migrations.Migration (Migration (..), newMigration) -- | A typeclass for database connections that needs to implemented for each -- specific database type to use this test. class BackendConnection c where + -- | Whether this backend supports transactional DDL; if it doesn't, + -- we'll skip any tests that rely on that behavior. + supportsTransactionalDDL :: c -> Bool - -- | Whether this backend supports transactional DDL; if it doesn't, - -- we'll skip any tests that rely on that behavior. - supportsTransactionalDDL :: c -> Bool + -- | Commits the current transaction. + commit :: c -> IO () - -- | Commits the current transaction. - commit :: c -> IO () + -- | Executes an IO action inside a transaction. + withTransaction :: c -> (c -> IO a) -> IO a - -- | Executes an IO action inside a transaction. - withTransaction :: c -> (c -> IO a) -> IO a + -- | Retrieves a list of all tables in the current database/scheme. + getTables :: c -> IO [ByteString] - -- | Retrieves a list of all tables in the current database/scheme. - getTables :: c -> IO [ByteString] + catchAll :: c -> (IO a -> IO a -> IO a) - catchAll :: c -> (IO a -> IO a -> IO a) - - -- | Returns a backend instance. - makeBackend :: c -> Backend + -- | Returns a backend instance. + makeBackend :: c -> Backend testSuite :: BackendConnection bc => Bool -> [bc -> IO ()] testSuite transactDDL = - [ isBootstrappedFalseTest - , bootstrapTest - , isBootstrappedTrueTest - , if transactDDL then applyMigrationFailure else (const $ return ()) - , applyMigrationSuccess - , revertMigrationFailure - , revertMigrationNothing - , revertMigrationJust - ] + [ isBootstrappedFalseTest + , bootstrapTest + , isBootstrappedTrueTest + , if transactDDL then applyMigrationFailure else (const $ return ()) + , applyMigrationSuccess + , revertMigrationFailure + , revertMigrationNothing + , revertMigrationJust + ] tests :: BackendConnection bc => bc -> IO () tests conn = do let acts = testSuite $ supportsTransactionalDDL conn forM_ acts $ \act -> do - commit conn - act conn + commit conn + act conn bootstrapTest :: BackendConnection bc => bc -> IO () bootstrapTest conn = do let backend = makeBackend conn bs <- getBootstrapMigration backend applyMigration backend bs - assertEqual "installed_migrations table exists" ["installed_migrations"] =<< getTables conn + assertEqual "installed_migrations table exists" ["installed_migrations"] + =<< getTables conn assertEqual "successfully bootstrapped" [mId bs] =<< getMigrations backend isBootstrappedTrueTest :: BackendConnection bc => bc -> IO () @@ -84,97 +84,118 @@ ignoreSqlExceptions conn act = applyMigrationSuccess :: BackendConnection bc => bc -> IO () applyMigrationSuccess conn = do - let backend = makeBackend conn + let backend = makeBackend conn - let m1 = (newMigration "validMigration") { mApply = "CREATE TABLE valid1 (a int)" } + let m1 = (newMigration "validMigration") {mApply = "CREATE TABLE valid1 (a int)"} - -- Apply the migrations, ignore exceptions - withTransaction conn $ \conn' -> applyMigration (makeBackend conn') m1 + -- Apply the migrations, ignore exceptions + withTransaction conn $ \conn' -> applyMigration (makeBackend conn') m1 - -- Check that none of the migrations were installed - assertEqual "Installed migrations" ["root", "validMigration"] =<< getMigrations backend - assertEqual "Installed tables" ["installed_migrations", "valid1"] =<< getTables conn + -- Check that none of the migrations were installed + assertEqual "Installed migrations" ["root", "validMigration"] + =<< getMigrations backend + assertEqual "Installed tables" ["installed_migrations", "valid1"] + =<< getTables conn --- |Does a failure to apply a migration imply a transaction rollback? +-- | Does a failure to apply a migration imply a transaction rollback? applyMigrationFailure :: BackendConnection bc => bc -> IO () applyMigrationFailure conn = do - let backend = makeBackend conn + let backend = makeBackend conn - let m1 = (newMigration "second") { mApply = "CREATE TABLE validButTemporary (a int)" } - m2 = (newMigration "third") { 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 conn $ withTransaction conn $ \conn' -> do - let backend' = makeBackend conn' - applyMigration backend' m1 - applyMigration backend' m2 + -- Apply the migrations, ignore exceptions + _ <- ignoreSqlExceptions conn $ withTransaction conn $ \conn' -> do + let backend' = makeBackend conn' + applyMigration backend' m1 + applyMigration backend' m2 - -- Check that none of the migrations were installed - assertEqual "Installed migrations" ["root"] =<< getMigrations backend - assertEqual "Installed tables" ["installed_migrations"] =<< getTables conn + -- Check that none of the migrations were installed + assertEqual "Installed migrations" ["root"] =<< getMigrations backend + assertEqual "Installed tables" ["installed_migrations"] =<< getTables conn revertMigrationFailure :: BackendConnection bc => bc -> IO () revertMigrationFailure conn = do - let backend = makeBackend conn + let backend = makeBackend conn - let m1 = (newMigration "second") { mApply = "CREATE TABLE validRMF (a int)" - , mRevert = Just "DROP TABLE validRMF"} - m2 = (newMigration "third") { mApply = "alter table validRMF add column b int" - , mRevert = Just "INVALID REVERT SQL"} + let + m1 = + (newMigration "second") + { mApply = "CREATE TABLE validRMF (a int)" + , mRevert = Just "DROP TABLE validRMF" + } + m2 = + (newMigration "third") + { mApply = "alter table validRMF add column b int" + , mRevert = Just "INVALID REVERT SQL" + } - applyMigration backend m1 - applyMigration backend m2 + applyMigration backend m1 + applyMigration backend m2 - installedBeforeRevert <- getMigrations backend + installedBeforeRevert <- getMigrations backend - commitBackend backend + commitBackend backend - -- Revert the migrations, ignore exceptions; the revert will fail, - -- but withTransaction will roll back. - _ <- ignoreSqlExceptions conn $ withTransaction conn $ \conn' -> do - let backend' = makeBackend conn' - revertMigration backend' m2 - revertMigration backend' m1 + -- Revert the migrations, ignore exceptions; the revert will fail, + -- but withTransaction will roll back. + _ <- ignoreSqlExceptions conn $ withTransaction conn $ \conn' -> do + let backend' = makeBackend conn' + revertMigration backend' m2 + revertMigration backend' m1 - -- Check that none of the migrations were reverted - assertEqual "successfully roll back failed revert" installedBeforeRevert - =<< getMigrations backend + -- Check that none of the migrations were reverted + assertEqual "successfully roll back failed revert" installedBeforeRevert + =<< getMigrations backend revertMigrationNothing :: BackendConnection bc => bc -> IO () revertMigrationNothing conn = do - let backend = makeBackend conn + let backend = makeBackend conn - let m1 = (newMigration "second") { mApply = "create table revert_nothing (a int)" - , mRevert = Nothing } + let m1 = + (newMigration "second") + { mApply = "create table revert_nothing (a int)" + , mRevert = Nothing + } - applyMigration backend m1 + applyMigration backend m1 - installedAfterApply <- getMigrations backend - assertBool "Check that the migration was applied" $ "second" `elem` installedAfterApply + installedAfterApply <- getMigrations backend + assertBool "Check that the migration was applied" $ + "second" `elem` installedAfterApply - -- Revert the migration, which should do nothing EXCEPT remove it - -- from the installed list - revertMigration backend m1 + -- Revert the migration, which should do nothing EXCEPT remove it + -- from the installed list + revertMigration backend m1 - installed <- getMigrations backend - assertBool "Check that the migration was reverted" $ not $ "second" `elem` installed + installed <- getMigrations backend + assertBool "Check that the migration was reverted" $ + not $ + "second" `elem` installed revertMigrationJust :: BackendConnection bc => bc -> IO () revertMigrationJust conn = do - let name = "revertable" - backend = makeBackend conn + let + name = "revertable" + backend = makeBackend conn - let m1 = (newMigration name) { 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 backend m1 + applyMigration backend m1 - installedAfterApply <- getMigrations backend - assertBool "Check that the migration was applied" $ name `elem` installedAfterApply + installedAfterApply <- getMigrations backend + assertBool "Check that the migration was applied" $ + name `elem` installedAfterApply - -- Revert the migration, which should do nothing EXCEPT remove it - -- from the installed list - revertMigration backend m1 + -- Revert the migration, which should do nothing EXCEPT remove it + -- from the installed list + revertMigration backend m1 - installed <- getMigrations backend - assertBool "Check that the migration was reverted" $ not $ name `elem` installed + installed <- getMigrations backend + assertBool "Check that the migration was reverted" $ not $ name `elem` installed diff --git a/src/Moo/CommandHandlers.hs b/src/Moo/CommandHandlers.hs index 91428a4..8e5c580 100644 --- a/src/Moo/CommandHandlers.hs +++ b/src/Moo/CommandHandlers.hs @@ -1,164 +1,180 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} + module Moo.CommandHandlers where import Data.String.Conversions (cs, (<>)) -import Moo.Core -import Moo.CommandUtils -import Control.Monad ( when, forM_ ) -import Data.Maybe ( isJust ) -import Control.Monad.Reader ( asks ) -import System.Exit ( exitWith, ExitCode(..), exitSuccess ) +import Control.Monad (forM_, when) +import Control.Monad.Reader (asks) +import Control.Monad.Trans (liftIO) +import Data.Maybe (isJust) import qualified Data.Time.Clock as Clock -import Control.Monad.Trans ( liftIO ) +import Moo.CommandUtils +import Moo.Core +import System.Exit (ExitCode (..), exitSuccess, exitWith) -import Database.Schema.Migrations.Store hiding (getMigrations) import Database.Schema.Migrations -import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Backend +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Store hiding (getMigrations) newCommand :: CommandHandler newCommand storeData = do - required <- asks _appRequiredArgs - store <- asks _appStore - linear <- asks _appLinearMigrations - timestamp <- asks _appTimestampFilenames - timeString <- (<>"_") <$> liftIO getCurrentTimestamp - - let [migrationId] = if timestamp - then fmap (timeString<>) required - else required + required <- asks _appRequiredArgs + store <- asks _appStore + linear <- asks _appLinearMigrations + timestamp <- asks _appTimestampFilenames + timeString <- (<> "_") <$> liftIO getCurrentTimestamp + + let [migrationId] = + if timestamp + then fmap (timeString <>) required + else required noAsk <- _noAsk <$> asks _appOptions liftIO $ do fullPath <- fullMigrationName store migrationId when (isJust $ storeLookup storeData migrationId) $ - do - putStrLn $ "Migration " <> (show fullPath) ++ " already exists" - exitWith (ExitFailure 1) + do + 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 . cs $ "Selecting dependencies for new \ - \migration: " <> migrationId - interactiveAskDeps storeData - - result <- if noAsk then (return True) else - (confirmCreation migrationId deps) + deps <- + if linear + then (return $ leafMigrations storeData) + else + if noAsk + then (return []) + else do + putStrLn . cs $ + "Selecting dependencies for new \ + \migration: " + <> migrationId + interactiveAskDeps storeData + + result <- + if noAsk + then (return True) + else + (confirmCreation migrationId deps) case result of True -> do - now <- Clock.getCurrentTime - status <- createNewMigration store $ (newMigration migrationId) { mDeps = deps - , mTimestamp = Just now - } - case status of - Left e -> putStrLn e >> (exitWith (ExitFailure 1)) - Right _ -> putStrLn $ "Migration created successfully: " ++ - show fullPath + now <- Clock.getCurrentTime + status <- + createNewMigration store $ + (newMigration migrationId) + { mDeps = deps + , mTimestamp = Just now + } + case status of + Left e -> putStrLn e >> (exitWith (ExitFailure 1)) + Right _ -> + putStrLn $ + "Migration created successfully: " + ++ show fullPath False -> do - putStrLn "Migration creation cancelled." + putStrLn "Migration creation cancelled." upgradeCommand :: CommandHandler upgradeCommand storeData = do - isTesting <- _test <$> asks _appOptions + 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 backend False - case isTesting of - True -> do - rollbackBackend backend - putStrLn "Upgrade test successful." - False -> do - commitBackend backend - putStrLn "Database successfully upgraded." + 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 backend False + case isTesting of + True -> do + rollbackBackend backend + putStrLn "Upgrade test successful." + False -> do + commitBackend backend + putStrLn "Database successfully upgraded." upgradeListCommand :: CommandHandler upgradeListCommand storeData = do 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 . cs . (" " <>)) + 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 . cs . (" " <>)) reinstallCommand :: CommandHandler reinstallCommand storeData = do - isTesting <- _test <$> asks _appOptions + isTesting <- _test <$> asks _appOptions required <- asks _appRequiredArgs let [migrationId] = required withBackend $ \backend -> do - ensureBootstrappedBackend backend >> commitBackend backend - m <- lookupMigration storeData migrationId + 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 - commitBackend backend - putStrLn "Migration successfully reinstalled." - True -> do - rollbackBackend backend - putStrLn "Reinstall test successful." + case isTesting of + False -> do + commitBackend backend + putStrLn "Migration successfully reinstalled." + True -> do + rollbackBackend backend + putStrLn "Reinstall test successful." listCommand :: CommandHandler listCommand _ = do withBackend $ \backend -> do - ensureBootstrappedBackend backend >> commitBackend backend - ms <- getMigrations backend - forM_ ms $ \m -> - when (not $ m == rootMigrationName) $ putStrLn . cs $ m + ensureBootstrappedBackend backend >> commitBackend backend + ms <- getMigrations backend + forM_ ms $ \m -> + when (not $ m == rootMigrationName) $ putStrLn . cs $ m applyCommand :: CommandHandler applyCommand storeData = do - isTesting <- _test <$> asks _appOptions - required <- asks _appRequiredArgs + isTesting <- _test <$> asks _appOptions + required <- asks _appRequiredArgs let [migrationId] = required withBackend $ \backend -> do - ensureBootstrappedBackend backend >> commitBackend backend - m <- lookupMigration storeData migrationId - _ <- apply m storeData backend True - case isTesting of - False -> do - commitBackend backend - putStrLn "Successfully applied migrations." - True -> do - rollbackBackend backend - putStrLn "Migration installation test successful." + ensureBootstrappedBackend backend >> commitBackend backend + m <- lookupMigration storeData migrationId + _ <- apply m storeData backend True + case isTesting of + False -> do + commitBackend backend + putStrLn "Successfully applied migrations." + True -> do + rollbackBackend backend + putStrLn "Migration installation test successful." revertCommand :: CommandHandler revertCommand storeData = do - isTesting <- _test <$> asks _appOptions + isTesting <- _test <$> asks _appOptions required <- asks _appRequiredArgs let [migrationId] = required withBackend $ \backend -> do - ensureBootstrappedBackend backend >> commitBackend backend - m <- lookupMigration storeData migrationId - _ <- revert m storeData backend - - case isTesting of - False -> do - commitBackend backend - putStrLn "Successfully reverted migrations." - True -> do - rollbackBackend backend - putStrLn "Migration uninstallation test successful." + ensureBootstrappedBackend backend >> commitBackend backend + m <- lookupMigration storeData migrationId + _ <- revert m storeData backend + + case isTesting of + False -> do + commitBackend backend + putStrLn "Successfully reverted migrations." + True -> do + rollbackBackend backend + putStrLn "Migration uninstallation test successful." testCommand :: CommandHandler testCommand storeData = do @@ -166,16 +182,17 @@ testCommand storeData = do let [migrationId] = required withBackend $ \backend -> do - ensureBootstrappedBackend backend >> commitBackend backend - m <- lookupMigration storeData migrationId - 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 backend - return () - applied <- apply m storeData backend True - forM_ (reverse applied) $ \migration -> do - revert migration storeData backend - rollbackBackend backend - putStrLn "Successfully tested migrations." + ensureBootstrappedBackend backend >> commitBackend backend + m <- lookupMigration storeData migrationId + 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 backend + return () + applied <- apply m storeData backend True + forM_ (reverse applied) $ \migration -> do + revert migration storeData backend + rollbackBackend backend + putStrLn "Successfully tested migrations." diff --git a/src/Moo/CommandInterface.hs b/src/Moo/CommandInterface.hs index 4912c75..40bd237 100644 --- a/src/Moo/CommandInterface.hs +++ b/src/Moo/CommandInterface.hs @@ -1,114 +1,137 @@ --- |This module defines the MOO command interface, the commnad line options --- parser, and helpers to manipulate the Command data structure. +-- | This module defines the MOO command interface, the commnad line options +-- parser, and helpers to manipulate the Command data structure. module Moo.CommandInterface - ( commands - , commandOptionUsage - , findCommand - , getCommandArgs - , usageString - ) where + ( commands + , commandOptionUsage + , findCommand + , getCommandArgs + , usageString + ) where import Data.Maybe import Moo.CommandHandlers 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 --- used to generate usage output. +-- | 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 +-- used to generate usage output. commands :: [Command] -commands = [ Command "new" [migrationName] - [] - ["no-ask", configFile] - "Create a new empty migration" - newCommand - - , Command "apply" [migrationName] - [] - [testOption, configFile] - "Apply the specified migration and its \ - \dependencies" - applyCommand - - , Command "revert" [migrationName] - [] - [testOption, configFile] - "Revert the specified migration and those \ - \that depend on it" - revertCommand - - , Command "test" [migrationName] - [] - [configFile] - "Test the specified migration by applying \ - \and reverting it in a transaction, then \ - \roll back" - testCommand - - , Command "upgrade" [] - [] - [testOption, configFile] - "Install all migrations that have not yet \ - \been installed" - - upgradeCommand - - , Command "upgrade-list" [] - [] - [] - "Show the list of migrations not yet \ - \installed" - upgradeListCommand - - , Command "reinstall" [migrationName] - [] - [testOption, configFile] - "Reinstall a migration by reverting, then \ - \reapplying it" - reinstallCommand - - , Command "list" [] - [] - [configFile] - "List migrations already installed in the backend" - listCommand - ] - where migrationName = "migrationName" - testOption = "test" - configFile = "config-file" - +commands = + [ Command + "new" + [migrationName] + [] + ["no-ask", configFile] + "Create a new empty migration" + newCommand + , Command + "apply" + [migrationName] + [] + [testOption, configFile] + "Apply the specified migration and its \ + \dependencies" + applyCommand + , Command + "revert" + [migrationName] + [] + [testOption, configFile] + "Revert the specified migration and those \ + \that depend on it" + revertCommand + , Command + "test" + [migrationName] + [] + [configFile] + "Test the specified migration by applying \ + \and reverting it in a transaction, then \ + \roll back" + testCommand + , Command + "upgrade" + [] + [] + [testOption, configFile] + "Install all migrations that have not yet \ + \been installed" + upgradeCommand + , Command + "upgrade-list" + [] + [] + [] + "Show the list of migrations not yet \ + \installed" + upgradeListCommand + , Command + "reinstall" + [migrationName] + [] + [testOption, configFile] + "Reinstall a migration by reverting, then \ + \reapplying it" + reinstallCommand + , Command + "list" + [] + [] + [configFile] + "List migrations already installed in the backend" + listCommand + ] + where + migrationName = "migrationName" + testOption = "test" + configFile = "config-file" findCommand :: String -> Maybe Command -findCommand name = listToMaybe [ c | c <- commands, _cName c == name ] +findCommand name = listToMaybe [c | c <- commands, _cName c == name] -commandOptions :: [ OptDescr (CommandOptions -> IO CommandOptions) ] -commandOptions = [ optionConfigFile - , optionTest - , optionNoAsk - ] +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" +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" +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] ) +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 + let (actions, required, _) = getOpt RequireOrder commandOptions args opts <- foldl (>>=) defaultOptions actions - return ( opts, required ) + return (opts, required) defaultOptions :: IO CommandOptions defaultOptions = return $ CommandOptions Nothing False False @@ -118,9 +141,9 @@ commandOptionUsage = usageInfo "Options:" commandOptions usageString :: Command -> String usageString command = - unwords (_cName command:optionalArgs ++ options ++ requiredArgs) - where - requiredArgs = map (\s -> "<" ++ s ++ ">") $ _cRequired command - optionalArgs = map (\s -> "[" ++ s ++ "]") $ _cOptional command - options = map (\s -> "["++ "--" ++ s ++ "]") optionStrings - optionStrings = _cAllowedOptions command + unwords (_cName command : optionalArgs ++ options ++ requiredArgs) + where + requiredArgs = map (\s -> "<" ++ s ++ ">") $ _cRequired command + optionalArgs = map (\s -> "[" ++ s ++ "]") $ _cOptional command + options = map (\s -> "[" ++ "--" ++ s ++ "]") optionStrings + optionStrings = _cAllowedOptions command diff --git a/src/Moo/CommandUtils.hs b/src/Moo/CommandUtils.hs index 86677f1..a953235 100644 --- a/src/Moo/CommandUtils.hs +++ b/src/Moo/CommandUtils.hs @@ -1,36 +1,45 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + module Moo.CommandUtils - ( apply - , confirmCreation - , interactiveAskDeps - , lookupMigration - , revert - , withBackend - , getCurrentTimestamp - ) where - -import Data.Text ( Text ) + ( apply + , confirmCreation + , interactiveAskDeps + , lookupMigration + , revert + , withBackend + , getCurrentTimestamp + ) where + +import Data.String.Conversions (cs, (<>)) +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 ) -import Control.Monad.Trans ( liftIO ) -import Data.List ( intercalate, sortBy, isPrefixOf ) +import Control.Exception (finally) +import Control.Monad (forM_, unless, when) +import Control.Monad.Reader (asks) +import Control.Monad.Trans (liftIO) +import Data.List (intercalate, isPrefixOf, sortBy) +import Data.Maybe (fromJust, isJust) import Data.Time.Clock (getCurrentTime) -import Data.Maybe ( fromJust, isJust ) -import System.Exit ( exitWith, ExitCode(..) ) -import System.IO ( stdout, hFlush, hGetBuffering - , hSetBuffering, stdin, BufferMode(..) ) - -import Database.Schema.Migrations ( migrationsToApply, migrationsToRevert ) -import Database.Schema.Migrations.Backend (Backend(..)) -import Database.Schema.Migrations.Migration ( Migration(..) ) -import Database.Schema.Migrations.Store ( StoreData - , storeLookup - , storeMigrations - ) +import System.Exit (ExitCode (..), exitWith) +import System.IO + ( BufferMode (..) + , hFlush + , hGetBuffering + , hSetBuffering + , stdin + , stdout + ) + +import Database.Schema.Migrations (migrationsToApply, migrationsToRevert) +import Database.Schema.Migrations.Backend (Backend (..)) +import Database.Schema.Migrations.Migration (Migration (..)) +import Database.Schema.Migrations.Store + ( StoreData + , storeLookup + , storeMigrations + ) import Moo.Core getCurrentTimestamp :: IO Text @@ -43,21 +52,23 @@ apply m storeData backend complain = do toApply <- migrationsToApply storeData backend m -- Apply them - if null toApply then - nothingToDo >> return [] else + if null toApply + then + nothingToDo >> return [] + else mapM_ (applyIt backend) toApply >> return toApply - - where - nothingToDo = - when complain $ - putStrLn . cs $ "Nothing to do; " <> - mId m <> - " already installed." - - applyIt conn it = do - putStr . cs $ "Applying: " <> mId it <> "... " - applyMigration conn it - putStrLn "done." + where + nothingToDo = + when complain $ + putStrLn . cs $ + "Nothing to do; " + <> mId m + <> " already installed." + + applyIt conn it = do + putStr . cs $ "Applying: " <> mId it <> "... " + applyMigration conn it + putStrLn "done." revert :: Migration -> StoreData -> Backend -> IO [Migration] revert m storeData backend = do @@ -65,21 +76,22 @@ revert m storeData backend = do toRevert <- liftIO $ migrationsToRevert storeData backend m -- Revert them - if null toRevert then - nothingToDo >> return [] else + if null toRevert + then + nothingToDo >> return [] + else mapM_ (revertIt backend) toRevert >> return toRevert - - where - nothingToDo = - putStrLn . cs $ "Nothing to do; " <> - mId m <> - " not installed." - - revertIt conn it = do - putStr . cs $ "Reverting: " <> mId it <> "... " - revertMigration conn it - putStrLn "done." - + where + nothingToDo = + putStrLn . cs $ + "Nothing to do; " + <> mId m + <> " not installed." + + revertIt conn it = do + putStr . cs $ "Reverting: " <> mId it <> "... " + revertMigration conn it + putStrLn "done." lookupMigration :: StoreData -> Text -> IO Migration lookupMigration storeData name = do @@ -104,17 +116,20 @@ confirmCreation :: Text -> [Text] -> IO Bool confirmCreation migrationId deps = do putStrLn "" putStrLn . cs $ "Confirm: create migration '" <> migrationId <> "'" - if null deps then putStrLn " (No dependencies)" - else putStrLn "with dependencies:" + if null deps + then putStrLn " (No dependencies)" + else putStrLn "with dependencies:" forM_ deps $ \d -> putStrLn . cs $ " " <> d - prompt "Are you sure?" [ ('y', (True, Nothing)) - , ('n', (False, Nothing)) - ] + prompt + "Are you sure?" + [ ('y', (True, Nothing)) + , ('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. -prompt :: (Eq a) => String -> PromptChoices a -> IO a +prompt :: Eq a => String -> PromptChoices a -> IO a prompt _ [] = error "prompt requires a list of choices" prompt message choiceMap = do putStr $ message ++ " (" ++ choiceStr ++ helpChar ++ "): " @@ -126,23 +141,28 @@ prompt message choiceMap = do when (c == 'h') $ putStr $ mkPromptHelp choiceMapWithHelp retry Just (val, _) -> putStrLn "" >> return val - where - retry = prompt message choiceMap - choiceStr = intercalate "" $ map (return . fst) choiceMap - helpChar = if hasHelp choiceMap then "h" else "" - choiceMapWithHelp = choiceMap ++ [('h', (undefined, Just "this help"))] + where + retry = prompt message choiceMap + choiceStr = intercalate "" $ map (return . fst) choiceMap + 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 mkPromptHelp choices = - intercalate "" [ [c] ++ ": " ++ fromJust msg ++ "\n" | - (c, (_, msg)) <- choices, isJust msg ] + 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 + where + hasMsg (_, (_, m)) = isJust m -- A general type for a set of choices that the user can make at a -- prompt. @@ -161,7 +181,7 @@ unbufferedGetChar = do -- The types for choices the user can make when being prompted for -- dependencies. data AskDepsChoice = Yes | No | View | Done | Quit - deriving (Eq) + deriving (Eq) -- Interactively ask the user about which dependencies should be used -- when creating a new migration. @@ -171,68 +191,74 @@ interactiveAskDeps storeData = do -- added, ask the user if it should be added to a dependency list let sorted = sortBy compareTimestamps $ storeMigrations storeData interactiveAskDeps' storeData (map mId sorted) - where - compareTimestamps m1 m2 = compare (mTimestamp m2) (mTimestamp m1) + 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. interactiveAskDeps' :: StoreData -> [Text] -> IO [Text] interactiveAskDeps' _ [] = return [] -interactiveAskDeps' storeData (name:rest) = do +interactiveAskDeps' storeData (name : rest) = do result <- prompt ("Depend on '" ++ cs name ++ "'?") askDepsChoices - if result == Done then return [] else - case result of - Yes -> do - next <- interactiveAskDeps' storeData rest - return $ name:next - No -> interactiveAskDeps' storeData rest - View -> do - -- load migration - let Just m = storeLookup storeData name - -- print out description, timestamp, deps - when (isJust $ mDesc m) - (putStrLn . cs $ " Description: " <> - fromJust (mDesc m)) - putStrLn $ " Created: " ++ show (mTimestamp m) - unless (null $ mDeps m) - (putStrLn . cs $ " Deps: " <> - T.intercalate "\n " (mDeps m)) - -- ask again - interactiveAskDeps' storeData (name:rest) - Quit -> do - putStrLn "cancelled." - exitWith (ExitFailure 1) - Done -> return [] + if result == Done + then return [] + else case result of + Yes -> do + next <- interactiveAskDeps' storeData rest + return $ name : next + No -> interactiveAskDeps' storeData rest + View -> do + -- load migration + let Just m = storeLookup storeData name + -- print out description, timestamp, deps + when + (isJust $ mDesc m) + ( putStrLn . cs $ + " Description: " + <> fromJust (mDesc m) + ) + putStrLn $ " Created: " ++ show (mTimestamp m) + unless + (null $ mDeps m) + ( putStrLn . cs $ + " Deps: " + <> T.intercalate "\n " (mDeps m) + ) + -- ask again + interactiveAskDeps' storeData (name : rest) + Quit -> do + putStrLn "cancelled." + exitWith (ExitFailure 1) + Done -> return [] -- The choices the user can make when being prompted for dependencies. askDepsChoices :: PromptChoices AskDepsChoice -askDepsChoices = [ ('y', (Yes, Just "yes, depend on this migration")) - , ('n', (No, Just "no, do not depend on this migration")) - , ('v', (View, Just "view migration details")) - , ('d', (Done, Just "done, do not ask me about more dependencies")) - , ('q', (Quit, Just "cancel this operation and quit")) - ] +askDepsChoices = + [ ('y', (Yes, Just "yes, depend on this migration")) + , ('n', (No, Just "no, do not depend on this migration")) + , ('v', (View, Just "view migration details")) + , ('d', (Done, Just "done, do not ask me about more dependencies")) + , ('q', (Quit, Just "cancel this operation and quit")) + ] -- The following code is vendored from MissingH Data.List.Utils: -{- | Similar to Data.List.span, but performs the test on the entire remaining -list instead of just one element. - -@spanList p xs@ is the same as @(takeWhileList p xs, dropWhileList p xs)@ --} +-- | Similar to Data.List.span, but performs the test on the entire remaining +-- list instead of just one element. +-- +-- @spanList p xs@ is the same as @(takeWhileList p xs, dropWhileList p xs)@ spanList :: ([a] -> Bool) -> [a] -> ([a], [a]) - -spanList _ [] = ([],[]) -spanList func list@(x:xs) = - if func list - then (x:ys,zs) - else ([],list) - where (ys,zs) = spanList func xs - -{- | Similar to Data.List.break, but performs the test on the entire remaining -list instead of just one element. --} +spanList _ [] = ([], []) +spanList func list@(x : xs) = + if func list + then (x : ys, zs) + else ([], list) + where + (ys, zs) = spanList func xs + +-- | Similar to Data.List.break, but performs the test on the entire remaining +-- list instead of just one element. breakList :: ([a] -> Bool) -> [a] -> ([a], [a]) breakList func = spanList (not . func) @@ -243,8 +269,9 @@ split :: Eq a => [a] -> [a] -> [[a]] split _ [] = [] split delim str = let (firstline, remainder) = breakList (isPrefixOf delim) str - in firstline : case remainder of - [] -> [] - x -> if x == delim - then [[]] - else split delim (drop (length delim) x) + in firstline : case remainder of + [] -> [] + x -> + if x == delim + then [[]] + else split delim (drop (length delim) x) diff --git a/src/Moo/Core.hs b/src/Moo/Core.hs index 979908d..b7e3c77 100644 --- a/src/Moo/Core.hs +++ b/src/Moo/Core.hs @@ -1,77 +1,83 @@ {-# LANGUAGE ExistentialQuantification #-} + module Moo.Core - ( AppT - , CommandHandler - , CommandOptions (..) - , Command (..) - , AppState (..) - , Configuration (..) - , makeParameters - , ExecutableParameters (..) - , envDatabaseName - , envLinearMigrations - , envStoreName - , loadConfiguration) where - -import Data.Text ( Text ) + ( AppT + , CommandHandler + , CommandOptions (..) + , Command (..) + , AppState (..) + , Configuration (..) + , makeParameters + , ExecutableParameters (..) + , envDatabaseName + , envLinearMigrations + , envStoreName + , loadConfiguration + ) where + +import Data.Text (Text) import Control.Monad.Reader (ReaderT) +import Data.Char (toLower) import qualified Data.Configurator as C import Data.Configurator.Types (Config, Configured) +import Data.Maybe (fromMaybe) import qualified Data.Text as T -import Data.Char (toLower) import System.Environment (getEnvironment) -import Data.Maybe (fromMaybe) -import Database.Schema.Migrations.Store (MigrationStore, StoreData) import Database.Schema.Migrations.Backend +import Database.Schema.Migrations.Store (MigrationStore, StoreData) --- |The monad in which the application runs. +-- | 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 +-- | 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 :: [Text] - , _appOptionalArgs :: [Text] - , _appBackend :: Backend - , _appStore :: MigrationStore - , _appStoreData :: StoreData - , _appLinearMigrations :: Bool - , _appTimestampFilenames :: Bool - } +-- | Application state which can be accessed by any command handler. +data AppState = AppState + { _appOptions :: CommandOptions + , _appCommand :: Command + , _appRequiredArgs :: [Text] + , _appOptionalArgs :: [Text] + , _appBackend :: Backend + , _appStore :: MigrationStore + , _appStoreData :: StoreData + , _appLinearMigrations :: Bool + , _appTimestampFilenames :: Bool + } type ShellEnvironment = [(String, String)] --- |Intermediate type used during config loading. +-- | Intermediate type used during config loading. data LoadConfig = LoadConfig - { _lcConnectionString :: Maybe String - , _lcMigrationStorePath :: Maybe FilePath - , _lcLinearMigrations :: Maybe Bool - , _lcTimestampFilenames :: Maybe Bool - } deriving Show - --- |Loading the configuration from a file or having it specified via environment --- |variables results in a value of type Configuration. + { _lcConnectionString :: Maybe String + , _lcMigrationStorePath :: Maybe FilePath + , _lcLinearMigrations :: Maybe Bool + , _lcTimestampFilenames :: Maybe Bool + } + deriving (Show) + +-- | Loading the configuration from a file or having it specified via environment +-- |variables results in a value of type Configuration. data Configuration = Configuration - { _connectionString :: String - , _migrationStorePath :: FilePath - , _linearMigrations :: Bool - , _timestampFilenames :: Bool - } deriving Show - --- |A value of type ExecutableParameters is what a moo executable (moo-postgresql, --- |moo-mysql, etc.) pass to the core package when they want to execute a --- |command. + { _connectionString :: String + , _migrationStorePath :: FilePath + , _linearMigrations :: Bool + , _timestampFilenames :: Bool + } + deriving (Show) + +-- | A value of type ExecutableParameters is what a moo executable (moo-postgresql, +-- |moo-mysql, etc.) pass to the core package when they want to execute a +-- |command. data ExecutableParameters = ExecutableParameters - { _parametersBackend :: Backend - , _parametersMigrationStorePath :: FilePath - , _parametersLinearMigrations :: Bool - , _parametersTimestampFilenames :: Bool - } deriving Show + { _parametersBackend :: Backend + , _parametersMigrationStorePath :: FilePath + , _parametersLinearMigrations :: Bool + , _parametersTimestampFilenames :: Bool + } + deriving (Show) defConfigFile :: String defConfigFile = "moo.cfg" @@ -81,35 +87,35 @@ newLoadConfig = LoadConfig Nothing Nothing Nothing Nothing validateLoadConfig :: LoadConfig -> Either String Configuration validateLoadConfig (LoadConfig Nothing _ _ _) = - Left "Invalid configuration: connection string not specified" + Left "Invalid configuration: connection string not specified" validateLoadConfig (LoadConfig _ Nothing _ _) = - Left "Invalid configuration: migration store path not specified" + Left "Invalid configuration: migration store path not specified" validateLoadConfig (LoadConfig (Just cs) (Just msp) lm ts) = - Right $ Configuration cs msp (fromMaybe False lm) (fromMaybe False ts) + Right $ Configuration cs msp (fromMaybe False lm) (fromMaybe False ts) --- |Setters for fields of 'LoadConfig'. -lcConnectionString, lcMigrationStorePath +-- | Setters for fields of 'LoadConfig'. +lcConnectionString + , lcMigrationStorePath :: LoadConfig -> Maybe String -> LoadConfig -lcConnectionString c v = c { _lcConnectionString = v } -lcMigrationStorePath c v = c { _lcMigrationStorePath = v } +lcConnectionString c v = c {_lcConnectionString = v} +lcMigrationStorePath c v = c {_lcMigrationStorePath = v} lcLinearMigrations :: LoadConfig -> Maybe Bool -> LoadConfig -lcLinearMigrations c v = c { _lcLinearMigrations = v } +lcLinearMigrations c v = c {_lcLinearMigrations = v} lcTimestampFilenames :: LoadConfig -> Maybe Bool -> LoadConfig -lcTimestampFilenames c v = c { _lcTimestampFilenames = v } - +lcTimestampFilenames c v = c {_lcTimestampFilenames = v} -- | @f .= v@ invokes f only if v is 'Just' -(.=) :: (Monad m) => (a -> Maybe b -> a) -> m (Maybe b) -> m (a -> a) +(.=) :: Monad m => (a -> Maybe b -> a) -> m (Maybe b) -> m (a -> a) (.=) f v' = do - v <- v' - return $ case v of - Just _ -> flip f v - _ -> id + v <- v' + return $ case v of + Just _ -> flip f v + _ -> id --- |It's just @flip '<*>'@ -(&) :: (Applicative m) => m a -> m (a -> b) -> m b +-- | It's just @flip '<*>'@ +(&) :: Applicative m => m a -> m (a -> b) -> m b (&) = flip (<*>) infixr 3 .= @@ -117,70 +123,88 @@ infixl 2 & applyEnvironment :: ShellEnvironment -> LoadConfig -> IO LoadConfig applyEnvironment env lc = - return lc & lcConnectionString .= f envDatabaseName - & lcMigrationStorePath .= f envStoreName - & lcLinearMigrations .= readFlag <$> f envLinearMigrations - & lcTimestampFilenames .= readFlag <$> f envTimestampFilenames - where f n = return $ lookup n env + return lc + & lcConnectionString + .= f envDatabaseName + & lcMigrationStorePath + .= f envStoreName + & lcLinearMigrations + .= readFlag + <$> f envLinearMigrations + & lcTimestampFilenames + .= readFlag + <$> f envTimestampFilenames + where + f n = return $ lookup n env applyConfigFile :: Config -> LoadConfig -> IO LoadConfig applyConfigFile cfg lc = - return lc & lcConnectionString .= f envDatabaseName - & lcMigrationStorePath .= f envStoreName - & lcLinearMigrations .= f envLinearMigrations - & lcTimestampFilenames .= f envTimestampFilenames - where - f :: Configured a => String -> IO (Maybe a) - f = C.lookup cfg . T.pack - --- |Loads config file (falling back to default one if not specified) and then --- overrides configuration with an environment. + return lc + & lcConnectionString + .= f envDatabaseName + & lcMigrationStorePath + .= f envStoreName + & lcLinearMigrations + .= f envLinearMigrations + & lcTimestampFilenames + .= f envTimestampFilenames + where + f :: Configured a => String -> IO (Maybe a) + f = C.lookup cfg . T.pack + +-- | Loads config file (falling back to default one if not specified) and then +-- overrides configuration with an environment. loadConfiguration :: Maybe FilePath -> IO (Either String Configuration) loadConfiguration pth = do - file <- maybe (C.load [C.Optional defConfigFile]) - (\p -> C.load [C.Required p]) pth - env <- getEnvironment - cfg <- applyConfigFile file newLoadConfig >>= applyEnvironment env + file <- + maybe + (C.load [C.Optional defConfigFile]) + (\p -> C.load [C.Required p]) + pth + env <- getEnvironment + cfg <- applyConfigFile file newLoadConfig >>= applyEnvironment env - return $ validateLoadConfig cfg + return $ validateLoadConfig cfg makeParameters :: Configuration -> Backend -> ExecutableParameters makeParameters conf backend = - ExecutableParameters - { _parametersBackend = backend + ExecutableParameters + { _parametersBackend = backend , _parametersMigrationStorePath = _migrationStorePath conf - , _parametersLinearMigrations = _linearMigrations conf + , _parametersLinearMigrations = _linearMigrations conf , _parametersTimestampFilenames = _timestampFilenames conf } --- |Converts @Just "on"@ and @Just "true"@ (case insensitive) to @True@, --- anything else to @False@. +-- | Converts @Just "on"@ and @Just "true"@ (case insensitive) to @True@, +-- anything else to @False@. readFlag :: Maybe String -> Maybe Bool -readFlag Nothing = Nothing +readFlag Nothing = Nothing readFlag (Just v) = go $ map toLower v - where - go "on" = Just True - go "true" = Just True - go "off" = Just False - go "false" = Just False - go _ = Nothing - --- |CommandOptions are those options that can be specified at the command --- prompt to modify the behavior of a command. -data CommandOptions = CommandOptions { _configFilePath :: Maybe String - , _test :: Bool - , _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 - , _cRequired :: [String] - , _cOptional :: [String] - , _cAllowedOptions :: [String] - , _cDescription :: String - , _cHandler :: CommandHandler - } + where + go "on" = Just True + go "true" = Just True + go "off" = Just False + go "false" = Just False + go _ = Nothing + +-- | CommandOptions are those options that can be specified at the command +-- prompt to modify the behavior of a command. +data CommandOptions = CommandOptions + { _configFilePath :: Maybe String + , _test :: Bool + , _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 + , _cRequired :: [String] + , _cOptional :: [String] + , _cAllowedOptions :: [String] + , _cDescription :: String + , _cHandler :: CommandHandler + } envDatabaseName :: String envDatabaseName = "DBM_DATABASE" @@ -193,4 +217,3 @@ envLinearMigrations = "DBM_LINEAR_MIGRATIONS" envTimestampFilenames :: String envTimestampFilenames = "DBM_TIMESTAMP_FILENAMES" - diff --git a/src/Moo/Main.hs b/src/Moo/Main.hs index 19549dc..c257aeb 100644 --- a/src/Moo/Main.hs +++ b/src/Moo/Main.hs @@ -1,28 +1,32 @@ {-# LANGUAGE OverloadedStrings #-} + module Moo.Main - ( mainWithParameters - , ExecutableParameters (..) - , Configuration (..) - , Args - , usage - , usageSpecific - , procArgs - ) + ( mainWithParameters + , ExecutableParameters (..) + , Configuration (..) + , Args + , usage + , usageSpecific + , procArgs + ) where -import Control.Monad (forM_, when) -import Control.Monad.Reader (runReaderT) -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) +import Control.Monad (forM_, when) +import Control.Monad.Reader (runReaderT) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Database.HDBC (SqlError, catchSql, seErrorMsg) +import System.Environment (getProgName) +import System.Exit (ExitCode (ExitFailure), exitWith) +import Prelude hiding (lookup) -import Database.Schema.Migrations.Filesystem (filesystemStore, FilesystemStoreSettings(..)) -import Database.Schema.Migrations.Store -import Moo.CommandInterface -import Moo.Core +import Database.Schema.Migrations.Filesystem + ( FilesystemStoreSettings (..) + , filesystemStore + ) +import Database.Schema.Migrations.Store +import Moo.CommandInterface +import Moo.Core type Args = [String] @@ -34,12 +38,15 @@ usage = do putStrLn "Environment:" putStrLn $ " " ++ envDatabaseName ++ ": database connection string" putStrLn $ " " ++ envStoreName ++ ": path to migration store" - putStrLn $ " " ++ envLinearMigrations ++ ": whether to use linear migrations (defaults to False)" + putStrLn $ + " " + ++ envLinearMigrations + ++ ": whether to use linear migrations (defaults to False)" putStrLn "Commands:" forM_ commands $ \command -> do - putStrLn $ " " ++ usageString command - putStrLn $ " " ++ _cDescription command - putStrLn "" + putStrLn $ " " ++ usageString command + putStrLn $ " " ++ _cDescription command + putStrLn "" putStrLn commandOptionUsage exitWith (ExitFailure 1) @@ -55,8 +62,8 @@ procArgs args = do when (null args) usage command <- case findCommand $ head args of - Nothing -> usage - Just c -> return c + Nothing -> usage + Just c -> return c (opts, required) <- getCommandArgs $ tail args @@ -66,31 +73,35 @@ mainWithParameters :: Args -> ExecutableParameters -> IO () mainWithParameters args parameters = do (command, opts, required) <- procArgs args - let storePathStr = _parametersMigrationStorePath parameters - store = filesystemStore $ FSStore { storePath = storePathStr } - linear = _parametersLinearMigrations parameters - - if length required < length ( _cRequired command) then - usageSpecific command else - do - loadedStoreData <- loadMigrations store - case loadedStoreData of - Left es -> do - putStrLn "There were errors in the migration store:" - forM_ es $ \err -> putStrLn $ " " ++ show err - Right storeData -> do - let st = AppState { _appOptions = opts - , _appCommand = command - , _appRequiredArgs = map cs required - , _appOptionalArgs = ["" :: Text] - , _appBackend = _parametersBackend parameters - , _appStore = store - , _appStoreData = storeData - , _appLinearMigrations = linear - , _appTimestampFilenames = - _parametersTimestampFilenames parameters - } - runReaderT (_cHandler command storeData) st `catchSql` reportSqlError + let + storePathStr = _parametersMigrationStorePath parameters + store = filesystemStore $ FSStore {storePath = storePathStr} + linear = _parametersLinearMigrations parameters + + if length required < length (_cRequired command) + then + usageSpecific command + else do + loadedStoreData <- loadMigrations store + case loadedStoreData of + Left es -> do + putStrLn "There were errors in the migration store:" + forM_ es $ \err -> putStrLn $ " " ++ show err + Right storeData -> do + let st = + AppState + { _appOptions = opts + , _appCommand = command + , _appRequiredArgs = map cs required + , _appOptionalArgs = ["" :: Text] + , _appBackend = _parametersBackend parameters + , _appStore = store + , _appStoreData = storeData + , _appLinearMigrations = linear + , _appTimestampFilenames = + _parametersTimestampFilenames parameters + } + runReaderT (_cHandler command storeData) st `catchSql` reportSqlError reportSqlError :: SqlError -> IO a reportSqlError e = do diff --git a/src/StoreManager.hs b/src/StoreManager.hs index b46e0f9..37c4c6e 100644 --- a/src/StoreManager.hs +++ b/src/StoreManager.hs @@ -1,90 +1,97 @@ module Main where -import Control.Applicative ( (<$>) ) +import Control.Applicative ((<$>)) import Control.Monad.State import qualified Data.Map as Map +import System.Directory + ( getTemporaryDirectory + ) import System.Environment - ( getArgs - , getProgName - , getEnvironment - ) + ( getArgs + , getEnvironment + , getProgName + ) import System.Exit - ( exitFailure - ) + ( exitFailure + ) import System.IO - ( Handle - , hClose - , openTempFile - , hPutStr - ) -import System.Directory - ( getTemporaryDirectory - ) -import System.Process + ( Handle + , hClose + , hPutStr + , openTempFile + ) import System.Posix.Files - ( removeLink - ) + ( removeLink + ) +import System.Process import Data.Maybe - ( fromJust - ) + ( fromJust + ) -import Graphics.Vty -import Graphics.Vty.Widgets.All import Database.Schema.Migrations.Filesystem import Database.Schema.Migrations.Migration - ( Migration(..) - ) + ( Migration (..) + ) import Database.Schema.Migrations.Store +import Graphics.Vty +import Graphics.Vty.Widgets.All -- XXX Generalize over all MigrationStore instances -data AppState = AppState { appStoreData :: StoreData - , appStore :: FilesystemStore - , appMigrationList :: SimpleList - , appVty :: Vty - } +data AppState = AppState + { appStoreData :: StoreData + , appStore :: FilesystemStore + , appMigrationList :: SimpleList + , appVty :: Vty + } type AppM = StateT AppState IO titleAttr :: Attr -titleAttr = def_attr - `with_back_color` blue - `with_fore_color` bright_white +titleAttr = + def_attr + `with_back_color` blue + `with_fore_color` bright_white bodyAttr :: Attr -bodyAttr = def_attr - `with_back_color` black - `with_fore_color` bright_white +bodyAttr = + def_attr + `with_back_color` black + `with_fore_color` bright_white fieldAttr :: Attr -fieldAttr = def_attr - `with_back_color` black - `with_fore_color` bright_green +fieldAttr = + def_attr + `with_back_color` black + `with_fore_color` bright_green selAttr :: Attr -selAttr = def_attr - `with_back_color` yellow - `with_fore_color` black +selAttr = + def_attr + `with_back_color` yellow + `with_fore_color` black scrollListUp :: AppState -> AppState scrollListUp appst = - appst { appMigrationList = scrollUp $ appMigrationList appst } + appst {appMigrationList = scrollUp $ appMigrationList appst} scrollListDown :: AppState -> AppState scrollListDown appst = - appst { appMigrationList = scrollDown $ appMigrationList appst } + appst {appMigrationList = scrollDown $ appMigrationList appst} -eventloop :: (Widget a) => AppM a -> (Event -> AppM Bool) -> AppM () +eventloop :: Widget a => AppM a -> (Event -> AppM Bool) -> AppM () eventloop uiBuilder handle = do w <- uiBuilder vty <- gets appVty evt <- liftIO $ do - (img, _) <- mkImage vty w - update vty $ pic_for_image img - next_event vty + (img, _) <- mkImage vty w + update vty $ pic_for_image img + next_event vty next <- handle evt - if next then - eventloop uiBuilder handle else + if next + then + eventloop uiBuilder handle + else return () continue :: AppM Bool @@ -100,24 +107,29 @@ handleEvent (EvKey (KASCII 'q') []) = stop handleEvent (EvKey (KASCII 'e') []) = editCurrentMigration >> continue handleEvent (EvResize w h) = do let wSize = appropriateListWindow $ DisplayRegion (toEnum w) (toEnum h) - modify (\appst -> appst { appMigrationList = (appMigrationList appst) { scrollWindowSize = wSize }}) + modify + ( \appst -> + appst + { appMigrationList = (appMigrationList appst) {scrollWindowSize = wSize} + } + ) continue handleEvent _ = continue -withTempFile :: (MonadIO m) => (Handle -> FilePath -> m a) -> m a +withTempFile :: MonadIO m => (Handle -> FilePath -> m a) -> m a withTempFile act = do (tempFilePath, newFile) <- liftIO $ createTempFile result <- act newFile tempFilePath liftIO $ cleanup newFile tempFilePath return result - where - createTempFile = do - tempDir <- getTemporaryDirectory - openTempFile tempDir "migration.txt" + where + createTempFile = do + tempDir <- getTemporaryDirectory + openTempFile tempDir "migration.txt" - cleanup handle tempFilePath = do - (hClose handle) `catch` (\_ -> return ()) - removeLink tempFilePath + cleanup handle tempFilePath = do + (hClose handle) `catch` (\_ -> return ()) + removeLink tempFilePath editCurrentMigration :: AppM () editCurrentMigration = do @@ -128,56 +140,63 @@ editCurrentMigration = do vty <- gets appVty withTempFile $ \tempHandle tempPath -> - liftIO $ do - -- Copy the migration to a temporary file - readFile migrationPath >>= hPutStr tempHandle - hClose tempHandle - - shutdown vty - - currentEnv <- getEnvironment - let editor = maybe "vi" id $ lookup "EDITOR" currentEnv - spawnEditor = do - -- Invoke an editor to edit the temporary file - (_, _, _, pHandle) <- createProcess $ shell $ editor ++ " " ++ tempPath - waitForProcess pHandle - - -- Once the editor closes, validate the temporary file - validateResult <- migrationFromPath tempPath - case validateResult of - Left e -> do - putStrLn $ "Error in edited migration: " ++ e - putStrLn $ "Try again? (y/n) " - c <- getChar - if c == 'y' then spawnEditor else return False - Right _ -> return True - - proceed <- spawnEditor - - -- Replace the original migration with the contents of the - -- temporary file - when (proceed) (readFile tempPath >>= writeFile migrationPath) + liftIO $ do + -- Copy the migration to a temporary file + readFile migrationPath >>= hPutStr tempHandle + hClose tempHandle + + shutdown vty + + currentEnv <- getEnvironment + let + editor = maybe "vi" id $ lookup "EDITOR" currentEnv + spawnEditor = do + -- Invoke an editor to edit the temporary file + (_, _, _, pHandle) <- createProcess $ shell $ editor ++ " " ++ tempPath + waitForProcess pHandle + + -- Once the editor closes, validate the temporary file + validateResult <- migrationFromPath tempPath + case validateResult of + Left e -> do + putStrLn $ "Error in edited migration: " ++ e + putStrLn $ "Try again? (y/n) " + c <- getChar + if c == 'y' then spawnEditor else return False + Right _ -> return True + + proceed <- spawnEditor + + -- Replace the original migration with the contents of the + -- temporary file + when (proceed) (readFile tempPath >>= writeFile migrationPath) -- Reinitialize application state put =<< (liftIO $ mkState store) getSelectedMigration :: AppState -> Migration getSelectedMigration appst = fromJust $ Map.lookup (fst $ getSelected list) mMap - where mMap = storeDataMapping $ appStoreData appst - list = appMigrationList appst + where + mMap = storeDataMapping $ appStoreData appst + list = appMigrationList appst buildUi :: AppState -> Box buildUi appst = - let header = text titleAttr (" " ++ (storePath $ appStore appst) ++ " ") - <++> hFill titleAttr '-' 1 - <++> text titleAttr " Store Manager " - status = text bodyAttr $ maybe "" id $ mDesc $ getSelectedMigration appst - helpBar = text titleAttr "q:quit e:edit " - <++> hFill titleAttr '-' 1 - in header - <--> appMigrationList appst - <--> helpBar - <--> status + let + header = + text titleAttr (" " ++ (storePath $ appStore appst) ++ " ") + <++> hFill titleAttr '-' 1 + <++> text titleAttr " Store Manager " + status = + text bodyAttr $ maybe "" id $ mDesc $ getSelectedMigration appst + helpBar = + text titleAttr "q:quit e:edit " + <++> hFill titleAttr '-' 1 + in + header + <--> appMigrationList appst + <--> helpBar + <--> status uiFromState :: AppM Box uiFromState = buildUi <$> get @@ -187,10 +206,10 @@ readStore store = do result <- loadMigrations store case result of Left es -> do - putStrLn "There were errors in the migration store:" - forM_ es $ \err -> do - putStrLn $ " " ++ show err - exitFailure + putStrLn "There were errors in the migration store:" + forM_ es $ \err -> do + putStrLn $ " " ++ show err + exitFailure Right theStoreData -> return theStoreData mkState :: FilesystemStore -> IO AppState @@ -198,13 +217,16 @@ mkState fsStore = do vty <- mkVty sz <- display_bounds $ terminal vty storeData <- readStore fsStore - let migrationList = mkSimpleList bodyAttr selAttr (appropriateListWindow sz) migrationNames - migrationNames = Map.keys $ storeDataMapping storeData - return $ AppState { appStoreData = storeData - , appStore = fsStore - , appMigrationList = migrationList - , appVty = vty - } + let + migrationList = mkSimpleList bodyAttr selAttr (appropriateListWindow sz) migrationNames + migrationNames = Map.keys $ storeDataMapping storeData + return $ + AppState + { appStoreData = storeData + , appStore = fsStore + , appMigrationList = migrationList + , appVty = vty + } appropriateListWindow :: DisplayRegion -> Int appropriateListWindow sz = fromEnum $ region_height sz - 3 @@ -214,11 +236,11 @@ main = do args <- getArgs when (length args /= 1) $ do - p <- getProgName - putStrLn ("Usage: " ++ p ++ " ") - exitFailure + p <- getProgName + putStrLn ("Usage: " ++ p ++ " ") + exitFailure - let store = FSStore { storePath = args !! 0 } + let store = FSStore {storePath = args !! 0} beginState <- mkState store @@ -229,4 +251,4 @@ main = do -- Clear the screen. reserve_display $ terminal endVty - shutdown endVty \ No newline at end of file + shutdown endVty diff --git a/test/Common.hs b/test/Common.hs index 51e17f0..d71e88c 100644 --- a/test/Common.hs +++ b/test/Common.hs @@ -1,21 +1,22 @@ {-# LANGUAGE TemplateHaskell #-} + module Common - ( TestDependable(..) - , repoRoot - , testFile - , satisfies - , (.&&.) - ) + ( TestDependable (..) + , repoRoot + , testFile + , satisfies + , (.&&.) + ) where -import Data.Text ( Text ) +import Data.Text (Text) import CommonTH -import System.FilePath ( () ) import Language.Haskell.TH.Syntax (lift) +import System.FilePath (()) import Test.HUnit -import Database.Schema.Migrations.Dependencies ( Dependable(..) ) +import Database.Schema.Migrations.Dependencies (Dependable (..)) repoRoot :: FilePath repoRoot = $(getRepoRoot >>= lift) @@ -24,14 +25,14 @@ testFile :: FilePath -> FilePath testFile fp = repoRoot "test" fp instance Dependable TestDependable where - depId = tdId - depsOf = tdDeps - -data TestDependable = TD { tdId :: Text - , tdDeps :: [Text] - } - deriving (Show, Eq, Ord) + depId = tdId + depsOf = tdDeps +data TestDependable = TD + { tdId :: Text + , tdDeps :: [Text] + } + deriving (Show, Eq, Ord) satisfies :: String -> a -> (a -> Bool) -> IO Test satisfies m v f = return $ TestCase $ assertBool m (f v) @@ -39,6 +40,6 @@ satisfies m v f = return $ TestCase $ assertBool m (f v) (.&&.) :: Test -> Test -> Test (TestList xs) .&&. (TestList ys) = TestList (xs ++ ys) (TestList xs) .&&. y = TestList (xs ++ [y]) -x .&&. (TestList ys) = TestList (x:ys) +x .&&. (TestList ys) = TestList (x : ys) a .&&. b = TestList [a, b] infixl 0 .&&. diff --git a/test/CommonTH.hs b/test/CommonTH.hs index 369c968..72f2b74 100644 --- a/test/CommonTH.hs +++ b/test/CommonTH.hs @@ -1,16 +1,21 @@ module CommonTH - ( getRepoRoot - ) + ( getRepoRoot + ) where import Language.Haskell.TH -import System.FilePath ( takeDirectory, combine ) -import System.Directory ( getCurrentDirectory, canonicalizePath ) +import System.Directory (canonicalizePath, getCurrentDirectory) +import System.FilePath (combine, takeDirectory) getRepoRoot :: Q FilePath getRepoRoot = - do here <- location - cwd <- runIO getCurrentDirectory - let thisFileName = combine cwd $ loc_filename here - -- XXX: This depends on the location of this file in the source tree - return =<< runIO $ canonicalizePath $ head $ drop 2 $ iterate takeDirectory thisFileName + do + here <- location + cwd <- runIO getCurrentDirectory + let thisFileName = combine cwd $ loc_filename here + -- XXX: This depends on the location of this file in the source tree + return =<< runIO $ + canonicalizePath $ + head $ + drop 2 $ + iterate takeDirectory thisFileName diff --git a/test/ConfigurationTest.hs b/test/ConfigurationTest.hs index 943d1ea..0a999b1 100644 --- a/test/ConfigurationTest.hs +++ b/test/ConfigurationTest.hs @@ -1,33 +1,35 @@ module ConfigurationTest (tests) where -import Control.Exception (SomeException, try) -import Data.Either (isLeft, isRight) -import System.Directory -import System.Environment (setEnv, unsetEnv) -import Test.HUnit +import Control.Exception (SomeException, try) +import Data.Either (isLeft, isRight) +import System.Directory +import System.Environment (setEnv, unsetEnv) +import Test.HUnit -import Common -import Moo.Core +import Common +import Moo.Core tests :: IO [Test] tests = sequence [prepareTestEnv >> e | e <- entries] - where entries = [ loadsConfigFile - , loadsPropertiesFromFile - , loadsDefaultConfigFile - , environmentOverridesProperties - , ifNoConfigFileIsAvailableEnvironmentIsUsed - , throwsWhenConfigFileIsInvalid - , returnsErrorWhenNotAllPropertiesAreSet - , canReadTimestampsConfig - ] + where + entries = + [ loadsConfigFile + , loadsPropertiesFromFile + , loadsDefaultConfigFile + , environmentOverridesProperties + , ifNoConfigFileIsAvailableEnvironmentIsUsed + , throwsWhenConfigFileIsInvalid + , returnsErrorWhenNotAllPropertiesAreSet + , canReadTimestampsConfig + ] prepareTestEnv :: IO () prepareTestEnv = do - setCurrentDirectory $ testFile "config_loading" - unsetEnv "DBM_DATABASE" - unsetEnv "DBM_MIGRATION_STORE" - unsetEnv "DBM_LINEAR_MIGRATIONS" - unsetEnv "DBM_TIMESTAMP_FILENAMES" + setCurrentDirectory $ testFile "config_loading" + unsetEnv "DBM_DATABASE" + unsetEnv "DBM_MIGRATION_STORE" + unsetEnv "DBM_LINEAR_MIGRATIONS" + unsetEnv "DBM_TIMESTAMP_FILENAMES" canReadTimestampsConfig :: IO Test canReadTimestampsConfig = do @@ -36,62 +38,70 @@ canReadTimestampsConfig = do loadsConfigFile :: IO Test loadsConfigFile = do - cfg' <- loadConfiguration (Just "cfg1.cfg") - satisfies "File not loaded" cfg' isRight + cfg' <- loadConfiguration (Just "cfg1.cfg") + satisfies "File not loaded" cfg' isRight loadsPropertiesFromFile :: IO Test loadsPropertiesFromFile = do - Right cfg <- loadConfiguration (Just "cfg1.cfg") - return - ( - _connectionString cfg ~?= "connection" .&&. - _migrationStorePath cfg ~?= "store" .&&. - _linearMigrations cfg ~?= True - ) + Right cfg <- loadConfiguration (Just "cfg1.cfg") + return + ( _connectionString cfg + ~?= "connection" + .&&. _migrationStorePath cfg + ~?= "store" + .&&. _linearMigrations cfg + ~?= True + ) loadsDefaultConfigFile :: IO Test loadsDefaultConfigFile = do - Right cfg <- loadConfiguration Nothing - return - ( - _connectionString cfg ~?= "mooconn" .&&. - _migrationStorePath cfg ~?= "moostore" .&&. - _linearMigrations cfg ~?= True - ) + Right cfg <- loadConfiguration Nothing + return + ( _connectionString cfg + ~?= "mooconn" + .&&. _migrationStorePath cfg + ~?= "moostore" + .&&. _linearMigrations cfg + ~?= True + ) environmentOverridesProperties :: IO Test environmentOverridesProperties = do - setEnv "DBM_DATABASE" "envconn" - setEnv "DBM_MIGRATION_STORE" "envstore" - setEnv "DBM_LINEAR_MIGRATIONS" "off" - Right cfg <- loadConfiguration (Just "cfg1.cfg") - return - ( - _connectionString cfg ~?= "envconn" .&&. - _migrationStorePath cfg ~?= "envstore" .&&. - _linearMigrations cfg ~?= False - ) + setEnv "DBM_DATABASE" "envconn" + setEnv "DBM_MIGRATION_STORE" "envstore" + setEnv "DBM_LINEAR_MIGRATIONS" "off" + Right cfg <- loadConfiguration (Just "cfg1.cfg") + return + ( _connectionString cfg + ~?= "envconn" + .&&. _migrationStorePath cfg + ~?= "envstore" + .&&. _linearMigrations cfg + ~?= False + ) ifNoConfigFileIsAvailableEnvironmentIsUsed :: IO Test ifNoConfigFileIsAvailableEnvironmentIsUsed = do - setCurrentDirectory $ testFile "" - setEnv "DBM_DATABASE" "envconn" - setEnv "DBM_MIGRATION_STORE" "envstore" - setEnv "DBM_LINEAR_MIGRATIONS" "off" - Right cfg <- loadConfiguration Nothing - return - ( - _connectionString cfg ~?= "envconn" .&&. - _migrationStorePath cfg ~?= "envstore" .&&. - _linearMigrations cfg ~?= False - ) + setCurrentDirectory $ testFile "" + setEnv "DBM_DATABASE" "envconn" + setEnv "DBM_MIGRATION_STORE" "envstore" + setEnv "DBM_LINEAR_MIGRATIONS" "off" + Right cfg <- loadConfiguration Nothing + return + ( _connectionString cfg + ~?= "envconn" + .&&. _migrationStorePath cfg + ~?= "envstore" + .&&. _linearMigrations cfg + ~?= False + ) returnsErrorWhenNotAllPropertiesAreSet :: IO Test returnsErrorWhenNotAllPropertiesAreSet = do - cfg <- loadConfiguration (Just "missing.cfg") - satisfies "Should return error" cfg isLeft + cfg <- loadConfiguration (Just "missing.cfg") + satisfies "Should return error" cfg isLeft throwsWhenConfigFileIsInvalid :: IO Test throwsWhenConfigFileIsInvalid = do - c <- try $ loadConfiguration (Just "invalid.cfg") - satisfies "Should throw" c (isLeft :: Either SomeException a -> Bool) + c <- try $ loadConfiguration (Just "invalid.cfg") + satisfies "Should throw" c (isLeft :: Either SomeException a -> Bool) diff --git a/test/CycleDetectionTest.hs b/test/CycleDetectionTest.hs index dfdd3e5..a28669d 100644 --- a/test/CycleDetectionTest.hs +++ b/test/CycleDetectionTest.hs @@ -1,11 +1,11 @@ module CycleDetectionTest - ( tests - ) + ( tests + ) where +import Data.Graph.Inductive.Graph (mkGraph) +import Data.Graph.Inductive.PatriciaTree (Gr) import Test.HUnit -import Data.Graph.Inductive.PatriciaTree ( Gr ) -import Data.Graph.Inductive.Graph ( mkGraph ) import Database.Schema.Migrations.CycleDetection @@ -13,57 +13,72 @@ tests :: [Test] tests = mkCycleTests noCycles :: Gr String String -noCycles = mkGraph [(1,"one"),(2,"two")] [(1,2,"one->two")] +noCycles = mkGraph [(1, "one"), (2, "two")] [(1, 2, "one->two")] noCyclesEmpty :: Gr String String noCyclesEmpty = mkGraph [] [] withCycleSimple :: Gr String String -withCycleSimple = mkGraph [(1,"one")] [(1,1,"one->one")] +withCycleSimple = mkGraph [(1, "one")] [(1, 1, "one->one")] withCycleComplex :: Gr String String -withCycleComplex = mkGraph [(1,"one"),(2,"two"),(3,"three"),(4,"four")] - [(4,1,"four->one"),(1,2,"one->two"),(2,3,"two->three"),(3,1,"three->one")] +withCycleComplex = + mkGraph + [(1, "one"), (2, "two"), (3, "three"), (4, "four")] + [ (4, 1, "four->one") + , (1, 2, "one->two") + , (2, 3, "two->three") + , (3, 1, "three->one") + ] withCycleRadial :: Gr String String -withCycleRadial = mkGraph [(1,"one"),(2,"two"),(3,"three"),(4,"four")] - [(2,1,""),(2,3,""),(3,4,""),(3,2,"")] +withCycleRadial = + mkGraph + [(1, "one"), (2, "two"), (3, "three"), (4, "four")] + [(2, 1, ""), (2, 3, ""), (3, 4, ""), (3, 2, "")] noCycleRadial :: Gr String String -noCycleRadial = mkGraph [(1,""),(2,""),(3,""),(4,"")] - [(1,2,""),(3,1,""),(4,1,"")] +noCycleRadial = + mkGraph + [(1, ""), (2, ""), (3, ""), (4, "")] + [(1, 2, ""), (3, 1, ""), (4, 1, "")] -- This graph would contain a loop if it were undirected, but it does -- not contain a directed cycle. noDirectedCycle1 :: Gr String String -noDirectedCycle1 = mkGraph [(1,""),(2,""),(3,""),(4,"")] - [(1,2,""),(1,3,""),(3,2,""),(2,4,"")] +noDirectedCycle1 = + mkGraph + [(1, ""), (2, ""), (3, ""), (4, "")] + [(1, 2, ""), (1, 3, ""), (3, 2, ""), (2, 4, "")] -- This graph would contain a loop if it were undirected, but it does -- not contain a directed cycle. noDirectedCycle2 :: Gr String String -noDirectedCycle2 = mkGraph [(1,"flub"),(2,"test.db"),(3,"test2"),(4,"test3"),(5,"test1")] - [ (1,2,"flub->test.db") - , (2,3,"test.db->test2") - , (2,4,"test.db->test3") - , (3,5,"test2->test1") - , (4,3,"test3->test2") - ] +noDirectedCycle2 = + mkGraph + [(1, "flub"), (2, "test.db"), (3, "test2"), (4, "test3"), (5, "test1")] + [ (1, 2, "flub->test.db") + , (2, 3, "test.db->test2") + , (2, 4, "test.db->test3") + , (3, 5, "test2->test1") + , (4, 3, "test3->test2") + ] type CycleTestCase = (Gr String String, Bool) cycleTests :: [CycleTestCase] -cycleTests = [ (noCyclesEmpty, False) - , (noCycles, False) - , (noCycleRadial, False) - , (withCycleSimple, True) - , (withCycleComplex, True) - , (withCycleRadial, True) - , (noDirectedCycle1, False) - , (noDirectedCycle2, False) - ] +cycleTests = + [ (noCyclesEmpty, False) + , (noCycles, False) + , (noCycleRadial, False) + , (withCycleSimple, True) + , (withCycleComplex, True) + , (withCycleRadial, True) + , (noDirectedCycle1, False) + , (noDirectedCycle2, False) + ] mkCycleTests :: [Test] mkCycleTests = map mkCycleTest cycleTests - where - mkCycleTest (g, expected) = expected ~=? hasCycle g + where + mkCycleTest (g, expected) = expected ~=? hasCycle g diff --git a/test/DependencyTest.hs b/test/DependencyTest.hs index 7bf1495..3db2ca0 100644 --- a/test/DependencyTest.hs +++ b/test/DependencyTest.hs @@ -1,39 +1,51 @@ {-# LANGUAGE OverloadedStrings #-} + module DependencyTest - ( tests - ) + ( tests + ) where -import Data.Text ( Text ) +import Data.Text (Text) +import Data.Graph.Inductive.Graph (Graph (..)) import Test.HUnit -import Data.Graph.Inductive.Graph ( Graph(..) ) -import Database.Schema.Migrations.Dependencies import Common +import Database.Schema.Migrations.Dependencies tests :: [Test] tests = depGraphTests ++ dependencyTests -type DepGraphTestCase = ([TestDependable], Either String (DependencyGraph TestDependable)) +type DepGraphTestCase = + ([TestDependable], Either String (DependencyGraph TestDependable)) depGraphTestCases :: [DepGraphTestCase] -depGraphTestCases = [ ( [] - , Right $ DG [] [] empty - ) - , ( [first, second] - , Right $ DG [(first,1),(second,2)] - [("first",1),("second",2)] (mkGraph [(1, "first"), (2, "second")] - [(2, 1, "first -> second")]) - ) - , ( [cycleFirst, cycleSecond] - , Left "Invalid dependency graph; cycle detected") - ] - where - first = TD "first" [] - second = TD "second" ["first"] - cycleFirst = TD "first" ["second"] - cycleSecond = TD "second" ["first"] +depGraphTestCases = + [ + ( [] + , Right $ DG [] [] empty + ) + , + ( [first, second] + , Right $ + DG + [(first, 1), (second, 2)] + [("first", 1), ("second", 2)] + ( mkGraph + [(1, "first"), (2, "second")] + [(2, 1, "first -> second")] + ) + ) + , + ( [cycleFirst, cycleSecond] + , Left "Invalid dependency graph; cycle detected" + ) + ] + where + first = TD "first" [] + second = TD "second" ["first"] + cycleFirst = TD "first" ["second"] + cycleSecond = TD "second" ["first"] depGraphTests :: [Test] depGraphTests = map mkDepGraphTest depGraphTestCases @@ -45,27 +57,77 @@ data Direction = Forward | Reverse deriving (Show) type DependencyTestCase = ([TestDependable], Text, Direction, [Text]) dependencyTestCases :: [DependencyTestCase] -dependencyTestCases = [ ([TD "first" []], "first", Forward, []) - , ([TD "first" []], "first", Reverse, []) - - , ([TD "first" ["second"], TD "second" []], "first", Forward, ["second"]) - , ([TD "first" ["second"], TD "second" []], "second", Reverse, ["first"]) - , ([TD "first" ["second"], TD "second" ["third"], TD "third" []], "first", Forward, ["third", "second"]) - , ([TD "first" ["second"], TD "second" ["third"], TD "third" [], TD "fourth" ["third"]] - , "first", Forward, ["third", "second"]) - , ([TD "first" [], TD "second" ["first"]] - , "first", Reverse, ["second"]) - , ([TD "first" [], TD "second" ["first"], TD "third" ["second"]] - , "first", Reverse, ["third", "second"]) - , ([TD "first" [], TD "second" ["first"], TD "third" ["second"], TD "fourth" ["second"]] - , "first", Reverse, ["fourth", "third", "second"]) - , ([ TD "first" ["second"], TD "second" ["third"], TD "third" ["fourth"] - , TD "second" ["fifth"], TD "fifth" ["third"], TD "fourth" []] - , "fourth", Reverse, ["first", "second", "fifth", "third"]) - , ([ TD "first" ["second"], TD "second" ["third", "fifth"], TD "third" ["fourth"] - , TD "fifth" ["third"], TD "fourth" []] - , "first", Forward, ["fourth", "third", "fifth", "second"]) - ] +dependencyTestCases = + [ ([TD "first" []], "first", Forward, []) + , ([TD "first" []], "first", Reverse, []) + , ([TD "first" ["second"], TD "second" []], "first", Forward, ["second"]) + , ([TD "first" ["second"], TD "second" []], "second", Reverse, ["first"]) + , + ( [TD "first" ["second"], TD "second" ["third"], TD "third" []] + , "first" + , Forward + , ["third", "second"] + ) + , + ( + [ TD "first" ["second"] + , TD "second" ["third"] + , TD "third" [] + , TD "fourth" ["third"] + ] + , "first" + , Forward + , ["third", "second"] + ) + , + ( [TD "first" [], TD "second" ["first"]] + , "first" + , Reverse + , ["second"] + ) + , + ( [TD "first" [], TD "second" ["first"], TD "third" ["second"]] + , "first" + , Reverse + , ["third", "second"] + ) + , + ( + [ TD "first" [] + , TD "second" ["first"] + , TD "third" ["second"] + , TD "fourth" ["second"] + ] + , "first" + , Reverse + , ["fourth", "third", "second"] + ) + , + ( + [ TD "first" ["second"] + , TD "second" ["third"] + , TD "third" ["fourth"] + , TD "second" ["fifth"] + , TD "fifth" ["third"] + , TD "fourth" [] + ] + , "fourth" + , Reverse + , ["first", "second", "fifth", "third"] + ) + , + ( + [ TD "first" ["second"] + , TD "second" ["third", "fifth"] + , TD "third" ["fourth"] + , TD "fifth" ["third"] + , TD "fourth" [] + ] + , "first" + , Forward + , ["fourth", "third", "fifth", "second"] + ) + ] fromRight :: Either a b -> b fromRight (Left _) = error "Got a Left value" @@ -73,10 +135,10 @@ fromRight (Right v) = v mkDependencyTest :: DependencyTestCase -> Test mkDependencyTest testCase@(deps, a, dir, expected) = - let f = case dir of - Forward -> dependencies - Reverse -> reverseDependencies - in (show testCase) ~: expected ~=? f (fromRight $ mkDepGraph deps) a + let f = case dir of + Forward -> dependencies + Reverse -> reverseDependencies + in (show testCase) ~: expected ~=? f (fromRight $ mkDepGraph deps) a dependencyTests :: [Test] dependencyTests = map mkDependencyTest dependencyTestCases diff --git a/test/FilesystemParseTest.hs b/test/FilesystemParseTest.hs index c34b914..1b7f969 100644 --- a/test/FilesystemParseTest.hs +++ b/test/FilesystemParseTest.hs @@ -1,21 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} + module FilesystemParseTest - ( tests - ) + ( tests + ) where +import Data.String.Conversions (cs) +import Data.Time.Clock (UTCTime) +import System.FilePath (()) import Test.HUnit -import Data.Time.Clock ( UTCTime ) -import System.FilePath ( () ) -import Data.String.Conversions ( cs ) import Common -import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Filesystem - ( FilesystemStoreSettings(..) - , migrationFromFile - ) + ( FilesystemStoreSettings (..) + , migrationFromFile + ) +import Database.Schema.Migrations.Migration tests :: IO [Test] tests = migrationParsingTests @@ -30,34 +31,39 @@ ts :: UTCTime ts = read tsStr valid_full :: Migration -valid_full = Migration { - mTimestamp = Just ts - , mId = "valid_full" - , mDesc = Just "A valid full migration." - , mDeps = ["another_migration"] - , mApply = "CREATE TABLE test ( a int );" - , mRevert = Just "DROP TABLE test;" - } +valid_full = + Migration + { mTimestamp = Just ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = "CREATE TABLE test ( a int );" + , mRevert = Just "DROP TABLE test;" + } valid_full_comments :: Migration -valid_full_comments = Migration { - mTimestamp = Just ts - , mId = "valid_full" - , mDesc = Just "A valid full migration." - , mDeps = ["another_migration"] - , mApply = "\n-- Comment on a line\nCREATE TABLE test (\n a int -- comment inline\n);\n" - , mRevert = Just "DROP TABLE test;" - } +valid_full_comments = + Migration + { mTimestamp = Just ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = + "\n-- Comment on a line\nCREATE TABLE test (\n a int -- comment inline\n);\n" + , mRevert = Just "DROP TABLE test;" + } valid_full_colon :: Migration -valid_full_colon = Migration { - mTimestamp = Just ts - , mId = "valid_full" - , mDesc = Just "A valid full migration." - , mDeps = ["another_migration"] - , mApply = "\n-- Comment on a line with a colon:\nCREATE TABLE test (\n a int\n);\n" - , mRevert = Just "DROP TABLE test;" - } +valid_full_colon = + Migration + { mTimestamp = Just ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = + "\n-- Comment on a line with a colon:\nCREATE TABLE test (\n a int\n);\n" + , mRevert = Just "DROP TABLE test;" + } testStorePath :: FilePath testStorePath = testFile $ "migration_parsing" @@ -66,55 +72,88 @@ fp :: FilePath -> FilePath fp = (testStorePath ) migrationParsingTestCases :: [MigrationParsingTestCase] -migrationParsingTestCases = [ ("valid_full", Right valid_full) - , ("valid_with_comments" - , Right (valid_full { mId = "valid_with_comments" })) - , ("valid_with_comments2" - , Right (valid_full_comments { mId = "valid_with_comments2" })) - , ("valid_with_colon" - , Right (valid_full_colon { mId = "valid_with_colon" })) - , ("valid_with_multiline_deps" - , Right (valid_full { mId = "valid_with_multiline_deps" - , mDeps = ["one", "two", "three"] } )) - , ("valid_no_depends" - , Right (valid_full { mId = "valid_no_depends", mDeps = [] })) - , ("valid_no_desc" - , 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") ++ - ":Error in " ++ - (show $ fp "invalid_missing_required_fields") ++ - ": missing required field(s): " ++ - "[\"Depends\"]") - , ("invalid_field_name" - , Left $ "Could not parse migration " ++ - (fp "invalid_field_name") ++ - ":Error in " ++ - (show $ fp "invalid_field_name") ++ - ": unrecognized field found") - , ("invalid_syntax" - , Left $ "Could not parse migration " ++ - (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") ++ - ":Error in " ++ - (show $ fp "invalid_timestamp") ++ - ": unrecognized field found") - ] +migrationParsingTestCases = + [ ("valid_full", Right valid_full) + , + ( "valid_with_comments" + , Right (valid_full {mId = "valid_with_comments"}) + ) + , + ( "valid_with_comments2" + , Right (valid_full_comments {mId = "valid_with_comments2"}) + ) + , + ( "valid_with_colon" + , Right (valid_full_colon {mId = "valid_with_colon"}) + ) + , + ( "valid_with_multiline_deps" + , Right + ( valid_full + { mId = "valid_with_multiline_deps" + , mDeps = ["one", "two", "three"] + } + ) + ) + , + ( "valid_no_depends" + , Right (valid_full {mId = "valid_no_depends", mDeps = []}) + ) + , + ( "valid_no_desc" + , 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") + ++ ":Error in " + ++ (show $ fp "invalid_missing_required_fields") + ++ ": missing required field(s): " + ++ "[\"Depends\"]" + ) + , + ( "invalid_field_name" + , Left $ + "Could not parse migration " + ++ (fp "invalid_field_name") + ++ ":Error in " + ++ (show $ fp "invalid_field_name") + ++ ": unrecognized field found" + ) + , + ( "invalid_syntax" + , Left $ + "Could not parse migration " + ++ (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") + ++ ":Error in " + ++ (show $ fp "invalid_timestamp") + ++ ": unrecognized field found" + ) + ] mkParsingTest :: MigrationParsingTestCase -> IO Test mkParsingTest (fname, expected) = do - let store = FSStore { storePath = testStorePath } + let store = FSStore {storePath = testStorePath} actual <- migrationFromFile store (cs fname) return $ test $ expected ~=? actual migrationParsingTests :: IO [Test] migrationParsingTests = - traverse mkParsingTest migrationParsingTestCases + traverse mkParsingTest migrationParsingTestCases diff --git a/test/FilesystemSerializeTest.hs b/test/FilesystemSerializeTest.hs index 2510c27..6adfb4b 100644 --- a/test/FilesystemSerializeTest.hs +++ b/test/FilesystemSerializeTest.hs @@ -1,13 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} + module FilesystemSerializeTest - ( tests - ) + ( tests + ) where +import Data.ByteString (ByteString) +import Data.String.Conversions (cs, (<>)) +import Data.Time.Clock (UTCTime) import Test.HUnit -import Data.ByteString ( ByteString ) -import Data.String.Conversions ( (<>), cs ) -import Data.Time.Clock ( UTCTime ) import Database.Schema.Migrations.Filesystem.Serialize import Database.Schema.Migrations.Migration @@ -25,53 +26,76 @@ ts :: UTCTime ts = read tsStr valid_full :: Migration -valid_full = Migration { - mTimestamp = Just ts - , mId = "valid_full" - , mDesc = Just "A valid full migration." - , mDeps = ["another_migration"] - , mApply = " CREATE TABLE test (\n a int\n );\n" - , mRevert = Just "DROP TABLE test;" - } +valid_full = + Migration + { mTimestamp = Just ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = " CREATE TABLE test (\n a int\n );\n" + , mRevert = Just "DROP TABLE test;" + } 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\ - \ a int\n\ - \ );\n\n\ - \Revert: |\n\ - \ DROP TABLE test;\n") - , (valid_full { mDesc = Nothing } - , cs $ "Created: " <> tsStr <> "\n\ - \Depends: another_migration\n\ - \Apply: |\n\ - \ CREATE TABLE test (\n\ - \ a int\n\ - \ );\n\n\ - \Revert: |\n\ - \ DROP TABLE test;\n") - , (valid_full { mDeps = ["one", "two"] } - , cs $ "Description: A valid full migration.\n\ - \Created: " <> tsStr <> "\n\ - \Depends: one two\n\ - \Apply: |\n\ - \ CREATE TABLE test (\n\ - \ a int\n\ - \ );\n\n\ - \Revert: |\n\ - \ DROP TABLE test;\n") - , (valid_full { mRevert = Nothing } - , cs $ "Description: A valid full migration.\n\ - \Created: " <> tsStr <> "\n\ - \Depends: another_migration\n\ - \Apply: |\n\ - \ CREATE TABLE test (\n\ - \ a int\n\ - \ );\n") - ] +serializationTestCases = + [ + ( valid_full + , cs $ + "Description: A valid full migration.\n\ + \Created: " + <> tsStr + <> "\n\ + \Depends: another_migration\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n\n\ + \Revert: |\n\ + \ DROP TABLE test;\n" + ) + , + ( valid_full {mDesc = Nothing} + , cs $ + "Created: " + <> tsStr + <> "\n\ + \Depends: another_migration\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n\n\ + \Revert: |\n\ + \ DROP TABLE test;\n" + ) + , + ( valid_full {mDeps = ["one", "two"]} + , cs $ + "Description: A valid full migration.\n\ + \Created: " + <> tsStr + <> "\n\ + \Depends: one two\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n\n\ + \Revert: |\n\ + \ DROP TABLE test;\n" + ) + , + ( valid_full {mRevert = Nothing} + , cs $ + "Description: A valid full migration.\n\ + \Created: " + <> tsStr + <> "\n\ + \Depends: another_migration\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n" + ) + ] serializationTests :: [Test] serializationTests = map mkSerializationTest serializationTestCases diff --git a/test/FilesystemTest.hs b/test/FilesystemTest.hs index 9240df9..922c2ee 100644 --- a/test/FilesystemTest.hs +++ b/test/FilesystemTest.hs @@ -1,35 +1,39 @@ {-# LANGUAGE OverloadedStrings #-} + module FilesystemTest - ( tests - ) + ( tests + ) where import Database.Schema.Migrations.Filesystem -import Database.Schema.Migrations.Store ( MigrationStore(..) ) +import Database.Schema.Migrations.Store (MigrationStore (..)) -import Test.HUnit -import qualified Data.Set as Set import Common +import qualified Data.Set as Set +import Test.HUnit tests :: IO [Test] tests = sequence [getMigrationsTest] getMigrationsTest :: IO Test getMigrationsTest = do - let store = filesystemStore $ FSStore { storePath = testFile "migration_parsing" } - expected = Set.fromList [ "invalid_field_name" - , "invalid_missing_required_fields" - , "invalid_syntax" - , "invalid_timestamp" - , "valid_full" - , "valid_no_depends" - , "valid_no_desc" - , "valid_no_revert" - , "valid_no_timestamp" - , "valid_with_comments" - , "valid_with_comments2" - , "valid_with_colon" - , "valid_with_multiline_deps" - ] + let + store = filesystemStore $ FSStore {storePath = testFile "migration_parsing"} + expected = + Set.fromList + [ "invalid_field_name" + , "invalid_missing_required_fields" + , "invalid_syntax" + , "invalid_timestamp" + , "valid_full" + , "valid_no_depends" + , "valid_no_desc" + , "valid_no_revert" + , "valid_no_timestamp" + , "valid_with_comments" + , "valid_with_comments2" + , "valid_with_colon" + , "valid_with_multiline_deps" + ] migrations <- getMigrations store return $ expected ~=? Set.fromList migrations diff --git a/test/InMemoryStore.hs b/test/InMemoryStore.hs index 96b906a..6d16c5a 100644 --- a/test/InMemoryStore.hs +++ b/test/InMemoryStore.hs @@ -1,35 +1,36 @@ module InMemoryStore (inMemoryStore) where -import Data.Text ( Text ) -import Data.String.Conversions ( cs ) +import Data.String.Conversions (cs) +import Data.Text (Text) -import Control.Concurrent.MVar -import Database.Schema.Migrations.Migration -import Database.Schema.Migrations.Store +import Control.Concurrent.MVar +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Store type InMemoryData = [(Text, Migration)] --- |Builds simple in-memory store that uses 'MVar' to preserve a list of --- migrations. +-- | Builds simple in-memory store that uses 'MVar' to preserve a list of +-- migrations. inMemoryStore :: IO MigrationStore inMemoryStore = do - store <- newMVar [] - return MigrationStore { - loadMigration = loadMigrationInMem store - , saveMigration = saveMigrationInMem store - , getMigrations = getMigrationsInMem store - , fullMigrationName = return . cs - } + store <- newMVar [] + return + MigrationStore + { loadMigration = loadMigrationInMem store + , saveMigration = saveMigrationInMem store + , getMigrations = getMigrationsInMem store + , fullMigrationName = return . cs + } loadMigrationInMem :: MVar InMemoryData -> Text -> IO (Either String Migration) loadMigrationInMem store migId = withMVar store $ \migrations -> do - let mig = lookup migId migrations - return $ case mig of - Just m -> Right m - _ -> Left "Migration not found" + let mig = lookup migId migrations + return $ case mig of + Just m -> Right m + _ -> Left "Migration not found" saveMigrationInMem :: MVar InMemoryData -> Migration -> IO () -saveMigrationInMem store m = modifyMVar_ store $ return . ((mId m, m):) +saveMigrationInMem store m = modifyMVar_ store $ return . ((mId m, m) :) getMigrationsInMem :: MVar InMemoryData -> IO [Text] getMigrationsInMem store = withMVar store $ return . fmap fst diff --git a/test/LinearMigrationsTest.hs b/test/LinearMigrationsTest.hs index ab3649e..699e302 100644 --- a/test/LinearMigrationsTest.hs +++ b/test/LinearMigrationsTest.hs @@ -1,95 +1,100 @@ {-# LANGUAGE OverloadedStrings #-} + module LinearMigrationsTest (tests) where -import InMemoryStore -import Test.HUnit +import InMemoryStore +import Test.HUnit -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 -import Moo.CommandHandlers -import Moo.Core +import Common +import Control.Monad.Reader (runReaderT) +import Data.Either (isRight) +import Data.Text (Text) +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Store +import Moo.CommandHandlers +import Moo.Core tests :: IO [Test] -tests = sequence [ addsMigration - , selectsLatestMigrationAsDep - , selectsOnlyLeavesAsDeps - , doesNotAddDependencyWhenLinearMigrationsAreDisabled - ] +tests = + sequence + [ addsMigration + , selectsLatestMigrationAsDep + , selectsOnlyLeavesAsDeps + , doesNotAddDependencyWhenLinearMigrationsAreDisabled + ] addsMigration :: IO Test addsMigration = do - state <- prepareState "first" - mig <- addTestMigration state - satisfies "Migration not added" mig isRight + state <- prepareState "first" + mig <- addTestMigration state + satisfies "Migration not added" mig isRight selectsLatestMigrationAsDep :: IO Test selectsLatestMigrationAsDep = do - state1 <- prepareState "first" - _ <- addTestMigration state1 - state2 <- prepareStateWith state1 "second" - Right mig <- addTestMigration state2 - return $ ["first"] ~=? mDeps mig + state1 <- prepareState "first" + _ <- addTestMigration state1 + state2 <- prepareStateWith state1 "second" + Right mig <- addTestMigration state2 + return $ ["first"] ~=? mDeps mig selectsOnlyLeavesAsDeps :: IO Test selectsOnlyLeavesAsDeps = do - state1 <- prepareNormalState "first" - addTestMigrationWithDeps state1 [] - state2 <- prepareStateWith state1 "second" - addTestMigrationWithDeps state2 ["first"] - state3 <- prepareStateWith state2 "third" - addTestMigrationWithDeps state3 ["first"] - state4' <- prepareStateWith state3 "fourth" - let state4 = state4' { _appLinearMigrations = True } - Right mig <- addTestMigration state4 - return $ ["second", "third"] ~=? mDeps mig + state1 <- prepareNormalState "first" + addTestMigrationWithDeps state1 [] + state2 <- prepareStateWith state1 "second" + addTestMigrationWithDeps state2 ["first"] + state3 <- prepareStateWith state2 "third" + addTestMigrationWithDeps state3 ["first"] + state4' <- prepareStateWith state3 "fourth" + let state4 = state4' {_appLinearMigrations = True} + Right mig <- addTestMigration state4 + return $ ["second", "third"] ~=? mDeps mig doesNotAddDependencyWhenLinearMigrationsAreDisabled :: IO Test doesNotAddDependencyWhenLinearMigrationsAreDisabled = do - state1 <- prepareNormalState "first" - _ <- addTestMigration state1 - state2 <- prepareStateWith state1 "second" - Right mig <- addTestMigration state2 - satisfies "Dependencies should be empty" (mDeps mig) null + state1 <- prepareNormalState "first" + _ <- addTestMigration state1 + state2 <- prepareStateWith state1 "second" + Right mig <- addTestMigration state2 + satisfies "Dependencies should be empty" (mDeps mig) null addTestMigration :: AppState -> IO (Either String Migration) addTestMigration state = do - let store = _appStore state - [migrationId] = _appRequiredArgs state - runReaderT (newCommand $ _appStoreData state) state - loadMigration store migrationId + let + store = _appStore state + [migrationId] = _appRequiredArgs state + runReaderT (newCommand $ _appStoreData state) state + loadMigration store migrationId addTestMigrationWithDeps :: AppState -> [Text] -> IO () addTestMigrationWithDeps state deps = do - let store = _appStore state - let [migrationId] = _appRequiredArgs state - saveMigration store (newMigration migrationId) { mDeps = deps } + let store = _appStore state + let [migrationId] = _appRequiredArgs state + saveMigration store (newMigration migrationId) {mDeps = deps} prepareState :: Text -> IO AppState prepareState m = do - store <- inMemoryStore - Right storeData <- loadMigrations store - return AppState { - _appOptions = CommandOptions Nothing False True - , _appBackend = undefined -- Not used here - , _appCommand = undefined -- Not used by newCommand - , _appRequiredArgs = [m] - , _appOptionalArgs = [] - , _appStore = store - , _appStoreData = storeData - , _appLinearMigrations = True - , _appTimestampFilenames = False - } + store <- inMemoryStore + Right storeData <- loadMigrations store + return + AppState + { _appOptions = CommandOptions Nothing False True + , _appBackend = undefined -- Not used here + , _appCommand = undefined -- Not used by newCommand + , _appRequiredArgs = [m] + , _appOptionalArgs = [] + , _appStore = store + , _appStoreData = storeData + , _appLinearMigrations = True + , _appTimestampFilenames = False + } prepareStateWith :: AppState -> Text -> IO AppState prepareStateWith state m = do - Right storeData <- loadMigrations $ _appStore state - return state { _appRequiredArgs = [m], _appStoreData = storeData } + Right storeData <- loadMigrations $ _appStore state + return state {_appRequiredArgs = [m], _appStoreData = storeData} prepareNormalState :: Text -> IO AppState prepareNormalState m = do - state <- prepareState m - return $ state { _appLinearMigrations = False } + state <- prepareState m + return $ state {_appLinearMigrations = False} diff --git a/test/Main.hs b/test/Main.hs index 4aeb008..e3308f9 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,40 +1,48 @@ module Main where -import Prelude -import Test.HUnit + import System.Exit -import System.IO ( stderr ) +import System.IO (stderr) +import Test.HUnit +import Prelude +import qualified ConfigurationTest +import qualified CycleDetectionTest import qualified DependencyTest -import qualified MigrationsTest -import qualified FilesystemSerializeTest import qualified FilesystemParseTest +import qualified FilesystemSerializeTest import qualified FilesystemTest -import qualified CycleDetectionTest -import qualified StoreTest import qualified LinearMigrationsTest -import qualified ConfigurationTest +import qualified MigrationsTest +import qualified StoreTest -import Control.Exception ( SomeException(..) ) +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 - ] + 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" diff --git a/test/MigrationsTest.hs b/test/MigrationsTest.hs index a53a994..cea7c0b 100644 --- a/test/MigrationsTest.hs +++ b/test/MigrationsTest.hs @@ -1,69 +1,84 @@ -{-# LANGUAGE TypeSynonymInstances,GeneralizedNewtypeDeriving,MultiParamTypeClasses,FlexibleInstances,OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} + module MigrationsTest - ( tests - ) + ( tests + ) where -import Test.HUnit import Control.Applicative ((<$>)) import qualified Data.Map as Map -import Data.Time.Clock ( UTCTime ) +import Data.Time.Clock (UTCTime) +import Test.HUnit import Database.Schema.Migrations -import Database.Schema.Migrations.Store hiding (getMigrations) -import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Backend +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Store hiding (getMigrations) tests :: [Test] tests = migrationsToApplyTests 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 () - } + 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, Backend, Migration, - [Migration]) +-- | 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 + , Backend + , Migration + , [Migration] + ) ts :: UTCTime ts = read "2009-04-15 10:02:06 UTC" blankMigration :: Migration -blankMigration = Migration { mTimestamp = Just ts - , mId = undefined - , mDesc = Nothing - , mApply = "" - , mRevert = Nothing - , mDeps = [] - } +blankMigration = + Migration + { mTimestamp = Just ts + , mId = undefined + , mDesc = Nothing + , mApply = "" + , mRevert = Nothing + , mDeps = [] + } missingMigrationsTestcases :: [MissingMigrationTestCase] -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" } - two = blankMigration { mId = "two", mDeps = ["one"] } - m = Map.fromList [ (mId e, e) | e <- [one, 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"} + two = blankMigration {mId = "two", mDeps = ["one"]} + m = Map.fromList [(mId e, e) | e <- [one, two]] mkTest :: MissingMigrationTestCase -> Test mkTest (mapping, backend, theMigration, expected) = - let Right graph = depGraphFromMapping mapping - storeData = StoreData mapping graph - result = migrationsToApply storeData backend theMigration - in "a test" ~: do + let + Right graph = depGraphFromMapping mapping + storeData = StoreData mapping graph + result = migrationsToApply storeData backend theMigration + in + "a test" ~: do actual <- result return $ expected == actual diff --git a/test/StoreTest.hs b/test/StoreTest.hs index 4db956f..fa6774c 100644 --- a/test/StoreTest.hs +++ b/test/StoreTest.hs @@ -1,119 +1,160 @@ {-# LANGUAGE OverloadedStrings #-} + module StoreTest - ( tests - ) + ( tests + ) where -import Test.HUnit import qualified Data.Map as Map +import Test.HUnit import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Store tests :: [Test] -tests = validateSingleMigrationTests - ++ validateMigrationMapTests +tests = + validateSingleMigrationTests + ++ validateMigrationMapTests -type ValidateSingleTestCase = ( MigrationMap - , Migration - , [MapValidationError] - ) +type ValidateSingleTestCase = + ( MigrationMap + , Migration + , [MapValidationError] + ) -type ValidateMigrationMapTestCase = ( MigrationMap - , [MapValidationError] - ) +type ValidateMigrationMapTestCase = + ( MigrationMap + , [MapValidationError] + ) emptyMap :: MigrationMap emptyMap = Map.fromList [] partialMap :: MigrationMap -partialMap = Map.fromList [ ("one", undefined) - , ("three", undefined) - ] +partialMap = + Map.fromList + [ ("one", undefined) + , ("three", undefined) + ] fullMap :: MigrationMap -fullMap = Map.fromList [ ("one", undefined) - , ("two", undefined) - , ("three", undefined) - ] +fullMap = + Map.fromList + [ ("one", undefined) + , ("two", undefined) + , ("three", undefined) + ] withDeps :: Migration -withDeps = Migration { mTimestamp = undefined - , mId = "with_deps" - , mDesc = Just "with dependencies" - , mApply = "" - , mRevert = Nothing - , mDeps = ["one", "two", "three"] - } +withDeps = + Migration + { mTimestamp = undefined + , mId = "with_deps" + , mDesc = Just "with dependencies" + , mApply = "" + , mRevert = Nothing + , mDeps = ["one", "two", "three"] + } noDeps :: Migration -noDeps = Migration { mTimestamp = undefined - , mId = "no_deps" - , mDesc = Just "no dependencies" - , mApply = "" - , mRevert = Nothing - , mDeps = [] - } +noDeps = + Migration + { mTimestamp = undefined + , mId = "no_deps" + , mDesc = Just "no dependencies" + , mApply = "" + , mRevert = Nothing + , mDeps = [] + } validateSingleTestCases :: [ValidateSingleTestCase] -validateSingleTestCases = [ (emptyMap, withDeps, [ DependencyReferenceError (mId withDeps) "one" - , DependencyReferenceError (mId withDeps) "two" - , DependencyReferenceError (mId withDeps) "three" - ] - ) - , (emptyMap, noDeps, []) - , (partialMap, withDeps, [DependencyReferenceError (mId withDeps) "two"]) - , (fullMap, withDeps, []) - , (fullMap, noDeps, []) - ] +validateSingleTestCases = + [ + ( emptyMap + , withDeps + , + [ DependencyReferenceError (mId withDeps) "one" + , DependencyReferenceError (mId withDeps) "two" + , DependencyReferenceError (mId withDeps) "three" + ] + ) + , (emptyMap, noDeps, []) + , (partialMap, withDeps, [DependencyReferenceError (mId withDeps) "two"]) + , (fullMap, withDeps, []) + , (fullMap, noDeps, []) + ] validateSingleMigrationTests :: [Test] validateSingleMigrationTests = - map mkValidateSingleTest validateSingleTestCases - where - mkValidateSingleTest (mmap, m, errs) = - errs ~=? validateSingleMigration mmap m + map mkValidateSingleTest validateSingleTestCases + where + mkValidateSingleTest (mmap, m, errs) = + errs ~=? validateSingleMigration mmap m m1 :: Migration -m1 = noDeps { mId = "m1" - , mDeps = [] } +m1 = + noDeps + { mId = "m1" + , mDeps = [] + } m2 :: Migration -m2 = noDeps { mId = "m2" - , mDeps = ["m1"] } +m2 = + noDeps + { mId = "m2" + , mDeps = ["m1"] + } m3 :: Migration -m3 = noDeps { mId = "m3" - , mDeps = ["nonexistent"] } +m3 = + noDeps + { mId = "m3" + , mDeps = ["nonexistent"] + } m4 :: Migration -m4 = noDeps { mId = "m4" - , mDeps = ["one", "two"] } +m4 = + noDeps + { mId = "m4" + , mDeps = ["one", "two"] + } map1 :: MigrationMap -map1 = Map.fromList [ ("m1", m1) - , ("m2", m2) - ] +map1 = + Map.fromList + [ ("m1", m1) + , ("m2", m2) + ] map2 :: MigrationMap -map2 = Map.fromList [ ("m3", m3) - ] +map2 = + Map.fromList + [ ("m3", m3) + ] map3 :: MigrationMap -map3 = Map.fromList [ ("m4", m4) - ] +map3 = + Map.fromList + [ ("m4", m4) + ] validateMapTestCases :: [ValidateMigrationMapTestCase] -validateMapTestCases = [ (emptyMap, []) - , (map1, []) - , (map2, [DependencyReferenceError (mId m3) "nonexistent"]) - , (map3, [ DependencyReferenceError (mId m4) "one" - , DependencyReferenceError (mId m4) "two"]) - ] +validateMapTestCases = + [ (emptyMap, []) + , (map1, []) + , (map2, [DependencyReferenceError (mId m3) "nonexistent"]) + , + ( map3 + , + [ DependencyReferenceError (mId m4) "one" + , DependencyReferenceError (mId m4) "two" + ] + ) + ] validateMigrationMapTests :: [Test] validateMigrationMapTests = - map mkValidateMapTest validateMapTestCases - where - mkValidateMapTest (mmap, errs) = - errs ~=? validateMigrationMap mmap + map mkValidateMapTest validateMapTestCases + where + mkValidateMapTest (mmap, errs) = + errs ~=? validateMigrationMap mmap From 3b9e1752de0014616edbcb6fa6663f8df9a9b362 Mon Sep 17 00:00:00 2001 From: Pat Brisbin Date: Mon, 1 Apr 2024 08:44:22 -0400 Subject: [PATCH 02/10] Modernize project - Hpack - Actions CI - Weed, lint, style - Hspec --- .github/workflows/ci.yml | 22 + .gitignore | 6 +- .restyled.yaml | 5 + MOO.TXT | 316 -------------- README.md | 399 +++++++++++++++--- dbmigrations.cabal | 338 ++++++++------- package.yaml | 111 +++++ programs/Moo.hs | 16 - src/Database/Schema/Migrations.hs | 55 +-- src/Database/Schema/Migrations/Backend.hs | 12 +- .../Schema/Migrations/Backend/HDBC.hs | 51 ++- .../Schema/Migrations/CycleDetection.hs | 36 +- .../Schema/Migrations/Dependencies.hs | 23 +- src/Database/Schema/Migrations/Filesystem.hs | 57 +-- .../Schema/Migrations/Filesystem/Serialize.hs | 22 +- src/Database/Schema/Migrations/Migration.hs | 11 +- src/Database/Schema/Migrations/Store.hs | 66 ++- .../Schema/Migrations/Test/BackendTest.hs | 302 ++++++------- src/Moo/CommandHandlers.hs | 178 ++++---- src/Moo/CommandInterface.hs | 22 +- src/Moo/CommandUtils.hs | 103 +++-- src/Moo/Core.hs | 29 +- src/Moo/Main.hs | 39 +- src/StoreManager.hs | 254 ----------- stack.yaml | 3 + stack.yaml.lock | 19 + test/ConfigurationTest.hs | 107 ----- test/FilesystemParseTest.hs | 159 ------- test/FilesystemSerializeTest.hs | 101 ----- test/FilesystemTest.hs | 39 -- test/LinearMigrationsTest.hs | 100 ----- test/Main.hs | 59 --- test/StoreTest.hs | 160 ------- {test => tests}/Common.hs | 24 +- {test => tests}/CommonTH.hs | 9 +- tests/ConfigurationSpec.hs | 77 ++++ .../CycleDetectionSpec.hs | 57 +-- .../DependencySpec.hs | 100 ++--- tests/FilesystemParseSpec.hs | 156 +++++++ tests/FilesystemSerializeSpec.hs | 90 ++++ tests/FilesystemSpec.hs | 36 ++ tests/HDBCSpec.hs | 22 + {test => tests}/InMemoryStore.hs | 15 +- tests/LinearMigrationsSpec.hs | 97 +++++ .../MigrationsSpec.hs | 58 ++- tests/Spec.hs | 1 + tests/StoreSpec.hs | 137 ++++++ {test => tests}/config_loading/cfg1.cfg | 0 {test => tests}/config_loading/cfg_ts.cfg | 0 {test => tests}/config_loading/invalid.cfg | 2 +- {test => tests}/config_loading/missing.cfg | 0 {test => tests}/config_loading/moo.cfg | 0 {test => tests}/example_store/root | 0 {test => tests}/example_store/update1 | 0 {test => tests}/example_store/update2 | 0 .../migration_parsing/invalid_field_name.txt | 0 .../invalid_missing_required_fields.txt | 0 .../migration_parsing/invalid_syntax.txt | 0 .../migration_parsing/invalid_timestamp.txt | 0 .../migration_parsing/valid_full.txt | 0 .../migration_parsing/valid_no_depends.txt | 0 .../migration_parsing/valid_no_desc.txt | 0 .../migration_parsing/valid_no_revert.txt | 0 .../migration_parsing/valid_no_timestamp.txt | 0 .../migration_parsing/valid_with_colon.txt | 0 .../migration_parsing/valid_with_comments.txt | 0 .../valid_with_comments2.txt | 0 .../valid_with_multiline_deps.txt | 0 weeder.toml | 10 + 69 files changed, 1936 insertions(+), 2175 deletions(-) create mode 100644 .github/workflows/ci.yml create mode 100644 .restyled.yaml delete mode 100644 MOO.TXT create mode 100644 package.yaml delete mode 100644 programs/Moo.hs delete mode 100644 src/StoreManager.hs create mode 100644 stack.yaml create mode 100644 stack.yaml.lock delete mode 100644 test/ConfigurationTest.hs delete mode 100644 test/FilesystemParseTest.hs delete mode 100644 test/FilesystemSerializeTest.hs delete mode 100644 test/FilesystemTest.hs delete mode 100644 test/LinearMigrationsTest.hs delete mode 100644 test/Main.hs delete mode 100644 test/StoreTest.hs rename {test => tests}/Common.hs (53%) rename {test => tests}/CommonTH.hs (76%) create mode 100644 tests/ConfigurationSpec.hs rename test/CycleDetectionTest.hs => tests/CycleDetectionSpec.hs (67%) rename test/DependencyTest.hs => tests/DependencySpec.hs (53%) create mode 100644 tests/FilesystemParseSpec.hs create mode 100644 tests/FilesystemSerializeSpec.hs create mode 100644 tests/FilesystemSpec.hs create mode 100644 tests/HDBCSpec.hs rename {test => tests}/InMemoryStore.hs (81%) create mode 100644 tests/LinearMigrationsSpec.hs rename test/MigrationsTest.hs => tests/MigrationsSpec.hs (57%) create mode 100644 tests/Spec.hs create mode 100644 tests/StoreSpec.hs rename {test => tests}/config_loading/cfg1.cfg (100%) rename {test => tests}/config_loading/cfg_ts.cfg (100%) rename {test => tests}/config_loading/invalid.cfg (56%) rename {test => tests}/config_loading/missing.cfg (100%) rename {test => tests}/config_loading/moo.cfg (100%) rename {test => tests}/example_store/root (100%) rename {test => tests}/example_store/update1 (100%) rename {test => tests}/example_store/update2 (100%) rename {test => tests}/migration_parsing/invalid_field_name.txt (100%) rename {test => tests}/migration_parsing/invalid_missing_required_fields.txt (100%) rename {test => tests}/migration_parsing/invalid_syntax.txt (100%) rename {test => tests}/migration_parsing/invalid_timestamp.txt (100%) rename {test => tests}/migration_parsing/valid_full.txt (100%) rename {test => tests}/migration_parsing/valid_no_depends.txt (100%) rename {test => tests}/migration_parsing/valid_no_desc.txt (100%) rename {test => tests}/migration_parsing/valid_no_revert.txt (100%) rename {test => tests}/migration_parsing/valid_no_timestamp.txt (100%) rename {test => tests}/migration_parsing/valid_with_colon.txt (100%) rename {test => tests}/migration_parsing/valid_with_comments.txt (100%) rename {test => tests}/migration_parsing/valid_with_comments2.txt (100%) rename {test => tests}/migration_parsing/valid_with_multiline_deps.txt (100%) create mode 100644 weeder.toml diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..7d5c134 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,22 @@ +name: CI + +on: + pull_request: + push: + branches: main + +jobs: + build: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + - uses: freckle/stack-action@v5 + + lint: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + - uses: haskell/actions/hlint-setup@v2 + - uses: haskell/actions/hlint-run@v2 + with: + fail-on: warning diff --git a/.gitignore b/.gitignore index 3605b4e..7f801f1 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,3 @@ -.*.swp -.cabal-sandbox -cabal.sandbox.config -dist +.stack-work dist-newstyle +result diff --git a/.restyled.yaml b/.restyled.yaml new file mode 100644 index 0000000..da55251 --- /dev/null +++ b/.restyled.yaml @@ -0,0 +1,5 @@ +restylers: + - "!stylish-haskell" + - fourmolu + - hlint + - "*" diff --git a/MOO.TXT b/MOO.TXT deleted file mode 100644 index fa95d40..0000000 --- a/MOO.TXT +++ /dev/null @@ -1,316 +0,0 @@ - -moo: the dbmigrations management tools ------------------------------------------- - -The database type specific package that work as a companion to this -library contain tools called "moo-postgresql", "moo-mysql", "moo-sqlite", -etc. They are responsible for creating, installing, and reverting migrations -in your database backend. Since all of these command line tools offer the -exact same interface, they are described here in a single document. -The executables mentioned above are simply called "moo" for the rest of -this document. That is, given an example that reads as "moo command" you -actually have to execute "moo-postgresql command" or "moo-mysql command" -and so on. - -At present, MySQL, PostgreSQL and Sqlite3 are the only supported database -backends. - -The moo tools work by creating migration files in a specific location, -called a migration store, on your filesystem. This directory is where -all possible migrations for your project will be kept. Moo allows you to -create migrations that depend on each other. When you use moo to upgrade -your database schema, it determines which migrations are missing, what -their dependencies are, and installs the required migrations in the -correct order (based on dependencies). - -Moo works by prompting you for new migration information. It then -creates a migration YAML file (whose format is described below), which -you then edit by hand. - -When migrations are installed into your database, the set of installed -migrations is tracked by way of a migration table that is installed into -your database. - - -Using dbmigrations with MySQL ------------------------------ - -While dbmigrations supports MySQL in general, the moo executable in this -package does not work with a MySQL backend directly. MySQL support has -been factored out into a separate package, called dbmigrations-mysql. -If you want to apply migrations to a MySQL backend, please install and -use dbmigrations-mysql instead of this package. The reason is that the -MySQL support depends on MySQL Haskell libraries which in turn have -build dependencies that make it necessary for MySQL itself to be -installed during build time. - - -Getting started ---------------- - - 1. Create a directory in which to store migration files. - - 2. Set an environment variable DBM_MIGRATION_STORE to the path to the - directory you created in step 1. - - 3. Set an environment variable DBM_DATABASE to a database connection - string that is appropriate for the database type you - chose. The contents of this depend on the database type, see the - "Environment" documentation section for more information. - - 4. Run "moo upgrade". This command will not actually install any - migrations, since you have not created any, but it will attempt to - connect to your database and install a migration-tracking table. - - If this step succeeds, you should see this output: - - Database is up to date. - - 5. Create a migration with "moo new". Here is an example output: - - $ moo new hello-world - Selecting dependencies for new migration: hello-world - - Confirm: create migration 'hello-world' - (No dependencies) - Are you sure? (yn): y - 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.yml that looks like this: - - Description: (Description here.) - Created: 2015-02-18 00:50:12.041176 UTC - Depends: - Apply: | - (Apply SQL here.) - - Revert: | - (Revert SQL here.) - - This migration has no valid apply or revert SQL yet; that's for you - to provide. You might edit the apply and revert fields as follows: - - Apply: | - CREATE TABLE foo (a int); - - Revert: | - DROP TABLE foo; - - 7. Test the new migration with "moo test". This will install the - migration in a transaction and roll it back. Here is example output: - - $ moo test hello-world - Applying: hello-world... done. - Reverting: hello-world... done. - Successfully tested migrations. - - 8. Install the migration. This can be done in one of two ways: with - "moo upgrade" or with "moo apply". Here are examples: - - $ moo apply hello-world - Applying: hello-world... done. - Successfully applied migrations. - - $ moo upgrade - Applying: hello-world... done. - Database successfully upgraded. - - 9. List installed migrations with "moo list". - - $ moo list - hello-world - - 10. Revert the migration. - - $ moo revert hello-world - Reverting: hello-world... done. - Successfully reverted migrations. - - 11. List migrations that have not been installed. - - $ moo upgrade-list - Migrations to install: - hello-world - -Configuration file format -------------------------- - -All moo commands accept a --config-file option which you can use to -specify the path to a configuration file containing your settings. This -approach is an alternative to setting environment variables. The -configuration file format uses the same environment variable names for -its fields. An example configuration is as follows: - - DBM_DATABASE = "/path/to/database.db" - DBM_MIGRATION_STORE = "/path/to/migration/store" - DBM_LINEAR_MIGRATIONS = on/off (or true/false; defaults to off) - DBM_TIMESTAMP_FILENAMES = on/off (or true/false; defaults to off) - -Alternatively, you may save your settings to "moo.cfg" file in the current -directory (probably a project root) and moo will load it automatically, if -present. Specifying --config-file disables this behavior. - -If you use a config file (either the default one or the one specified with ---config-file option) but the environment variables are set, they will -override settings from the file. You may use this to have project settings -specified in a file and use environment to specify user-local configuration -options. - -Migration file format ---------------------- - -A migration used by this package is a structured document in YAML -format containing these fields: - - Description: (optional) a textual description of the migration - - Dependencies: (required, but may be empty) a whitespace-separated - list of migration names on which the migration - depends; these names are the migration filenames - without the filename extension - - Created: The UTC date and time at which this migration was - created - - Apply: The SQL necessary to apply this migration to the - database - - Revert: (optional) The SQL necessary to revert this migration - from the database - -The format of this file is somewhat flexible; please see the YAML 1.2 -format specification for a full description of syntax features. I -recommend appending "|" to the Apply and Revert fields if they contain -multi-line SQL that you want to keep that way, e.g., - - Apply: | - CREATE OR REPLACE FUNCTION ... - ... - ... - - Revert: | - DROP TABLE foo; - DROP TABLE bar; - -Note that this is only *necessary* when concatenating the lines would -have a different meaning, e.g., - - Apply: - -- Comment here - CREATE TABLE; - -Without "|" on the "Apply:" line, the above text would be collapsed to -"-- Comment here CREATE TABLE;" which is probably not what you want. -For a full treatment of this behavior, see the YAML spec. - -Environment ------------ - -Moo depends on these environment variables / configuration file -settings: - - DBM_DATABASE - - The database connection string for the database you'll be - managing. The connection strings for each supported database type - are as follows: - - PostgreSQL: - - The format of this value is a PostgreSQL database connection - string, i.e., that described at: - - http://www.postgresql.org/docs/8.1/static/libpq.html#LIBPQ-CONNECT - - SQlite3: - - The format of this value is a filesystem path to the Sqlite3 - database to be used. - - MySQL: - - For MySQL, DBM_DATABASE should be a value of key value pairs, - where each pair is formed by `key=value`, and each pair separated - by a semicolon. Required keys are `host`, `user` and `database`, - and you can optionally supply `port` and `password`. - - Example: DBM_DATABASE="host=localhost; user=root; database=cows" - - DBM_MIGRATION_STORE - - The path to the filesystem directory where your migrations will be - kept. moo will create new migrations in this directory and use - the migrations in this directory when updating the database - schema. Initially, you'll probably set this to an extant (but - empty) directory. moo will not create it for you. - - DBM_LINEAR_MIGRATIONS - - If set to true/on, the linear migrations feature will be enabled. - Defaults to off. See 'Linear migrations' section for more details. - - DBM_TIMESTAMP_FILENAMES - - If set to true/on, the migration filename for new migrations will - have a timestamp embedded in it. - -Commands --------- - - new : create a new migration with the given name and - save it in the migration store. This command will prompt you for - dependencies on other migrations (if the 'linear migrations' - feature is disabled) and ask for confirmation before creating the - migration in the store. If you use the --no-ask flag, the migration - will be created immediately with no dependencies. - - apply : apply the specified migration (and its - dependencies) to the database. This operation will be performed - in a single transaction which will be rolled back if an error - occurs. moo will output updates as each migration is applied. - - revert : revert the specified migration (and its - reverse dependencies -- the migrations which depend on it) from - the database. This operation will be performed in a single - transaction which will be rolled back if an error occurs. moo - will output updates as each migration is reverted. - - test : once you've created a migration, you might - find it useful to test the migration to be sure that it is - syntactically valid; the "test" command will apply the specified - migration and revert it (if revert SQL is specified in the - migration). It will perform both of these operations in a - transaction and then issue a rollback. - - upgrade: this will apply all migrations in the migration store which - have not yet been applied to the database. Each migration will be - applied with its dependenciees in the correct order. All of the - migrations will be applied together in a single transaction. By - default, this transaction is committed; if you use the --test - flag, the transaction will be rolled back, allowing you to test - the entire upgrade process. - - upgrade-list: this will list the migrations that the "upgrade" - command would apply if you were to run it. In other words, this - will list all migrations which have not yet been applied to the - database. - - reinstall: this will revert, then reapply a migration, all in a - transaction. If --test is specified, the transaction will be - rolled back; otherwise it will be committed. This is mostly - useful in development when a migration applies but is incorrect - and needs to be tweaked and reapplied. - -Linear migrations ------------------ - -If you know that every migration needs to depend on all previous ones, -consider enabling this feature. When enabled, 'moo new' will automatically -select smallest subset of existing migrations that will make the new one -indirectly depend on every other already in the store. This in turn makes -the store linear-ish (in terms of order of execution) and helps managing the -migrations by always depending on previous work. Also, this may easily be used -to see how the database changed in time. diff --git a/README.md b/README.md index 81ebaf9..93ed36f 100644 --- a/README.md +++ b/README.md @@ -1,64 +1,363 @@ +# dbmigrations -Stability Note --------------- - -Warning: this package is no longer actively maintained, and -unfortunately I do not have plans to resume maintenance. This package -is very old; in fact, it's the first Haskell package I published, and -it shows in many ways. I also don't use it nowadays, which doesn't -help when it comes to maintenance. If you are using this library in -production, just keep this in mind and I encourage you to consider -alternatives. If you would like to take over maintenance, please -consider forking this and letting me know at `cygnus AT foobox DOT com` -so I can update the Hackage deprecation status in favor of your new -package. - -dbmigrations ------------- - -This package contains a library for the creation, management, and -installation of schema updates (called "migrations") for a relational -database. In particular, this package lets the migration author express -explicit dependencies between migrations. This library is accompanied -by a number database-specific packages that contain the management -tools to automatically install or revert migrations accordingly. +This package contains a library for the creation, management, and installation +of schema updates (called "migrations") for a relational database. In +particular, this package lets the migration author express explicit dependencies +between migrations. This library is accompanied by a number database-specific +packages that contain the management tools to automatically install or revert +migrations accordingly. This package operates on two logical entities: - - The "backend": the relational database whose schema you want to - manage. +- **backend**: the relational database whose schema you want to manage. - - The "migration store": the collection of schema changes you want to - apply to the database. These migrations are expressed using plain - text files collected together in a single directory, although the - library is general enough to permit easy implementation of other - storage representations for migrations. +- **migration store**: the collection of schema changes you want to apply to the + database. These migrations are expressed using plain text files collected + together in a single directory, although the library is general enough to + permit easy implementation of other storage representations for migrations. -Getting started ---------------- +## Getting started -To get started, install the right database-specific dbmigrations package -for your database. Current options are: +To get started, install the right database-specific dbmigrations package for +your database. Current options are: - * `dbmigrations-postgresql` - * `dbmigrations-mysql` - * `dbmigrations-sqlite` +- `dbmigrations-postgresql` +- `dbmigrations-mysql` +- `dbmigrations-sqlite` -Each package provides a variant of the "moo" management program -("moo-postgresql", "moo-mysql", and "moo-sqlite" respectively) to be -used to manage your database schema. See MOO.TXT for details on how to -use these tools to manage your database migrations. +Each package provides a CLI suitable for the given backend. -Submitting patches ------------------- +The database type-specific packages that work as a companion to this library +contain tools called `moo-postgresql`, `moo-mysql`, `moo-sqlite`, etc. They are +responsible for creating, installing, and reverting migrations in your database +backend. Since all of these command line tools offer the exact same interface, +they are described here in a single document. The executables mentioned above +are simply called `moo` for the rest of this document. That is, given an example +that reads as `moo command` you actually have to execute `moo-postgresql +command` or `moo-mysql command` and so on. -I'll gladly consider accepting patches to this package; please do not -hesitate to submit GitHub pull requests. I'll be more likely to accept -a patch if you can follow these guidelines where appropriate: +At present, MySQL, PostgreSQL and Sqlite3 are the only supported database +backends. - - Keep patches small; a single patch should make a single logical - change with minimal scope. +The moo tools work by creating migration files in a specific location, called a +migration store, on your filesystem. This directory is where all possible +migrations for your project will be kept. Moo allows you to create migrations +that depend on each other. When you use moo to upgrade your database schema, it +determines which migrations are missing, what their dependencies are, and +installs the required migrations in the correct order (based on dependencies). - - If possible, include tests with your patch. +Moo works by prompting you for new migration information. It then creates a +migration YAML file (whose format is described below), which you then edit by +hand. - - If possible, include haddock with your patch. +When migrations are installed into your database, the set of installed +migrations is tracked by way of a migration table that is installed into your +database. + +## Example + +_In the examples below, replace any `moo` command shown with `moo-`._ + +1. Create a directory in which to store migration files. + +2. Set an environment variable `DBM_MIGRATION_STORE` to the path to the + directory you created in step 1. + +3. Set an environment variable `DBM_DATABASE` to a database connection string + that is appropriate for the database type you chose. The contents of this + depend on the database type, see the "Environment" documentation section for + more information. + +4. Run `moo upgrade`. This command will not actually install any migrations, + since you have not created any, but it will attempt to connect to your + database and install a migration-tracking table. + + If this step succeeds, you should see this output: + + ``` + Database is up to date. + ``` + +5. Create a migration with `moo new`. Here is an example output: + + ```console + % moo new hello-world + Selecting dependencies for new migration: hello-world + + Confirm: create migration 'hello-world' + (No dependencies) + Are you sure? (yn): y + Migration created successfully: ".../hello-world.yml" + ``` + +6. Edit the migration you created. In this case, moo created a file + `$DBM_MIGRATION_STORE/hello_world.yml` that looks like this: + + ```yaml + Description: (Description here.) + Created: 2015-02-18 00:50:12.041176 UTC + Depends: + Apply: | + (Apply SQL here.) + + Revert: | + (Revert SQL here.) + ``` + + This migration has no valid apply or revert SQL yet; that's for you to + provide. You might edit the apply and revert fields as follows: + + ```yaml + Apply: | + CREATE TABLE foo (a int); + + Revert: | + DROP TABLE foo; + ``` + +7. Test the new migration with `moo test`. This will install the migration in a + transaction and roll it back. Here is example output: + + ```console + % moo test hello-world + Applying: hello-world... done. + Reverting: hello-world... done. + Successfully tested migrations. + ``` + + + + +8. Install the migration. This can be done in one of two ways: with `moo + upgrade` or with `moo apply`. Here are examples: + + + ```console + % moo apply hello-world + Applying: hello-world... done. + Successfully applied migrations. + + % moo upgrade + Applying: hello-world... done. + Database successfully upgraded. + ``` + + + +9. List installed migrations with `moo list`. + + ```console + % moo list + hello-world + ``` + +10. Revert the migration. + + ```console + % moo revert hello-world + Reverting: hello-world... done. + Successfully reverted migrations. + ``` + +11. List migrations that have not been installed. + + ```console + % moo upgrade-list + Migrations to install: + hello-world + ``` + +## Configuration File Format + +All moo commands accept a `--config-file` option which you can use to specify +the path to a configuration file containing your settings. This approach is an +alternative to setting environment variables. The configuration file format uses +the same environment variable names for its fields. An example configuration is +as follows: + +``` +DBM_DATABASE = "/path/to/database.db" +DBM_MIGRATION_STORE = "/path/to/migration/store" +DBM_LINEAR_MIGRATIONS = on/off (or true/false; defaults to off) +DBM_TIMESTAMP_FILENAMES = on/off (or true/false; defaults to off) +``` + +Alternatively, you may save your settings to `moo.cfg` file in the current +directory (probably a project root) and moo will load it automatically, if +present. Specifying `--config-file` disables this behavior. + +If you use a config file (either the default one or the one specified with +`--config-file` option) but the environment variables are set, they will +override settings from the file. You may use this to have project settings +specified in a file and use environment to specify user-local configuration +options. + +## Migration Files Format + +A migration used by this package is a structured document in YAML +format containing these fields: + +``` + Description: (optional) a textual description of the migration + +Dependencies: (required, but may be empty) a whitespace-separated + list of migration names on which the migration + depends; these names are the migration filenames + without the filename extension + + Created: The UTC date and time at which this migration was + created + + Apply: The SQL necessary to apply this migration to the + database + + Revert: (optional) The SQL necessary to revert this migration + from the database +``` + +The format of this file is somewhat flexible; please see the YAML 1.2 format +specification for a full description of syntax features. I recommend appending +"|" to the Apply and Revert fields if they contain multi-line SQL that you want +to keep that way, e.g., + +```yaml +Apply: | + CREATE OR REPLACE FUNCTION ... + ... + ... + +Revert: | + DROP TABLE foo; + DROP TABLE bar; +``` + +Note that this is only _necessary_ when concatenating the lines would have a +different meaning, e.g., + + + +```yaml +Apply: + -- Comment here + CREATE TABLE; +``` + + + +Without "|" on the "Apply:" line, the above text would be collapsed to "-- +Comment here CREATE TABLE;" which is probably not what you want. For a full +treatment of this behavior, see the YAML spec. + +## Environment + +Moo depends on these environment variables / configuration file +settings: + +``` +DBM_DATABASE + + The database connection string for the database you'll be + managing. The connection strings for each supported database type + are as follows: + + PostgreSQL: + + The format of this value is a PostgreSQL database connection + string, i.e., that described at: + + http://www.postgresql.org/docs/8.1/static/libpq.html#LIBPQ-CONNECT + + SQlite3: + + The format of this value is a filesystem path to the Sqlite3 + database to be used. + + MySQL: + + For MySQL, DBM_DATABASE should be a value of key value pairs, + where each pair is formed by `key=value`, and each pair separated + by a semicolon. Required keys are `host`, `user` and `database`, + and you can optionally supply `port` and `password`. + + Example: DBM_DATABASE="host=localhost; user=root; database=cows" + +DBM_MIGRATION_STORE + + The path to the filesystem directory where your migrations will be + kept. moo will create new migrations in this directory and use + the migrations in this directory when updating the database + schema. Initially, you'll probably set this to an extant (but + empty) directory. moo will not create it for you. + +DBM_LINEAR_MIGRATIONS + + If set to true/on, the linear migrations feature will be enabled. + Defaults to off. See 'Linear migrations' section for more details. + +DBM_TIMESTAMP_FILENAMES + + If set to true/on, the migration filename for new migrations will + have a timestamp embedded in it. +``` + +## Commands + +``` + new : create a new migration with the given name and + save it in the migration store. This command will prompt you for + dependencies on other migrations (if the 'linear migrations' + feature is disabled) and ask for confirmation before creating the + migration in the store. If you use the --no-ask flag, the migration + will be created immediately with no dependencies. + + apply : apply the specified migration (and its + dependencies) to the database. This operation will be performed + in a single transaction which will be rolled back if an error + occurs. moo will output updates as each migration is applied. + + revert : revert the specified migration (and its + reverse dependencies -- the migrations which depend on it) from + the database. This operation will be performed in a single + transaction which will be rolled back if an error occurs. moo + will output updates as each migration is reverted. + + test : once you've created a migration, you might + find it useful to test the migration to be sure that it is + syntactically valid; the "test" command will apply the specified + migration and revert it (if revert SQL is specified in the + migration). It will perform both of these operations in a + transaction and then issue a rollback. + + upgrade: this will apply all migrations in the migration store which + have not yet been applied to the database. Each migration will be + applied with its dependenciees in the correct order. All of the + migrations will be applied together in a single transaction. By + default, this transaction is committed; if you use the --test + flag, the transaction will be rolled back, allowing you to test + the entire upgrade process. + + upgrade-list: this will list the migrations that the "upgrade" + command would apply if you were to run it. In other words, this + will list all migrations which have not yet been applied to the + database. + + reinstall: this will revert, then reapply a migration, all in a + transaction. If --test is specified, the transaction will be + rolled back; otherwise it will be committed. This is mostly + useful in development when a migration applies but is incorrect + and needs to be tweaked and reapplied. +``` + +## Linear Migrations + +If you know that every migration needs to depend on all previous ones, consider +enabling this feature. When enabled, `moo new` will automatically select +smallest subset of existing migrations that will make the new one indirectly +depend on every other already in the store. This in turn makes the store +linear-ish (in terms of order of execution) and helps managing the migrations by +always depending on previous work. Also, this may easily be used to see how the +database changed in time. + +--- + +[LICENSE](./LICENSE) | [CHANGELOG](./CHANGELOG.md) diff --git a/dbmigrations.cabal b/dbmigrations.cabal index 4d961ce..916d263 100644 --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -1,171 +1,181 @@ -Name: dbmigrations -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 - (called /migrations/) for a relational database. In - particular, this package lets the migration author - express explicit dependencies between migrations - and the management tool automatically installs or - reverts migrations accordingly, using transactions - for safety. +cabal-version: 1.18 - This package is written to support a number of - different databases. For packages that support - specific databases using this library, see packages - named "dbmigrations-BACKEND". Each package - provides an executable "moo-BACKEND" for managing - migrations. Usage information for the "moo-" - executables can be found in "MOO.TXT" in this - package. +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack - This package also includes a conformance test suite - to ensure that backend implementations respect the - library's required semantics. +name: dbmigrations +version: 2.1.0 +synopsis: An implementation of relational database "migrations" +description: Please see +category: Database +homepage: https://github.com/haskell-github-trust/dbmigrations#readme +bug-reports: https://github.com/haskell-github-trust/dbmigrations/issues +author: Jonathan Daugherty +maintainer: Pat Brisbin +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + tests/example_store/root + tests/example_store/update1 + tests/example_store/update2 + tests/config_loading/cfg1.cfg + tests/config_loading/cfg_ts.cfg + tests/config_loading/invalid.cfg + tests/config_loading/missing.cfg + tests/config_loading/moo.cfg + tests/migration_parsing/invalid_field_name.txt + tests/migration_parsing/invalid_missing_required_fields.txt + tests/migration_parsing/invalid_syntax.txt + tests/migration_parsing/invalid_timestamp.txt + tests/migration_parsing/valid_full.txt + tests/migration_parsing/valid_no_depends.txt + tests/migration_parsing/valid_no_desc.txt + tests/migration_parsing/valid_no_revert.txt + tests/migration_parsing/valid_no_timestamp.txt + tests/migration_parsing/valid_with_colon.txt + tests/migration_parsing/valid_with_comments.txt + tests/migration_parsing/valid_with_comments2.txt + tests/migration_parsing/valid_with_multiline_deps.txt +extra-doc-files: + README.md + CHANGELOG.md -Category: Database -Author: Jonathan Daugherty -Maintainer: Jonathan Daugherty -Build-Type: Simple -License: BSD3 -License-File: LICENSE -Cabal-Version: >= 1.10 +source-repository head + type: git + location: https://github.com/haskell-github-trust/dbmigrations -Data-Files: - README.md - MOO.TXT - test/example_store/root - test/example_store/update1 - test/example_store/update2 - test/config_loading/cfg1.cfg - test/config_loading/cfg_ts.cfg - test/config_loading/invalid.cfg - test/config_loading/missing.cfg - test/config_loading/moo.cfg - test/migration_parsing/invalid_field_name.txt - test/migration_parsing/invalid_missing_required_fields.txt - test/migration_parsing/invalid_syntax.txt - test/migration_parsing/invalid_timestamp.txt - test/migration_parsing/valid_full.txt - test/migration_parsing/valid_no_depends.txt - test/migration_parsing/valid_no_desc.txt - test/migration_parsing/valid_no_revert.txt - test/migration_parsing/valid_no_timestamp.txt - test/migration_parsing/valid_with_colon.txt - test/migration_parsing/valid_with_comments.txt - test/migration_parsing/valid_with_comments2.txt - test/migration_parsing/valid_with_multiline_deps.txt - -Source-Repository head - type: git - location: git://github.com/jtdaugherty/dbmigrations.git - -Library - default-language: Haskell2010 - if impl(ghc >= 6.12.0) - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields - -fno-warn-unused-do-bind - else - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields - - Build-Depends: - base >= 4 && < 5, - 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, - bytestring >= 0.9, - string-conversions >= 0.4, - text >= 0.11, - configurator >= 0.2, - split >= 0.2.2, - HUnit >= 1.2, - aeson, - 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 - Moo.CommandHandlers - Moo.CommandInterface - Moo.CommandUtils - Moo.Core - Moo.Main +library + 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 + Moo.CommandHandlers + Moo.CommandInterface + Moo.CommandUtils + Moo.Core + Moo.Main + other-modules: + Paths_dbmigrations + hs-source-dirs: + src + default-extensions: + BangPatterns + DataKinds + DeriveAnyClass + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TypeApplications + TypeFamilies + ghc-options: -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe + build-depends: + HDBC + , aeson + , base <5 + , bytestring + , configurator + , containers + , directory + , fgl + , filepath + , hspec + , mtl + , string-conversions + , text + , time + , yaml + default-language: GHC2021 + if impl(ghc >= 9.2) + ghc-options: -Wno-missing-kind-signatures + if impl(ghc >= 8.10) + ghc-options: -Wno-missing-safe-haskell-mode -test-suite dbmigrations-tests - default-language: Haskell2010 +test-suite spec type: exitcode-stdio-1.0 - Build-Depends: - base >= 4 && < 5, - dbmigrations, - time >= 1.4, - containers >= 0.2, - mtl >= 2.1, - filepath >= 1.1, - directory >= 1.0, - fgl >= 5.4, - template-haskell, - yaml, - bytestring >= 0.9, - string-conversions >= 0.4, - MissingH, - HDBC >= 2.2.1, - HUnit >= 1.2, - process >= 1.1, - configurator >= 0.2, - text >= 0.11, - split >= 0.2.2 - + main-is: Spec.hs other-modules: - Common - CommonTH - CycleDetectionTest - DependencyTest - FilesystemParseTest - FilesystemSerializeTest - FilesystemTest - MigrationsTest - StoreTest - InMemoryStore - LinearMigrationsTest - ConfigurationTest - - if impl(ghc >= 6.12.0) - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields - -fno-warn-unused-do-bind -Wwarn - else - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields - - Hs-Source-Dirs: test - Main-is: Main.hs - -Executable moo - default-language: Haskell2010 - Build-Depends: - base >= 4 && < 5, - configurator >= 0.2, - dbmigrations - - if impl(ghc >= 6.12.0) - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields - -fno-warn-unused-do-bind - else - ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields - - Hs-Source-Dirs: programs - Main-is: Moo.hs + Common + CommonTH + ConfigurationSpec + CycleDetectionSpec + DependencySpec + FilesystemParseSpec + FilesystemSerializeSpec + FilesystemSpec + HDBCSpec + InMemoryStore + LinearMigrationsSpec + MigrationsSpec + StoreSpec + Paths_dbmigrations + hs-source-dirs: + tests + default-extensions: + BangPatterns + DataKinds + DeriveAnyClass + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TypeApplications + TypeFamilies + ghc-options: -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -threaded -rtsopts "-with-rtsopts=-N" + build-depends: + HDBC + , HDBC-sqlite3 + , base <5 + , containers + , dbmigrations + , directory + , fgl + , filepath + , hspec + , mtl + , string-conversions + , template-haskell + , text + , time + default-language: GHC2021 + if impl(ghc >= 9.2) + ghc-options: -Wno-missing-kind-signatures + if impl(ghc >= 8.10) + ghc-options: -Wno-missing-safe-haskell-mode diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..338c545 --- /dev/null +++ b/package.yaml @@ -0,0 +1,111 @@ +name: dbmigrations +version: 2.1.0 +synopsis: An implementation of relational database "migrations" +description: Please see +author: "Jonathan Daugherty " +maintainer: "Pat Brisbin " +category: Database +github: haskell-github-trust/dbmigrations +license: BSD3 +license-file: LICENSE + +extra-doc-files: + - README.md + - CHANGELOG.md + +extra-source-files: + - tests/example_store/* + - tests/config_loading/* + - tests/migration_parsing/* + +ghc-options: + - -fwrite-ide-info + - -Weverything + - -Wno-all-missed-specialisations + - -Wno-missed-specialisations + - -Wno-missing-exported-signatures # re-enables missing-signatures + - -Wno-missing-import-lists + - -Wno-missing-local-signatures + - -Wno-monomorphism-restriction + - -Wno-safe + - -Wno-unsafe + +when: + - condition: "impl(ghc >= 9.2)" + ghc-options: + - -Wno-missing-kind-signatures + - condition: "impl(ghc >= 8.10)" + ghc-options: + - -Wno-missing-safe-haskell-mode + +dependencies: + - base < 5 + +language: GHC2021 +default-extensions: + - BangPatterns + - DataKinds + - DeriveAnyClass + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveLift + - DeriveTraversable + - DerivingStrategies + - FlexibleContexts + - FlexibleInstances + - GADTs + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NoImplicitPrelude + - NoMonomorphismRestriction + - OverloadedStrings + - RankNTypes + - ScopedTypeVariables + - StandaloneDeriving + - TypeApplications + - TypeFamilies + + # Soon after + # - DuplicateRecordFields + # - NoFieldSelectors + # - OverloadedRecordDot + +library: + source-dirs: src + dependencies: + - HDBC + - aeson + - bytestring + - configurator + - containers + - directory + - fgl + - filepath + - hspec + - mtl + - string-conversions + - text + - time + - yaml + +tests: + spec: + source-dirs: tests + ghc-options: -threaded -rtsopts "-with-rtsopts=-N" + main: Spec.hs + dependencies: + - HDBC + - HDBC-sqlite3 + - containers + - dbmigrations + - directory + - fgl + - filepath + - hspec + - mtl + - string-conversions + - template-haskell + - text + - time diff --git a/programs/Moo.hs b/programs/Moo.hs deleted file mode 100644 index 77fec11..0000000 --- a/programs/Moo.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Main - ( main - ) -where - -import Prelude - -main :: IO () -main = do - error $ - "This package (dbmigrations) does no longer contain the executable to \ - \create, apply or revert database migrations. Please install the specific \ - \wrapper package for your database: dbmigrations-postgresql, \ - \dbmigrations-mysql, or dbmigrations-sqlite. These packages contain \ - \database-specific executables that replace the former moo executable from the \ - \dbmigrations package." diff --git a/src/Database/Schema/Migrations.hs b/src/Database/Schema/Migrations.hs index 40e98c2..62747f7 100644 --- a/src/Database/Schema/Migrations.hs +++ b/src/Database/Schema/Migrations.hs @@ -9,19 +9,18 @@ module Database.Schema.Migrations ) where -import Data.Maybe (catMaybes) -import qualified Data.Set as Set -import Data.Text (Text) +import Prelude -import qualified Database.Schema.Migrations.Backend as B +import Data.Maybe (mapMaybe) +import Data.Set qualified as Set +import Data.Text (Text) +import Database.Schema.Migrations.Backend qualified as B import Database.Schema.Migrations.Dependencies ( dependencies , reverseDependencies ) -import Database.Schema.Migrations.Migration - ( Migration (..) - ) -import qualified Database.Schema.Migrations.Store as S +import Database.Schema.Migrations.Migration (Migration (..)) +import Database.Schema.Migrations.Store qualified as S -- | Given a 'B.Backend' and a 'S.MigrationMap', query the backend and -- return a list of migration names which are available in the @@ -31,7 +30,7 @@ missingMigrations backend storeData = do let storeMigrationNames = map mId $ S.storeMigrations storeData backendMigrations <- B.getMigrations backend - return $ + pure $ Set.toList $ Set.difference (Set.fromList storeMigrationNames) @@ -46,13 +45,18 @@ createNewMigration -> IO (Either String Migration) createNewMigration store newM = do available <- S.getMigrations store - case mId newM `elem` available of - True -> do - fullPath <- S.fullMigrationName store (mId newM) - return $ Left $ "Migration " ++ (show fullPath) ++ " already exists" - False -> do - S.saveMigration store newM - return $ Right newM + ( if mId newM `elem` available + then + ( do + fullPath <- S.fullMigrationName store (mId newM) + pure $ Left $ "Migration " <> show fullPath <> " already exists" + ) + else + ( do + S.saveMigration store newM + pure $ Right newM + ) + ) -- | Given a 'B.Backend', ensure that the backend is ready for use by -- bootstrapping it. This entails installing the appropriate database @@ -61,9 +65,10 @@ createNewMigration store newM = do ensureBootstrappedBackend :: B.Backend -> IO () ensureBootstrappedBackend backend = do bsStatus <- B.isBootstrapped backend - case bsStatus of - True -> return () - False -> B.getBootstrapMigration backend >>= B.applyMigration backend + ( if bsStatus + then pure () + else B.getBootstrapMigration backend >>= B.applyMigration backend + ) -- | Given a migration mapping computed from a MigrationStore, a -- backend, and a migration to apply, return a list of migrations to @@ -79,11 +84,11 @@ migrationsToApply storeData backend migration = do allMissing <- missingMigrations backend storeData let - deps = (dependencies graph $ mId migration) ++ [mId migration] + deps = dependencies graph (mId migration) <> [mId migration] namesToInstall = [e | e <- deps, e `elem` allMissing] - loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToInstall + loadedMigrations = mapMaybe (S.storeLookup storeData) namesToInstall - return loadedMigrations + pure loadedMigrations -- | Given a migration mapping computed from a MigrationStore, a -- backend, and a migration to revert, return a list of migrations to @@ -99,8 +104,8 @@ migrationsToRevert storeData backend migration = do allInstalled <- B.getMigrations backend let - rDeps = (reverseDependencies graph $ mId migration) ++ [mId migration] + rDeps = reverseDependencies graph (mId migration) <> [mId migration] namesToRevert = [e | e <- rDeps, e `elem` allInstalled] - loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToRevert + loadedMigrations = mapMaybe (S.storeLookup storeData) namesToRevert - return loadedMigrations + pure loadedMigrations diff --git a/src/Database/Schema/Migrations/Backend.hs b/src/Database/Schema/Migrations/Backend.hs index eb2af5e..c39ddfb 100644 --- a/src/Database/Schema/Migrations/Backend.hs +++ b/src/Database/Schema/Migrations/Backend.hs @@ -1,16 +1,13 @@ -{-# LANGUAGE OverloadedStrings #-} - module Database.Schema.Migrations.Backend ( Backend (..) , rootMigrationName ) where -import Data.Text (Text) +import Prelude -import Database.Schema.Migrations.Migration - ( Migration (..) - ) +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 @@ -24,8 +21,7 @@ rootMigrationName = "root" -- migrations. A Backend also supplies the migration necessary to -- "bootstrap" a backend so that it can track which migrations are -- installed. -data Backend - = Backend +data Backend = Backend { getBootstrapMigration :: IO Migration -- ^ The migration necessary to bootstrap a database with -- this connection interface. This might differ slightly diff --git a/src/Database/Schema/Migrations/Backend/HDBC.hs b/src/Database/Schema/Migrations/Backend/HDBC.hs index 8e0c1cb..ab3d2d5 100644 --- a/src/Database/Schema/Migrations/Backend/HDBC.hs +++ b/src/Database/Schema/Migrations/Backend/HDBC.hs @@ -1,34 +1,29 @@ -{-# LANGUAGE OverloadedStrings #-} - module Database.Schema.Migrations.Backend.HDBC ( hdbcBackend + , HDBCConnection (..) ) where +import Prelude + +import Control.Exception (catch) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) import Database.HDBC ( IConnection (getTables, run, runRaw) + , SqlError , commit , disconnect , fromSql , quickQuery' , rollback , toSql + , withTransaction ) - -import Database.Schema.Migrations.Backend - ( Backend (..) - , rootMigrationName - ) -import Database.Schema.Migrations.Migration - ( Migration (..) - , newMigration - ) - -import Data.String.Conversions (cs, (<>)) -import Data.Text (Text) - -import Control.Applicative ((<$>)) -import Data.Time.Clock (getCurrentTime) +import Database.Schema.Migrations.Backend (Backend (..), rootMigrationName) +import Database.Schema.Migrations.Migration (Migration (..), newMigration) +import Database.Schema.Migrations.Test.BackendTest qualified as BackendTest migrationTableName :: Text migrationTableName = "installed_migrations" @@ -47,7 +42,7 @@ hdbcBackend conn = , getBootstrapMigration = do ts <- getCurrentTime - return $ + pure $ (newMigration rootMigrationName) { mApply = createSql , mRevert = Just revertSql @@ -65,10 +60,10 @@ hdbcBackend conn = <> " (migration_id) VALUES (?)" ) [toSql $ mId m] - return () + pure () , revertMigration = \m -> do case mRevert m of - Nothing -> return () + Nothing -> pure () Just query -> runRaw conn (cs query) -- Remove migration from installed_migrations in either case. _ <- @@ -80,12 +75,24 @@ hdbcBackend conn = <> " WHERE migration_id = ?" ) [toSql $ mId m] - return () + pure () , getMigrations = do results <- quickQuery' conn (cs $ "SELECT migration_id FROM " <> migrationTableName) [] - return $ map (fromSql . head) results + pure $ map (fromSql . head) results , commitBackend = commit conn , rollbackBackend = rollback conn , disconnectBackend = disconnect conn } + +-- | For newtype deriving any HDBC-compatible connection +newtype HDBCConnection a = HDBCConnection a + +instance IConnection a => BackendTest.BackendConnection (HDBCConnection a) where + supportsTransactionalDDL = const True + makeBackend (HDBCConnection c) = hdbcBackend c + commit (HDBCConnection c) = commit c + withTransaction (HDBCConnection c) transaction = + withTransaction c (transaction . HDBCConnection) + getTables (HDBCConnection c) = map cs <$> getTables c + catchAll (HDBCConnection _) act handler = act `catch` \(_ :: SqlError) -> handler diff --git a/src/Database/Schema/Migrations/CycleDetection.hs b/src/Database/Schema/Migrations/CycleDetection.hs index f93cd19..6b84c46 100644 --- a/src/Database/Schema/Migrations/CycleDetection.hs +++ b/src/Database/Schema/Migrations/CycleDetection.hs @@ -3,16 +3,11 @@ module Database.Schema.Migrations.CycleDetection ) where -import Data.Graph.Inductive.Graph - ( Graph (..) - , Node - , edges - , nodes - ) +import Prelude import Control.Monad (forM) import Control.Monad.State (State, evalState, get, gets, put) - +import Data.Graph.Inductive.Graph (Graph (..), Node, edges, nodes) import Data.List (findIndex) import Data.Maybe (fromJust) @@ -30,9 +25,9 @@ replace :: [a] -> Int -> a -> [a] replace elems index val | index > length elems = error "replacement index too large" | otherwise = - (take index elems) - ++ [val] - ++ (reverse $ take ((length elems) - (index + 1)) $ reverse elems) + take index elems + <> [val] + <> reverse (take (length elems - (index + 1)) $ reverse elems) setMark :: Int -> Mark -> State CycleDetectionState () setMark n mark = do @@ -46,8 +41,8 @@ hasCycle' g = do m <- getMark n case m of White -> visit g n - _ -> return False - return $ or result + _ -> pure False + pure $ or result visit :: Graph g => g a b -> Node -> State CycleDetectionState Bool visit g n = do @@ -55,11 +50,14 @@ visit g n = do result <- forM [v | (u, v) <- edges g, u == n] $ \node -> do m <- getMark node case m of - Gray -> return True + Gray -> pure True White -> visit g node - _ -> return False - case or result of - True -> return True - False -> do - setMark n Black - return False + _ -> pure False + ( if or result + then pure True + else + ( do + setMark n Black + pure False + ) + ) diff --git a/src/Database/Schema/Migrations/Dependencies.hs b/src/Database/Schema/Migrations/Dependencies.hs index 1a76808..23eb203 100644 --- a/src/Database/Schema/Migrations/Dependencies.hs +++ b/src/Database/Schema/Migrations/Dependencies.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} - -- | 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. @@ -13,6 +10,9 @@ module Database.Schema.Migrations.Dependencies ) where +import Prelude + +import Data.Bifunctor (first) import Data.Graph.Inductive.Graph ( Graph (..) , Node @@ -24,9 +24,7 @@ import Data.Graph.Inductive.Graph ) import Data.Graph.Inductive.PatriciaTree (Gr) import Data.Maybe (fromJust) -import Data.Monoid ((<>)) import Data.Text (Text) - import Database.Schema.Migrations.CycleDetection (hasCycle) -- | 'Dependable' objects supply a representation of their identifiers, @@ -58,13 +56,12 @@ data DependencyGraph a = DG instance Eq a => Eq (DependencyGraph a) where g1 == g2 = - ( (nodes $ depGraph g1) == (nodes $ depGraph g2) - && (edges $ depGraph g1) == (edges $ depGraph g2) - ) + nodes (depGraph g1) == nodes (depGraph g2) + && edges (depGraph g1) == edges (depGraph g2) instance Show a => Show (DependencyGraph a) where show g = - "(" ++ (show $ nodes $ depGraph g) ++ ", " ++ (show $ edges $ depGraph g) ++ ")" + "(" <> show (nodes $ depGraph g) <> ", " <> show (edges $ depGraph g) <> ")" -- XXX: provide details about detected cycles @@ -97,14 +94,14 @@ mkDepGraph objects = objMap = map (\o -> (depId o, o)) objects ids = zip objects [1 ..] - names = map (\(o, i) -> (depId o, i)) ids + names = map (first depId) ids type NextNodesFunc = Gr Text Text -> Node -> [Node] cleanLDups :: Eq a => [a] -> [a] cleanLDups [] = [] cleanLDups [e] = [e] -cleanLDups (e : es) = if e `elem` es then (cleanLDups es) else (e : cleanLDups es) +cleanLDups (e : es) = if e `elem` es then cleanLDups es else e : cleanLDups es -- | Given a dependency graph and an ID, return the IDs of objects that -- the object depends on. IDs are returned with least direct @@ -124,8 +121,8 @@ dependenciesWith nextNodes dg@(DG _ nMap theGraph) name = let lookupId = fromJust $ lookup name nMap depNodes = nextNodes theGraph lookupId - recurse theNodes = map (dependenciesWith nextNodes dg) theNodes getLabel node = fromJust $ lab theGraph node labels = map getLabel depNodes + recurse = map (dependenciesWith nextNodes dg) in - labels ++ (concat $ recurse labels) + labels <> concat (recurse labels) diff --git a/src/Database/Schema/Migrations/Filesystem.hs b/src/Database/Schema/Migrations/Filesystem.hs index 7c4e108..71b3656 100644 --- a/src/Database/Schema/Migrations/Filesystem.hs +++ b/src/Database/Schema/Migrations/Filesystem.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- | This module provides a type for interacting with a -- filesystem-backed 'MigrationStore'. module Database.Schema.Migrations.Filesystem @@ -16,36 +10,31 @@ where import Prelude -import qualified Data.ByteString.Char8 as BSC -import Data.String.Conversions (cs, (<>)) -import Data.Text (Text) -import qualified Data.Text as T -import System.Directory (doesFileExist, getDirectoryContents) -import System.FilePath (dropExtension, takeBaseName, takeExtension, ()) - -import qualified Data.Map as Map -import Data.Time (defaultTimeLocale, formatTime, parseTimeM) -import Data.Time.Clock (UTCTime) -import Data.Typeable (Typeable) - import Control.Exception (Exception (..), catch, throw) import Control.Monad (filterM) - import Data.Aeson import Data.Aeson.Types (typeMismatch) -import qualified Data.Yaml as Yaml -import GHC.Generics (Generic) - +import Data.ByteString.Char8 qualified as BSC +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (defaultTimeLocale, formatTime, parseTimeM) +import Data.Time.Clock (UTCTime) +import Data.Yaml qualified as Yaml import Database.Schema.Migrations.Filesystem.Serialize import Database.Schema.Migrations.Migration (Migration (..)) import Database.Schema.Migrations.Store +import GHC.Generics (Generic) +import System.Directory (doesFileExist, getDirectoryContents) +import System.FilePath (dropExtension, takeBaseName, takeExtension, ()) -data FilesystemStoreSettings = FSStore {storePath :: FilePath} - -data FilesystemStoreError = FilesystemStoreError String - deriving (Show, Typeable) +newtype FilesystemStoreSettings = FSStore + { storePath :: FilePath + } -instance Exception FilesystemStoreError +newtype FilesystemStoreError = FilesystemStoreError String + deriving stock (Show) + deriving anyclass (Exception) throwFS :: String -> a throwFS = throw . FilesystemStoreError @@ -60,14 +49,14 @@ filesystemStore :: FilesystemStoreSettings -> MigrationStore filesystemStore s = MigrationStore { fullMigrationName = fmap addNewMigrationExtension . fsFullMigrationName s - , loadMigration = \theId -> migrationFromFile s theId + , loadMigration = migrationFromFile s , 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 [cs $ dropExtension short | (short, _) <- existing] + pure [cs $ dropExtension short | (short, _) <- existing] , saveMigration = \m -> do filename <- fsFullMigrationName s $ mId m BSC.writeFile (cs $ addNewMigrationExtension filename) $ serializeMigration m @@ -81,10 +70,10 @@ addMigrationExtension path ext = path <> ext -- | Build path to migrations without extension. fsFullMigrationName :: FilesystemStoreSettings -> Text -> IO FilePath -fsFullMigrationName s name = return $ storePath s cs name +fsFullMigrationName s name = pure $ storePath s cs name isMigrationFilename :: String -> Bool -isMigrationFilename path = (cs $ takeExtension path) `elem` [filenameExtension, filenameExtensionTxt] +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 @@ -95,13 +84,13 @@ migrationFromFile store name = 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 +-- pure the 'Migration' if successful. Otherwise pure a parsing -- error message. migrationFromPath :: FilePath -> IO (Either String Migration) migrationFromPath path = do let name = cs $ takeBaseName path (Right <$> process name) - `catch` ( \(FilesystemStoreError s) -> return $ Left $ "Could not parse migration " ++ path ++ ":" ++ s + `catch` ( \(FilesystemStoreError s) -> pure $ Left $ "Could not parse migration " <> path <> ":" <> s ) where readMigrationFile = do @@ -124,7 +113,7 @@ data MigrationYaml = MigrationYaml , myRevert :: Maybe Text , myDepends :: DependsYaml } - deriving (Generic) + deriving stock (Generic) instance FromJSON MigrationYaml where parseJSON = genericParseJSON jsonOptions diff --git a/src/Database/Schema/Migrations/Filesystem/Serialize.hs b/src/Database/Schema/Migrations/Filesystem/Serialize.hs index 51b7e48..df44477 100644 --- a/src/Database/Schema/Migrations/Filesystem/Serialize.hs +++ b/src/Database/Schema/Migrations/Filesystem/Serialize.hs @@ -1,24 +1,18 @@ -{-# LANGUAGE OverloadedStrings #-} - module Database.Schema.Migrations.Filesystem.Serialize ( serializeMigration ) where -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS +import Prelude --- for UTCTime Show instance +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS import Data.Maybe (catMaybes) -import Data.Monoid ((<>)) import Data.String.Conversions (cs) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Time () - -import Database.Schema.Migrations.Migration - ( Migration (..) - ) +import Database.Schema.Migrations.Migration (Migration (..)) type FieldSerializer = Migration -> Maybe ByteString @@ -44,7 +38,7 @@ serializeTimestamp m = Just ts -> Just $ "Created: " <> (cs . show $ ts) serializeDepends :: FieldSerializer -serializeDepends m = Just . cs $ "Depends: " <> (T.intercalate " " $ mDeps m) +serializeDepends m = Just . cs $ "Depends: " <> T.intercalate " " (mDeps m) serializeRevert :: FieldSerializer serializeRevert m = @@ -53,10 +47,10 @@ serializeRevert m = Just revert -> Just $ "Revert: |\n" - <> (serializeMultiline revert) + <> serializeMultiline revert serializeApply :: FieldSerializer -serializeApply m = Just $ "Apply: |\n" <> (serializeMultiline $ mApply m) +serializeApply m = Just $ "Apply: |\n" <> serializeMultiline (mApply m) commonPrefix :: Text -> Text -> Text commonPrefix a b = cs . map fst $ takeWhile (uncurry (==)) (T.zip a b) diff --git a/src/Database/Schema/Migrations/Migration.hs b/src/Database/Schema/Migrations/Migration.hs index a0e585f..994da94 100644 --- a/src/Database/Schema/Migrations/Migration.hs +++ b/src/Database/Schema/Migrations/Migration.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Database.Schema.Migrations.Migration ( Migration (..) , newMigration @@ -7,13 +5,12 @@ module Database.Schema.Migrations.Migration ) where -import Database.Schema.Migrations.Dependencies +import Prelude import Data.Text (Text) import Data.Time () - --- for UTCTime Show instance -import qualified Data.Time.Clock as Clock +import Data.Time.Clock qualified as Clock +import Database.Schema.Migrations.Dependencies data Migration = Migration { mTimestamp :: Maybe Clock.UTCTime @@ -23,7 +20,7 @@ data Migration = Migration , mRevert :: Maybe Text , mDeps :: [Text] } - deriving (Eq, Show, Ord) + deriving stock (Eq, Show, Ord) instance Dependable Migration where depsOf = mDeps diff --git a/src/Database/Schema/Migrations/Store.hs b/src/Database/Schema/Migrations/Store.hs index d7e73f0..3e920e4 100644 --- a/src/Database/Schema/Migrations/Store.hs +++ b/src/Database/Schema/Migrations/Store.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -- | This module provides an abstraction for a /migration store/, a -- facility in which 'Migration's can be stored and from which they -- can be loaded. This module also provides functions for taking @@ -24,21 +22,19 @@ module Database.Schema.Migrations.Store ) where -import Control.Applicative ((<$>)) +import Prelude + import Control.Monad (mzero) import Data.Graph.Inductive.Graph (indeg, labNodes) -import qualified Data.Map as Map +import Data.Map qualified as Map import Data.Maybe (isJust) import Data.Text (Text) - import Database.Schema.Migrations.Dependencies ( DependencyGraph (..) , depsOf , mkDepGraph ) -import Database.Schema.Migrations.Migration - ( Migration (..) - ) +import Database.Schema.Migrations.Migration (Migration (..)) -- | A mapping from migration name to 'Migration'. This is exported -- for testing purposes, but you'll want to interface with this @@ -53,8 +49,7 @@ data StoreData = StoreData -- | 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 +data MigrationStore = MigrationStore { loadMigration :: Text -> IO (Either String Migration) -- ^ Load a migration from the store. , saveMigration :: Migration -> IO () @@ -80,15 +75,15 @@ data MapValidationError DependencyGraphError String | -- | The specified migration is invalid. InvalidMigration String - deriving (Eq) + deriving stock (Eq) instance Show MapValidationError where show (DependencyReferenceError from to) = - "Migration " ++ (show from) ++ " references nonexistent dependency " ++ show to + "Migration " <> show from <> " references nonexistent dependency " <> show to show (DependencyGraphError msg) = - "There was an error constructing the dependency graph: " ++ msg + "There was an error constructing the dependency graph: " <> msg show (InvalidMigration msg) = - "There was an error loading a migration: " ++ msg + "There was an error loading a migration: " <> msg -- | A convenience function for extracting the list of 'Migration's -- extant in the specified 'StoreData'. @@ -109,37 +104,40 @@ storeLookup storeData migrationName = loadMigrations :: MigrationStore -> IO (Either [MapValidationError] StoreData) loadMigrations store = do migrations <- getMigrations store - loadedWithErrors <- mapM (\name -> loadMigration store name) migrations + loadedWithErrors <- mapM (loadMigration store) migrations let mMap = Map.fromList $ [(mId e, e) | e <- loaded] validationErrors = validateMigrationMap mMap (loaded, loadErrors) = sortResults loadedWithErrors ([], []) - allErrors = validationErrors ++ (InvalidMigration <$> loadErrors) + allErrors = validationErrors <> (InvalidMigration <$> loadErrors) sortResults [] v = v sortResults (Left e : rest) (ms, es) = sortResults rest (ms, e : es) sortResults (Right m : rest) (ms, es) = sortResults rest (m : ms, es) - case null allErrors of - False -> return $ Left allErrors - True -> do - -- Construct a dependency graph and, if that succeeds, return - -- StoreData. - case depGraphFromMapping mMap of - Left e -> return $ Left [DependencyGraphError e] - Right gr -> - return $ - Right - StoreData - { storeDataMapping = mMap - , storeDataGraph = gr - } + ( if null allErrors + then + ( do + -- Construct a dependency graph and, if that succeeds, return + -- StoreData. + case depGraphFromMapping mMap of + Left e -> pure $ Left [DependencyGraphError e] + Right gr -> + pure $ + Right + StoreData + { storeDataMapping = mMap + , storeDataGraph = gr + } + ) + else pure $ Left allErrors + ) -- | Validate a migration map. Returns zero or more validation errors. validateMigrationMap :: MigrationMap -> [MapValidationError] validateMigrationMap mMap = do - validateSingleMigration mMap =<< snd <$> Map.toList mMap + validateSingleMigration mMap . snd =<< Map.toList mMap -- | Validate a single migration. Looks up the migration's -- dependencies in the specified 'MigrationMap' and returns a @@ -148,10 +146,8 @@ validateSingleMigration :: MigrationMap -> Migration -> [MapValidationError] validateSingleMigration mMap m = do depId <- depsOf m if isJust $ Map.lookup depId mMap - then - mzero - else - return $ DependencyReferenceError (mId m) depId + then mzero + else pure $ DependencyReferenceError (mId m) depId -- | Create a 'DependencyGraph' from a 'MigrationMap'; returns Left if -- the dependency graph cannot be constructed (e.g., due to a diff --git a/src/Database/Schema/Migrations/Test/BackendTest.hs b/src/Database/Schema/Migrations/Test/BackendTest.hs index 521a558..d4f2e12 100644 --- a/src/Database/Schema/Migrations/Test/BackendTest.hs +++ b/src/Database/Schema/Migrations/Test/BackendTest.hs @@ -1,21 +1,42 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | A test that is not executed as part of this package's test suite but rather -- acts as a conformance test suit for database specific backend -- implementations. All backend specific executable packages are expected to -- have a test suite that runs this test. +-- +-- Usage: +-- +-- @ +-- module MyBackendSpec +-- ( spec +-- ) +-- where +-- +-- import Database.Schema.Migrations.Test.BackendTest hiding (spec) +-- import Database.Schema.Migrations.Test.BackendTest qualified as BackendTest +-- import MyBackend +-- import Test.Hspec +-- +-- instance BackendConnection MyBackendConnection where +-- -- ... +-- +-- newConnection :: IO MyBackendConnection +-- newConnection = undefined +-- +-- spec :: Spec +-- spec = before newConnection BackendTest.spec +-- @ module Database.Schema.Migrations.Test.BackendTest ( BackendConnection (..) - , tests + , spec ) where -import Data.ByteString (ByteString) - -import Control.Monad (forM_) -import Test.HUnit +import Prelude +import Control.Monad (void) +import Data.ByteString (ByteString) import Database.Schema.Migrations.Backend (Backend (..)) import Database.Schema.Migrations.Migration (Migration (..), newMigration) +import Test.Hspec -- | A typeclass for database connections that needs to implemented for each -- specific database type to use this test. @@ -38,164 +59,149 @@ class BackendConnection c where -- | Returns a backend instance. makeBackend :: c -> Backend -testSuite :: BackendConnection bc => Bool -> [bc -> IO ()] -testSuite transactDDL = - [ isBootstrappedFalseTest - , bootstrapTest - , isBootstrappedTrueTest - , if transactDDL then applyMigrationFailure else (const $ return ()) - , applyMigrationSuccess - , revertMigrationFailure - , revertMigrationNothing - , revertMigrationJust - ] - -tests :: BackendConnection bc => bc -> IO () -tests conn = do - let acts = testSuite $ supportsTransactionalDDL conn - forM_ acts $ \act -> do - commit conn - act conn - -bootstrapTest :: BackendConnection bc => bc -> IO () -bootstrapTest conn = do - let backend = makeBackend conn - bs <- getBootstrapMigration backend - applyMigration backend bs - assertEqual "installed_migrations table exists" ["installed_migrations"] - =<< getTables conn - assertEqual "successfully bootstrapped" [mId bs] =<< getMigrations backend - -isBootstrappedTrueTest :: BackendConnection bc => bc -> IO () -isBootstrappedTrueTest conn = do - result <- isBootstrapped $ makeBackend conn - assertBool "Bootstrapped check" result - -isBootstrappedFalseTest :: BackendConnection bc => bc -> IO () -isBootstrappedFalseTest conn = do - result <- isBootstrapped $ makeBackend conn - assertBool "Bootstrapped check" $ not result - -ignoreSqlExceptions :: BackendConnection bc => bc -> IO a -> IO (Maybe a) -ignoreSqlExceptions conn act = - (catchAll conn) - (act >>= return . Just) - (return Nothing) - -applyMigrationSuccess :: BackendConnection bc => bc -> IO () -applyMigrationSuccess conn = do - let backend = makeBackend conn +spec :: BackendConnection bc => SpecWith bc +spec = do + it "successfully bootstraps" $ \conn -> do + -- This should be false pre-bootstrap + isBootstrapped (makeBackend conn) `shouldReturn` False - let m1 = (newMigration "validMigration") {mApply = "CREATE TABLE valid1 (a int)"} + let backend = makeBackend conn + bs <- getBootstrapMigration backend + applyMigration backend bs - -- Apply the migrations, ignore exceptions - withTransaction conn $ \conn' -> applyMigration (makeBackend conn') m1 + -- This should be true now + isBootstrapped (makeBackend conn) `shouldReturn` True - -- Check that none of the migrations were installed - assertEqual "Installed migrations" ["root", "validMigration"] - =<< getMigrations backend - assertEqual "Installed tables" ["installed_migrations", "valid1"] - =<< getTables conn + getTables conn `shouldReturn` ["installed_migrations"] + getMigrations backend `shouldReturn` [mId bs] --- | Does a failure to apply a migration imply a transaction rollback? -applyMigrationFailure :: BackendConnection bc => bc -> IO () -applyMigrationFailure conn = do - let backend = makeBackend conn + it "migrates in a transaction" $ needDDL $ \conn -> do + backend <- makeBootstrappedBackend conn - let - m1 = (newMigration "second") {mApply = "CREATE TABLE validButTemporary (a int)"} - m2 = (newMigration "third") {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 conn $ withTransaction conn $ \conn' -> do - let backend' = makeBackend conn' - applyMigration backend' m1 - applyMigration backend' m2 + ignoreSqlExceptions_ conn $ withTransaction conn $ \conn' -> do + let backend' = makeBackend conn' + applyMigration backend' m1 + applyMigration backend' m2 - -- Check that none of the migrations were installed - assertEqual "Installed migrations" ["root"] =<< getMigrations backend - assertEqual "Installed tables" ["installed_migrations"] =<< getTables conn + getTables conn `shouldReturn` ["installed_migrations"] + getMigrations backend `shouldReturn` ["root"] -revertMigrationFailure :: BackendConnection bc => bc -> IO () -revertMigrationFailure conn = do - let backend = makeBackend conn + it "applies migrations" $ needDDL $ \conn -> do + let + backend = makeBackend conn + m1 = + (newMigration "validMigration") + { mApply = "CREATE TABLE valid1 (a int)" + } - let - m1 = - (newMigration "second") - { mApply = "CREATE TABLE validRMF (a int)" - , mRevert = Just "DROP TABLE validRMF" - } - m2 = - (newMigration "third") - { mApply = "alter table validRMF add column b int" - , mRevert = Just "INVALID REVERT SQL" - } - - applyMigration backend m1 - applyMigration backend m2 - - installedBeforeRevert <- getMigrations backend - - commitBackend backend - - -- Revert the migrations, ignore exceptions; the revert will fail, - -- but withTransaction will roll back. - _ <- ignoreSqlExceptions conn $ withTransaction conn $ \conn' -> do - let backend' = makeBackend conn' - revertMigration backend' m2 - revertMigration backend' m1 - - -- Check that none of the migrations were reverted - assertEqual "successfully roll back failed revert" installedBeforeRevert - =<< getMigrations backend - -revertMigrationNothing :: BackendConnection bc => bc -> IO () -revertMigrationNothing conn = do - let backend = makeBackend conn + withTransaction conn $ \conn' -> do + applyMigration (makeBackend conn') m1 - let m1 = - (newMigration "second") - { mApply = "create table revert_nothing (a int)" - , mRevert = Nothing - } + getTables conn `shouldReturn` ["installed_migrations", "valid1"] + getMigrations backend `shouldReturn` ["root", "validMigration"] - applyMigration backend m1 + context "revertMigration" $ do + it "handles failure to revert" $ needDDL $ \conn -> do + backend <- makeBootstrappedBackend conn - installedAfterApply <- getMigrations backend - assertBool "Check that the migration was applied" $ - "second" `elem` installedAfterApply + let + m1 = + (newMigration "second") + { mApply = "CREATE TABLE validRMF (a int)" + , mRevert = Just "DROP TABLE validRMF" + } + m2 = + (newMigration "third") + { mApply = "alter table validRMF add column b int" + , mRevert = Just "INVALID REVERT SQL" + } - -- Revert the migration, which should do nothing EXCEPT remove it - -- from the installed list - revertMigration backend m1 + applyMigration backend m1 + applyMigration backend m2 - installed <- getMigrations backend - assertBool "Check that the migration was reverted" $ - not $ - "second" `elem` installed + installedBeforeRevert <- getMigrations backend + commitBackend backend -revertMigrationJust :: BackendConnection bc => bc -> IO () -revertMigrationJust conn = do - let - name = "revertable" - backend = makeBackend conn + -- Revert the migrations, ignore exceptions; the revert will fail, but + -- withTransaction will roll back. + ignoreSqlExceptions_ conn $ withTransaction conn $ \conn' -> do + let backend' = makeBackend conn' + revertMigration backend' m2 + revertMigration backend' m1 - let m1 = - (newMigration name) - { mApply = "CREATE TABLE the_test_table (a int)" - , mRevert = Just "DROP TABLE the_test_table" - } + getMigrations backend `shouldReturn` installedBeforeRevert + + it "runs the Revert SQL" $ \conn -> do + backend <- makeBootstrappedBackend conn + + let + name = "revertable" + m1 = + (newMigration name) + { mApply = "CREATE TABLE the_test_table (a int)" + , mRevert = Just "DROP TABLE the_test_table" + } + + applyMigration backend m1 + + installedAfterApply <- getMigrations backend + installedAfterApply `shouldSatisfy` (name `elem`) - applyMigration backend m1 + revertMigration backend m1 - installedAfterApply <- getMigrations backend - assertBool "Check that the migration was applied" $ - name `elem` installedAfterApply + tables <- getTables conn + tables `shouldNotSatisfy` ("the_test_table" `elem`) -- dropped + installed <- getMigrations backend + installed `shouldNotSatisfy` (name `elem`) - -- Revert the migration, which should do nothing EXCEPT remove it - -- from the installed list - revertMigration backend m1 + it "removes the migration even if there's no Revert SQL" $ \conn -> do + backend <- makeBootstrappedBackend conn - installed <- getMigrations backend - assertBool "Check that the migration was reverted" $ not $ name `elem` installed + let + name = "second" + m1 = + (newMigration name) + { mApply = "create table revert_nothing (a int)" + , mRevert = Nothing + } + + applyMigration backend m1 + + installedAfterApply <- getMigrations backend + installedAfterApply `shouldSatisfy` (name `elem`) + + revertMigration backend m1 + + tables <- getTables conn + tables `shouldSatisfy` ("revert_nothing" `elem`) -- still here + installed <- getMigrations backend + installed `shouldNotSatisfy` (name `elem`) + +makeBootstrappedBackend :: BackendConnection bc => bc -> IO Backend +makeBootstrappedBackend conn = do + let backend = makeBackend conn + bs <- getBootstrapMigration backend + backend <$ applyMigration backend bs + +-- | Wrap a spec that requires transactional DDL and mark it pending if the +-- backend does not support that. +needDDL :: BackendConnection bc => (bc -> Expectation) -> bc -> Expectation +needDDL f conn + | supportsTransactionalDDL conn = + pendingWith "Skipping due to lack of Transactional DDL" + | otherwise = f conn + +ignoreSqlExceptions_ :: BackendConnection bc => bc -> IO a -> IO () +ignoreSqlExceptions_ conn act = void act `catch` pure () + where + catch = catchAll conn diff --git a/src/Moo/CommandHandlers.hs b/src/Moo/CommandHandlers.hs index 8e5c580..779e712 100644 --- a/src/Moo/CommandHandlers.hs +++ b/src/Moo/CommandHandlers.hs @@ -1,24 +1,32 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Moo.CommandHandlers where - -import Data.String.Conversions (cs, (<>)) - -import Control.Monad (forM_, when) +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Moo.CommandHandlers + ( newCommand + , upgradeCommand + , upgradeListCommand + , reinstallCommand + , listCommand + , applyCommand + , revertCommand + , testCommand + ) +where + +import Prelude + +import Control.Monad (forM_, unless, when) import Control.Monad.Reader (asks) import Control.Monad.Trans (liftIO) import Data.Maybe (isJust) -import qualified Data.Time.Clock as Clock -import Moo.CommandUtils -import Moo.Core -import System.Exit (ExitCode (..), exitSuccess, exitWith) - +import Data.String.Conversions (cs) +import Data.Time.Clock qualified as Clock import Database.Schema.Migrations import Database.Schema.Migrations.Backend import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Store hiding (getMigrations) +import Moo.CommandUtils +import Moo.Core +import System.Exit (ExitCode (..), exitSuccess, exitWith) newCommand :: CommandHandler newCommand storeData = do @@ -32,22 +40,22 @@ newCommand storeData = do if timestamp then fmap (timeString <>) required else required - noAsk <- _noAsk <$> asks _appOptions + noAsk <- asks (_noAsk . _appOptions) liftIO $ do 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) + then pure $ leafMigrations storeData else if noAsk - then (return []) + then pure [] else do putStrLn . cs $ "Selecting dependencies for new \ @@ -57,31 +65,35 @@ newCommand storeData = do result <- if noAsk - then (return True) + then pure True + else confirmCreation migrationId deps + + ( if result + then + ( do + now <- Clock.getCurrentTime + status <- + createNewMigration store $ + (newMigration migrationId) + { mDeps = deps + , mTimestamp = Just now + } + case status of + Left e -> putStrLn e >> exitWith (ExitFailure 1) + Right _ -> + putStrLn $ + "Migration created successfully: " + <> show fullPath + ) else - (confirmCreation migrationId deps) - - case result of - True -> do - now <- Clock.getCurrentTime - status <- - createNewMigration store $ - (newMigration migrationId) - { mDeps = deps - , mTimestamp = Just now - } - case status of - Left e -> putStrLn e >> (exitWith (ExitFailure 1)) - Right _ -> - putStrLn $ - "Migration created successfully: " - ++ show fullPath - False -> do - putStrLn "Migration creation cancelled." + ( do + putStrLn "Migration creation cancelled." + ) + ) upgradeCommand :: CommandHandler upgradeCommand storeData = do - isTesting <- _test <$> asks _appOptions + isTesting <- asks (_test . _appOptions) withBackend $ \backend -> do ensureBootstrappedBackend backend >> commitBackend backend migrationNames <- missingMigrations backend storeData @@ -91,13 +103,18 @@ upgradeCommand storeData = do forM_ migrationNames $ \migrationName -> do m <- lookupMigration storeData migrationName apply m storeData backend False - case isTesting of - True -> do - rollbackBackend backend - putStrLn "Upgrade test successful." - False -> do - commitBackend backend - putStrLn "Database successfully upgraded." + ( if isTesting + then + ( do + rollbackBackend backend + putStrLn "Upgrade test successful." + ) + else + ( do + commitBackend backend + putStrLn "Database successfully upgraded." + ) + ) upgradeListCommand :: CommandHandler upgradeListCommand storeData = do @@ -112,7 +129,7 @@ upgradeListCommand storeData = do reinstallCommand :: CommandHandler reinstallCommand storeData = do - isTesting <- _test <$> asks _appOptions + isTesting <- asks (_test . _appOptions) required <- asks _appRequiredArgs let [migrationId] = required @@ -123,13 +140,18 @@ reinstallCommand storeData = do _ <- revert m storeData backend _ <- apply m storeData backend True - case isTesting of - False -> do - commitBackend backend - putStrLn "Migration successfully reinstalled." - True -> do - rollbackBackend backend - putStrLn "Reinstall test successful." + ( if isTesting + then + ( do + rollbackBackend backend + putStrLn "Reinstall test successful." + ) + else + ( do + commitBackend backend + putStrLn "Migration successfully reinstalled." + ) + ) listCommand :: CommandHandler listCommand _ = do @@ -137,11 +159,11 @@ listCommand _ = do ensureBootstrappedBackend backend >> commitBackend backend ms <- getMigrations backend forM_ ms $ \m -> - when (not $ m == rootMigrationName) $ putStrLn . cs $ m + unless (m == rootMigrationName) $ putStrLn . cs $ m applyCommand :: CommandHandler applyCommand storeData = do - isTesting <- _test <$> asks _appOptions + isTesting <- asks (_test . _appOptions) required <- asks _appRequiredArgs let [migrationId] = required @@ -149,17 +171,22 @@ applyCommand storeData = do ensureBootstrappedBackend backend >> commitBackend backend m <- lookupMigration storeData migrationId _ <- apply m storeData backend True - case isTesting of - False -> do - commitBackend backend - putStrLn "Successfully applied migrations." - True -> do - rollbackBackend backend - putStrLn "Migration installation test successful." + ( if isTesting + then + ( do + rollbackBackend backend + putStrLn "Migration installation test successful." + ) + else + ( do + commitBackend backend + putStrLn "Successfully applied migrations." + ) + ) revertCommand :: CommandHandler revertCommand storeData = do - isTesting <- _test <$> asks _appOptions + isTesting <- asks (_test . _appOptions) required <- asks _appRequiredArgs let [migrationId] = required @@ -168,13 +195,18 @@ revertCommand storeData = do m <- lookupMigration storeData migrationId _ <- revert m storeData backend - case isTesting of - False -> do - commitBackend backend - putStrLn "Successfully reverted migrations." - True -> do - rollbackBackend backend - putStrLn "Migration uninstallation test successful." + ( if isTesting + then + ( do + rollbackBackend backend + putStrLn "Migration uninstallation test successful." + ) + else + ( do + commitBackend backend + putStrLn "Successfully reverted migrations." + ) + ) testCommand :: CommandHandler testCommand storeData = do @@ -187,10 +219,10 @@ testCommand storeData = do migrationNames <- missingMigrations backend storeData -- If the migration is already installed, remove it as part of -- the test - when (not $ migrationId `elem` migrationNames) $ + unless (migrationId `elem` migrationNames) $ do _ <- revert m storeData backend - return () + pure () applied <- apply m storeData backend True forM_ (reverse applied) $ \migration -> do revert migration storeData backend diff --git a/src/Moo/CommandInterface.hs b/src/Moo/CommandInterface.hs index 40bd237..21b98ba 100644 --- a/src/Moo/CommandInterface.hs +++ b/src/Moo/CommandInterface.hs @@ -8,6 +8,8 @@ module Moo.CommandInterface , usageString ) where +import Prelude + import Data.Maybe import Moo.CommandHandlers import Moo.Core @@ -15,8 +17,6 @@ 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 --- used to generate usage output. commands :: [Command] commands = [ Command @@ -105,7 +105,7 @@ optionConfigFile = ["config-file"] ( ReqArg ( \arg opt -> - return opt {_configFilePath = Just arg} + pure opt {_configFilePath = Just arg} ) "FILE" ) @@ -116,7 +116,7 @@ optionTest = Option "t" ["test"] - (NoArg (\opt -> return opt {_test = True})) + (NoArg (\opt -> pure opt {_test = True})) "Perform the action then rollback when finished" optionNoAsk :: OptDescr (CommandOptions -> IO CommandOptions) @@ -124,26 +124,26 @@ optionNoAsk = Option "n" ["no-ask"] - (NoArg (\opt -> return opt {_noAsk = True})) + (NoArg (\opt -> pure 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) + pure (opts, required) defaultOptions :: IO CommandOptions -defaultOptions = return $ CommandOptions Nothing False False +defaultOptions = pure $ CommandOptions Nothing False False commandOptionUsage :: String commandOptionUsage = usageInfo "Options:" commandOptions usageString :: Command -> String usageString command = - unwords (_cName command : optionalArgs ++ options ++ requiredArgs) + unwords (_cName command : optionalArgs <> options <> requiredArgs) where - requiredArgs = map (\s -> "<" ++ s ++ ">") $ _cRequired command - optionalArgs = map (\s -> "[" ++ s ++ "]") $ _cOptional command - options = map (\s -> "[" ++ "--" ++ s ++ "]") optionStrings + requiredArgs = map (\s -> "<" <> s <> ">") $ _cRequired command + optionalArgs = map (\s -> "[" <> s <> "]") $ _cOptional command + options = map (\s -> "[--" <> s <> "]") optionStrings optionStrings = _cAllowedOptions command diff --git a/src/Moo/CommandUtils.hs b/src/Moo/CommandUtils.hs index a953235..3a9f263 100644 --- a/src/Moo/CommandUtils.hs +++ b/src/Moo/CommandUtils.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - module Moo.CommandUtils ( apply , confirmCreation @@ -11,27 +8,19 @@ module Moo.CommandUtils , getCurrentTimestamp ) where -import Data.String.Conversions (cs, (<>)) -import Data.Text (Text) -import qualified Data.Text as T +import Prelude import Control.Exception (finally) import Control.Monad (forM_, unless, when) import Control.Monad.Reader (asks) import Control.Monad.Trans (liftIO) +import Data.Foldable (for_) import Data.List (intercalate, isPrefixOf, sortBy) import Data.Maybe (fromJust, isJust) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Text qualified as T import Data.Time.Clock (getCurrentTime) -import System.Exit (ExitCode (..), exitWith) -import System.IO - ( BufferMode (..) - , hFlush - , hGetBuffering - , hSetBuffering - , stdin - , stdout - ) - import Database.Schema.Migrations (migrationsToApply, migrationsToRevert) import Database.Schema.Migrations.Backend (Backend (..)) import Database.Schema.Migrations.Migration (Migration (..)) @@ -41,6 +30,15 @@ import Database.Schema.Migrations.Store , storeMigrations ) import Moo.Core +import System.Exit (ExitCode (..), exitWith) +import System.IO + ( BufferMode (..) + , hFlush + , hGetBuffering + , hSetBuffering + , stdin + , stdout + ) getCurrentTimestamp :: IO Text getCurrentTimestamp = @@ -53,10 +51,8 @@ apply m storeData backend complain = do -- Apply them if null toApply - then - nothingToDo >> return [] - else - mapM_ (applyIt backend) toApply >> return toApply + then nothingToDo >> pure [] + else mapM_ (applyIt backend) toApply >> pure toApply where nothingToDo = when complain $ @@ -77,10 +73,8 @@ revert m storeData backend = do -- Revert them if null toRevert - then - nothingToDo >> return [] - else - mapM_ (revertIt backend) toRevert >> return toRevert + then nothingToDo >> pure [] + else mapM_ (revertIt backend) toRevert >> pure toRevert where nothingToDo = putStrLn . cs $ @@ -100,7 +94,7 @@ lookupMigration storeData name = do Nothing -> do putStrLn . cs $ "No such migration: " <> name exitWith (ExitFailure 1) - Just m' -> return m' + Just m' -> pure m' -- Given an action that needs a database connection, connect to the -- database using the backend and invoke the action @@ -108,7 +102,7 @@ lookupMigration storeData name = do withBackend :: (Backend -> IO a) -> AppT a withBackend act = do backend <- asks _appBackend - liftIO $ (act backend) `finally` (disconnectBackend backend) + liftIO $ act backend `finally` disconnectBackend backend -- Given a migration name and selected dependencies, get the user's -- confirmation that a migration should be created. @@ -132,7 +126,7 @@ confirmCreation migrationId deps = do prompt :: Eq a => String -> PromptChoices a -> IO a prompt _ [] = error "prompt requires a list of choices" prompt message choiceMap = do - putStr $ message ++ " (" ++ choiceStr ++ helpChar ++ "): " + putStr $ message <> " (" <> choiceStr <> helpChar <> "): " hFlush stdout c <- unbufferedGetChar case lookup c choiceMap of @@ -140,12 +134,12 @@ prompt message choiceMap = do when (c /= '\n') $ putStrLn "" when (c == 'h') $ putStr $ mkPromptHelp choiceMapWithHelp retry - Just (val, _) -> putStrLn "" >> return val + Just (val, _) -> putStrLn "" >> pure val where retry = prompt message choiceMap - choiceStr = intercalate "" $ map (return . fst) choiceMap + choiceStr = intercalate "" $ map (pure . fst) choiceMap helpChar = if hasHelp choiceMap then "h" else "" - choiceMapWithHelp = choiceMap ++ [('h', (undefined, Just "this help"))] + 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. @@ -153,14 +147,14 @@ mkPromptHelp :: PromptChoices a -> String mkPromptHelp choices = intercalate "" - [ [c] ++ ": " ++ fromJust msg ++ "\n" + [ [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 +hasHelp = any hasMsg where hasMsg (_, (_, m)) = isJust m @@ -176,12 +170,12 @@ unbufferedGetChar = do hSetBuffering stdin NoBuffering c <- getChar hSetBuffering stdin bufferingMode - return c + pure c -- The types for choices the user can make when being prompted for -- dependencies. data AskDepsChoice = Yes | No | View | Done | Quit - deriving (Eq) + deriving stock (Eq) -- Interactively ask the user about which dependencies should be used -- when creating a new migration. @@ -198,39 +192,40 @@ interactiveAskDeps storeData = do -- user view information about potential dependencies. Returns a list -- of migration names which were selected. interactiveAskDeps' :: StoreData -> [Text] -> IO [Text] -interactiveAskDeps' _ [] = return [] +interactiveAskDeps' _ [] = pure [] interactiveAskDeps' storeData (name : rest) = do - result <- prompt ("Depend on '" ++ cs name ++ "'?") askDepsChoices + result <- prompt ("Depend on '" <> cs name <> "'?") askDepsChoices if result == Done - then return [] + then pure [] else case result of Yes -> do next <- interactiveAskDeps' storeData rest - return $ name : next + pure $ name : next No -> interactiveAskDeps' storeData rest View -> do -- load migration - let Just m = storeLookup storeData name - -- print out description, timestamp, deps - when - (isJust $ mDesc m) - ( putStrLn . cs $ - " Description: " - <> fromJust (mDesc m) - ) - putStrLn $ " Created: " ++ show (mTimestamp m) - unless - (null $ mDeps m) - ( putStrLn . cs $ - " Deps: " - <> T.intercalate "\n " (mDeps m) - ) + for_ (storeLookup storeData name) $ \m -> do + -- print out description, timestamp, deps + when + (isJust $ mDesc m) + ( putStrLn . cs $ + " Description: " + <> fromJust (mDesc m) + ) + putStrLn $ " Created: " <> show (mTimestamp m) + unless + (null $ mDeps m) + ( putStrLn . cs $ + " Deps: " + <> T.intercalate "\n " (mDeps m) + ) + -- ask again interactiveAskDeps' storeData (name : rest) Quit -> do putStrLn "cancelled." exitWith (ExitFailure 1) - Done -> return [] + Done -> pure [] -- The choices the user can make when being prompted for dependencies. askDepsChoices :: PromptChoices AskDepsChoice diff --git a/src/Moo/Core.hs b/src/Moo/Core.hs index b7e3c77..7be862f 100644 --- a/src/Moo/Core.hs +++ b/src/Moo/Core.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ExistentialQuantification #-} - module Moo.Core ( AppT , CommandHandler @@ -15,14 +13,15 @@ module Moo.Core , loadConfiguration ) where -import Data.Text (Text) +import Prelude import Control.Monad.Reader (ReaderT) import Data.Char (toLower) -import qualified Data.Configurator as C +import Data.Configurator qualified as C import Data.Configurator.Types (Config, Configured) import Data.Maybe (fromMaybe) -import qualified Data.Text as T +import Data.Text (Text) +import Data.Text qualified as T import System.Environment (getEnvironment) import Database.Schema.Migrations.Backend @@ -56,7 +55,7 @@ data LoadConfig = LoadConfig , _lcLinearMigrations :: Maybe Bool , _lcTimestampFilenames :: Maybe Bool } - deriving (Show) + deriving stock (Show) -- | Loading the configuration from a file or having it specified via environment -- |variables results in a value of type Configuration. @@ -66,7 +65,7 @@ data Configuration = Configuration , _linearMigrations :: Bool , _timestampFilenames :: Bool } - deriving (Show) + deriving stock (Show) -- | A value of type ExecutableParameters is what a moo executable (moo-postgresql, -- |moo-mysql, etc.) pass to the core package when they want to execute a @@ -77,7 +76,7 @@ data ExecutableParameters = ExecutableParameters , _parametersLinearMigrations :: Bool , _parametersTimestampFilenames :: Bool } - deriving (Show) + deriving stock (Show) defConfigFile :: String defConfigFile = "moo.cfg" @@ -110,7 +109,7 @@ lcTimestampFilenames c v = c {_lcTimestampFilenames = v} (.=) :: Monad m => (a -> Maybe b -> a) -> m (Maybe b) -> m (a -> a) (.=) f v' = do v <- v' - return $ case v of + pure $ case v of Just _ -> flip f v _ -> id @@ -123,23 +122,21 @@ infixl 2 & applyEnvironment :: ShellEnvironment -> LoadConfig -> IO LoadConfig applyEnvironment env lc = - return lc + pure lc & lcConnectionString .= f envDatabaseName & lcMigrationStorePath .= f envStoreName & lcLinearMigrations .= readFlag - <$> f envLinearMigrations - & lcTimestampFilenames - .= readFlag + <$> f envLinearMigrations & lcTimestampFilenames .= readFlag <$> f envTimestampFilenames where - f n = return $ lookup n env + f n = pure $ lookup n env applyConfigFile :: Config -> LoadConfig -> IO LoadConfig applyConfigFile cfg lc = - return lc + pure lc & lcConnectionString .= f envDatabaseName & lcMigrationStorePath @@ -164,7 +161,7 @@ loadConfiguration pth = do env <- getEnvironment cfg <- applyConfigFile file newLoadConfig >>= applyEnvironment env - return $ validateLoadConfig cfg + pure $ validateLoadConfig cfg makeParameters :: Configuration -> Backend -> ExecutableParameters makeParameters conf backend = diff --git a/src/Moo/Main.hs b/src/Moo/Main.hs index c257aeb..a16d748 100644 --- a/src/Moo/Main.hs +++ b/src/Moo/Main.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Moo.Main ( mainWithParameters , ExecutableParameters (..) @@ -11,15 +9,13 @@ module Moo.Main ) where +import Prelude + import Control.Monad (forM_, when) import Control.Monad.Reader (runReaderT) import Data.String.Conversions (cs) import Data.Text (Text) import Database.HDBC (SqlError, catchSql, seErrorMsg) -import System.Environment (getProgName) -import System.Exit (ExitCode (ExitFailure), exitWith) -import Prelude hiding (lookup) - import Database.Schema.Migrations.Filesystem ( FilesystemStoreSettings (..) , filesystemStore @@ -27,6 +23,8 @@ import Database.Schema.Migrations.Filesystem import Database.Schema.Migrations.Store import Moo.CommandInterface import Moo.Core +import System.Environment (getProgName) +import System.Exit (ExitCode (ExitFailure), exitWith) type Args = [String] @@ -34,18 +32,18 @@ usage :: IO a usage = do progName <- getProgName - putStrLn $ "Usage: " ++ progName ++ " [args]" + putStrLn $ "Usage: " <> progName <> " [args]" putStrLn "Environment:" - putStrLn $ " " ++ envDatabaseName ++ ": database connection string" - putStrLn $ " " ++ envStoreName ++ ": path to migration store" + putStrLn $ " " <> envDatabaseName <> ": database connection string" + putStrLn $ " " <> envStoreName <> ": path to migration store" putStrLn $ " " - ++ envLinearMigrations - ++ ": whether to use linear migrations (defaults to False)" + <> envLinearMigrations + <> ": whether to use linear migrations (defaults to False)" putStrLn "Commands:" forM_ commands $ \command -> do - putStrLn $ " " ++ usageString command - putStrLn $ " " ++ _cDescription command + putStrLn $ " " <> usageString command + putStrLn $ " " <> _cDescription command putStrLn "" putStrLn commandOptionUsage @@ -54,20 +52,18 @@ usage = do usageSpecific :: Command -> IO a usageSpecific command = do pn <- getProgName - putStrLn $ "Usage: " ++ pn ++ " " ++ usageString command + putStrLn $ "Usage: " <> pn <> " " <> usageString command exitWith (ExitFailure 1) procArgs :: Args -> IO (Command, CommandOptions, [String]) procArgs args = do when (null args) usage - command <- case findCommand $ head args of - Nothing -> usage - Just c -> return c + command <- maybe usage pure (findCommand $ head args) (opts, required) <- getCommandArgs $ tail args - return (command, opts, required) + pure (command, opts, required) mainWithParameters :: Args -> ExecutableParameters -> IO () mainWithParameters args parameters = do @@ -79,14 +75,13 @@ mainWithParameters args parameters = do linear = _parametersLinearMigrations parameters if length required < length (_cRequired command) - then - usageSpecific command + then usageSpecific command else do loadedStoreData <- loadMigrations store case loadedStoreData of Left es -> do putStrLn "There were errors in the migration store:" - forM_ es $ \err -> putStrLn $ " " ++ show err + forM_ es $ \err -> putStrLn $ " " <> show err Right storeData -> do let st = AppState @@ -105,5 +100,5 @@ mainWithParameters args parameters = do reportSqlError :: SqlError -> IO a reportSqlError e = do - putStrLn $ "\n" ++ "A database error occurred: " ++ seErrorMsg e + putStrLn $ "\nA database error occurred: " <> seErrorMsg e exitWith (ExitFailure 1) diff --git a/src/StoreManager.hs b/src/StoreManager.hs deleted file mode 100644 index 37c4c6e..0000000 --- a/src/StoreManager.hs +++ /dev/null @@ -1,254 +0,0 @@ -module Main where - -import Control.Applicative ((<$>)) -import Control.Monad.State -import qualified Data.Map as Map -import System.Directory - ( getTemporaryDirectory - ) -import System.Environment - ( getArgs - , getEnvironment - , getProgName - ) -import System.Exit - ( exitFailure - ) -import System.IO - ( Handle - , hClose - , hPutStr - , openTempFile - ) -import System.Posix.Files - ( removeLink - ) -import System.Process - -import Data.Maybe - ( fromJust - ) - -import Database.Schema.Migrations.Filesystem -import Database.Schema.Migrations.Migration - ( Migration (..) - ) -import Database.Schema.Migrations.Store -import Graphics.Vty -import Graphics.Vty.Widgets.All - --- XXX Generalize over all MigrationStore instances -data AppState = AppState - { appStoreData :: StoreData - , appStore :: FilesystemStore - , appMigrationList :: SimpleList - , appVty :: Vty - } - -type AppM = StateT AppState IO - -titleAttr :: Attr -titleAttr = - def_attr - `with_back_color` blue - `with_fore_color` bright_white - -bodyAttr :: Attr -bodyAttr = - def_attr - `with_back_color` black - `with_fore_color` bright_white - -fieldAttr :: Attr -fieldAttr = - def_attr - `with_back_color` black - `with_fore_color` bright_green - -selAttr :: Attr -selAttr = - def_attr - `with_back_color` yellow - `with_fore_color` black - -scrollListUp :: AppState -> AppState -scrollListUp appst = - appst {appMigrationList = scrollUp $ appMigrationList appst} - -scrollListDown :: AppState -> AppState -scrollListDown appst = - appst {appMigrationList = scrollDown $ appMigrationList appst} - -eventloop :: Widget a => AppM a -> (Event -> AppM Bool) -> AppM () -eventloop uiBuilder handle = do - w <- uiBuilder - vty <- gets appVty - evt <- liftIO $ do - (img, _) <- mkImage vty w - update vty $ pic_for_image img - next_event vty - next <- handle evt - if next - then - eventloop uiBuilder handle - else - return () - -continue :: AppM Bool -continue = return True - -stop :: AppM Bool -stop = return False - -handleEvent :: Event -> AppM Bool -handleEvent (EvKey KUp []) = modify scrollListUp >> continue -handleEvent (EvKey KDown []) = modify scrollListDown >> continue -handleEvent (EvKey (KASCII 'q') []) = stop -handleEvent (EvKey (KASCII 'e') []) = editCurrentMigration >> continue -handleEvent (EvResize w h) = do - let wSize = appropriateListWindow $ DisplayRegion (toEnum w) (toEnum h) - modify - ( \appst -> - appst - { appMigrationList = (appMigrationList appst) {scrollWindowSize = wSize} - } - ) - continue -handleEvent _ = continue - -withTempFile :: MonadIO m => (Handle -> FilePath -> m a) -> m a -withTempFile act = do - (tempFilePath, newFile) <- liftIO $ createTempFile - result <- act newFile tempFilePath - liftIO $ cleanup newFile tempFilePath - return result - where - createTempFile = do - tempDir <- getTemporaryDirectory - openTempFile tempDir "migration.txt" - - cleanup handle tempFilePath = do - (hClose handle) `catch` (\_ -> return ()) - removeLink tempFilePath - -editCurrentMigration :: AppM () -editCurrentMigration = do - -- Get the current migration - m <- gets getSelectedMigration - store <- gets appStore - migrationPath <- fullMigrationName store $ mId m - vty <- gets appVty - - withTempFile $ \tempHandle tempPath -> - liftIO $ do - -- Copy the migration to a temporary file - readFile migrationPath >>= hPutStr tempHandle - hClose tempHandle - - shutdown vty - - currentEnv <- getEnvironment - let - editor = maybe "vi" id $ lookup "EDITOR" currentEnv - spawnEditor = do - -- Invoke an editor to edit the temporary file - (_, _, _, pHandle) <- createProcess $ shell $ editor ++ " " ++ tempPath - waitForProcess pHandle - - -- Once the editor closes, validate the temporary file - validateResult <- migrationFromPath tempPath - case validateResult of - Left e -> do - putStrLn $ "Error in edited migration: " ++ e - putStrLn $ "Try again? (y/n) " - c <- getChar - if c == 'y' then spawnEditor else return False - Right _ -> return True - - proceed <- spawnEditor - - -- Replace the original migration with the contents of the - -- temporary file - when (proceed) (readFile tempPath >>= writeFile migrationPath) - - -- Reinitialize application state - put =<< (liftIO $ mkState store) - -getSelectedMigration :: AppState -> Migration -getSelectedMigration appst = fromJust $ Map.lookup (fst $ getSelected list) mMap - where - mMap = storeDataMapping $ appStoreData appst - list = appMigrationList appst - -buildUi :: AppState -> Box -buildUi appst = - let - header = - text titleAttr (" " ++ (storePath $ appStore appst) ++ " ") - <++> hFill titleAttr '-' 1 - <++> text titleAttr " Store Manager " - status = - text bodyAttr $ maybe "" id $ mDesc $ getSelectedMigration appst - helpBar = - text titleAttr "q:quit e:edit " - <++> hFill titleAttr '-' 1 - in - header - <--> appMigrationList appst - <--> helpBar - <--> status - -uiFromState :: AppM Box -uiFromState = buildUi <$> get - -readStore :: FilesystemStore -> IO StoreData -readStore store = do - result <- loadMigrations store - case result of - Left es -> do - putStrLn "There were errors in the migration store:" - forM_ es $ \err -> do - putStrLn $ " " ++ show err - exitFailure - Right theStoreData -> return theStoreData - -mkState :: FilesystemStore -> IO AppState -mkState fsStore = do - vty <- mkVty - sz <- display_bounds $ terminal vty - storeData <- readStore fsStore - let - migrationList = mkSimpleList bodyAttr selAttr (appropriateListWindow sz) migrationNames - migrationNames = Map.keys $ storeDataMapping storeData - return $ - AppState - { appStoreData = storeData - , appStore = fsStore - , appMigrationList = migrationList - , appVty = vty - } - -appropriateListWindow :: DisplayRegion -> Int -appropriateListWindow sz = fromEnum $ region_height sz - 3 - -main :: IO () -main = do - args <- getArgs - - when (length args /= 1) $ do - p <- getProgName - putStrLn ("Usage: " ++ p ++ " ") - exitFailure - - let store = FSStore {storePath = args !! 0} - - beginState <- mkState store - - -- Capture the new application state because it might contain a new - -- Vty. - endState <- execStateT (eventloop uiFromState handleEvent) beginState - let endVty = appVty endState - - -- Clear the screen. - reserve_display $ terminal endVty - shutdown endVty diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..b20cbcd --- /dev/null +++ b/stack.yaml @@ -0,0 +1,3 @@ +resolver: lts-22.14 +extra-deps: + - HDBC-sqlite3-2.3.3.1 diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..80a0540 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,19 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: HDBC-sqlite3-2.3.3.1@sha256:5025fd94d02b9b3f0b8b8233796dd9a85a0b3dda6503c6e671e3eddbc51cb4d4,2424 + pantry-tree: + sha256: 76e71f73502350ed3fe5fc64604a21a3c8027d49fe6846183d53dbdaf583437a + size: 1427 + original: + hackage: HDBC-sqlite3-2.3.3.1 +snapshots: +- completed: + sha256: 48ac4445a1906866c846cd2a3a9c28fcdf3b2066237e49405dbe56ce1974a043 + size: 713334 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/14.yaml + original: lts-22.14 diff --git a/test/ConfigurationTest.hs b/test/ConfigurationTest.hs deleted file mode 100644 index 0a999b1..0000000 --- a/test/ConfigurationTest.hs +++ /dev/null @@ -1,107 +0,0 @@ -module ConfigurationTest (tests) where - -import Control.Exception (SomeException, try) -import Data.Either (isLeft, isRight) -import System.Directory -import System.Environment (setEnv, unsetEnv) -import Test.HUnit - -import Common -import Moo.Core - -tests :: IO [Test] -tests = sequence [prepareTestEnv >> e | e <- entries] - where - entries = - [ loadsConfigFile - , loadsPropertiesFromFile - , loadsDefaultConfigFile - , environmentOverridesProperties - , ifNoConfigFileIsAvailableEnvironmentIsUsed - , throwsWhenConfigFileIsInvalid - , returnsErrorWhenNotAllPropertiesAreSet - , canReadTimestampsConfig - ] - -prepareTestEnv :: IO () -prepareTestEnv = do - setCurrentDirectory $ testFile "config_loading" - unsetEnv "DBM_DATABASE" - unsetEnv "DBM_MIGRATION_STORE" - unsetEnv "DBM_LINEAR_MIGRATIONS" - unsetEnv "DBM_TIMESTAMP_FILENAMES" - -canReadTimestampsConfig :: IO Test -canReadTimestampsConfig = do - Right cfg <- loadConfiguration (Just "cfg_ts.cfg") - satisfies "Timestamp not set" cfg _timestampFilenames - -loadsConfigFile :: IO Test -loadsConfigFile = do - cfg' <- loadConfiguration (Just "cfg1.cfg") - satisfies "File not loaded" cfg' isRight - -loadsPropertiesFromFile :: IO Test -loadsPropertiesFromFile = do - Right cfg <- loadConfiguration (Just "cfg1.cfg") - return - ( _connectionString cfg - ~?= "connection" - .&&. _migrationStorePath cfg - ~?= "store" - .&&. _linearMigrations cfg - ~?= True - ) - -loadsDefaultConfigFile :: IO Test -loadsDefaultConfigFile = do - Right cfg <- loadConfiguration Nothing - return - ( _connectionString cfg - ~?= "mooconn" - .&&. _migrationStorePath cfg - ~?= "moostore" - .&&. _linearMigrations cfg - ~?= True - ) - -environmentOverridesProperties :: IO Test -environmentOverridesProperties = do - setEnv "DBM_DATABASE" "envconn" - setEnv "DBM_MIGRATION_STORE" "envstore" - setEnv "DBM_LINEAR_MIGRATIONS" "off" - Right cfg <- loadConfiguration (Just "cfg1.cfg") - return - ( _connectionString cfg - ~?= "envconn" - .&&. _migrationStorePath cfg - ~?= "envstore" - .&&. _linearMigrations cfg - ~?= False - ) - -ifNoConfigFileIsAvailableEnvironmentIsUsed :: IO Test -ifNoConfigFileIsAvailableEnvironmentIsUsed = do - setCurrentDirectory $ testFile "" - setEnv "DBM_DATABASE" "envconn" - setEnv "DBM_MIGRATION_STORE" "envstore" - setEnv "DBM_LINEAR_MIGRATIONS" "off" - Right cfg <- loadConfiguration Nothing - return - ( _connectionString cfg - ~?= "envconn" - .&&. _migrationStorePath cfg - ~?= "envstore" - .&&. _linearMigrations cfg - ~?= False - ) - -returnsErrorWhenNotAllPropertiesAreSet :: IO Test -returnsErrorWhenNotAllPropertiesAreSet = do - cfg <- loadConfiguration (Just "missing.cfg") - satisfies "Should return error" cfg isLeft - -throwsWhenConfigFileIsInvalid :: IO Test -throwsWhenConfigFileIsInvalid = do - c <- try $ loadConfiguration (Just "invalid.cfg") - satisfies "Should throw" c (isLeft :: Either SomeException a -> Bool) diff --git a/test/FilesystemParseTest.hs b/test/FilesystemParseTest.hs deleted file mode 100644 index 1b7f969..0000000 --- a/test/FilesystemParseTest.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module FilesystemParseTest - ( tests - ) -where - -import Data.String.Conversions (cs) -import Data.Time.Clock (UTCTime) -import System.FilePath (()) -import Test.HUnit - -import Common - -import Database.Schema.Migrations.Filesystem - ( FilesystemStoreSettings (..) - , migrationFromFile - ) -import Database.Schema.Migrations.Migration - -tests :: IO [Test] -tests = migrationParsingTests - --- filename, result -type MigrationParsingTestCase = (FilePath, Either String Migration) - -tsStr :: String -tsStr = "2009-04-15 10:02:06 UTC" - -ts :: UTCTime -ts = read tsStr - -valid_full :: Migration -valid_full = - Migration - { mTimestamp = Just ts - , mId = "valid_full" - , mDesc = Just "A valid full migration." - , mDeps = ["another_migration"] - , mApply = "CREATE TABLE test ( a int );" - , mRevert = Just "DROP TABLE test;" - } - -valid_full_comments :: Migration -valid_full_comments = - Migration - { mTimestamp = Just ts - , mId = "valid_full" - , mDesc = Just "A valid full migration." - , mDeps = ["another_migration"] - , mApply = - "\n-- Comment on a line\nCREATE TABLE test (\n a int -- comment inline\n);\n" - , mRevert = Just "DROP TABLE test;" - } - -valid_full_colon :: Migration -valid_full_colon = - Migration - { mTimestamp = Just ts - , mId = "valid_full" - , mDesc = Just "A valid full migration." - , mDeps = ["another_migration"] - , mApply = - "\n-- Comment on a line with a colon:\nCREATE TABLE test (\n a int\n);\n" - , mRevert = Just "DROP TABLE test;" - } - -testStorePath :: FilePath -testStorePath = testFile $ "migration_parsing" - -fp :: FilePath -> FilePath -fp = (testStorePath ) - -migrationParsingTestCases :: [MigrationParsingTestCase] -migrationParsingTestCases = - [ ("valid_full", Right valid_full) - , - ( "valid_with_comments" - , Right (valid_full {mId = "valid_with_comments"}) - ) - , - ( "valid_with_comments2" - , Right (valid_full_comments {mId = "valid_with_comments2"}) - ) - , - ( "valid_with_colon" - , Right (valid_full_colon {mId = "valid_with_colon"}) - ) - , - ( "valid_with_multiline_deps" - , Right - ( valid_full - { mId = "valid_with_multiline_deps" - , mDeps = ["one", "two", "three"] - } - ) - ) - , - ( "valid_no_depends" - , Right (valid_full {mId = "valid_no_depends", mDeps = []}) - ) - , - ( "valid_no_desc" - , 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") - ++ ":Error in " - ++ (show $ fp "invalid_missing_required_fields") - ++ ": missing required field(s): " - ++ "[\"Depends\"]" - ) - , - ( "invalid_field_name" - , Left $ - "Could not parse migration " - ++ (fp "invalid_field_name") - ++ ":Error in " - ++ (show $ fp "invalid_field_name") - ++ ": unrecognized field found" - ) - , - ( "invalid_syntax" - , Left $ - "Could not parse migration " - ++ (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") - ++ ":Error in " - ++ (show $ fp "invalid_timestamp") - ++ ": unrecognized field found" - ) - ] - -mkParsingTest :: MigrationParsingTestCase -> IO Test -mkParsingTest (fname, expected) = do - let store = FSStore {storePath = testStorePath} - actual <- migrationFromFile store (cs fname) - return $ test $ expected ~=? actual - -migrationParsingTests :: IO [Test] -migrationParsingTests = - traverse mkParsingTest migrationParsingTestCases diff --git a/test/FilesystemSerializeTest.hs b/test/FilesystemSerializeTest.hs deleted file mode 100644 index 6adfb4b..0000000 --- a/test/FilesystemSerializeTest.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module FilesystemSerializeTest - ( tests - ) -where - -import Data.ByteString (ByteString) -import Data.String.Conversions (cs, (<>)) -import Data.Time.Clock (UTCTime) -import Test.HUnit - -import Database.Schema.Migrations.Filesystem.Serialize -import Database.Schema.Migrations.Migration - -tests :: [Test] -tests = serializationTests - -mkSerializationTest :: (Migration, ByteString) -> Test -mkSerializationTest (m, expectedString) = test $ expectedString ~=? serializeMigration m - -tsStr :: String -tsStr = "2009-04-15 10:02:06 UTC" - -ts :: UTCTime -ts = read tsStr - -valid_full :: Migration -valid_full = - Migration - { mTimestamp = Just ts - , mId = "valid_full" - , mDesc = Just "A valid full migration." - , mDeps = ["another_migration"] - , mApply = " CREATE TABLE test (\n a int\n );\n" - , mRevert = Just "DROP TABLE test;" - } - -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\ - \ a int\n\ - \ );\n\n\ - \Revert: |\n\ - \ DROP TABLE test;\n" - ) - , - ( valid_full {mDesc = Nothing} - , cs $ - "Created: " - <> tsStr - <> "\n\ - \Depends: another_migration\n\ - \Apply: |\n\ - \ CREATE TABLE test (\n\ - \ a int\n\ - \ );\n\n\ - \Revert: |\n\ - \ DROP TABLE test;\n" - ) - , - ( valid_full {mDeps = ["one", "two"]} - , cs $ - "Description: A valid full migration.\n\ - \Created: " - <> tsStr - <> "\n\ - \Depends: one two\n\ - \Apply: |\n\ - \ CREATE TABLE test (\n\ - \ a int\n\ - \ );\n\n\ - \Revert: |\n\ - \ DROP TABLE test;\n" - ) - , - ( valid_full {mRevert = Nothing} - , cs $ - "Description: A valid full migration.\n\ - \Created: " - <> tsStr - <> "\n\ - \Depends: another_migration\n\ - \Apply: |\n\ - \ CREATE TABLE test (\n\ - \ a int\n\ - \ );\n" - ) - ] - -serializationTests :: [Test] -serializationTests = map mkSerializationTest serializationTestCases diff --git a/test/FilesystemTest.hs b/test/FilesystemTest.hs deleted file mode 100644 index 922c2ee..0000000 --- a/test/FilesystemTest.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module FilesystemTest - ( tests - ) -where - -import Database.Schema.Migrations.Filesystem -import Database.Schema.Migrations.Store (MigrationStore (..)) - -import Common -import qualified Data.Set as Set -import Test.HUnit - -tests :: IO [Test] -tests = sequence [getMigrationsTest] - -getMigrationsTest :: IO Test -getMigrationsTest = do - let - store = filesystemStore $ FSStore {storePath = testFile "migration_parsing"} - expected = - Set.fromList - [ "invalid_field_name" - , "invalid_missing_required_fields" - , "invalid_syntax" - , "invalid_timestamp" - , "valid_full" - , "valid_no_depends" - , "valid_no_desc" - , "valid_no_revert" - , "valid_no_timestamp" - , "valid_with_comments" - , "valid_with_comments2" - , "valid_with_colon" - , "valid_with_multiline_deps" - ] - migrations <- getMigrations store - return $ expected ~=? Set.fromList migrations diff --git a/test/LinearMigrationsTest.hs b/test/LinearMigrationsTest.hs deleted file mode 100644 index 699e302..0000000 --- a/test/LinearMigrationsTest.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module LinearMigrationsTest (tests) where - -import InMemoryStore -import Test.HUnit - -import Common -import Control.Monad.Reader (runReaderT) -import Data.Either (isRight) -import Data.Text (Text) -import Database.Schema.Migrations.Migration -import Database.Schema.Migrations.Store -import Moo.CommandHandlers -import Moo.Core - -tests :: IO [Test] -tests = - sequence - [ addsMigration - , selectsLatestMigrationAsDep - , selectsOnlyLeavesAsDeps - , doesNotAddDependencyWhenLinearMigrationsAreDisabled - ] - -addsMigration :: IO Test -addsMigration = do - state <- prepareState "first" - mig <- addTestMigration state - satisfies "Migration not added" mig isRight - -selectsLatestMigrationAsDep :: IO Test -selectsLatestMigrationAsDep = do - state1 <- prepareState "first" - _ <- addTestMigration state1 - state2 <- prepareStateWith state1 "second" - Right mig <- addTestMigration state2 - return $ ["first"] ~=? mDeps mig - -selectsOnlyLeavesAsDeps :: IO Test -selectsOnlyLeavesAsDeps = do - state1 <- prepareNormalState "first" - addTestMigrationWithDeps state1 [] - state2 <- prepareStateWith state1 "second" - addTestMigrationWithDeps state2 ["first"] - state3 <- prepareStateWith state2 "third" - addTestMigrationWithDeps state3 ["first"] - state4' <- prepareStateWith state3 "fourth" - let state4 = state4' {_appLinearMigrations = True} - Right mig <- addTestMigration state4 - return $ ["second", "third"] ~=? mDeps mig - -doesNotAddDependencyWhenLinearMigrationsAreDisabled :: IO Test -doesNotAddDependencyWhenLinearMigrationsAreDisabled = do - state1 <- prepareNormalState "first" - _ <- addTestMigration state1 - state2 <- prepareStateWith state1 "second" - Right mig <- addTestMigration state2 - satisfies "Dependencies should be empty" (mDeps mig) null - -addTestMigration :: AppState -> IO (Either String Migration) -addTestMigration state = do - let - store = _appStore state - [migrationId] = _appRequiredArgs state - runReaderT (newCommand $ _appStoreData state) state - loadMigration store migrationId - -addTestMigrationWithDeps :: AppState -> [Text] -> IO () -addTestMigrationWithDeps state deps = do - let store = _appStore state - let [migrationId] = _appRequiredArgs state - saveMigration store (newMigration migrationId) {mDeps = deps} - -prepareState :: Text -> IO AppState -prepareState m = do - store <- inMemoryStore - Right storeData <- loadMigrations store - return - AppState - { _appOptions = CommandOptions Nothing False True - , _appBackend = undefined -- Not used here - , _appCommand = undefined -- Not used by newCommand - , _appRequiredArgs = [m] - , _appOptionalArgs = [] - , _appStore = store - , _appStoreData = storeData - , _appLinearMigrations = True - , _appTimestampFilenames = False - } - -prepareStateWith :: AppState -> Text -> IO AppState -prepareStateWith state m = do - Right storeData <- loadMigrations $ _appStore state - return state {_appRequiredArgs = [m], _appStoreData = storeData} - -prepareNormalState :: Text -> IO AppState -prepareNormalState m = do - state <- prepareState m - return $ state {_appLinearMigrations = False} diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 index e3308f9..0000000 --- a/test/Main.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Main where - -import System.Exit -import System.IO (stderr) -import Test.HUnit -import Prelude - -import qualified ConfigurationTest -import qualified CycleDetectionTest -import qualified DependencyTest -import qualified FilesystemParseTest -import qualified FilesystemSerializeTest -import qualified FilesystemTest -import qualified LinearMigrationsTest -import qualified MigrationsTest -import qualified StoreTest - -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/StoreTest.hs b/test/StoreTest.hs deleted file mode 100644 index fa6774c..0000000 --- a/test/StoreTest.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module StoreTest - ( tests - ) -where - -import qualified Data.Map as Map -import Test.HUnit - -import Database.Schema.Migrations.Migration -import Database.Schema.Migrations.Store - -tests :: [Test] -tests = - validateSingleMigrationTests - ++ validateMigrationMapTests - -type ValidateSingleTestCase = - ( MigrationMap - , Migration - , [MapValidationError] - ) - -type ValidateMigrationMapTestCase = - ( MigrationMap - , [MapValidationError] - ) - -emptyMap :: MigrationMap -emptyMap = Map.fromList [] - -partialMap :: MigrationMap -partialMap = - Map.fromList - [ ("one", undefined) - , ("three", undefined) - ] - -fullMap :: MigrationMap -fullMap = - Map.fromList - [ ("one", undefined) - , ("two", undefined) - , ("three", undefined) - ] - -withDeps :: Migration -withDeps = - Migration - { mTimestamp = undefined - , mId = "with_deps" - , mDesc = Just "with dependencies" - , mApply = "" - , mRevert = Nothing - , mDeps = ["one", "two", "three"] - } - -noDeps :: Migration -noDeps = - Migration - { mTimestamp = undefined - , mId = "no_deps" - , mDesc = Just "no dependencies" - , mApply = "" - , mRevert = Nothing - , mDeps = [] - } - -validateSingleTestCases :: [ValidateSingleTestCase] -validateSingleTestCases = - [ - ( emptyMap - , withDeps - , - [ DependencyReferenceError (mId withDeps) "one" - , DependencyReferenceError (mId withDeps) "two" - , DependencyReferenceError (mId withDeps) "three" - ] - ) - , (emptyMap, noDeps, []) - , (partialMap, withDeps, [DependencyReferenceError (mId withDeps) "two"]) - , (fullMap, withDeps, []) - , (fullMap, noDeps, []) - ] - -validateSingleMigrationTests :: [Test] -validateSingleMigrationTests = - map mkValidateSingleTest validateSingleTestCases - where - mkValidateSingleTest (mmap, m, errs) = - errs ~=? validateSingleMigration mmap m - -m1 :: Migration -m1 = - noDeps - { mId = "m1" - , mDeps = [] - } - -m2 :: Migration -m2 = - noDeps - { mId = "m2" - , mDeps = ["m1"] - } - -m3 :: Migration -m3 = - noDeps - { mId = "m3" - , mDeps = ["nonexistent"] - } - -m4 :: Migration -m4 = - noDeps - { mId = "m4" - , mDeps = ["one", "two"] - } - -map1 :: MigrationMap -map1 = - Map.fromList - [ ("m1", m1) - , ("m2", m2) - ] - -map2 :: MigrationMap -map2 = - Map.fromList - [ ("m3", m3) - ] - -map3 :: MigrationMap -map3 = - Map.fromList - [ ("m4", m4) - ] - -validateMapTestCases :: [ValidateMigrationMapTestCase] -validateMapTestCases = - [ (emptyMap, []) - , (map1, []) - , (map2, [DependencyReferenceError (mId m3) "nonexistent"]) - , - ( map3 - , - [ DependencyReferenceError (mId m4) "one" - , DependencyReferenceError (mId m4) "two" - ] - ) - ] - -validateMigrationMapTests :: [Test] -validateMigrationMapTests = - map mkValidateMapTest validateMapTestCases - where - mkValidateMapTest (mmap, errs) = - errs ~=? validateMigrationMap mmap diff --git a/test/Common.hs b/tests/Common.hs similarity index 53% rename from test/Common.hs rename to tests/Common.hs index d71e88c..69dbd4e 100644 --- a/test/Common.hs +++ b/tests/Common.hs @@ -2,27 +2,23 @@ module Common ( TestDependable (..) - , repoRoot , testFile - , satisfies - , (.&&.) ) where -import Data.Text (Text) +import Prelude import CommonTH +import Data.Text (Text) +import Database.Schema.Migrations.Dependencies (Dependable (..)) import Language.Haskell.TH.Syntax (lift) import System.FilePath (()) -import Test.HUnit - -import Database.Schema.Migrations.Dependencies (Dependable (..)) repoRoot :: FilePath repoRoot = $(getRepoRoot >>= lift) testFile :: FilePath -> FilePath -testFile fp = repoRoot "test" fp +testFile fp = repoRoot "tests" fp instance Dependable TestDependable where depId = tdId @@ -32,14 +28,4 @@ data TestDependable = TD { tdId :: Text , tdDeps :: [Text] } - deriving (Show, Eq, Ord) - -satisfies :: String -> a -> (a -> Bool) -> IO Test -satisfies m v f = return $ TestCase $ assertBool m (f v) - -(.&&.) :: Test -> Test -> Test -(TestList xs) .&&. (TestList ys) = TestList (xs ++ ys) -(TestList xs) .&&. y = TestList (xs ++ [y]) -x .&&. (TestList ys) = TestList (x : ys) -a .&&. b = TestList [a, b] -infixl 0 .&&. + deriving stock (Show, Eq, Ord) diff --git a/test/CommonTH.hs b/tests/CommonTH.hs similarity index 76% rename from test/CommonTH.hs rename to tests/CommonTH.hs index 72f2b74..30ce629 100644 --- a/test/CommonTH.hs +++ b/tests/CommonTH.hs @@ -3,6 +3,8 @@ module CommonTH ) where +import Prelude + import Language.Haskell.TH import System.Directory (canonicalizePath, getCurrentDirectory) import System.FilePath (combine, takeDirectory) @@ -14,8 +16,5 @@ getRepoRoot = cwd <- runIO getCurrentDirectory let thisFileName = combine cwd $ loc_filename here -- XXX: This depends on the location of this file in the source tree - return =<< runIO $ - canonicalizePath $ - head $ - drop 2 $ - iterate takeDirectory thisFileName + runIO $ + canonicalizePath (iterate takeDirectory thisFileName !! 2) diff --git a/tests/ConfigurationSpec.hs b/tests/ConfigurationSpec.hs new file mode 100644 index 0000000..7f4159b --- /dev/null +++ b/tests/ConfigurationSpec.hs @@ -0,0 +1,77 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module ConfigurationSpec + ( spec + ) +where + +import Prelude + +import Common +import Data.Either (isLeft, isRight) +import Moo.Core +import System.Directory +import System.Environment (setEnv, unsetEnv) +import Test.Hspec + +spec :: Spec +spec = before_ prepareTestEnv $ do + describe "loadConfiguration" $ do + it "loads a file" $ do + cfg <- loadConfiguration $ Just "cfg1.cfg" + cfg `shouldSatisfy` isRight + + it "loads properties from a file" $ do + Right cfg <- loadConfiguration $ Just "cfg1.cfg" + + _connectionString cfg `shouldBe` "connection" + _migrationStorePath cfg `shouldBe` "store" + _linearMigrations cfg `shouldBe` True + + it "loads default config file" $ do + Right cfg <- loadConfiguration Nothing + + _connectionString cfg `shouldBe` "mooconn" + _migrationStorePath cfg `shouldBe` "moostore" + _linearMigrations cfg `shouldBe` True + + it "can be overriden via ENV" $ do + setEnv "DBM_DATABASE" "envconn" + setEnv "DBM_MIGRATION_STORE" "envstore" + setEnv "DBM_LINEAR_MIGRATIONS" "off" + Right cfg <- loadConfiguration $ Just "cfg1.cfg" + + _connectionString cfg `shouldBe` "envconn" + _migrationStorePath cfg `shouldBe` "envstore" + _linearMigrations cfg `shouldBe` False + + it "uses ENV if no config file is available" $ do + setCurrentDirectory $ testFile "" + setEnv "DBM_DATABASE" "envconn" + setEnv "DBM_MIGRATION_STORE" "envstore" + setEnv "DBM_LINEAR_MIGRATIONS" "off" + Right cfg <- loadConfiguration Nothing + + _connectionString cfg `shouldBe` "envconn" + _migrationStorePath cfg `shouldBe` "envstore" + _linearMigrations cfg `shouldBe` False + + it "returns error when not all properties are set" $ do + cfg <- loadConfiguration $ Just "missing.cfg" + cfg `shouldSatisfy` isLeft + + it "throws when config is invalid" $ do + loadConfiguration (Just "invalid.cfg") `shouldThrow` anyException + + it "can read timestamps config" $ do + Right cfg <- loadConfiguration $ Just "cfg_ts.cfg" + + _timestampFilenames cfg `shouldBe` True + +prepareTestEnv :: IO () +prepareTestEnv = do + setCurrentDirectory $ testFile "config_loading" + unsetEnv "DBM_DATABASE" + unsetEnv "DBM_MIGRATION_STORE" + unsetEnv "DBM_LINEAR_MIGRATIONS" + unsetEnv "DBM_TIMESTAMP_FILENAMES" diff --git a/test/CycleDetectionTest.hs b/tests/CycleDetectionSpec.hs similarity index 67% rename from test/CycleDetectionTest.hs rename to tests/CycleDetectionSpec.hs index a28669d..7143d33 100644 --- a/test/CycleDetectionTest.hs +++ b/tests/CycleDetectionSpec.hs @@ -1,16 +1,42 @@ -module CycleDetectionTest - ( tests +module CycleDetectionSpec + ( spec ) where +import Prelude + +import Data.Foldable (for_) import Data.Graph.Inductive.Graph (mkGraph) import Data.Graph.Inductive.PatriciaTree (Gr) -import Test.HUnit - import Database.Schema.Migrations.CycleDetection +import Test.Hspec + +spec :: Spec +spec = do + describe "hasCycle" $ do + for_ cycleTests $ \(name, g, expected) -> do + let msg = + "determines " + <> (if expected then "cycles" else "no cycles") + <> " for the " + <> name + <> " example" + + it msg $ hasCycle g `shouldBe` expected -tests :: [Test] -tests = mkCycleTests +type CycleTestCase = (String, Gr String String, Bool) + +cycleTests :: [CycleTestCase] +cycleTests = + [ ("empty", noCyclesEmpty, False) + , ("simple", noCycles, False) + , ("radial without cycle", noCycleRadial, False) + , ("simple", withCycleSimple, True) + , ("complex", withCycleComplex, True) + , ("radial with cycle", withCycleRadial, True) + , ("no directed", noDirectedCycle1, False) + , ("no directed (2)", noDirectedCycle2, False) + ] noCycles :: Gr String String noCycles = mkGraph [(1, "one"), (2, "two")] [(1, 2, "one->two")] @@ -63,22 +89,3 @@ noDirectedCycle2 = , (3, 5, "test2->test1") , (4, 3, "test3->test2") ] - -type CycleTestCase = (Gr String String, Bool) - -cycleTests :: [CycleTestCase] -cycleTests = - [ (noCyclesEmpty, False) - , (noCycles, False) - , (noCycleRadial, False) - , (withCycleSimple, True) - , (withCycleComplex, True) - , (withCycleRadial, True) - , (noDirectedCycle1, False) - , (noDirectedCycle2, False) - ] - -mkCycleTests :: [Test] -mkCycleTests = map mkCycleTest cycleTests - where - mkCycleTest (g, expected) = expected ~=? hasCycle g diff --git a/test/DependencyTest.hs b/tests/DependencySpec.hs similarity index 53% rename from test/DependencyTest.hs rename to tests/DependencySpec.hs index 3db2ca0..a0b4980 100644 --- a/test/DependencyTest.hs +++ b/tests/DependencySpec.hs @@ -1,59 +1,61 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module DependencyTest - ( tests +module DependencySpec + ( spec ) where -import Data.Text (Text) - -import Data.Graph.Inductive.Graph (Graph (..)) -import Test.HUnit +import Prelude import Common +import Data.Foldable (for_) +import Data.Graph.Inductive.Graph (Graph (..)) +import Data.Text (Text, unpack) +import Data.Text qualified as T import Database.Schema.Migrations.Dependencies +import Test.Hspec -tests :: [Test] -tests = depGraphTests ++ dependencyTests +spec :: Spec +spec = do + describe "mkDepGraph" $ do + let + first = TD "first" [] + second = TD "second" ["first"] + cycleFirst = TD "first" ["second"] + cycleSecond = TD "second" ["first"] -type DepGraphTestCase = - ([TestDependable], Either String (DependencyGraph TestDependable)) + it "returns empty for empty" $ do + mkDepGraph @TestDependable [] `shouldBe` Right (DG [] [] empty) -depGraphTestCases :: [DepGraphTestCase] -depGraphTestCases = - [ - ( [] - , Right $ DG [] [] empty - ) - , - ( [first, second] - , Right $ - DG - [(first, 1), (second, 2)] - [("first", 1), ("second", 2)] - ( mkGraph - [(1, "first"), (2, "second")] - [(2, 1, "first -> second")] + it "builds a graph" $ do + mkDepGraph [first, second] + `shouldBe` Right + ( DG + [(first, 1), (second, 2)] + [("first", 1), ("second", 2)] + ( mkGraph + [(1, "first"), (2, "second")] + [(2, 1, "first -> second")] + ) ) - ) - , - ( [cycleFirst, cycleSecond] - , Left "Invalid dependency graph; cycle detected" - ) - ] - where - first = TD "first" [] - second = TD "second" ["first"] - cycleFirst = TD "first" ["second"] - cycleSecond = TD "second" ["first"] -depGraphTests :: [Test] -depGraphTests = map mkDepGraphTest depGraphTestCases + it "fails on cycles" $ do + mkDepGraph [cycleFirst, cycleSecond] + `shouldBe` Left "Invalid dependency graph; cycle detected" + + describe "dependencies and reverseDependencies" $ do + for_ dependencyTestCases $ \(deps, a, dir, expected) -> do + let (f, arrow) = case dir of + Forward -> (dependencies, " -> ") + Reverse -> (reverseDependencies, " <- ") + + it (unpack $ T.intercalate arrow $ map tdId deps) $ do + let Right g = mkDepGraph deps + f g a `shouldBe` expected -mkDepGraphTest :: DepGraphTestCase -> Test -mkDepGraphTest (input, expected) = expected ~=? mkDepGraph input +data Direction = Forward | Reverse + deriving stock (Show) -data Direction = Forward | Reverse deriving (Show) type DependencyTestCase = ([TestDependable], Text, Direction, [Text]) dependencyTestCases :: [DependencyTestCase] @@ -128,17 +130,3 @@ dependencyTestCases = , ["fourth", "third", "fifth", "second"] ) ] - -fromRight :: Either a b -> b -fromRight (Left _) = error "Got a Left value" -fromRight (Right v) = v - -mkDependencyTest :: DependencyTestCase -> Test -mkDependencyTest testCase@(deps, a, dir, expected) = - let f = case dir of - Forward -> dependencies - Reverse -> reverseDependencies - in (show testCase) ~: expected ~=? f (fromRight $ mkDepGraph deps) a - -dependencyTests :: [Test] -dependencyTests = map mkDependencyTest dependencyTestCases diff --git a/tests/FilesystemParseSpec.hs b/tests/FilesystemParseSpec.hs new file mode 100644 index 0000000..d022940 --- /dev/null +++ b/tests/FilesystemParseSpec.hs @@ -0,0 +1,156 @@ +module FilesystemParseSpec + ( spec + ) +where + +import Prelude + +import Common +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Database.Schema.Migrations.Filesystem + ( FilesystemStoreSettings (..) + , migrationFromFile + ) +import Database.Schema.Migrations.Migration +import System.FilePath (()) +import Test.Hspec + +spec :: Spec +spec = do + describe "migrationFromFile" $ do + let + testStorePath :: FilePath + testStorePath = testFile "migration_parsing" + + fp :: FilePath -> FilePath + fp = (testStorePath ) + + migrationFromFile' :: Text -> IO (Either String Migration) + migrationFromFile' = + migrationFromFile (FSStore {storePath = testStorePath}) . cs + + it "fully valid" $ do + migrationFromFile' "valid_full" `shouldReturn` Right validFull + + it "comments" $ do + migrationFromFile' "valid_with_comments" + `shouldReturn` Right (validFull {mId = "valid_with_comments"}) + + it "comments (2)" $ do + migrationFromFile' "valid_with_comments2" + `shouldReturn` Right (validFullComments {mId = "valid_with_comments2"}) + + it "colon" $ do + migrationFromFile' "valid_with_colon" + `shouldReturn` Right (validFullColon {mId = "valid_with_colon"}) + + it "multi-line deps" $ do + migrationFromFile' "valid_with_multiline_deps" + `shouldReturn` Right + ( validFull + { mId = "valid_with_multiline_deps" + , mDeps = ["one", "two", "three"] + } + ) + + it "no deps" $ do + migrationFromFile' "valid_no_depends" + `shouldReturn` Right (validFull {mId = "valid_no_depends", mDeps = []}) + + it "no description" $ do + migrationFromFile' "valid_no_desc" + `shouldReturn` Right (validFull {mId = "valid_no_desc", mDesc = Nothing}) + + it "no revert" $ do + migrationFromFile' "valid_no_revert" + `shouldReturn` Right (validFull {mId = "valid_no_revert", mRevert = Nothing}) + + it "no timestamp" $ do + migrationFromFile' "valid_no_timestamp" + `shouldReturn` Right (validFull {mId = "valid_no_timestamp", mTimestamp = Nothing}) + + context "invalid" $ do + it "missing required fields" $ do + pendingWith "Aeson 2.x changes the message format" + migrationFromFile' "invalid_missing_required_fields" + `shouldReturn` Left + ( "Could not parse migration " + <> fp "invalid_missing_required_fields" + <> ":Error in " + <> show (fp "invalid_missing_required_fields") + <> ": missing required field(s): " + <> "[\"Depends\"]" + ) + + it "unrecognized field name" $ do + pendingWith "Aeson 2.x changes the message format" + migrationFromFile' "invalid_field_name" + `shouldReturn` Left + ( "Could not parse migration " + <> fp "invalid_field_name" + <> ":Error in " + <> show (fp "invalid_field_name") + <> ": unrecognized field found" + ) + + it "invalid syntax" $ do + migrationFromFile' "invalid_syntax" + `shouldReturn` Left + ( "Could not parse migration " + <> 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}}))" + ) + + it "invalid timestamp" $ do + pendingWith "Aeson 2.x changes the message format" + migrationFromFile' "invalid_timestamp" + `shouldReturn` Left + ( "Could not parse migration " + <> fp "invalid_timestamp" + <> ":Error in " + <> show (fp "invalid_timestamp") + <> ": unrecognized field found" + ) + +validFull :: Migration +validFull = + Migration + { mTimestamp = Just ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = "CREATE TABLE test ( a int );" + , mRevert = Just "DROP TABLE test;" + } + +validFullComments :: Migration +validFullComments = + Migration + { mTimestamp = Just ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = + "\n-- Comment on a line\nCREATE TABLE test (\n a int -- comment inline\n);\n" + , mRevert = Just "DROP TABLE test;" + } + +validFullColon :: Migration +validFullColon = + Migration + { mTimestamp = Just ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = + "\n-- Comment on a line with a colon:\nCREATE TABLE test (\n a int\n);\n" + , mRevert = Just "DROP TABLE test;" + } + +ts :: UTCTime +ts = read tsStr + +tsStr :: String +tsStr = "2009-04-15 10:02:06 UTC" diff --git a/tests/FilesystemSerializeSpec.hs b/tests/FilesystemSerializeSpec.hs new file mode 100644 index 0000000..e54d480 --- /dev/null +++ b/tests/FilesystemSerializeSpec.hs @@ -0,0 +1,90 @@ +module FilesystemSerializeSpec + ( spec + ) +where + +import Prelude + +import Data.String.Conversions (cs) +import Data.Time.Clock (UTCTime) +import Database.Schema.Migrations.Filesystem.Serialize +import Database.Schema.Migrations.Migration +import Test.Hspec + +spec :: Spec +spec = do + describe "serializeMigration" $ do + it "handles fully valid" $ do + serializeMigration validFull + `shouldBe` cs + ( "Description: A valid full migration.\nCreated: " + <> tsStr + <> "\n\ + \Depends: another_migration\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n\n\ + \Revert: |\n\ + \ DROP TABLE test;\n" + ) + + it "handles no description" $ do + serializeMigration (validFull {mDesc = Nothing}) + `shouldBe` cs + ( "Created: " + <> tsStr + <> "\n\ + \Depends: another_migration\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n\n\ + \Revert: |\n\ + \ DROP TABLE test;\n" + ) + + it "handles no deps" $ do + serializeMigration (validFull {mDeps = ["one", "two"]}) + `shouldBe` cs + ( "Description: A valid full migration.\nCreated: " + <> tsStr + <> "\n\ + \Depends: one two\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n\n\ + \Revert: |\n\ + \ DROP TABLE test;\n" + ) + + it "handles no revert" $ do + serializeMigration (validFull {mRevert = Nothing}) + `shouldBe` cs + ( "Description: A valid full migration.\nCreated: " + <> tsStr + <> "\n\ + \Depends: another_migration\n\ + \Apply: |\n\ + \ CREATE TABLE test (\n\ + \ a int\n\ + \ );\n" + ) + +validFull :: Migration +validFull = + Migration + { mTimestamp = Just ts + , mId = "valid_full" + , mDesc = Just "A valid full migration." + , mDeps = ["another_migration"] + , mApply = " CREATE TABLE test (\n a int\n );\n" + , mRevert = Just "DROP TABLE test;" + } + +ts :: UTCTime +ts = read tsStr + +tsStr :: String +tsStr = "2009-04-15 10:02:06 UTC" diff --git a/tests/FilesystemSpec.hs b/tests/FilesystemSpec.hs new file mode 100644 index 0000000..206bacc --- /dev/null +++ b/tests/FilesystemSpec.hs @@ -0,0 +1,36 @@ +module FilesystemSpec + ( spec + ) +where + +import Prelude + +import Common +import Database.Schema.Migrations.Filesystem +import Database.Schema.Migrations.Store (MigrationStore (..)) +import Test.Hspec + +spec :: Spec +spec = do + describe "getMigrations" $ do + it "gets all migrations in the store" $ do + let store = + filesystemStore $ + FSStore {storePath = testFile "migration_parsing"} + + migrations <- getMigrations store + migrations + `shouldMatchList` [ "invalid_field_name" + , "invalid_missing_required_fields" + , "invalid_syntax" + , "invalid_timestamp" + , "valid_full" + , "valid_no_depends" + , "valid_no_desc" + , "valid_no_revert" + , "valid_no_timestamp" + , "valid_with_comments" + , "valid_with_comments2" + , "valid_with_colon" + , "valid_with_multiline_deps" + ] diff --git a/tests/HDBCSpec.hs b/tests/HDBCSpec.hs new file mode 100644 index 0000000..6dbf7fd --- /dev/null +++ b/tests/HDBCSpec.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Use SQlite3 as an example to test the supplied 'hdbcBackend' +module HDBCSpec + ( spec + ) +where + +import Prelude + +import Database.HDBC (IConnection (disconnect)) +import Database.HDBC.Sqlite3 (Connection, connectSqlite3) +import Database.Schema.Migrations.Backend.HDBC +import Database.Schema.Migrations.Test.BackendTest hiding (spec) +import Database.Schema.Migrations.Test.BackendTest qualified as BackendTest +import Test.Hspec + +deriving via (HDBCConnection Connection) instance BackendConnection Connection + +spec :: Spec +spec = before (connectSqlite3 ":memory:") $ after disconnect BackendTest.spec diff --git a/test/InMemoryStore.hs b/tests/InMemoryStore.hs similarity index 81% rename from test/InMemoryStore.hs rename to tests/InMemoryStore.hs index 6d16c5a..a2215da 100644 --- a/test/InMemoryStore.hs +++ b/tests/InMemoryStore.hs @@ -1,9 +1,10 @@ module InMemoryStore (inMemoryStore) where -import Data.String.Conversions (cs) -import Data.Text (Text) +import Prelude import Control.Concurrent.MVar +import Data.String.Conversions (cs) +import Data.Text (Text) import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Store @@ -14,23 +15,23 @@ type InMemoryData = [(Text, Migration)] inMemoryStore :: IO MigrationStore inMemoryStore = do store <- newMVar [] - return + pure MigrationStore { loadMigration = loadMigrationInMem store , saveMigration = saveMigrationInMem store , getMigrations = getMigrationsInMem store - , fullMigrationName = return . cs + , fullMigrationName = pure . cs } loadMigrationInMem :: MVar InMemoryData -> Text -> IO (Either String Migration) loadMigrationInMem store migId = withMVar store $ \migrations -> do let mig = lookup migId migrations - return $ case mig of + pure $ case mig of Just m -> Right m _ -> Left "Migration not found" saveMigrationInMem :: MVar InMemoryData -> Migration -> IO () -saveMigrationInMem store m = modifyMVar_ store $ return . ((mId m, m) :) +saveMigrationInMem store m = modifyMVar_ store $ pure . ((mId m, m) :) getMigrationsInMem :: MVar InMemoryData -> IO [Text] -getMigrationsInMem store = withMVar store $ return . fmap fst +getMigrationsInMem store = withMVar store $ pure . fmap fst diff --git a/tests/LinearMigrationsSpec.hs b/tests/LinearMigrationsSpec.hs new file mode 100644 index 0000000..01415c7 --- /dev/null +++ b/tests/LinearMigrationsSpec.hs @@ -0,0 +1,97 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module LinearMigrationsSpec + ( spec + ) +where + +import Prelude + +import Control.Monad.Reader (runReaderT) +import Data.Either (isRight) +import Data.Text (Text) +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Store +import InMemoryStore +import Moo.CommandHandlers +import Moo.Core +import Test.Hspec + +spec :: Spec +spec = do + describe "linear migrations" $ do + it "addsMigration" $ do + state <- prepareState "first" + mig <- addTestMigration state + + mig `shouldSatisfy` isRight + + it "selectsLatestMigrationAsDep" $ do + state1 <- prepareState "first" + _ <- addTestMigration state1 + state2 <- prepareStateWith state1 "second" + Right mig <- addTestMigration state2 + + mDeps mig `shouldBe` ["first"] + + it "selectsOnlyLeavesAsDeps" $ do + state1 <- prepareNormalState "first" + addTestMigrationWithDeps state1 [] + state2 <- prepareStateWith state1 "second" + addTestMigrationWithDeps state2 ["first"] + state3 <- prepareStateWith state2 "third" + addTestMigrationWithDeps state3 ["first"] + state4' <- prepareStateWith state3 "fourth" + let state4 = state4' {_appLinearMigrations = True} + Right mig <- addTestMigration state4 + + mDeps mig `shouldBe` ["second", "third"] + + it "doesNotAddDependencyWhenLinearMigrationsAreDisabled" $ do + state1 <- prepareNormalState "first" + _ <- addTestMigration state1 + state2 <- prepareStateWith state1 "second" + Right mig <- addTestMigration state2 + + mDeps mig `shouldSatisfy` null + +addTestMigration :: AppState -> IO (Either String Migration) +addTestMigration state = do + let + store = _appStore state + [migrationId] = _appRequiredArgs state + runReaderT (newCommand $ _appStoreData state) state + loadMigration store migrationId + +addTestMigrationWithDeps :: AppState -> [Text] -> IO () +addTestMigrationWithDeps state deps = do + let store = _appStore state + let [migrationId] = _appRequiredArgs state + saveMigration store (newMigration migrationId) {mDeps = deps} + +prepareState :: Text -> IO AppState +prepareState m = do + store <- inMemoryStore + Right storeData <- loadMigrations store + pure + AppState + { _appOptions = CommandOptions Nothing False True + , _appBackend = undefined -- Not used here + , _appCommand = undefined -- Not used by newCommand + , _appRequiredArgs = [m] + , _appOptionalArgs = [] + , _appStore = store + , _appStoreData = storeData + , _appLinearMigrations = True + , _appTimestampFilenames = False + } + +prepareStateWith :: AppState -> Text -> IO AppState +prepareStateWith state m = do + Right storeData <- loadMigrations $ _appStore state + pure state {_appRequiredArgs = [m], _appStoreData = storeData} + +prepareNormalState :: Text -> IO AppState +prepareNormalState m = do + state <- prepareState m + pure $ state {_appLinearMigrations = False} diff --git a/test/MigrationsTest.hs b/tests/MigrationsSpec.hs similarity index 57% rename from test/MigrationsTest.hs rename to tests/MigrationsSpec.hs index cea7c0b..8ddb765 100644 --- a/test/MigrationsTest.hs +++ b/tests/MigrationsSpec.hs @@ -1,38 +1,46 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module MigrationsTest - ( tests +module MigrationsSpec + ( spec ) where -import Control.Applicative ((<$>)) -import qualified Data.Map as Map -import Data.Time.Clock (UTCTime) -import Test.HUnit +import Prelude +import Data.Foldable (for_) +import Data.Map qualified as Map +import Data.Time.Clock (UTCTime) import Database.Schema.Migrations import Database.Schema.Migrations.Backend import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Store hiding (getMigrations) +import Test.Hspec + +spec :: Spec +spec = do + describe "migrationsToApply" $ do + for_ missingMigrationsTestcases $ \(mapping, backend, mig, expected) -> do + let + Right graph = depGraphFromMapping mapping + storeData = StoreData mapping graph + withDeps = case mDeps mig of + [] -> "" + ds -> " with deps " <> show ds -tests :: [Test] -tests = migrationsToApplyTests + it ("migration " <> show (mId mig) <> withDeps) $ do + migrationsToApply storeData backend mig `shouldReturn` expected testBackend :: [Migration] -> Backend testBackend testMs = Backend { getBootstrapMigration = undefined - , isBootstrapped = return True + , isBootstrapped = pure True , applyMigration = const undefined , revertMigration = const undefined - , getMigrations = return $ mId <$> testMs - , commitBackend = return () - , rollbackBackend = return () - , disconnectBackend = return () + , getMigrations = pure $ mId <$> testMs + , commitBackend = pure () + , rollbackBackend = pure () + , disconnectBackend = pure () } -- | Given a backend and a store, what are the list of migrations @@ -70,17 +78,3 @@ missingMigrationsTestcases = one = blankMigration {mId = "one"} two = blankMigration {mId = "two", mDeps = ["one"]} m = Map.fromList [(mId e, e) | e <- [one, two]] - -mkTest :: MissingMigrationTestCase -> Test -mkTest (mapping, backend, theMigration, expected) = - let - Right graph = depGraphFromMapping mapping - storeData = StoreData mapping graph - result = migrationsToApply storeData backend theMigration - in - "a test" ~: do - actual <- result - return $ expected == actual - -migrationsToApplyTests :: [Test] -migrationsToApplyTests = map mkTest missingMigrationsTestcases diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 index 0000000..8044961 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -Wno-missing-export-lists #-} diff --git a/tests/StoreSpec.hs b/tests/StoreSpec.hs new file mode 100644 index 0000000..a03a6fd --- /dev/null +++ b/tests/StoreSpec.hs @@ -0,0 +1,137 @@ +module StoreSpec + ( spec + ) +where + +import Data.Map qualified as Map +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Store +import Test.Hspec +import Prelude + +spec :: Spec +spec = do + describe "validateSingleMigration" $ do + it "handles an empty map with deps" $ do + validateSingleMigration emptyMap withDeps + `shouldBe` [ DependencyReferenceError (mId withDeps) "one" + , DependencyReferenceError (mId withDeps) "two" + , DependencyReferenceError (mId withDeps) "three" + ] + + it "handles an empty map without deps" $ do + validateSingleMigration emptyMap noDeps `shouldBe` [] + + it "handles a partial map with deps" $ do + validateSingleMigration partialMap withDeps + `shouldBe` [DependencyReferenceError (mId withDeps) "two"] + + it "handles a full map with deps" $ do + validateSingleMigration fullMap withDeps `shouldBe` [] + + it "handles a full map without deps" $ do + validateSingleMigration fullMap noDeps `shouldBe` [] + + describe "validateMigrationMap" $ do + it "handles an empty map" $ do + validateMigrationMap emptyMap `shouldBe` [] + + it "map1 example" $ do + validateMigrationMap map1 `shouldBe` [] + + it "map2 example" $ do + validateMigrationMap map2 + `shouldBe` [DependencyReferenceError (mId m3) "nonexistent"] + + it "map3 example" $ do + validateMigrationMap map3 + `shouldBe` [ DependencyReferenceError (mId m4) "one" + , DependencyReferenceError (mId m4) "two" + ] + +emptyMap :: MigrationMap +emptyMap = Map.empty + +partialMap :: MigrationMap +partialMap = + Map.fromList + [ ("one", undefined) + , ("three", undefined) + ] + +fullMap :: MigrationMap +fullMap = + Map.fromList + [ ("one", undefined) + , ("two", undefined) + , ("three", undefined) + ] + +withDeps :: Migration +withDeps = + Migration + { mTimestamp = undefined + , mId = "with_deps" + , mDesc = Just "with dependencies" + , mApply = "" + , mRevert = Nothing + , mDeps = ["one", "two", "three"] + } + +noDeps :: Migration +noDeps = + Migration + { mTimestamp = undefined + , mId = "no_deps" + , mDesc = Just "no dependencies" + , mApply = "" + , mRevert = Nothing + , mDeps = [] + } + +m1 :: Migration +m1 = + noDeps + { mId = "m1" + , mDeps = [] + } + +m2 :: Migration +m2 = + noDeps + { mId = "m2" + , mDeps = ["m1"] + } + +m3 :: Migration +m3 = + noDeps + { mId = "m3" + , mDeps = ["nonexistent"] + } + +m4 :: Migration +m4 = + noDeps + { mId = "m4" + , mDeps = ["one", "two"] + } + +map1 :: MigrationMap +map1 = + Map.fromList + [ ("m1", m1) + , ("m2", m2) + ] + +map2 :: MigrationMap +map2 = + Map.fromList + [ ("m3", m3) + ] + +map3 :: MigrationMap +map3 = + Map.fromList + [ ("m4", m4) + ] diff --git a/test/config_loading/cfg1.cfg b/tests/config_loading/cfg1.cfg similarity index 100% rename from test/config_loading/cfg1.cfg rename to tests/config_loading/cfg1.cfg diff --git a/test/config_loading/cfg_ts.cfg b/tests/config_loading/cfg_ts.cfg similarity index 100% rename from test/config_loading/cfg_ts.cfg rename to tests/config_loading/cfg_ts.cfg diff --git a/test/config_loading/invalid.cfg b/tests/config_loading/invalid.cfg similarity index 56% rename from test/config_loading/invalid.cfg rename to tests/config_loading/invalid.cfg index 1145e94..71a5406 100644 --- a/test/config_loading/invalid.cfg +++ b/tests/config_loading/invalid.cfg @@ -1,3 +1,3 @@ -MALFORMED_ = +MALFORMED_ = CONFIG = ASD FILE diff --git a/test/config_loading/missing.cfg b/tests/config_loading/missing.cfg similarity index 100% rename from test/config_loading/missing.cfg rename to tests/config_loading/missing.cfg diff --git a/test/config_loading/moo.cfg b/tests/config_loading/moo.cfg similarity index 100% rename from test/config_loading/moo.cfg rename to tests/config_loading/moo.cfg diff --git a/test/example_store/root b/tests/example_store/root similarity index 100% rename from test/example_store/root rename to tests/example_store/root diff --git a/test/example_store/update1 b/tests/example_store/update1 similarity index 100% rename from test/example_store/update1 rename to tests/example_store/update1 diff --git a/test/example_store/update2 b/tests/example_store/update2 similarity index 100% rename from test/example_store/update2 rename to tests/example_store/update2 diff --git a/test/migration_parsing/invalid_field_name.txt b/tests/migration_parsing/invalid_field_name.txt similarity index 100% rename from test/migration_parsing/invalid_field_name.txt rename to tests/migration_parsing/invalid_field_name.txt diff --git a/test/migration_parsing/invalid_missing_required_fields.txt b/tests/migration_parsing/invalid_missing_required_fields.txt similarity index 100% rename from test/migration_parsing/invalid_missing_required_fields.txt rename to tests/migration_parsing/invalid_missing_required_fields.txt diff --git a/test/migration_parsing/invalid_syntax.txt b/tests/migration_parsing/invalid_syntax.txt similarity index 100% rename from test/migration_parsing/invalid_syntax.txt rename to tests/migration_parsing/invalid_syntax.txt diff --git a/test/migration_parsing/invalid_timestamp.txt b/tests/migration_parsing/invalid_timestamp.txt similarity index 100% rename from test/migration_parsing/invalid_timestamp.txt rename to tests/migration_parsing/invalid_timestamp.txt diff --git a/test/migration_parsing/valid_full.txt b/tests/migration_parsing/valid_full.txt similarity index 100% rename from test/migration_parsing/valid_full.txt rename to tests/migration_parsing/valid_full.txt diff --git a/test/migration_parsing/valid_no_depends.txt b/tests/migration_parsing/valid_no_depends.txt similarity index 100% rename from test/migration_parsing/valid_no_depends.txt rename to tests/migration_parsing/valid_no_depends.txt diff --git a/test/migration_parsing/valid_no_desc.txt b/tests/migration_parsing/valid_no_desc.txt similarity index 100% rename from test/migration_parsing/valid_no_desc.txt rename to tests/migration_parsing/valid_no_desc.txt diff --git a/test/migration_parsing/valid_no_revert.txt b/tests/migration_parsing/valid_no_revert.txt similarity index 100% rename from test/migration_parsing/valid_no_revert.txt rename to tests/migration_parsing/valid_no_revert.txt diff --git a/test/migration_parsing/valid_no_timestamp.txt b/tests/migration_parsing/valid_no_timestamp.txt similarity index 100% rename from test/migration_parsing/valid_no_timestamp.txt rename to tests/migration_parsing/valid_no_timestamp.txt diff --git a/test/migration_parsing/valid_with_colon.txt b/tests/migration_parsing/valid_with_colon.txt similarity index 100% rename from test/migration_parsing/valid_with_colon.txt rename to tests/migration_parsing/valid_with_colon.txt diff --git a/test/migration_parsing/valid_with_comments.txt b/tests/migration_parsing/valid_with_comments.txt similarity index 100% rename from test/migration_parsing/valid_with_comments.txt rename to tests/migration_parsing/valid_with_comments.txt diff --git a/test/migration_parsing/valid_with_comments2.txt b/tests/migration_parsing/valid_with_comments2.txt similarity index 100% rename from test/migration_parsing/valid_with_comments2.txt rename to tests/migration_parsing/valid_with_comments2.txt diff --git a/test/migration_parsing/valid_with_multiline_deps.txt b/tests/migration_parsing/valid_with_multiline_deps.txt similarity index 100% rename from test/migration_parsing/valid_with_multiline_deps.txt rename to tests/migration_parsing/valid_with_multiline_deps.txt diff --git a/weeder.toml b/weeder.toml new file mode 100644 index 0000000..b6ac9c0 --- /dev/null +++ b/weeder.toml @@ -0,0 +1,10 @@ +roots = [ + "^Database\\.Schema\\.Migrations\\.Backend\\.HDBC\\.hdbcBackend$", + "^Database\\.Schema\\.Migrations\\.Test\\.BackendTest\\..*$", + "^Main\\.main$", + "^Moo\\.Core\\.makeParameters$", + "^Moo\\.Main\\..*$", + "^Paths_dbmigrations\\..*$", + "^Spec\\.main$" +] +type-class-roots = true From 4f167b1a24dd0b40d494775535adfa2e8690f37a Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Mon, 1 Apr 2024 16:20:48 -0400 Subject: [PATCH 03/10] Fix inverted conditional --- dbmigrations.cabal | 90 ++++++++++++++++++- package.yaml | 21 ++++- sqlite/app/Main.hs | 25 ++++++ tests/HDBCSpec.hs => sqlite/tests/Main.hs | 13 ++- .../Schema/Migrations/Test/BackendTest.hs | 5 +- 5 files changed, 138 insertions(+), 16 deletions(-) create mode 100644 sqlite/app/Main.hs rename tests/HDBCSpec.hs => sqlite/tests/Main.hs (71%) diff --git a/dbmigrations.cabal b/dbmigrations.cabal index 916d263..445d119 100644 --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -114,6 +114,47 @@ library if impl(ghc >= 8.10) ghc-options: -Wno-missing-safe-haskell-mode +executable dbm-sqlite + main-is: Main.hs + other-modules: + Paths_dbmigrations + hs-source-dirs: + sqlite/app + default-extensions: + BangPatterns + DataKinds + DeriveAnyClass + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TypeApplications + TypeFamilies + ghc-options: -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -threaded -rtsopts "-with-rtsopts=-N" + build-depends: + HDBC-sqlite3 + , base <5 + , dbmigrations + default-language: GHC2021 + if impl(ghc >= 9.2) + ghc-options: -Wno-missing-kind-signatures + if impl(ghc >= 8.10) + ghc-options: -Wno-missing-safe-haskell-mode + test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs @@ -126,7 +167,6 @@ test-suite spec FilesystemParseSpec FilesystemSerializeSpec FilesystemSpec - HDBCSpec InMemoryStore LinearMigrationsSpec MigrationsSpec @@ -160,9 +200,7 @@ test-suite spec TypeFamilies ghc-options: -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -threaded -rtsopts "-with-rtsopts=-N" build-depends: - HDBC - , HDBC-sqlite3 - , base <5 + base <5 , containers , dbmigrations , directory @@ -179,3 +217,47 @@ test-suite spec ghc-options: -Wno-missing-kind-signatures if impl(ghc >= 8.10) ghc-options: -Wno-missing-safe-haskell-mode + +test-suite sqlite-spec + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_dbmigrations + hs-source-dirs: + sqlite/tests + default-extensions: + BangPatterns + DataKinds + DeriveAnyClass + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TypeApplications + TypeFamilies + ghc-options: -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -threaded -rtsopts "-with-rtsopts=-N" + build-depends: + HDBC + , HDBC-sqlite3 + , base <5 + , dbmigrations + , hspec + default-language: GHC2021 + if impl(ghc >= 9.2) + ghc-options: -Wno-missing-kind-signatures + if impl(ghc >= 8.10) + ghc-options: -Wno-missing-safe-haskell-mode diff --git a/package.yaml b/package.yaml index 338c545..e42bd44 100644 --- a/package.yaml +++ b/package.yaml @@ -90,14 +90,21 @@ library: - time - yaml +executables: + dbm-sqlite: + source-dirs: sqlite/app + ghc-options: -threaded -rtsopts "-with-rtsopts=-N" + main: Main.hs + dependencies: + - HDBC-sqlite3 + - dbmigrations + tests: spec: source-dirs: tests ghc-options: -threaded -rtsopts "-with-rtsopts=-N" main: Spec.hs dependencies: - - HDBC - - HDBC-sqlite3 - containers - dbmigrations - directory @@ -109,3 +116,13 @@ tests: - template-haskell - text - time + + sqlite-spec: + source-dirs: sqlite/tests + ghc-options: -threaded -rtsopts "-with-rtsopts=-N" + main: Main.hs + dependencies: + - HDBC + - HDBC-sqlite3 + - dbmigrations + - hspec diff --git a/sqlite/app/Main.hs b/sqlite/app/Main.hs new file mode 100644 index 0000000..825786d --- /dev/null +++ b/sqlite/app/Main.hs @@ -0,0 +1,25 @@ +module Main (main) where + +import Prelude hiding (lookup) + +import Database.HDBC.Sqlite3 (connectSqlite3) +import Database.Schema.Migrations.Backend.HDBC (hdbcBackend) +import Moo.Core +import Moo.Main +import System.Environment (getArgs) +import System.Exit + +main :: IO () +main = do + args <- getArgs + (_, opts, _) <- procArgs args + loadedConf <- loadConfiguration $ _configFilePath opts + case loadedConf of + Left e -> putStrLn e >> exitFailure + Right conf -> do + let connectionString = _connectionString conf + connection <- connectSqlite3 connectionString + let + backend = hdbcBackend connection + parameters = makeParameters conf backend + mainWithParameters args parameters diff --git a/tests/HDBCSpec.hs b/sqlite/tests/Main.hs similarity index 71% rename from tests/HDBCSpec.hs rename to sqlite/tests/Main.hs index 6dbf7fd..66feb59 100644 --- a/tests/HDBCSpec.hs +++ b/sqlite/tests/Main.hs @@ -1,11 +1,7 @@ {-# LANGUAGE DerivingVia #-} {-# OPTIONS_GHC -Wno-orphans #-} --- | Use SQlite3 as an example to test the supplied 'hdbcBackend' -module HDBCSpec - ( spec - ) -where +module Main (main) where import Prelude @@ -18,5 +14,8 @@ import Test.Hspec deriving via (HDBCConnection Connection) instance BackendConnection Connection -spec :: Spec -spec = before (connectSqlite3 ":memory:") $ after disconnect BackendTest.spec +main :: IO () +main = + hspec + . before (connectSqlite3 ":memory:") + $ after disconnect BackendTest.spec diff --git a/src/Database/Schema/Migrations/Test/BackendTest.hs b/src/Database/Schema/Migrations/Test/BackendTest.hs index d4f2e12..5ad1b30 100644 --- a/src/Database/Schema/Migrations/Test/BackendTest.hs +++ b/src/Database/Schema/Migrations/Test/BackendTest.hs @@ -197,9 +197,8 @@ makeBootstrappedBackend conn = do -- backend does not support that. needDDL :: BackendConnection bc => (bc -> Expectation) -> bc -> Expectation needDDL f conn - | supportsTransactionalDDL conn = - pendingWith "Skipping due to lack of Transactional DDL" - | otherwise = f conn + | supportsTransactionalDDL conn = f conn + | otherwise = pendingWith "Skipping due to lack of Transactional DDL" ignoreSqlExceptions_ :: BackendConnection bc => bc -> IO a -> IO () ignoreSqlExceptions_ conn act = void act `catch` pure () From e5d15b1a640c665805d5f6f7fcaa736ce7c402fd Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Mon, 1 Apr 2024 16:37:39 -0400 Subject: [PATCH 04/10] Add separate directory for dbm-sqlite --- .../Schema/Migrations/Backend/HDBC.hs | 29 +++++++------------ .../Schema/Migrations/Test/BackendTest.hs | 14 +++++---- 2 files changed, 19 insertions(+), 24 deletions(-) diff --git a/src/Database/Schema/Migrations/Backend/HDBC.hs b/src/Database/Schema/Migrations/Backend/HDBC.hs index ab3d2d5..adfe4b8 100644 --- a/src/Database/Schema/Migrations/Backend/HDBC.hs +++ b/src/Database/Schema/Migrations/Backend/HDBC.hs @@ -7,6 +7,7 @@ where import Prelude import Control.Exception (catch) +import Control.Monad (void) import Data.String.Conversions (cs) import Data.Text (Text) import Data.Time.Clock (getCurrentTime) @@ -25,60 +26,52 @@ import Database.Schema.Migrations.Backend (Backend (..), rootMigrationName) import Database.Schema.Migrations.Migration (Migration (..), newMigration) import Database.Schema.Migrations.Test.BackendTest qualified as BackendTest -migrationTableName :: Text -migrationTableName = "installed_migrations" - -createSql :: Text -createSql = "CREATE TABLE " <> migrationTableName <> " (migration_id TEXT)" - -revertSql :: Text -revertSql = "DROP TABLE " <> migrationTableName +installedMigrations :: Text +installedMigrations = "installed_migrations" -- | General Backend constructor for all HDBC connection implementations. hdbcBackend :: IConnection conn => conn -> Backend hdbcBackend conn = Backend - { isBootstrapped = elem (cs migrationTableName) <$> getTables conn + { isBootstrapped = elem (cs installedMigrations) <$> getTables conn , getBootstrapMigration = do ts <- getCurrentTime pure $ (newMigration rootMigrationName) - { mApply = createSql - , mRevert = Just revertSql + { mApply = "CREATE TABLE " <> installedMigrations <> " (migration_id TEXT)" + , mRevert = Just $ "DROP TABLE " <> installedMigrations , mDesc = Just "Migration table installation" , mTimestamp = Just ts } , applyMigration = \m -> do runRaw conn (cs $ mApply m) - _ <- + void $ run conn ( cs $ "INSERT INTO " - <> migrationTableName + <> installedMigrations <> " (migration_id) VALUES (?)" ) [toSql $ mId m] - pure () , revertMigration = \m -> do case mRevert m of Nothing -> pure () Just query -> runRaw conn (cs query) -- Remove migration from installed_migrations in either case. - _ <- + void $ run conn ( cs $ "DELETE FROM " - <> migrationTableName + <> installedMigrations <> " WHERE migration_id = ?" ) [toSql $ mId m] - pure () , getMigrations = do results <- - quickQuery' conn (cs $ "SELECT migration_id FROM " <> migrationTableName) [] + quickQuery' conn (cs $ "SELECT migration_id FROM " <> installedMigrations) [] pure $ map (fromSql . head) results , commitBackend = commit conn , rollbackBackend = rollback conn diff --git a/src/Database/Schema/Migrations/Test/BackendTest.hs b/src/Database/Schema/Migrations/Test/BackendTest.hs index 5ad1b30..fd2d440 100644 --- a/src/Database/Schema/Migrations/Test/BackendTest.hs +++ b/src/Database/Schema/Migrations/Test/BackendTest.hs @@ -93,16 +93,18 @@ spec = do applyMigration backend' m1 applyMigration backend' m2 + -- The failure to apply m2 results in no tables + pendingWith "Fails and I don't know why" getTables conn `shouldReturn` ["installed_migrations"] getMigrations backend `shouldReturn` ["root"] it "applies migrations" $ needDDL $ \conn -> do - let - backend = makeBackend conn - m1 = - (newMigration "validMigration") - { mApply = "CREATE TABLE valid1 (a int)" - } + backend <- makeBootstrappedBackend conn + + let m1 = + (newMigration "validMigration") + { mApply = "CREATE TABLE valid1 (a int)" + } withTransaction conn $ \conn' -> do applyMigration (makeBackend conn') m1 From 067c1a709e6a270f89d4209aba69fdce8e4df730 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Mon, 1 Apr 2024 16:38:56 -0400 Subject: [PATCH 05/10] Put executables behind flags --- dbmigrations.cabal | 19 +++++++++++++++++++ package.yaml | 22 ++++++++++++++++++++++ 2 files changed, 41 insertions(+) diff --git a/dbmigrations.cabal b/dbmigrations.cabal index 445d119..0ab469c 100644 --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -46,6 +46,21 @@ source-repository head type: git location: https://github.com/haskell-github-trust/dbmigrations +flag mysql + description: Build the mysql executable (and tests) application + manual: False + default: False + +flag postgresql + description: Build the postgresql executable (and tests) application + manual: False + default: False + +flag sqlite + description: Build the sqlite executable (and tests) + manual: False + default: False + library exposed-modules: Database.Schema.Migrations @@ -154,6 +169,8 @@ executable dbm-sqlite ghc-options: -Wno-missing-kind-signatures if impl(ghc >= 8.10) ghc-options: -Wno-missing-safe-haskell-mode + if !(flag(sqlite)) + buildable: False test-suite spec type: exitcode-stdio-1.0 @@ -261,3 +278,5 @@ test-suite sqlite-spec ghc-options: -Wno-missing-kind-signatures if impl(ghc >= 8.10) ghc-options: -Wno-missing-safe-haskell-mode + if !(flag(sqlite)) + buildable: False diff --git a/package.yaml b/package.yaml index e42bd44..2d455e9 100644 --- a/package.yaml +++ b/package.yaml @@ -98,6 +98,9 @@ executables: dependencies: - HDBC-sqlite3 - dbmigrations + when: + - condition: ! "!(flag(sqlite))" + buildable: false tests: spec: @@ -126,3 +129,22 @@ tests: - HDBC-sqlite3 - dbmigrations - hspec + when: + - condition: ! "!(flag(sqlite))" + buildable: false + +flags: + sqlite: + description: Build the sqlite executable (and tests) + manual: false + default: false + + mysql: + description: Build the mysql executable (and tests) application + manual: false + default: false + + postgresql: + description: Build the postgresql executable (and tests) application + manual: false + default: false From daa09c4aa4e2259efd2b0dfa1ed03fc280d3f5ef Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Mon, 1 Apr 2024 16:39:16 -0400 Subject: [PATCH 06/10] Remove MySQL, add PostgreSQL --- dbmigrations.cabal | 94 ++++++++++++++++++- package.yaml | 56 ++++++++++- postgresql/app/Main.hs | 9 ++ postgresql/tests/Main.hs | 29 ++++++ sqlite/app/Main.hs | 20 +--- sqlite/tests/Main.hs | 8 +- src/Database/Schema/Migrations/Backend.hs | 14 ++- .../Schema/Migrations/Backend/HDBC.hs | 10 +- .../Schema/Migrations/Test/BackendTest.hs | 32 ++----- src/Moo/Main.hs | 25 ++++- stack.yaml | 2 + stack.yaml.lock | 14 +++ 12 files changed, 247 insertions(+), 66 deletions(-) create mode 100644 postgresql/app/Main.hs create mode 100644 postgresql/tests/Main.hs diff --git a/dbmigrations.cabal b/dbmigrations.cabal index 0ab469c..fc62130 100644 --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -46,11 +46,6 @@ source-repository head type: git location: https://github.com/haskell-github-trust/dbmigrations -flag mysql - description: Build the mysql executable (and tests) application - manual: False - default: False - flag postgresql description: Build the postgresql executable (and tests) application manual: False @@ -129,6 +124,49 @@ library if impl(ghc >= 8.10) ghc-options: -Wno-missing-safe-haskell-mode +executable dbm-postgresql + main-is: Main.hs + other-modules: + Paths_dbmigrations + hs-source-dirs: + postgresql/app + default-extensions: + BangPatterns + DataKinds + DeriveAnyClass + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TypeApplications + TypeFamilies + ghc-options: -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -threaded -rtsopts "-with-rtsopts=-N" + build-depends: + HDBC-postgresql + , base <5 + , dbmigrations + default-language: GHC2021 + if impl(ghc >= 9.2) + ghc-options: -Wno-missing-kind-signatures + if impl(ghc >= 8.10) + ghc-options: -Wno-missing-safe-haskell-mode + if !(flag(postgresql)) + buildable: False + executable dbm-sqlite main-is: Main.hs other-modules: @@ -172,6 +210,52 @@ executable dbm-sqlite if !(flag(sqlite)) buildable: False +test-suite postgresql-spec + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_dbmigrations + hs-source-dirs: + postgresql/tests + default-extensions: + BangPatterns + DataKinds + DeriveAnyClass + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TypeApplications + TypeFamilies + ghc-options: -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -threaded -rtsopts "-with-rtsopts=-N" + build-depends: + HDBC + , HDBC-postgresql + , base <5 + , dbmigrations + , hspec + default-language: GHC2021 + if impl(ghc >= 9.2) + ghc-options: -Wno-missing-kind-signatures + if impl(ghc >= 8.10) + ghc-options: -Wno-missing-safe-haskell-mode + if !(flag(postgresql)) + buildable: False + test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs diff --git a/package.yaml b/package.yaml index 2d455e9..b2a36b8 100644 --- a/package.yaml +++ b/package.yaml @@ -102,6 +102,28 @@ executables: - condition: ! "!(flag(sqlite))" buildable: false + # dbm-mysql: + # source-dirs: mysql/app + # ghc-options: -threaded -rtsopts "-with-rtsopts=-N" + # main: Main.hs + # dependencies: + # - HDBC-mysql + # - dbmigrations + # when: + # - condition: ! "!(flag(mysql))" + # buildable: false + + dbm-postgresql: + source-dirs: postgresql/app + ghc-options: -threaded -rtsopts "-with-rtsopts=-N" + main: Main.hs + dependencies: + - HDBC-postgresql + - dbmigrations + when: + - condition: ! "!(flag(postgresql))" + buildable: false + tests: spec: source-dirs: tests @@ -133,16 +155,42 @@ tests: - condition: ! "!(flag(sqlite))" buildable: false + # mysql-spec: + # source-dirs: mysql/tests + # ghc-options: -threaded -rtsopts "-with-rtsopts=-N" + # main: Main.hs + # dependencies: + # - HDBC + # - HDBC-mysql + # - dbmigrations + # - hspec + # when: + # - condition: ! "!(flag(mysql))" + # buildable: false + + postgresql-spec: + source-dirs: postgresql/tests + ghc-options: -threaded -rtsopts "-with-rtsopts=-N" + main: Main.hs + dependencies: + - HDBC + - HDBC-postgresql + - dbmigrations + - hspec + when: + - condition: ! "!(flag(postgresql))" + buildable: false + flags: sqlite: description: Build the sqlite executable (and tests) manual: false default: false - mysql: - description: Build the mysql executable (and tests) application - manual: false - default: false + # mysql: + # description: Build the mysql executable (and tests) application + # manual: false + # default: false postgresql: description: Build the postgresql executable (and tests) application diff --git a/postgresql/app/Main.hs b/postgresql/app/Main.hs new file mode 100644 index 0000000..f1f47f5 --- /dev/null +++ b/postgresql/app/Main.hs @@ -0,0 +1,9 @@ +module Main (main) where + +import Prelude + +import Database.HDBC.PostgreSQL (connectPostgreSQL) +import Moo.Main + +main :: IO () +main = hdbcMain connectPostgreSQL diff --git a/postgresql/tests/Main.hs b/postgresql/tests/Main.hs new file mode 100644 index 0000000..1e662f2 --- /dev/null +++ b/postgresql/tests/Main.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Main (main) where + +import Prelude + +import Data.Maybe (fromMaybe) +import Database.HDBC (IConnection (disconnect)) +import Database.HDBC.PostgreSQL (Connection, connectPostgreSQL) +import Database.Schema.Migrations.Backend.HDBC +import Database.Schema.Migrations.Test.BackendTest hiding (spec) +import Database.Schema.Migrations.Test.BackendTest qualified as BackendTest +import System.Environment (lookupEnv) +import Test.Hspec + +deriving via (HDBCConnection Connection) instance BackendConnection Connection + +main :: IO () +main = hspec $ before setupPostgreSQL $ after disconnect BackendTest.spec + +setupPostgreSQL :: IO Connection +setupPostgreSQL = do + url <- fromMaybe defaultDatabaseURL <$> lookupEnv "DATABASE_URL" + conn <- connectPostgreSQL url + conn <$ dropTables conn + +defaultDatabaseURL :: String +defaultDatabaseURL = "postgres://postgres:password@localhost:5432" diff --git a/sqlite/app/Main.hs b/sqlite/app/Main.hs index 825786d..e8501dd 100644 --- a/sqlite/app/Main.hs +++ b/sqlite/app/Main.hs @@ -1,25 +1,9 @@ module Main (main) where -import Prelude hiding (lookup) +import Prelude import Database.HDBC.Sqlite3 (connectSqlite3) -import Database.Schema.Migrations.Backend.HDBC (hdbcBackend) -import Moo.Core import Moo.Main -import System.Environment (getArgs) -import System.Exit main :: IO () -main = do - args <- getArgs - (_, opts, _) <- procArgs args - loadedConf <- loadConfiguration $ _configFilePath opts - case loadedConf of - Left e -> putStrLn e >> exitFailure - Right conf -> do - let connectionString = _connectionString conf - connection <- connectSqlite3 connectionString - let - backend = hdbcBackend connection - parameters = makeParameters conf backend - mainWithParameters args parameters +main = hdbcMain connectSqlite3 diff --git a/sqlite/tests/Main.hs b/sqlite/tests/Main.hs index 66feb59..4547c29 100644 --- a/sqlite/tests/Main.hs +++ b/sqlite/tests/Main.hs @@ -15,7 +15,7 @@ import Test.Hspec deriving via (HDBCConnection Connection) instance BackendConnection Connection main :: IO () -main = - hspec - . before (connectSqlite3 ":memory:") - $ after disconnect BackendTest.spec +main = hspec $ before setupSQLite3 $ after disconnect BackendTest.spec + +setupSQLite3 :: IO Connection +setupSQLite3 = connectSqlite3 ":memory:" diff --git a/src/Database/Schema/Migrations/Backend.hs b/src/Database/Schema/Migrations/Backend.hs index c39ddfb..0e08ba2 100644 --- a/src/Database/Schema/Migrations/Backend.hs +++ b/src/Database/Schema/Migrations/Backend.hs @@ -1,11 +1,13 @@ module Database.Schema.Migrations.Backend ( Backend (..) , rootMigrationName + , bootstrapIfNecessary ) where import Prelude +import Control.Monad (unless) import Data.Text (Text) import Database.Schema.Migrations.Migration (Migration (..)) @@ -16,9 +18,9 @@ rootMigrationName :: Text rootMigrationName = "root" -- | A Backend represents a database engine backend such as MySQL or --- SQLite. A Backend supplies relatively low-level functions for +-- SQLite. A Backend supplies relatively low-level functions for -- inspecting the backend's state, applying migrations, and reverting --- migrations. A Backend also supplies the migration necessary to +-- migrations. A Backend also supplies the migration necessary to -- "bootstrap" a backend so that it can track which migrations are -- installed. data Backend = Backend @@ -67,3 +69,11 @@ data Backend = Backend instance Show Backend where show _ = "dbmigrations backend" + +bootstrapIfNecessary :: Backend -> IO () +bootstrapIfNecessary backend = do + x <- isBootstrapped backend + + unless x $ do + bs <- getBootstrapMigration backend + applyMigration backend bs diff --git a/src/Database/Schema/Migrations/Backend/HDBC.hs b/src/Database/Schema/Migrations/Backend/HDBC.hs index adfe4b8..948b036 100644 --- a/src/Database/Schema/Migrations/Backend/HDBC.hs +++ b/src/Database/Schema/Migrations/Backend/HDBC.hs @@ -6,14 +6,13 @@ where import Prelude -import Control.Exception (catch) import Control.Monad (void) +import Data.Foldable (traverse_) import Data.String.Conversions (cs) import Data.Text (Text) import Data.Time.Clock (getCurrentTime) import Database.HDBC ( IConnection (getTables, run, runRaw) - , SqlError , commit , disconnect , fromSql @@ -83,9 +82,10 @@ newtype HDBCConnection a = HDBCConnection a instance IConnection a => BackendTest.BackendConnection (HDBCConnection a) where supportsTransactionalDDL = const True - makeBackend (HDBCConnection c) = hdbcBackend c - commit (HDBCConnection c) = commit c withTransaction (HDBCConnection c) transaction = withTransaction c (transaction . HDBCConnection) getTables (HDBCConnection c) = map cs <$> getTables c - catchAll (HDBCConnection _) act handler = act `catch` \(_ :: SqlError) -> handler + dropTables (HDBCConnection c) = do + ts <- getTables c + traverse_ (\t -> runRaw c (cs $ "DROP TABLE " <> t)) ts + makeBackend (HDBCConnection c) = hdbcBackend c diff --git a/src/Database/Schema/Migrations/Test/BackendTest.hs b/src/Database/Schema/Migrations/Test/BackendTest.hs index fd2d440..d7e56da 100644 --- a/src/Database/Schema/Migrations/Test/BackendTest.hs +++ b/src/Database/Schema/Migrations/Test/BackendTest.hs @@ -32,31 +32,18 @@ module Database.Schema.Migrations.Test.BackendTest import Prelude +import Control.Exception (SomeException, catch) import Control.Monad (void) import Data.ByteString (ByteString) -import Database.Schema.Migrations.Backend (Backend (..)) +import Database.Schema.Migrations.Backend (Backend (..), bootstrapIfNecessary) import Database.Schema.Migrations.Migration (Migration (..), newMigration) import Test.Hspec --- | A typeclass for database connections that needs to implemented for each --- specific database type to use this test. class BackendConnection c where - -- | Whether this backend supports transactional DDL; if it doesn't, - -- we'll skip any tests that rely on that behavior. supportsTransactionalDDL :: c -> Bool - - -- | Commits the current transaction. - commit :: c -> IO () - - -- | Executes an IO action inside a transaction. withTransaction :: c -> (c -> IO a) -> IO a - - -- | Retrieves a list of all tables in the current database/scheme. getTables :: c -> IO [ByteString] - - catchAll :: c -> (IO a -> IO a -> IO a) - - -- | Returns a backend instance. + dropTables :: c -> IO () makeBackend :: c -> Backend spec :: BackendConnection bc => SpecWith bc @@ -88,7 +75,7 @@ spec = do { mApply = "INVALID SQL" } - ignoreSqlExceptions_ conn $ withTransaction conn $ \conn' -> do + ignoreAny $ withTransaction conn $ \conn' -> do let backend' = makeBackend conn' applyMigration backend' m1 applyMigration backend' m2 @@ -136,7 +123,7 @@ spec = do -- Revert the migrations, ignore exceptions; the revert will fail, but -- withTransaction will roll back. - ignoreSqlExceptions_ conn $ withTransaction conn $ \conn' -> do + ignoreAny $ withTransaction conn $ \conn' -> do let backend' = makeBackend conn' revertMigration backend' m2 revertMigration backend' m1 @@ -192,8 +179,7 @@ spec = do makeBootstrappedBackend :: BackendConnection bc => bc -> IO Backend makeBootstrappedBackend conn = do let backend = makeBackend conn - bs <- getBootstrapMigration backend - backend <$ applyMigration backend bs + backend <$ bootstrapIfNecessary backend -- | Wrap a spec that requires transactional DDL and mark it pending if the -- backend does not support that. @@ -202,7 +188,5 @@ needDDL f conn | supportsTransactionalDDL conn = f conn | otherwise = pendingWith "Skipping due to lack of Transactional DDL" -ignoreSqlExceptions_ :: BackendConnection bc => bc -> IO a -> IO () -ignoreSqlExceptions_ conn act = void act `catch` pure () - where - catch = catchAll conn +ignoreAny :: IO a -> IO () +ignoreAny act = void act `catch` \(_ :: SomeException) -> pure () diff --git a/src/Moo/Main.hs b/src/Moo/Main.hs index a16d748..e33de02 100644 --- a/src/Moo/Main.hs +++ b/src/Moo/Main.hs @@ -1,5 +1,6 @@ module Moo.Main - ( mainWithParameters + ( hdbcMain + , mainWithParameters , ExecutableParameters (..) , Configuration (..) , Args @@ -15,7 +16,8 @@ import Control.Monad (forM_, when) import Control.Monad.Reader (runReaderT) import Data.String.Conversions (cs) import Data.Text (Text) -import Database.HDBC (SqlError, catchSql, seErrorMsg) +import Database.HDBC (IConnection, SqlError, catchSql, seErrorMsg) +import Database.Schema.Migrations.Backend.HDBC import Database.Schema.Migrations.Filesystem ( FilesystemStoreSettings (..) , filesystemStore @@ -23,8 +25,8 @@ import Database.Schema.Migrations.Filesystem import Database.Schema.Migrations.Store import Moo.CommandInterface import Moo.Core -import System.Environment (getProgName) -import System.Exit (ExitCode (ExitFailure), exitWith) +import System.Environment (getArgs, getProgName) +import System.Exit type Args = [String] @@ -102,3 +104,18 @@ reportSqlError :: SqlError -> IO a reportSqlError e = do putStrLn $ "\nA database error occurred: " <> seErrorMsg e exitWith (ExitFailure 1) + +hdbcMain :: IConnection conn => (String -> IO conn) -> IO () +hdbcMain connect = do + args <- getArgs + (_, opts, _) <- procArgs args + loadedConf <- loadConfiguration $ _configFilePath opts + case loadedConf of + Left e -> putStrLn e >> exitFailure + Right conf -> do + let connectionString = _connectionString conf + connection <- connect connectionString + let + backend = hdbcBackend connection + parameters = makeParameters conf backend + mainWithParameters args parameters diff --git a/stack.yaml b/stack.yaml index b20cbcd..04ef95b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,5 @@ resolver: lts-22.14 extra-deps: - HDBC-sqlite3-2.3.3.1 + - HDBC-mysql-0.7.1.0 + - HDBC-postgresql-2.5.0.1 diff --git a/stack.yaml.lock b/stack.yaml.lock index 80a0540..b7496c0 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -11,6 +11,20 @@ packages: size: 1427 original: hackage: HDBC-sqlite3-2.3.3.1 +- completed: + hackage: HDBC-mysql-0.7.1.0@sha256:0a10703f7fd1bd19c8061ebd6dd318acbc107d55502936ba21c1ca705ca1d790,1454 + pantry-tree: + sha256: 88c0deba27d970b269b603c24edb10c53966683ff914cce39d30bc77c09cc8c1 + size: 463 + original: + hackage: HDBC-mysql-0.7.1.0 +- completed: + hackage: HDBC-postgresql-2.5.0.1@sha256:37bb911cd996d12c91fa711002877f32f91bcc488de76d85a05865c3af9dc580,3032 + pantry-tree: + sha256: bb1e349a28844e59ed36e1a3963cd6946e57f5e39244a6d36397d6291d68a138 + size: 1611 + original: + hackage: HDBC-postgresql-2.5.0.1 snapshots: - completed: sha256: 48ac4445a1906866c846cd2a3a9c28fcdf3b2066237e49405dbe56ce1974a043 From 93500ca3ed438dd815bdcc7cf5718831d2eb3817 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Tue, 2 Apr 2024 09:58:34 -0400 Subject: [PATCH 07/10] Rename Moo to DBM --- CHANGELOG.md | 82 ++--------------- README.md | 105 ++++++++++++---------- dbmigrations.cabal | 12 +-- package.yaml | 1 + postgresql/app/Main.hs | 2 +- sqlite/app/Main.hs | 2 +- src/{Moo => DBM}/CommandHandlers.hs | 6 +- src/{Moo => DBM}/CommandInterface.hs | 8 +- src/{Moo => DBM}/CommandUtils.hs | 4 +- src/{Moo => DBM}/Core.hs | 10 +-- src/{Moo => DBM}/Main.hs | 6 +- tests/ConfigurationSpec.hs | 2 +- tests/LinearMigrationsSpec.hs | 4 +- tests/config_loading/{moo.cfg => dbm.cfg} | 0 weeder.toml | 4 +- 15 files changed, 94 insertions(+), 154 deletions(-) rename src/{Moo => DBM}/CommandHandlers.hs (99%) rename src/{Moo => DBM}/CommandInterface.hs (96%) rename src/{Moo => DBM}/CommandUtils.hs (99%) rename src/{Moo => DBM}/Core.hs (96%) rename src/{Moo => DBM}/Main.hs (98%) rename tests/config_loading/{moo.cfg => dbm.cfg} (100%) diff --git a/CHANGELOG.md b/CHANGELOG.md index ca09f5e..fd0a195 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,81 +1,9 @@ +## [_Unreleased_](https://github.com/pbrisbin/dbmigrations/compare/v3.0.0.0...main) -2.1.0 ------ +## [v3.0.0.0](https://github.com/pbrisbin/dbmigrations/tree/v3.0.0.0) -Package changes: -- Migrated from `yaml-light` to `yaml` package for YAML parsing (thanks - Hank Levsen ) +First release after change of maintainer. -Other changes: -- `Text` is now used instead of `String` in most parts of the codebase - (thanks Vitalii Guzeev ) -- New migrations now get the `.yml` file extension, but old migration - `txt` files are also supported. +## v2 -2.0.0 ------ - -This release contains breaking changes! - -- Factored out all database-specific functionality into separate -packages (thanks Bastian Krol) -- Replaced "moo" program with one that emits an error instructing users -to use backend-specific dbmigrations packages -- Added missing test data files to package -- Removed `DBM_DATABASE_TYPE` environment variable in favor of backend -selection by use of backend-specific packages -- Allow `DBM_TIMESTAMP_FILENAMES` to be set via environment variable -(thanks Alexander Lippling) - -1.1.1 ------ - -- Improve configuration validation error messages and clean up -validation routine -- Reinstate support for GHC 7.8 - -1.1 ---- - -- Add support for MySQL databases (thanks Ollie Charles -). Please see MOO.TXT for a disclaimer about this -feature! - -1.0 ---- - -- Added support for (optionally) adding timestamps to generated -migration filenames (thanks Matt Parsons ) - * Adds flag for time stamp on file names - * Adds configuration for timestamping filenames -- Added new "linear migrations" feature (thanks Jakub Fijałkowski -, Andrew Martin ). This -feature is an optional alternative to the default behavior: rather than -prompting the user for dependencies of new migrations (the default -behavior), linear mode automatically selects dependencies for new -migrations such that they depend on the smallest subset of migrations -necessary to (effectively) depend on all existing migrations, thus -"linearizing" the migration sequence. See MOO.TXT for details. -- Configuration file loading now defaults to "moo.cfg" in the CWD if ---config-file is not specified, and environment variables override -settings in the config file - -0.9.1 ------ - -- Restored default timestamp and description values in migrations -created by new migration command - -0.9 ---- - -- Fix 'moo' usage output to use correct program name -- Replaced Backend type class in favor of concrete Backend record type -- Added hdbcBackend constructor -- Backends now always run in IO rather than some MonadIO -- Removed monad parameter from MigrationStore (always use IO) -- Replaced MigrationStore type class with concrete MigrationStore type -- Added filesystem migration store constructor -- Improve configuration type so that it has been implicitly validated -- Made newMigration pure, made migration timestamps optional -- createNewMigration now takes a Migration for greater caller control +See https://github.com/jtdaugherty/dbmigrations. diff --git a/README.md b/README.md index 93ed36f..d95079e 100644 --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ This package contains a library for the creation, management, and installation of schema updates (called "migrations") for a relational database. In particular, this package lets the migration author express explicit dependencies between migrations. This library is accompanied by a number database-specific -packages that contain the management tools to automatically install or revert +executables that contain the management tools to automatically install or revert migrations accordingly. This package operates on two logical entities: @@ -18,35 +18,48 @@ This package operates on two logical entities: ## Getting started -To get started, install the right database-specific dbmigrations package for -your database. Current options are: +To get started, install with the right database-specific flag for your database. -- `dbmigrations-postgresql` -- `dbmigrations-mysql` -- `dbmigrations-sqlite` +```console +stack install dbmigrations --flag dbmigrations: +``` -Each package provides a CLI suitable for the given backend. +Then run the database-specific executable that was installed. -The database type-specific packages that work as a companion to this library -contain tools called `moo-postgresql`, `moo-mysql`, `moo-sqlite`, etc. They are -responsible for creating, installing, and reverting migrations in your database -backend. Since all of these command line tools offer the exact same interface, -they are described here in a single document. The executables mentioned above -are simply called `moo` for the rest of this document. That is, given an example -that reads as `moo command` you actually have to execute `moo-postgresql -command` or `moo-mysql command` and so on. +```console +dbm- help +``` + +For example, + +```console +stack install dbmigrations --flag dbmigrations:postgresql +``` -At present, MySQL, PostgreSQL and Sqlite3 are the only supported database -backends. +```console +dbm-postgresql help +``` + +Available backends are: + +- `sqlite` +- ~~`mysql`~~ _temporarily disabled due to upstream issue_ +- `postgresql` -The moo tools work by creating migration files in a specific location, called a +Since all of `dbm-` command line tools offer the exact same interface, +they are described here in a single document. The executables mentioned above +are simply called `dbm` for the rest of this document. That is, given an example +that reads as `dbm command` you actually have to execute `dbm-postgresql +command` or `dbm-mysql command` and so on. + +The DBM tools work by creating migration files in a specific location, called a migration store, on your filesystem. This directory is where all possible -migrations for your project will be kept. Moo allows you to create migrations -that depend on each other. When you use moo to upgrade your database schema, it +migrations for your project will be kept. DBM allows you to create migrations +that depend on each other. When you use DBM to upgrade your database schema, it determines which migrations are missing, what their dependencies are, and installs the required migrations in the correct order (based on dependencies). -Moo works by prompting you for new migration information. It then creates a +DBM works by prompting you for new migration information. It then creates a migration YAML file (whose format is described below), which you then edit by hand. @@ -56,8 +69,6 @@ database. ## Example -_In the examples below, replace any `moo` command shown with `moo-`._ - 1. Create a directory in which to store migration files. 2. Set an environment variable `DBM_MIGRATION_STORE` to the path to the @@ -68,7 +79,7 @@ _In the examples below, replace any `moo` command shown with `moo-`._ depend on the database type, see the "Environment" documentation section for more information. -4. Run `moo upgrade`. This command will not actually install any migrations, +4. Run `dbm upgrade`. This command will not actually install any migrations, since you have not created any, but it will attempt to connect to your database and install a migration-tracking table. @@ -78,10 +89,10 @@ _In the examples below, replace any `moo` command shown with `moo-`._ Database is up to date. ``` -5. Create a migration with `moo new`. Here is an example output: +5. Create a migration with `dbm new`. Here is an example output: ```console - % moo new hello-world + % dbm new hello-world Selecting dependencies for new migration: hello-world Confirm: create migration 'hello-world' @@ -90,7 +101,7 @@ _In the examples below, replace any `moo` command shown with `moo-`._ Migration created successfully: ".../hello-world.yml" ``` -6. Edit the migration you created. In this case, moo created a file +6. Edit the migration you created. In this case, DBM created a file `$DBM_MIGRATION_STORE/hello_world.yml` that looks like this: ```yaml @@ -115,46 +126,46 @@ _In the examples below, replace any `moo` command shown with `moo-`._ DROP TABLE foo; ``` -7. Test the new migration with `moo test`. This will install the migration in a +7. Test the new migration with `dbm test`. This will install the migration in a transaction and roll it back. Here is example output: ```console - % moo test hello-world + % dbm test hello-world Applying: hello-world... done. Reverting: hello-world... done. Successfully tested migrations. ``` - + -8. Install the migration. This can be done in one of two ways: with `moo - upgrade` or with `moo apply`. Here are examples: +8. Install the migration. This can be done in one of two ways: with `dbm + upgrade` or with `dbm apply`. Here are examples: ```console - % moo apply hello-world + % dbm apply hello-world Applying: hello-world... done. Successfully applied migrations. - % moo upgrade + % dbm upgrade Applying: hello-world... done. Database successfully upgraded. ``` -9. List installed migrations with `moo list`. +9. List installed migrations with `dbm list`. ```console - % moo list + % dbm list hello-world ``` 10. Revert the migration. ```console - % moo revert hello-world + % dbm revert hello-world Reverting: hello-world... done. Successfully reverted migrations. ``` @@ -162,14 +173,14 @@ _In the examples below, replace any `moo` command shown with `moo-`._ 11. List migrations that have not been installed. ```console - % moo upgrade-list + % dbm upgrade-list Migrations to install: hello-world ``` ## Configuration File Format -All moo commands accept a `--config-file` option which you can use to specify +All DBM commands accept a `--config-file` option which you can use to specify the path to a configuration file containing your settings. This approach is an alternative to setting environment variables. The configuration file format uses the same environment variable names for its fields. An example configuration is @@ -182,8 +193,8 @@ DBM_LINEAR_MIGRATIONS = on/off (or true/false; defaults to off) DBM_TIMESTAMP_FILENAMES = on/off (or true/false; defaults to off) ``` -Alternatively, you may save your settings to `moo.cfg` file in the current -directory (probably a project root) and moo will load it automatically, if +Alternatively, you may save your settings to `dbm.cfg` file in the current +directory (probably a project root) and DBM will load it automatically, if present. Specifying `--config-file` disables this behavior. If you use a config file (either the default one or the one specified with @@ -250,7 +261,7 @@ treatment of this behavior, see the YAML spec. ## Environment -Moo depends on these environment variables / configuration file +DBM depends on these environment variables / configuration file settings: ``` @@ -284,10 +295,10 @@ DBM_DATABASE DBM_MIGRATION_STORE The path to the filesystem directory where your migrations will be - kept. moo will create new migrations in this directory and use + kept. DBM will create new migrations in this directory and use the migrations in this directory when updating the database schema. Initially, you'll probably set this to an extant (but - empty) directory. moo will not create it for you. + empty) directory. DBM will not create it for you. DBM_LINEAR_MIGRATIONS @@ -313,12 +324,12 @@ DBM_TIMESTAMP_FILENAMES apply : apply the specified migration (and its dependencies) to the database. This operation will be performed in a single transaction which will be rolled back if an error - occurs. moo will output updates as each migration is applied. + occurs. DBM will output updates as each migration is applied. revert : revert the specified migration (and its reverse dependencies -- the migrations which depend on it) from the database. This operation will be performed in a single - transaction which will be rolled back if an error occurs. moo + transaction which will be rolled back if an error occurs. DBM will output updates as each migration is reverted. test : once you've created a migration, you might @@ -351,7 +362,7 @@ DBM_TIMESTAMP_FILENAMES ## Linear Migrations If you know that every migration needs to depend on all previous ones, consider -enabling this feature. When enabled, `moo new` will automatically select +enabling this feature. When enabled, `dbm new` will automatically select smallest subset of existing migrations that will make the new one indirectly depend on every other already in the store. This in turn makes the store linear-ish (in terms of order of execution) and helps managing the migrations by diff --git a/dbmigrations.cabal b/dbmigrations.cabal index fc62130..434b203 100644 --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -22,9 +22,9 @@ extra-source-files: tests/example_store/update2 tests/config_loading/cfg1.cfg tests/config_loading/cfg_ts.cfg + tests/config_loading/dbm.cfg tests/config_loading/invalid.cfg tests/config_loading/missing.cfg - tests/config_loading/moo.cfg tests/migration_parsing/invalid_field_name.txt tests/migration_parsing/invalid_missing_required_fields.txt tests/migration_parsing/invalid_syntax.txt @@ -68,11 +68,11 @@ library Database.Schema.Migrations.Migration Database.Schema.Migrations.Store Database.Schema.Migrations.Test.BackendTest - Moo.CommandHandlers - Moo.CommandInterface - Moo.CommandUtils - Moo.Core - Moo.Main + DBM.CommandHandlers + DBM.CommandInterface + DBM.CommandUtils + DBM.Core + DBM.Main other-modules: Paths_dbmigrations hs-source-dirs: diff --git a/package.yaml b/package.yaml index b2a36b8..69f1b01 100644 --- a/package.yaml +++ b/package.yaml @@ -102,6 +102,7 @@ executables: - condition: ! "!(flag(sqlite))" buildable: false + # TODO: HDBC-mysql fails to compile # dbm-mysql: # source-dirs: mysql/app # ghc-options: -threaded -rtsopts "-with-rtsopts=-N" diff --git a/postgresql/app/Main.hs b/postgresql/app/Main.hs index f1f47f5..8c1be2f 100644 --- a/postgresql/app/Main.hs +++ b/postgresql/app/Main.hs @@ -2,8 +2,8 @@ module Main (main) where import Prelude +import DBM.Main import Database.HDBC.PostgreSQL (connectPostgreSQL) -import Moo.Main main :: IO () main = hdbcMain connectPostgreSQL diff --git a/sqlite/app/Main.hs b/sqlite/app/Main.hs index e8501dd..de7ac39 100644 --- a/sqlite/app/Main.hs +++ b/sqlite/app/Main.hs @@ -2,8 +2,8 @@ module Main (main) where import Prelude +import DBM.Main import Database.HDBC.Sqlite3 (connectSqlite3) -import Moo.Main main :: IO () main = hdbcMain connectSqlite3 diff --git a/src/Moo/CommandHandlers.hs b/src/DBM/CommandHandlers.hs similarity index 99% rename from src/Moo/CommandHandlers.hs rename to src/DBM/CommandHandlers.hs index 779e712..9533357 100644 --- a/src/Moo/CommandHandlers.hs +++ b/src/DBM/CommandHandlers.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module Moo.CommandHandlers +module DBM.CommandHandlers ( newCommand , upgradeCommand , upgradeListCommand @@ -17,6 +17,8 @@ import Prelude import Control.Monad (forM_, unless, when) import Control.Monad.Reader (asks) import Control.Monad.Trans (liftIO) +import DBM.CommandUtils +import DBM.Core import Data.Maybe (isJust) import Data.String.Conversions (cs) import Data.Time.Clock qualified as Clock @@ -24,8 +26,6 @@ import Database.Schema.Migrations import Database.Schema.Migrations.Backend import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Store hiding (getMigrations) -import Moo.CommandUtils -import Moo.Core import System.Exit (ExitCode (..), exitSuccess, exitWith) newCommand :: CommandHandler diff --git a/src/Moo/CommandInterface.hs b/src/DBM/CommandInterface.hs similarity index 96% rename from src/Moo/CommandInterface.hs rename to src/DBM/CommandInterface.hs index 21b98ba..333724d 100644 --- a/src/Moo/CommandInterface.hs +++ b/src/DBM/CommandInterface.hs @@ -1,6 +1,6 @@ --- | This module defines the MOO command interface, the commnad line options +-- | This module defines the DBM command interface, the commnad line options -- parser, and helpers to manipulate the Command data structure. -module Moo.CommandInterface +module DBM.CommandInterface ( commands , commandOptionUsage , findCommand @@ -10,9 +10,9 @@ module Moo.CommandInterface import Prelude +import DBM.CommandHandlers +import DBM.Core import Data.Maybe -import Moo.CommandHandlers -import Moo.Core import System.Console.GetOpt -- | The available commands; used to dispatch from the command line and diff --git a/src/Moo/CommandUtils.hs b/src/DBM/CommandUtils.hs similarity index 99% rename from src/Moo/CommandUtils.hs rename to src/DBM/CommandUtils.hs index 3a9f263..205b3b9 100644 --- a/src/Moo/CommandUtils.hs +++ b/src/DBM/CommandUtils.hs @@ -1,4 +1,4 @@ -module Moo.CommandUtils +module DBM.CommandUtils ( apply , confirmCreation , interactiveAskDeps @@ -14,6 +14,7 @@ import Control.Exception (finally) import Control.Monad (forM_, unless, when) import Control.Monad.Reader (asks) import Control.Monad.Trans (liftIO) +import DBM.Core import Data.Foldable (for_) import Data.List (intercalate, isPrefixOf, sortBy) import Data.Maybe (fromJust, isJust) @@ -29,7 +30,6 @@ import Database.Schema.Migrations.Store , storeLookup , storeMigrations ) -import Moo.Core import System.Exit (ExitCode (..), exitWith) import System.IO ( BufferMode (..) diff --git a/src/Moo/Core.hs b/src/DBM/Core.hs similarity index 96% rename from src/Moo/Core.hs rename to src/DBM/Core.hs index 7be862f..015e223 100644 --- a/src/Moo/Core.hs +++ b/src/DBM/Core.hs @@ -1,4 +1,4 @@ -module Moo.Core +module DBM.Core ( AppT , CommandHandler , CommandOptions (..) @@ -67,9 +67,9 @@ data Configuration = Configuration } deriving stock (Show) --- | A value of type ExecutableParameters is what a moo executable (moo-postgresql, --- |moo-mysql, etc.) pass to the core package when they want to execute a --- |command. +-- | A value of type ExecutableParameters is what a DBM executable +-- (dbm-postgresql, dbm-mysql, etc.) pass to the core package when they want to +-- execute a command. data ExecutableParameters = ExecutableParameters { _parametersBackend :: Backend , _parametersMigrationStorePath :: FilePath @@ -79,7 +79,7 @@ data ExecutableParameters = ExecutableParameters deriving stock (Show) defConfigFile :: String -defConfigFile = "moo.cfg" +defConfigFile = "dbm.cfg" newLoadConfig :: LoadConfig newLoadConfig = LoadConfig Nothing Nothing Nothing Nothing diff --git a/src/Moo/Main.hs b/src/DBM/Main.hs similarity index 98% rename from src/Moo/Main.hs rename to src/DBM/Main.hs index e33de02..3850d14 100644 --- a/src/Moo/Main.hs +++ b/src/DBM/Main.hs @@ -1,4 +1,4 @@ -module Moo.Main +module DBM.Main ( hdbcMain , mainWithParameters , ExecutableParameters (..) @@ -14,6 +14,8 @@ import Prelude import Control.Monad (forM_, when) import Control.Monad.Reader (runReaderT) +import DBM.CommandInterface +import DBM.Core import Data.String.Conversions (cs) import Data.Text (Text) import Database.HDBC (IConnection, SqlError, catchSql, seErrorMsg) @@ -23,8 +25,6 @@ import Database.Schema.Migrations.Filesystem , filesystemStore ) import Database.Schema.Migrations.Store -import Moo.CommandInterface -import Moo.Core import System.Environment (getArgs, getProgName) import System.Exit diff --git a/tests/ConfigurationSpec.hs b/tests/ConfigurationSpec.hs index 7f4159b..ed3e288 100644 --- a/tests/ConfigurationSpec.hs +++ b/tests/ConfigurationSpec.hs @@ -8,8 +8,8 @@ where import Prelude import Common +import DBM.Core import Data.Either (isLeft, isRight) -import Moo.Core import System.Directory import System.Environment (setEnv, unsetEnv) import Test.Hspec diff --git a/tests/LinearMigrationsSpec.hs b/tests/LinearMigrationsSpec.hs index 01415c7..5d019a9 100644 --- a/tests/LinearMigrationsSpec.hs +++ b/tests/LinearMigrationsSpec.hs @@ -8,13 +8,13 @@ where import Prelude import Control.Monad.Reader (runReaderT) +import DBM.CommandHandlers +import DBM.Core import Data.Either (isRight) import Data.Text (Text) import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Store import InMemoryStore -import Moo.CommandHandlers -import Moo.Core import Test.Hspec spec :: Spec diff --git a/tests/config_loading/moo.cfg b/tests/config_loading/dbm.cfg similarity index 100% rename from tests/config_loading/moo.cfg rename to tests/config_loading/dbm.cfg diff --git a/weeder.toml b/weeder.toml index b6ac9c0..ffeb28f 100644 --- a/weeder.toml +++ b/weeder.toml @@ -2,8 +2,8 @@ roots = [ "^Database\\.Schema\\.Migrations\\.Backend\\.HDBC\\.hdbcBackend$", "^Database\\.Schema\\.Migrations\\.Test\\.BackendTest\\..*$", "^Main\\.main$", - "^Moo\\.Core\\.makeParameters$", - "^Moo\\.Main\\..*$", + "^DBM\\.Core\\.makeParameters$", + "^DBM\\.Main\\..*$", "^Paths_dbmigrations\\..*$", "^Spec\\.main$" ] From 4aec8122b8da5476ea0cc6417c90b5581394acc4 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Tue, 2 Apr 2024 11:09:32 -0400 Subject: [PATCH 08/10] Bump resolver --- stack.yaml | 2 +- stack.yaml.lock | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/stack.yaml b/stack.yaml index 04ef95b..f5cbed4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-22.14 +resolver: lts-22.15 extra-deps: - HDBC-sqlite3-2.3.3.1 - HDBC-mysql-0.7.1.0 diff --git a/stack.yaml.lock b/stack.yaml.lock index b7496c0..d71e6bb 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -27,7 +27,7 @@ packages: hackage: HDBC-postgresql-2.5.0.1 snapshots: - completed: - sha256: 48ac4445a1906866c846cd2a3a9c28fcdf3b2066237e49405dbe56ce1974a043 + sha256: 5b002d57c51092aa58a8696ccf0993e74fa6ed2efd48e2bbca349e9c2f67c5ef size: 713334 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/14.yaml - original: lts-22.14 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/15.yaml + original: lts-22.15 From 9155d1b791f301fbf7809696adc0922a20dfde47 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Sat, 6 Apr 2024 14:51:22 -0400 Subject: [PATCH 09/10] Set version to 3.0.0 --- dbmigrations.cabal | 2 +- package.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/dbmigrations.cabal b/dbmigrations.cabal index 434b203..c68a0c9 100644 --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -5,7 +5,7 @@ cabal-version: 1.18 -- see: https://github.com/sol/hpack name: dbmigrations -version: 2.1.0 +version: 3.0.0 synopsis: An implementation of relational database "migrations" description: Please see category: Database diff --git a/package.yaml b/package.yaml index 69f1b01..1f5aa58 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: dbmigrations -version: 2.1.0 +version: 3.0.0 synopsis: An implementation of relational database "migrations" description: Please see author: "Jonathan Daugherty " From 2be737ca9d18db8011d0185339c21335ecdcb5e6 Mon Sep 17 00:00:00 2001 From: Kris Nuttycombe Date: Sat, 14 Feb 2026 16:27:29 -0700 Subject: [PATCH 10/10] Add Kris Nuttycombe as a maintainer. --- dbmigrations.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dbmigrations.cabal b/dbmigrations.cabal index c68a0c9..6e5e96b 100644 --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -12,7 +12,7 @@ category: Database homepage: https://github.com/haskell-github-trust/dbmigrations#readme bug-reports: https://github.com/haskell-github-trust/dbmigrations/issues author: Jonathan Daugherty -maintainer: Pat Brisbin +maintainer: Pat Brisbin , Kris Nuttycombe license: BSD3 license-file: LICENSE build-type: Simple