From b214a580b61be1df0143fb38f64be90d049191b8 Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Wed, 8 Jul 2026 17:03:04 +0100 Subject: [PATCH 1/2] Fix exponential dependency resolution on non-linear DAGs dependenciesWith enumerated every path from the start object (each object's direct successor names followed by the recursive expansion of each name), then deduplicated the result with the quadratic cleanLDups. The number of paths is exponential in the depth of a non-linear dependency graph, so an upgrade over a "diamond ladder" of just 46 migrations took ~55 seconds. Produce the identical ordering in linear time by scanning the virtual path enumeration from the end: walk successor names in reverse order, expand each name's subtree at most once (a repeated expansion occurs earlier in the enumeration, so it cannot contain a last occurrence), and emit each name the first time it is seen, i.e. at its last occurrence. Like the old code, the traversal is name-driven rather than node-driven, so behaviour is preserved even for graphs with duplicate object names. Also replace the assoc-list lookup in dependenciesWith and the list-membership filters in migrationsToApply/migrationsToRevert with Map/Set equivalents. Add a stress test that simulates the upgrade command over a diamond-ladder graph (two migrations per level, each depending on both migrations of the previous level). It now runs in ~3ms where it previously took ~55s. Co-Authored-By: Claude Fable 5 --- dbmigrations.cabal | 1 + src/Database/Schema/Migrations.hs | 6 +- .../Schema/Migrations/Dependencies.hs | 49 +++++-- test/Main.hs | 3 + test/NonLinearStressTest.hs | 138 ++++++++++++++++++ 5 files changed, 181 insertions(+), 16 deletions(-) create mode 100644 test/NonLinearStressTest.hs diff --git a/dbmigrations.cabal b/dbmigrations.cabal index 4d961ce..2e2451d 100644 --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -140,6 +140,7 @@ test-suite dbmigrations-tests 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/Dependencies.hs b/src/Database/Schema/Migrations/Dependencies.hs index d596d58..8bbec0c 100644 --- a/src/Database/Schema/Migrations/Dependencies.hs +++ b/src/Database/Schema/Migrations/Dependencies.hs @@ -16,6 +16,8 @@ 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 Database.Schema.Migrations.CycleDetection ( hasCycle ) @@ -76,28 +78,47 @@ mkDepGraph objects = if hasCycle theGraph 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) - -- |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 = dependenciesWith suc -- |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 = dependenciesWith pre +-- This used to enumerate every path from the start object (each +-- object's direct successor names followed by the expansion of each +-- name in turn, resolving names through the name map), keep the last +-- occurrence of each name, and reverse the result. Path enumeration +-- is exponential in the depth of a non-linear graph, so instead we +-- produce the same ordering by scanning the virtual enumeration from +-- the end: walk successor names in reverse order, expand each name's +-- subtree at most once (a repeated expansion occurs earlier in the +-- enumeration, so it cannot contain a last occurrence), and emit each +-- name the first time it is seen, i.e. at its last occurrence. 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) +dependenciesWith nextNodes (DG _ nMap theGraph) name = + let -- Like `lookup name nMap`: on duplicate names, the first + -- entry wins. + nameMap = Map.fromListWith (\_ old -> old) nMap + + succNames n = let node = fromJust $ Map.lookup n nameMap + in map (fromJust . lab theGraph) $ nextNodes theGraph node + + expand st@(expanded, emitted, acc) n + | n `Set.member` expanded = st + | otherwise = + let succs = reverse $ succNames n + expandedSt = foldl' expand (Set.insert n expanded, emitted, acc) succs + in foldl' emit expandedSt succs + + emit st@(expanded, emitted, acc) n + | n `Set.member` emitted = st + | otherwise = (expanded, Set.insert n emitted, n : acc) + + (_, _, emittedReversed) = expand (Set.empty, Set.empty, []) name + in reverse emittedReversed diff --git a/test/Main.hs b/test/Main.hs index 4aeb008..cbeea86 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -13,6 +13,7 @@ import qualified CycleDetectionTest import qualified StoreTest import qualified LinearMigrationsTest import qualified ConfigurationTest +import qualified NonLinearStressTest import Control.Exception ( SomeException(..) ) @@ -27,6 +28,8 @@ 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 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) + ] From b7556ce80342c4a7fecbe55a70ee3aadc9eedcbb Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Wed, 8 Jul 2026 18:06:21 +0100 Subject: [PATCH 2/2] Rewrite dependency resolution on algebraic-graphs Replace the fgl-based dependency graph and the hand-rolled traversal and cycle detection with algebraic-graphs, which postdates this library's original design: - The graph is now an AdjacencyMap keyed by object name, built directly with `stars`, so the node-index bookkeeping (depGraphObjectMap/depGraphNameMap) disappears. - dependencies/reverseDependencies are `reachable` + `induce` + `topSort` (reverseDependencies via `transpose`). topSort returns the lexicographically smallest topological ordering, so results are deterministic by construction rather than dependent on graph node numbering (i.e. on directory listing order). - The CycleDetection module is deleted: cycle rejection now comes from `topSort`'s Left result, which contains the actual cycle, so mkDepGraph can finally report which objects form the cycle (resolving the long-standing XXX comment). Its test cases are ported to mkDepGraph-level tests. - mkDepGraph now rejects duplicate object identifiers explicitly. Previously duplicates were silently tolerated with confusing behaviour (name lookups resolved to the first match while the graph contained both vertices). Ordering semantics: any result is still a valid topological order, but the specific order changes where siblings were previously ordered by node number; one DependencyTest expectation is updated accordingly. Linear migration histories are unaffected (their topological order is unique). The non-linear stress test runs marginally faster than the previous implementation (46 migrations: 2.3ms; 2002 migrations: 7.4s vs 9.8s). Co-Authored-By: Claude Fable 5 --- dbmigrations.cabal | 6 +- .../Schema/Migrations/CycleDetection.hs | 64 --------- .../Schema/Migrations/Dependencies.hs | 122 +++++++----------- src/Database/Schema/Migrations/Store.hs | 6 +- test/CycleDetectionTest.hs | 69 ---------- test/DependencyTest.hs | 54 ++++++-- test/Main.hs | 2 - 7 files changed, 95 insertions(+), 228 deletions(-) delete mode 100644 src/Database/Schema/Migrations/CycleDetection.hs delete mode 100644 test/CycleDetectionTest.hs diff --git a/dbmigrations.cabal b/dbmigrations.cabal index 2e2451d..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,7 +133,6 @@ test-suite dbmigrations-tests other-modules: Common CommonTH - CycleDetectionTest DependencyTest FilesystemParseTest FilesystemSerializeTest 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 8bbec0c..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,15 +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. @@ -32,93 +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] + 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 = dependenciesWith suc +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 = dependenciesWith pre - --- This used to enumerate every path from the start object (each --- object's direct successor names followed by the expansion of each --- name in turn, resolving names through the name map), keep the last --- occurrence of each name, and reverse the result. Path enumeration --- is exponential in the depth of a non-linear graph, so instead we --- produce the same ordering by scanning the virtual enumeration from --- the end: walk successor names in reverse order, expand each name's --- subtree at most once (a repeated expansion occurs earlier in the --- enumeration, so it cannot contain a last occurrence), and emit each --- name the first time it is seen, i.e. at its last occurrence. -dependenciesWith :: (Dependable d) => NextNodesFunc -> DependencyGraph d -> Text -> [Text] -dependenciesWith nextNodes (DG _ nMap theGraph) name = - let -- Like `lookup name nMap`: on duplicate names, the first - -- entry wins. - nameMap = Map.fromListWith (\_ old -> old) nMap - - succNames n = let node = fromJust $ Map.lookup n nameMap - in map (fromJust . lab theGraph) $ nextNodes theGraph node - - expand st@(expanded, emitted, acc) n - | n `Set.member` expanded = st - | otherwise = - let succs = reverse $ succNames n - expandedSt = foldl' expand (Set.insert n expanded, emitted, acc) succs - in foldl' emit expandedSt succs - - emit st@(expanded, emitted, acc) n - | n `Set.member` emitted = st - | otherwise = (expanded, Set.insert n emitted, n : acc) - - (_, _, emittedReversed) = expand (Set.empty, Set.empty, []) name - in reverse emittedReversed +reverseDependencies g = closureOf (transpose $ depGraph g) + +-- 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 cbeea86..ec2b943 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -9,7 +9,6 @@ import qualified MigrationsTest import qualified FilesystemSerializeTest import qualified FilesystemParseTest import qualified FilesystemTest -import qualified CycleDetectionTest import qualified StoreTest import qualified LinearMigrationsTest import qualified ConfigurationTest @@ -35,7 +34,6 @@ loadTests = do , DependencyTest.tests , FilesystemSerializeTest.tests , MigrationsTest.tests - , CycleDetectionTest.tests , StoreTest.tests ]