From b214a580b61be1df0143fb38f64be90d049191b8 Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Wed, 8 Jul 2026 17:03:04 +0100 Subject: [PATCH] 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) + ]