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