@@ -5,7 +5,7 @@
55{-# LANGUAGE TupleSections #-}
66module Obelisk.Migration where
77
8−import Control.Monad (forM, forM_, unless)
8+import Control.Monad (forM, forM_, unless, void)
99import Control.Monad.Catch (Exception, MonadThrow, throwM)
1010import Control.Monad.IO.Class (MonadIO, liftIO)
1111import Control.Monad.State.Strict (evalStateT, get, put)
@@ -40,6 +40,9 @@ data CyclicGraphError = CyclicGraphError
4040data MultipleTerminalVertices = MultipleTerminalVertices
4141 deriving Show
4242
43+data NoTerminalVertex = NoTerminalVertex
44+ deriving Show
45+
4346data NonEquivalentPaths = NonEquivalentPaths Hash Hash
4447 deriving Show
4548
@@ -48,6 +51,7 @@ data MissingEdgeInActionMap = MissingEdgeInActionMap (Hash, Hash)
4851
4952instance Exception CyclicGraphError
5053instance Exception MultipleTerminalVertices
54+instance Exception NoTerminalVertex
5155instance Exception NonEquivalentPaths
5256instance Exception MissingEdgeInActionMap
5357
@@ -85,6 +89,30 @@ readGraph root name = doesDirectoryExist root >>= \case
8589 False -> do
8690 return Nothing
8791
92+-- | Ensures that the migration class is correct
93+--
94+-- Throw the following if integrity check fails
95+-- * `CyclicGraphError`
96+-- * `NonEquivalentPaths`
97+ensureGraphIntegrity
98+ :: (MonadThrow m, Monoid action, Ord action)
99+ => Migration action -> m ()
100+ensureGraphIntegrity m = do
101+ graph <- fmap adjacencyMap $ getDag $ _migration_graph m
102+ firstVertex <- getFirst $ _migration_graph m
103+ let
104+ traverseFrom visited acc start = case Map.lookup start graph of
105+ Nothing -> pure ()
106+ Just adjs -> void $ flip traverse (Set.toList adjs) $ \adj -> do
107+ acc' <- fmap (mappend acc) $ getAction m (start, adj)
108+ visited' <- case Map.lookup adj visited of
109+ Nothing -> pure $ Map.insert adj acc' visited
110+ Just adjAcc -> if acc' == adjAcc
111+ then pure visited
112+ else throwM $ NonEquivalentPaths start adj
113+ traverseFrom visited' acc' adj
114+ traverseFrom mempty mempty firstVertex
115+
88116-- | Find the concataneted actions between two vertices
89117--
90118-- All paths between the vertices must have the same mappend'ed action;
@@ -135,10 +163,10 @@ getAction (Migration _ h) e = case Map.lookup e h of
135163-- | Get the last vertex of the given DAG. Nothing if empty graph.
136164--
137165-- Assumes that the graph is fully connected.
138−getLast :: (MonadThrow m, Ord a, Eq a) => AdjacencyMap a -> m (Maybe a)
166+getLast :: (MonadThrow m, Ord a, Eq a) => AdjacencyMap a -> m a
139167getLast g = lastVertices >>= \case
140− [] -> pure $ Nothing
141− [x] -> pure $ Just x
168+ [] -> throwM NoTerminalVertex
169+ [x] -> pure x
142170 _ -> throwM MultipleTerminalVertices
143171 where
144172 lastVertices
@@ -149,7 +177,7 @@ getLast g = lastVertices >>= \case
149177 =<< getDag g
150178
151179-- | Get the first vertex of the given DAG. Nothing if empty graph.
152−getFirst :: (MonadThrow m, Ord a, Eq a) => AdjacencyMap a -> m (Maybe a)
180+getFirst :: (MonadThrow m, Ord a, Eq a) => AdjacencyMap a -> m a
153181getFirst = getLast . transpose
154182
155183-- | Write an edge directly to the filesystem.