Fix exponential dependency resolution on non-linear DAGs

dbmigrations.cabal

@@ -140,6 +140,7 @@ test-suite dbmigrations-tests
     FilesystemSerializeTest
     FilesystemTest
     MigrationsTest
+    NonLinearStressTest
     StoreTest
     InMemoryStore
     LinearMigrationsTest

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

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

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

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)
+         ]