diff --git a/dbmigrations.cabal b/dbmigrations.cabal index 4d961ce..4e75782 100644 --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -77,7 +77,7 @@ Library mtl >= 2.1, filepath >= 1.1, directory >= 1.0, - fgl >= 5.4, + algebraic-graphs >= 0.7, template-haskell, yaml, bytestring >= 0.9, @@ -94,7 +94,6 @@ Library 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 @@ -118,7 +117,7 @@ test-suite dbmigrations-tests mtl >= 2.1, filepath >= 1.1, directory >= 1.0, - fgl >= 5.4, + algebraic-graphs >= 0.7, template-haskell, yaml, bytestring >= 0.9, @@ -134,12 +133,12 @@ test-suite dbmigrations-tests other-modules: Common CommonTH - CycleDetectionTest DependencyTest FilesystemParseTest FilesystemSerializeTest FilesystemTest MigrationsTest + NonLinearStressTest StoreTest InMemoryStore LinearMigrationsTest diff --git a/src/Database/Schema/Migrations.hs b/src/Database/Schema/Migrations.hs index 252a2c6..76a0821 100644 --- a/src/Database/Schema/Migrations.hs +++ b/src/Database/Schema/Migrations.hs @@ -71,7 +71,8 @@ migrationsToApply storeData backend migration = do allMissing <- missingMigrations backend storeData let deps = (dependencies graph $ mId migration) ++ [mId migration] - namesToInstall = [ e | e <- deps, e `elem` allMissing ] + missing = Set.fromList allMissing + namesToInstall = [ e | e <- deps, e `Set.member` missing ] loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToInstall return loadedMigrations @@ -87,7 +88,8 @@ migrationsToRevert storeData backend migration = do allInstalled <- B.getMigrations backend let rDeps = (reverseDependencies graph $ mId migration) ++ [mId migration] - namesToRevert = [ e | e <- rDeps, e `elem` allInstalled ] + installed = Set.fromList allInstalled + namesToRevert = [ e | e <- rDeps, e `Set.member` installed ] loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToRevert return loadedMigrations diff --git a/src/Database/Schema/Migrations/CycleDetection.hs b/src/Database/Schema/Migrations/CycleDetection.hs deleted file mode 100644 index 7dcb073..0000000 --- a/src/Database/Schema/Migrations/CycleDetection.hs +++ /dev/null @@ -1,64 +0,0 @@ -module Database.Schema.Migrations.CycleDetection - ( hasCycle - ) -where - -import Data.Graph.Inductive.Graph - ( Graph(..) - , Node - , nodes - , edges - ) - -import Control.Monad.State ( State, evalState, gets, get, put ) -import Control.Monad ( forM ) - -import Data.Maybe ( fromJust ) -import Data.List ( findIndex ) - -data Mark = White | Gray | Black -type CycleDetectionState = [(Node, Mark)] - --- Cycle detection algorithm taken from http://www.cs.berkeley.edu/~kamil/teaching/sp03/041403.pdf -hasCycle :: Graph g => g a b -> Bool -hasCycle g = evalState (hasCycle' g) [(n, White) | n <- nodes g] - -getMark :: Int -> State CycleDetectionState Mark -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) - -setMark :: Int -> Mark -> State CycleDetectionState () -setMark n mark = do - st <- get - let index = fromJust $ findIndex (\(n', _) -> n' == n) st - put $ replace st index (n, mark) - -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 - 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 - case or result of - True -> return True - False -> do - setMark n Black - return False diff --git a/src/Database/Schema/Migrations/Dependencies.hs b/src/Database/Schema/Migrations/Dependencies.hs index d596d58..a2ba394 100644 --- a/src/Database/Schema/Migrations/Dependencies.hs +++ b/src/Database/Schema/Migrations/Dependencies.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} -- |This module types and functions for representing a dependency -- graph of arbitrary objects and functions for querying such graphs -- to get dependency and reverse dependency information. @@ -11,13 +11,14 @@ module Database.Schema.Migrations.Dependencies ) where +import Data.List.NonEmpty ( toList ) 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 qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T -import Database.Schema.Migrations.CycleDetection ( hasCycle ) +import Algebra.Graph.AdjacencyMap ( AdjacencyMap, induce, stars, transpose ) +import Algebra.Graph.AdjacencyMap.Algorithm ( reachable, topSort ) -- |'Dependable' objects supply a representation of their identifiers, -- and a list of other objects upon which they depend. @@ -30,74 +31,64 @@ class (Eq a, Ord a) => Dependable a where -- |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. +data DependencyGraph a = DG { depGraphObjects :: [a] + -- ^ The objects the graph was built from. + , depGraph :: AdjacencyMap Text + -- ^ A directed graph of the objects' + -- dependency relationships, with an edge + -- from each object's identifier to the + -- identifier of each of its dependencies. } instance (Eq a) => Eq (DependencyGraph a) where - g1 == g2 = ((nodes $ depGraph g1) == (nodes $ depGraph g2) && - (edges $ depGraph g1) == (edges $ depGraph g2)) + g1 == g2 = depGraph g1 == depGraph g2 instance (Show a) => Show (DependencyGraph a) where - show g = "(" ++ (show $ nodes $ depGraph g) ++ ", " ++ (show $ edges $ depGraph g) ++ ")" + show = show . depGraph --- 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). +-- constructed (e.g., if the graph contains a cycle or the object +-- identifiers are not unique). 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 - } +mkDepGraph objects + | not (null duplicates) = + Left $ "Invalid dependency graph; duplicate object identifiers: " + <> T.unpack (T.intercalate ", " duplicates) + | otherwise = + case topSort theGraph of + Left cyc -> Left $ "Invalid dependency graph; cycle detected: " + <> T.unpack (T.intercalate " -> " (toList cyc)) + Right _ -> Right DG { depGraphObjects = objects + , 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 [] = [] -cleanLDups [e] = [e] -cleanLDups (e:es) = if e `elem` es then (cleanLDups es) else (e:cleanLDups es) + theGraph = stars [ (depId o, depsOf o) | o <- objects ] + duplicates = Map.keys $ Map.filter (> 1) $ + Map.fromListWith (+) [ (depId o, 1 :: Int) | o <- objects ] -- |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 +dependencies g = closureOf (depGraph g) -- |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 +reverseDependencies g = closureOf (transpose $ depGraph g) -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) +-- The transitive closure of a name: topologically sort the subgraph +-- reachable from it (obtaining the lexicographically smallest such +-- ordering, so the result is deterministic) and reverse the result so +-- that the deepest dependencies come first. The name itself is the +-- unique source of the subgraph and is excluded from the result. +closureOf :: AdjacencyMap Text -> Text -> [Text] +closureOf g name = + case topSort (induce (`Set.member` reach) g) of + Right order -> reverse $ filter (/= name) order + Left cyc -> error $ "BUG: dependency graph contains a cycle: " + <> T.unpack (T.intercalate " -> " (toList cyc)) + where + reach = Set.fromList $ reachable g name diff --git a/src/Database/Schema/Migrations/Store.hs b/src/Database/Schema/Migrations/Store.hs index e60247f..f1821f2 100644 --- a/src/Database/Schema/Migrations/Store.hs +++ b/src/Database/Schema/Migrations/Store.hs @@ -28,7 +28,8 @@ import Data.Maybe ( isJust ) import Control.Monad ( mzero ) import Control.Applicative ( (<$>) ) import qualified Data.Map as Map -import Data.Graph.Inductive.Graph ( labNodes, indeg ) +import qualified Data.Set as Set +import Algebra.Graph.AdjacencyMap ( adjacencyMap, vertexList ) import Database.Schema.Migrations.Migration ( Migration(..) @@ -155,5 +156,6 @@ depGraphFromMapping mapping = mkDepGraph $ Map.elems mapping -- |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] +leafMigrations s = [l | l <- vertexList g, l `Set.notMember` dependedOn] where g = depGraph $ storeDataGraph s + dependedOn = Set.unions $ Map.elems $ adjacencyMap g diff --git a/test/CycleDetectionTest.hs b/test/CycleDetectionTest.hs deleted file mode 100644 index dfdd3e5..0000000 --- a/test/CycleDetectionTest.hs +++ /dev/null @@ -1,69 +0,0 @@ -module CycleDetectionTest - ( tests - ) -where - -import Test.HUnit -import Data.Graph.Inductive.PatriciaTree ( Gr ) -import Data.Graph.Inductive.Graph ( mkGraph ) - -import Database.Schema.Migrations.CycleDetection - -tests :: [Test] -tests = mkCycleTests - -noCycles :: Gr String String -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")] - -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")] - -withCycleRadial :: Gr String String -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,"")] - --- 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,"")] - --- 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") - ] - -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/test/DependencyTest.hs index 7bf1495..3258d5e 100644 --- a/test/DependencyTest.hs +++ b/test/DependencyTest.hs @@ -4,30 +4,34 @@ module DependencyTest ) where +import Data.Either ( isLeft ) import Data.Text ( Text ) import Test.HUnit -import Data.Graph.Inductive.Graph ( Graph(..) ) +import qualified Algebra.Graph.AdjacencyMap as AM import Database.Schema.Migrations.Dependencies import Common tests :: [Test] -tests = depGraphTests ++ dependencyTests +tests = depGraphTests ++ cycleDetectionTests ++ dependencyTests type DepGraphTestCase = ([TestDependable], Either String (DependencyGraph TestDependable)) depGraphTestCases :: [DepGraphTestCase] depGraphTestCases = [ ( [] - , Right $ DG [] [] empty + , Right $ DG [] AM.empty ) , ( [first, second] - , Right $ DG [(first,1),(second,2)] - [("first",1),("second",2)] (mkGraph [(1, "first"), (2, "second")] - [(2, 1, "first -> second")]) + , Right $ DG [first, second] + (AM.stars [ ("first", []) + , ("second", ["first"]) + ]) ) , ( [cycleFirst, cycleSecond] - , Left "Invalid dependency graph; cycle detected") + , Left "Invalid dependency graph; cycle detected: second -> first") + , ( [first, TD "first" ["second"], second] + , Left "Invalid dependency graph; duplicate object identifiers: first") ] where first = TD "first" [] @@ -41,6 +45,37 @@ depGraphTests = map mkDepGraphTest depGraphTestCases mkDepGraphTest :: DepGraphTestCase -> Test mkDepGraphTest (input, expected) = expected ~=? mkDepGraph input +-- |Test cases for cycle detection during graph construction: the +-- input objects and whether they contain a dependency cycle. +type CycleTestCase = ([TestDependable], Bool) + +cycleTestCases :: [CycleTestCase] +cycleTestCases = [ ([], False) + , ([TD "one" ["two"], TD "two" []], False) + , ([ TD "one" ["two"], TD "two" [], TD "three" ["one"] + , TD "four" ["one"]], False) + , ([TD "one" ["one"]], True) + , ([ TD "one" ["two"], TD "two" ["three"], TD "three" ["one"] + , TD "four" ["one"]], True) + , ([ TD "one" [], TD "two" ["one", "three"] + , TD "three" ["four", "two"], TD "four" []], True) + -- These graphs would contain a loop if they were + -- undirected, but they do not contain a directed + -- cycle. + , ([ TD "one" ["two", "three"], TD "two" ["four"] + , TD "three" ["two"], TD "four" []], False) + , ([ TD "flub" ["test.db"], TD "test.db" ["test2", "test3"] + , TD "test2" ["test1"], TD "test3" ["test2"] + , TD "test1" []], False) + ] + +cycleDetectionTests :: [Test] +cycleDetectionTests = map mkCycleTest cycleTestCases + where + mkCycleTest (input, expected) = + ("cycle detection: " ++ show input) ~: + expected ~=? isLeft (mkDepGraph input) + data Direction = Forward | Reverse deriving (Show) type DependencyTestCase = ([TestDependable], Text, Direction, [Text]) @@ -58,10 +93,7 @@ dependencyTestCases = [ ([TD "first" []], "first", Forward, []) , ([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"]) + , "first", Reverse, ["third", "fourth", "second"]) , ([ TD "first" ["second"], TD "second" ["third", "fifth"], TD "third" ["fourth"] , TD "fifth" ["third"], TD "fourth" []] , "first", Forward, ["fourth", "third", "fifth", "second"]) diff --git a/test/Main.hs b/test/Main.hs index 4aeb008..ec2b943 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -9,10 +9,10 @@ import qualified MigrationsTest import qualified FilesystemSerializeTest import qualified FilesystemParseTest import qualified FilesystemTest -import qualified CycleDetectionTest import qualified StoreTest import qualified LinearMigrationsTest import qualified ConfigurationTest +import qualified NonLinearStressTest import Control.Exception ( SomeException(..) ) @@ -27,12 +27,13 @@ loadTests = do return $ "Linear migrations" ~: test linTests , do cfgTests <- ConfigurationTest.tests return $ "Configuration tests" ~: test cfgTests + , do stressTests <- NonLinearStressTest.tests + return $ "Non-linear DAG stress" ~: test stressTests ] return $ concat [ ioTests , DependencyTest.tests , FilesystemSerializeTest.tests , MigrationsTest.tests - , CycleDetectionTest.tests , StoreTest.tests ] diff --git a/test/NonLinearStressTest.hs b/test/NonLinearStressTest.hs new file mode 100644 index 0000000..b0c6471 --- /dev/null +++ b/test/NonLinearStressTest.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE OverloadedStrings #-} +-- |This test guards against exponential blowup in dependency +-- resolution when the migration graph is a non-linear DAG. It +-- simulates what the @upgrade@ command does -- for each missing +-- migration, compute 'migrationsToApply' and apply the results -- over +-- a "diamond ladder" graph: each level has two migrations and both +-- migrations of level N depend on both migrations of level N-1. Such +-- a graph has 2*depth+2 migrations but exponentially many +-- root-to-leaf paths, which historically made 'dependencies' +-- enumerate every path. +module NonLinearStressTest + ( tests + ) +where + +import Test.HUnit +import Control.Monad ( forM_ ) +import Data.IORef +import qualified Data.Map as Map +import Data.Maybe ( fromMaybe ) +import qualified Data.Text as T +import Data.Text ( Text ) +import Data.Time.Clock ( UTCTime, getCurrentTime, diffUTCTime ) +import System.Environment ( lookupEnv ) + +import Database.Schema.Migrations ( migrationsToApply, missingMigrations ) +import Database.Schema.Migrations.Backend +import Database.Schema.Migrations.Migration +import Database.Schema.Migrations.Store hiding ( getMigrations ) + +-- Depth of the ladder. 2*depth+2 migrations in total. Overridable +-- with the STRESS_DEPTH environment variable for experimentation. +defaultDepth :: Int +defaultDepth = 22 + +-- The whole simulated upgrade must finish within this many seconds. +timeLimitSeconds :: Double +timeLimitSeconds = 10 + +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 = [] + } + +levelName :: String -> Int -> Text +levelName side i = T.pack (side ++ show i) + +-- |A "diamond ladder": base <- {a1,b1} <- {a2,b2} <- ... <- top, +-- where each level depends on *both* migrations of the previous +-- level. +diamondLadder :: Int -> [Migration] +diamondLadder depth = base : concatMap level [1..depth] ++ [top] + where + base = blankMigration { mId = "base" } + top = blankMigration { mId = "top" + , mDeps = previousLevel (depth + 1) + } + level i = [ blankMigration { mId = levelName "a" i + , mDeps = previousLevel i + } + , blankMigration { mId = levelName "b" i + , mDeps = previousLevel i + } + ] + previousLevel 1 = ["base"] + previousLevel i = [levelName "a" (i - 1), levelName "b" (i - 1)] + +-- |A backend that records applied migrations in an IORef, in +-- application order. +recordingBackend :: IORef [Text] -> Backend +recordingBackend ref = + Backend { getBootstrapMigration = undefined + , isBootstrapped = return True + , applyMigration = \m -> modifyIORef' ref (mId m:) + , revertMigration = const undefined + , getMigrations = readIORef ref + , commitBackend = return () + , rollbackBackend = return () + , disconnectBackend = return () + } + +-- |Mirror of the upgrade command: for every missing migration, +-- compute the migrations to apply and apply them. Returns the +-- migration names in application order. +simulateUpgrade :: StoreData -> IO [Text] +simulateUpgrade storeData = do + ref <- newIORef [] + let backend = recordingBackend ref + migrationNames <- missingMigrations backend storeData + forM_ migrationNames $ \name -> do + let m = fromMaybe (error $ "missing migration " ++ show name) + (storeLookup storeData name) + toApply <- migrationsToApply storeData backend m + forM_ toApply (applyMigration backend) + reverse <$> readIORef ref + +tests :: IO [Test] +tests = do + depth <- maybe defaultDepth read <$> lookupEnv "STRESS_DEPTH" + + let migrations = diamondLadder depth + mapping = Map.fromList [ (mId m, m) | m <- migrations ] + graph = either error id (depGraphFromMapping mapping) + storeData = StoreData mapping graph + + start <- getCurrentTime + applied <- simulateUpgrade storeData + end <- getCurrentTime + + let elapsed = realToFrac (diffUTCTime end start) :: Double + appliedIndex = Map.fromList (zip applied [(0 :: Int)..]) + indexOf name = fromMaybe (error $ "not applied: " ++ show name) + (Map.lookup name appliedIndex) + inOrder m = all (\dep -> indexOf dep < indexOf (mId m)) (mDeps m) + + putStrLn $ "Non-linear upgrade of " ++ show (length migrations) ++ + " migrations (ladder depth " ++ show depth ++ ") took " ++ + show elapsed ++ "s" + + return [ "all migrations applied exactly once" ~: + Map.keys mapping ~=? Map.keys appliedIndex + , "applied count matches store size" ~: + length migrations ~=? length applied + , "dependencies applied before dependents" ~: + assertBool "dependency applied after dependent" + (all inOrder migrations) + , "non-linear upgrade completes in reasonable time" ~: + assertBool ("took " ++ show elapsed ++ "s, limit " ++ + show timeLimitSeconds ++ "s") + (elapsed < timeLimitSeconds) + ]