@@ -17,6 +17,7 @@ import qualified Data.Text as T
1717import GHC.Generics
1818import Data.Binary
1919import Debug.Trace
20+import Data.Either (lefts, rights)
2021
2122--operators which manipulate a transaction graph
2223data TransactionGraphOperator = JumpToHead HeadName |
@@ -52,7 +53,9 @@ headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchi
5253 matchingTrans = M.filter (transaction ==) heads
5354
5455transactionForUUID :: U.UUID -> TransactionGraph -> Either RelationalError Transaction
55−transactionForUUID uuid graph = if S.null matchingTrans then
56+transactionForUUID uuid graph = if uuid == U.nil then
57+ Left RootTransactionTraversalError
58+ else if S.null matchingTrans then
5659 Left $ NoSuchTransactionError uuid
5760 else
5861 Right $ head (S.toList matchingTrans)
@@ -83,23 +86,24 @@ childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transa
8386
8487-- create a new commit and add it to the heads
8588-- 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)
86−addBranch :: U.UUID -> HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
87−addBranch newUUID newBranchName branchPoint graph = addTransactionToGraph newBranchName branchPoint newUUID (transactionContext branchPoint) graph
89+addBranch :: U.UUID -> HeadName -> U.UUID -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
90+addBranch newUUID newBranchName branchPointId graph = do
91+ parentTrans <- transactionForUUID branchPointId graph
92+ addTransactionToGraph newBranchName branchPointId newUUID (transactionContext parentTrans) graph
8893
8994--adds a disconnected transaction to a transaction graph at some head
9095addDisconnectedTransaction :: U.UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
91−addDisconnectedTransaction newUUID headName (DisconnectedTransaction parentUUID context) graph = do
92− parentTrans <- transactionForUUID parentUUID graph
93− addTransactionToGraph headName parentTrans newUUID context graph
96+addDisconnectedTransaction newUUID headName (DisconnectedTransaction parentUUID context) graph = addTransactionToGraph headName parentUUID newUUID context graph
9497
9598-- create a new transaction on "newHeadName" with the branchPointTrans
96−addTransactionToGraph :: HeadName -> Transaction -> U.UUID -> DatabaseContext -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
97−addTransactionToGraph newHeadName branchPointTrans newUUID newContext (TransactionGraph heads transSet) = do
98− let freshTransaction = Transaction newUUID (TransactionInfo (transactionUUID branchPointTrans) S.empty) newContext
99+addTransactionToGraph :: HeadName -> U.UUID -> U.UUID -> DatabaseContext -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
100+addTransactionToGraph newHeadName branchPointTransId newUUID newContext graph@(TransactionGraph heads transSet) = do
101+ parentTransaction <- transactionForUUID branchPointTransId graph
102+ let freshTransaction = Transaction newUUID (TransactionInfo branchPointTransId S.empty) newContext
99103 -- there are two parents for MergeTransactions! not implemented
100104 --update parentTransaction to add child
101− let parentTransaction = branchPointTrans
102− let updatedTransSet = (S.insert freshTransaction <$> S.insert parentTransaction <$> S.delete parentTransaction) transSet
105+ let updatedParentTransaction = transactionSetChildren parentTransaction (S.insert (transactionUUID freshTransaction) (transactionChildren parentTransaction))
106+ updatedTransSet = (S.insert freshTransaction <$> S.insert updatedParentTransaction) transSet
103107 let updatedGraph = TransactionGraph (M.insert newHeadName freshTransaction heads) updatedTransSet
104108 return (freshTransaction, updatedGraph)
105109
@@ -182,12 +186,10 @@ evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) gr
182186
183187-- create a new commit and add it to the heads
184188-- 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)
185−evalGraphOp newUUID (DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
189+evalGraphOp newUUID (DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case addBranch newUUID newBranchName parentUUID graph of
186190 Left err -> Left err
187− Right parentTrans -> case addBranch newUUID newBranchName parentTrans graph of
188− Left err -> Left err
189− Right (_, newGraph) -> Right (newDiscon, newGraph)
190− where
191+ Right (_, newGraph) -> Right (newDiscon, newGraph)
192+ where
191193 newDiscon = DisconnectedTransaction newUUID disconContext
192194
193195-- add the disconnected transaction to the graph
@@ -273,29 +275,55 @@ validateHeadName headName graph (t1, t2) = do
273275 else
274276 Right trans
275277
276−-- | Return the common ancestor of two transactions. When looking for the first common ancestor, we don't need to search both parents of a merge transaction because the merge must have diverged from a common ancestor anyway, so we arbitrarily just search one of the parents of a merge transaction. Technically, due to merge transactions, this may not actually return the first common ancestor, but it should be pretty close.
277−subGraphToFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> TransactionGraph -> Transaction -> Transaction -> Either RelationalError TransactionGraph
278−subGraphToFirstCommonAncestor origGraph resultHeads subGraph trans1 trans2 = do
279− let t1id = transactionUUID trans1
280− t2id = transactionUUID trans2
281− validChildIds = traceShowId $ S.map transactionUUID (transactionsForGraph subGraph)
282− filterTransSet transSet = S.map (\t -> filterChildTransactions t validChildIds) transSet
283− if t1id == t2id then
284− --also filter child transactions
285− Right (TransactionGraph resultHeads (S.union (transactionsForGraph subGraph) (filterTransSet (S.singleton trans1))))
286− else if U.null t1id || U.null t2id then --no common ancestor
287− Left (NoCommonTransactionAncestorError t1id t2id)
278+-- 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.
279+subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph
280+subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans traverseSet = do
281+ let currentid = transactionUUID currentTrans
282+ goalid = transactionUUID goalTrans
283+ if currentTrans == goalTrans then
284+ Right (TransactionGraph resultHeads traverseSet) -- add filter
285+ --catch root transaction to improve error?
288286 else do
289− parentTrans1 <- oneParent trans1
290− parentTrans2 <- oneParent trans2
291− --add transactions to graph
292− let subGraph' = TransactionGraph resultHeads newTrans
293− newTrans = S.union (transactionsForGraph subGraph) (filterTransSet (S.fromList [trans1, trans2]))
294− subGraphToFirstCommonAncestor origGraph resultHeads subGraph' parentTrans1 parentTrans2
287+ currentTransChildren <- liftM S.fromList $ mapM (flip transactionForUUID origGraph) (S.toList (transactionChildren currentTrans))
288+ let searchChildren = S.difference (S.insert currentTrans traverseSet) currentTransChildren
289+ searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans traverseSet)
290+ childSearches = map searchChild (S.toList searchChildren)
291+ errors = lefts childSearches
292+ pathsFound = rights childSearches
293+ if null childSearches || all (== (Left (FailedToFindTransactionError goalid))) childSearches then --no path found, so search the parent
294+ case oneParent currentTrans of
295+ Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)
296+ Left err -> Left err
297+ Right currentTransParent -> do
298+ subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans traverseSet)
299+ else if length errors > 0 then -- traversal error
300+ Left (head errors)
301+ else -- we found a path
302+ Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))
295303 where
296304 oneParent (Transaction _ (TransactionInfo parentId _) _) = transactionForUUID parentId origGraph
297305 oneParent (Transaction _ (MergeTransactionInfo parentId _ _) _) = transactionForUUID parentId origGraph
298306
307+-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.
308+pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)
309+pathToTransaction graph currentTransaction targetTransaction accumTransSet = do
310+ let targetId = transactionUUID targetTransaction
311+ if targetTransaction == currentTransaction then
312+ Right accumTransSet
313+ else do
314+ currentTransChildren <- mapM (flip transactionForUUID graph) (S.toList (transactionChildren currentTransaction))
315+ if length currentTransChildren == 0 then
316+ Left (FailedToFindTransactionError targetId)
317+ else do
318+ let searches = map (\t -> pathToTransaction graph targetTransaction t (S.insert t accumTransSet)) currentTransChildren
319+ let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)
320+ paths = rights searches
321+ if length realErrors > 0 then -- found some real errors
322+ Left (head realErrors)
323+ else if length paths == 0 then -- failed to find transaction in all children
324+ Left (FailedToFindTransactionError targetId)
325+ else --we have some paths!
326+ Right (S.unions paths)
299327
300328mergeTransactions :: U.UUID -> U.UUID -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
301329mergeTransactions newUUID parentUUID mergeStrategy (headNameA, headNameB) graph = do
@@ -315,14 +343,15 @@ mergeTransactions newUUID parentUUID mergeStrategy (headNameA, headNameB) graph
315343
316344 disconParent <- transactionForUUID parentUUID graph
317345 let subHeads = M.filterWithKey (\k _ -> elem k [headNameA, headNameB]) (transactionHeadsForGraph graph)
318− subGraph <- subGraphToFirstCommonAncestor graph subHeads emptyTransactionGraph transA transB
346+ subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty
347+
319348 case createMergeTransaction newUUID mergeStrategy subGraph (transA, transB) of
320349 Left err -> Left (MergeTransactionError err)
321350 Right mergedTrans -> case headNameForTransaction disconParent graph of
322351 Nothing -> Left (TransactionIsNotAHeadError parentUUID)
323352 Just headName -> do
324353 -- why create a merge transaction and then only use the context?
325− (newTrans, newGraph) <- addTransactionToGraph headName disconParent newUUID (transactionContext mergedTrans) graph
354+ (newTrans, newGraph) <- addTransactionToGraph headName parentUUID newUUID (transactionContext mergedTrans) graph
326355 let newGraph' = TransactionGraph newHeads (transactionsForGraph newGraph)
327356 newHeads = M.delete headNameToDelete (transactionHeadsForGraph newGraph)
328357 newDiscon = newDisconnectedTransaction newUUID (transactionContext newTrans)