git.iko.soy/project-m36
on 97d73bb help sign in
project-m36/src/lib/ProjectM36/TransactionGraph.hs
463 lines 27 kB history raw
1{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}
2module ProjectM36.TransactionGraph where
3import ProjectM36.Base
4import ProjectM36.Error
5import ProjectM36.Transaction
6import ProjectM36.Relation
7import ProjectM36.TupleSet
8import ProjectM36.Tuple
9import qualified Data.Vector as V
10import qualified ProjectM36.Attribute as A
11import qualified Data.UUID as U
12import qualified Data.Set as S
13import qualified Data.Map as M
14import Control.Monad
15import qualified Data.Text as T
16import GHC.Generics
17import Data.Binary
18import ProjectM36.TransactionGraph.Merge
19import Data.Either (lefts, rights, isRight)
20--import Debug.Trace
22-- | Record a lookup for a specific transaction in the graph.
23data TransactionIdLookup = TransactionIdLookup TransactionId |
24 TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]
25 deriving (Show, Eq, Binary, Generic)
27-- topic~3^2
28data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- git ~: walk back n parents, arbitrarily choosing a parent when a choice must be made
29 TransactionIdHeadBranchBacktrack Int -- git ^: walk back one parent level to the nth arbitrarily-chosen parent
30 deriving (Show, Eq, Binary, Generic)
32--operators which manipulate a transaction graph
33data TransactionGraphOperator = JumpToHead HeadName |
34 JumpToTransaction TransactionId |
35 Branch HeadName |
36 MergeTransactions MergeStrategy HeadName HeadName |
37 Commit |
38 Rollback
39 deriving (Eq, Show, Binary, Generic)
41data ROTransactionGraphOperator = ShowGraph
44bootstrapTransactionGraph :: TransactionId -> DatabaseContext -> TransactionGraph
45bootstrapTransactionGraph freshId context = TransactionGraph bootstrapHeads bootstrapTransactions
46 where
47 bootstrapHeads = M.singleton "master" freshTransaction
48 newSchemas = Schemas context M.empty
49 freshTransaction = Transaction freshId (TransactionInfo U.nil S.empty) newSchemas
50 bootstrapTransactions = S.singleton freshTransaction
52emptyTransactionGraph :: TransactionGraph
53emptyTransactionGraph = TransactionGraph M.empty S.empty
55transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction
56transactionForHead headName (TransactionGraph heads _) = M.lookup headName heads
58headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName
59headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then
60 Nothing
61 else
62 Just $ (head . M.keys) matchingTrans
63 where
64 matchingTrans = M.filter (transaction ==) heads
66transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction
67transactionForId tid graph = if tid == U.nil then
68 Left RootTransactionTraversalError
69 else if S.null matchingTrans then
70 Left $ NoSuchTransactionError tid
71 else
72 Right $ head (S.toList matchingTrans)
73 where
74 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
76transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction)
77transactionsForIds idSet graph = do
78 transList <- forM (S.toList idSet) ((flip transactionForId) graph)
79 return (S.fromList transList)
81isRootTransaction :: Transaction -> TransactionGraph -> Bool
82isRootTransaction (Transaction _ (TransactionInfo pId _) _) _ = U.null pId
83isRootTransaction (Transaction _ (MergeTransactionInfo _ _ _) _) _ = False
85-- the first transaction has no parent - all other do have parents- merges have two parents
86parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
87parentTransactions (Transaction _ (TransactionInfo pId _) _) graph = do
88 trans <- transactionForId pId graph
89 return (S.singleton trans)
91parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph
94childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
95childTransactions (Transaction _ (TransactionInfo _ children) _) = transactionsForIds children
96childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transactionsForIds children
98-- create a new commit and add it to the heads
99-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
100addBranch :: TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
101addBranch newId newBranchName branchPointId graph = do
102 parentTrans <- transactionForId branchPointId graph
103 let newTrans = Transaction newId (TransactionInfo branchPointId S.empty) (schemas parentTrans)
104 addTransactionToGraph newBranchName newTrans graph
106--adds a disconnected transaction to a transaction graph at some head
107addDisconnectedTransaction :: TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
108addDisconnectedTransaction newId headName (DisconnectedTransaction parentId schemas') graph = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty) schemas') graph
111addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
112addTransactionToGraph headName newTrans graph = do
113 let parentIds = transactionParentIds newTrans
114 childIds = transactionChildIds newTrans
115 newId = transactionId newTrans
116 validateIds ids = mapM (\i -> transactionForId i graph) (S.toList ids)
117 addChildTransaction trans = transactionSetChildren trans (S.insert newId (transactionChildIds trans))
118 --validate that the parent transactions are in the graph
119 _ <- validateIds parentIds
120 when (S.size parentIds < 1) (Left $ NewTransactionMissingParentError newId)
121 --if the headName already exists, ensure that it refers to a parent
122 case transactionForHead headName graph of
123 Nothing -> pure () -- any headName is OK
124 Just trans -> when (S.notMember (transactionId trans) parentIds) (Left (HeadNameSwitchingHeadProhibitedError headName))
125 --validate that the transaction has no children
126 when (not (S.null childIds)) (Left $ NewTransactionMayNotHaveChildrenError newId)
127 --validate that the trasaction's id is unique
128 when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))
129 --update the parent transactions to point to the new transaction
130 parents <- mapM (\tid -> transactionForId tid graph) (S.toList parentIds)
131 let updatedParents = S.map addChildTransaction (S.fromList parents)
132 updatedTransSet = S.insert newTrans (S.union updatedParents (transactionsForGraph graph))
133 updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph)
134 pure (newTrans, (TransactionGraph updatedHeads updatedTransSet))
136validateGraph :: TransactionGraph -> Maybe [RelationalError]
137validateGraph graph@(TransactionGraph _ transSet) = do
138 --check that all transaction ids are unique in the graph
139 --FINISH ME!
140 --uuids = map transactionId transSet
141 --check that all heads appear in the transSet
142 --check that all forward and backward links are in place
143 _ <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)
144 mapM (walkChildTransactions S.empty graph) (S.toList transSet)
146--verify that all parent links exist and that all children exist
147--maybe verify that all parents end at transaction id nil and all children end at leaves
148walkParentTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
149walkParentTransactions seenTransSet graph trans =
150 let transId = transactionId trans in
151 if transId == U.nil then
152 Nothing
153 else if S.member transId seenTransSet then
154 Just $ TransactionGraphCycleError transId
155 else
156 let parentTransSetOrError = parentTransactions trans graph in
157 case parentTransSetOrError of
158 Left err -> Just err
159 Right parentTransSet -> do
160 walk <- mapM (walkParentTransactions (S.insert transId seenTransSet) graph) (S.toList parentTransSet)
161 case walk of
162 err:_ -> Just err
163 _ -> Nothing
165--refactor: needless duplication in these two functions
166walkChildTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
167walkChildTransactions seenTransSet graph trans =
168 let transId = transactionId trans in
169 if childTransactions trans graph == Right S.empty then
170 Nothing
171 else if S.member transId seenTransSet then
172 Just $ TransactionGraphCycleError transId
173 else
174 let childTransSetOrError = childTransactions trans graph in
175 case childTransSetOrError of
176 Left err -> Just err
177 Right childTransSet -> do
178 walk <- mapM (walkChildTransactions (S.insert transId seenTransSet) graph) (S.toList childTransSet)
179 case walk of
180 err:_ -> Just err
181 _ -> Nothing
183-- returns the new "current" transaction, updated graph, and tutorial d result
184-- the current transaction is not part of the transaction graph until it is committed
185evalGraphOp :: TransactionId -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
187--affects only disconncted transaction
188evalGraphOp _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId graph of
189 Left err -> Left err
190 Right parentTrans -> Right (newTrans, graph)
191 where
192 newTrans = DisconnectedTransaction jumpId (schemas parentTrans)
194-- switch from one head to another
195-- affects only disconnectedtransaction
196evalGraphOp _ _ graph (JumpToHead headName) =
197 case transactionForHead headName graph of
198 Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) in
199 Right (disconnectedTrans, graph)
200 Nothing -> Left $ NoSuchHeadNameError headName
201-- add new head pointing to branchPoint
202-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)
203-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch
204 {-
205evalGraphOp newId discon@(DisconnectedTransaction parentId disconContext) graph (Branch newBranchName) = case transactionForId parentId graph of
206 Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")
207 Just parentTrans -> case addBranch newBranchName parentTrans graph of
208 Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")
209 Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")
210 where
211 newDiscon = DisconnectedTransaction (transactionId parentTrans) disconContext
212-}
214-- create a new commit and add it to the heads
215-- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)
216evalGraphOp newId (DisconnectedTransaction parentId schemas') graph (Branch newBranchName) = case addBranch newId newBranchName parentId graph of
217 Left err -> Left err
218 Right (_, newGraph) -> Right (newDiscon, newGraph)
219 where
220 newDiscon = DisconnectedTransaction newId schemas'
222-- add the disconnected transaction to the graph
223-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
224evalGraphOp newTransId discon@(DisconnectedTransaction parentId schemas') graph Commit = case transactionForId parentId graph of
225 Left err -> Left err
226 Right parentTransaction -> case headNameForTransaction parentTransaction graph of
227 Nothing -> Left $ TransactionIsNotAHeadError parentId
228 Just headName -> case maybeUpdatedGraph of
229 Left err-> Left err
230 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)
231 where
232 newDisconnectedTrans = DisconnectedTransaction newTransId schemas'
233 maybeUpdatedGraph = addDisconnectedTransaction newTransId headName discon graph
235-- refresh the disconnected transaction, return the same graph
236evalGraphOp _ (DisconnectedTransaction parentId _) graph Rollback = case transactionForId parentId graph of
237 Left err -> Left err
238 Right parentTransaction -> Right (newDiscon, graph)
239 where
240 newDiscon = DisconnectedTransaction parentId (schemas parentTransaction)
242-- a successful merge should remove a head
243evalGraphOp newId (DisconnectedTransaction parentId _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph
245--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
246graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
247graphAsRelation (DisconnectedTransaction parentId _) graph@(TransactionGraph _ transSet) = do
248 tupleMatrix <- mapM tupleGenerator (S.toList transSet)
249 mkRelationFromList attrs tupleMatrix
250 where
251 attrs = A.attributesFromList [Attribute "id" TextAtomType,
252 Attribute "parents" (RelationAtomType parentAttributes),
253 Attribute "current" BoolAtomType,
254 Attribute "head" TextAtomType
255 ]
256 parentAttributes = A.attributesFromList [Attribute "id" TextAtomType]
257 tupleGenerator transaction = case transactionParentsRelation transaction graph of
258 Left err -> Left err
259 Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),
260 RelationAtom parentTransRel,
261 BoolAtom $ parentId == transactionId transaction,
262 TextAtom $ case headNameForTransaction transaction graph of
263 Just headName -> headName
264 Nothing -> ""
265 ]
267transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
268transactionParentsRelation trans graph = do
269 if isRootTransaction trans graph then do
270 mkRelation attrs emptyTupleSet
271 else do
272 parentTransSet <- parentTransactions trans graph
273 let tuples = map trans2tuple (S.toList parentTransSet)
274 mkRelationFromTuples attrs tuples
275 where
276 attrs = A.attributesFromList [Attribute "id" TextAtomType]
277 trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (TextAtom (T.pack (show $ transactionId trans2)))
279{-
280--display transaction graph as relation
281evalROGraphOp :: DisconnectedTransaction -> TransactionGraph -> ROTransactionGraphOperator -> Either RelationalError Relation
282evalROGraphOp discon graph ShowGraph = do
283 graphRel <- graphAsRelation discon graph
284 return graphRel
285-}
287-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph
288createMergeTransaction :: TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
289createMergeTransaction newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do
290 selectedTrans <- validateHeadName selectedBranch graph t2
291 pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty) (schemas selectedTrans)
293-- merge functions, relvars, individually
294createMergeTransaction newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction newId strat graph t2
296-- merge function, relvars, but, on error, just take the component from the preferred branch
297createMergeTransaction newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction newId strat graph t2
299-- | Returns the correct Transaction for the branch name in the graph and ensures that it is one of the two transaction arguments in the tuple.
300validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
301validateHeadName headName graph (t1, t2) = do
302 case transactionForHead headName graph of
303 Nothing -> Left SelectedHeadMismatchMergeError
304 Just trans -> if trans /= t1 && trans /= t2 then
305 Left SelectedHeadMismatchMergeError
306 else
307 Right trans
309-- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal.
310subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph
311subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans traverseSet = do
312 let currentid = transactionId currentTrans
313 goalid = transactionId goalTrans
314 if currentTrans == goalTrans then
315 Right (TransactionGraph resultHeads traverseSet) -- add filter
316 --catch root transaction to improve error?
317 else do
318 currentTransChildren <- liftM S.fromList $ mapM (flip transactionForId origGraph) (S.toList (transactionChildIds currentTrans))
319 let searchChildren = S.difference (S.insert currentTrans traverseSet) currentTransChildren
320 searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans traverseSet)
321 childSearches = map searchChild (S.toList searchChildren)
322 errors = lefts childSearches
323 pathsFound = rights childSearches
324 realErrors = filter (/= (FailedToFindTransactionError goalid)) errors
325 -- report any non-search-related errors
326 when (not (null realErrors)) (Left (head realErrors))
327 -- if no paths found, search the parent
328 if null pathsFound then
329 case oneParent currentTrans of
330 Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)
331 Left err -> Left err
332 Right currentTransParent -> do
333 subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans traverseSet)
334 else -- we found a path
335 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))
336 where
337 oneParent (Transaction _ (TransactionInfo parentId _) _) = transactionForId parentId origGraph
338 oneParent (Transaction _ (MergeTransactionInfo parentId _ _) _) = transactionForId parentId origGraph
340-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.
341pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)
342pathToTransaction graph currentTransaction targetTransaction accumTransSet = do
343 let targetId = transactionId targetTransaction
344 if transactionId targetTransaction == transactionId currentTransaction then do
345 Right accumTransSet
346 else do
347 currentTransChildren <- mapM (flip transactionForId graph) (S.toList (transactionChildIds currentTransaction))
348 if length currentTransChildren == 0 then
349 Left (FailedToFindTransactionError targetId)
350 else do
351 let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) currentTransChildren
352 let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)
353 paths = rights searches
354 if length realErrors > 0 then -- found some real errors
355 Left (head realErrors)
356 else if length paths == 0 then -- failed to find transaction in all children
357 Left (FailedToFindTransactionError targetId)
358 else --we have some paths!
359 Right (S.unions paths)
361mergeTransactions :: TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
362mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph = do
363 let transactionForHeadErr name = case transactionForHead name graph of
364 Nothing -> Left (NoSuchHeadNameError name)
365 Just t -> Right t
366 transA <- transactionForHeadErr headNameA
367 transB <- transactionForHeadErr headNameB
368 disconParent <- transactionForId parentId graph
369 let subHeads = M.filterWithKey (\k _ -> elem k [headNameA, headNameB]) (transactionHeadsForGraph graph)
370 subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty
371 subGraph' <- filterSubGraph subGraph subHeads
372 case createMergeTransaction newId mergeStrategy subGraph' (transA, transB) of
373 Left err -> Left (MergeTransactionError err)
374 Right mergedTrans -> case headNameForTransaction disconParent graph of
375 Nothing -> Left (TransactionIsNotAHeadError parentId)
376 Just headName -> do
377 (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph
378 let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)
379 newDiscon = DisconnectedTransaction newId (schemas newTrans)
380 pure (newDiscon, newGraph')
382--TEMPORARY COPY/PASTE
383showTransactionStructureX :: Transaction -> TransactionGraph -> String
384showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo
385 where
386 headInfo = maybe "" show (headNameForTransaction trans graph)
387 parentTransactionsInfo = if isRootTransaction trans graph then "root" else case parentTransactions trans graph of
388 Left err -> show err
389 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet
391showGraphStructureX :: TransactionGraph -> String
392showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet
393 where
394 folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n"
395 headsInfo = show $ M.map transactionId heads
397-- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph.
398filterSubGraph :: TransactionGraph -> TransactionHeads -> Either RelationalError TransactionGraph
399filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet
400 where
401 validIds = S.map transactionId (transactionsForGraph graph)
402 newTransSet = S.map (filterTransaction validIds) (transactionsForGraph graph)
403 newHeads = M.map (filterTransaction validIds) heads
405--helper function for commonalities in union merge
406createUnionMergeTransaction :: TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
407createUnionMergeTransaction newId strategy graph (t1,t2) = do
408 let contextA = concreteDatabaseContext t1
409 contextB = concreteDatabaseContext t2
411 preference <- case strategy of
412 UnionMergeStrategy -> pure PreferNeither
413 UnionPreferMergeStrategy preferBranch -> do
414 case transactionForHead preferBranch graph of
415 Nothing -> Left (PreferredHeadMissingMergeError preferBranch)
416 Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond
417 badStrat -> Left (InvalidMergeStrategyError badStrat)
419 incDeps <- unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)
420 relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)
421 atomFuncs <- unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)
422 notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB)
423 types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)
424 -- TODO: add merge of subschemas
425 let newContext = DatabaseContext incDeps relVars atomFuncs notifs types
426 newSchemas = Schemas newContext (subschemas t1)
427 pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty) newSchemas)
429lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction
430lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph
431lookupTransaction graph (TransactionIdHeadNameLookup headName backtracks) = case transactionForHead headName graph of
432 Nothing -> Left (NoSuchHeadNameError headName)
433 Just headTrans -> do
434 traversedId <- traverseGraph graph (transactionId headTrans) backtracks
435 transactionForId traversedId graph
437traverseGraph :: TransactionGraph -> TransactionId -> [TransactionIdHeadBacktrack] -> Either RelationalError TransactionId
438traverseGraph graph currentTid backtrackSteps = foldM (backtrackGraph graph) currentTid backtrackSteps
440backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrack -> Either RelationalError TransactionId
441-- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily
442backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do
443 trans <- transactionForId currentTid graph
444 let parents = S.toAscList (transactionParentIds trans)
445 if length parents < 1 then
446 Left RootTransactionTraversalError
447 else do
448 parentTrans <- transactionForId (head parents) graph
449 if steps == 1 then do
450 pure (transactionId parentTrans)
451 else
452 backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1))
454backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do
455 trans <- transactionForId currentTid graph
456 let parents = transactionParentIds trans
457 if S.size parents < 1 then
458 Left RootTransactionTraversalError
459 else if S.size parents < steps then
460 Left (ParentCountTraversalError (S.size parents) steps)
461 else
462 pure (S.elemAt (steps - 1) parents)