git.iko.soy/project-m36
on master help sign in
intermediate transaction graph test commit
83fc9f0AgentM
ProjectM36/Transaction.hs+7
compare with master
unifiedsplit
@@ -12,3 +12,10 @@ transactionParentUUIDs :: Transaction -> S.Set U.UUID
12transactionParentUUIDs (Transaction _ (TransactionInfo pUUID _) _) = S.singleton pUUID
12transactionParentUUIDs (Transaction _ (TransactionInfo pUUID _) _) = S.singleton pUUID
13transactionParentUUIDs (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _) = S.fromList [pUUID1, pUUID2]
13transactionParentUUIDs (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _) = S.fromList [pUUID1, pUUID2]
14
14
15+-- | Return the same transaction but referencing only the specific child transactions. This is useful when traversing a graph and returning a subgraph. This doesn't filter parent transactions because it assumes a head-to-root traversal.
16+filterChildrenFromTransactionInfo :: TransactionInfo -> S.Set U.UUID -> TransactionInfo
17+filterChildrenFromTransactionInfo (TransactionInfo parentId childIds) filterIds = TransactionInfo parentId (S.intersection childIds filterIds)
18+filterChildrenFromTransactionInfo (MergeTransactionInfo parentIdA parentIdB childIds) filterIds = MergeTransactionInfo parentIdA parentIdB (S.intersection childIds filterIds)
19+
20+filterChildTransactions :: Transaction -> S.Set U.UUID -> Transaction
21+filterChildTransactions (Transaction selfId tInfo context) filterIds = Transaction selfId (filterChildrenFromTransactionInfo tInfo filterIds) context
ProjectM36/TransactionGraph.hs+75−53
@@ -16,6 +16,7 @@ import Control.Monad
16import qualified Data.Text as T
16import qualified Data.Text as T
17import GHC.Generics
17import GHC.Generics
18import Data.Binary
18import Data.Binary
19+import Debug.Trace
19
20
20--operators which manipulate a transaction graph
21--operators which manipulate a transaction graph
21data TransactionGraphOperator = JumpToHead HeadName |
22data TransactionGraphOperator = JumpToHead HeadName |
@@ -210,34 +211,7 @@ evalGraphOp _ (DisconnectedTransaction parentUUID _) graph Rollback = case trans
210 newDiscon = newDisconnectedTransaction parentUUID (transactionContext parentTransaction)
211 newDiscon = newDisconnectedTransaction parentUUID (transactionContext parentTransaction)
211
212
212-- a successful merge should remove a head
213-- a successful merge should remove a head
213−evalGraphOp newUUID (DisconnectedTransaction parentUUID _) graph (MergeTransactions mergeStrategy headNameA headNameB) = do
214+evalGraphOp newUUID (DisconnectedTransaction parentUUID _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions newUUID parentUUID mergeStrategy (headNameA, headNameB) graph
214− let transactionForHeadErr name = case transactionForHead name graph of
215− Nothing -> Left (NoSuchHeadNameError name)
216− Just t -> Right t
217− transA <- transactionForHeadErr headNameA
218− transB <- transactionForHeadErr headNameB
219− let transAid = transactionUUID transA
220− transBid = transactionUUID transB
221− headNameToDelete <- if parentUUID == transAid then
222− pure headNameB
223− else if parentUUID == transBid then
224− pure headNameA
225− else
226− Left (MergeTransactionError (DisconnectedTransactionNotAMergeHeadError parentUUID))
227−
228− disconParent <- transactionForUUID parentUUID graph
229− subGraph <- subGraphToFirstCommonAncestor graph emptyTransactionGraph transA transB
230− case mergeTransactions newUUID mergeStrategy subGraph (transA, transB) of
231− Left err -> Left (MergeTransactionError err)
232− Right mergedTrans -> case headNameForTransaction disconParent graph of
233− Nothing -> Left (TransactionIsNotAHeadError parentUUID)
234− Just headName -> do
235− let newDiscon = newDisconnectedTransaction mergedTransUUID (transactionContext mergedTrans)
236− mergedTransUUID = transactionUUID mergedTrans
237− (_, newGraph) <- addDisconnectedTransaction mergedTransUUID headName newDiscon graph
238− let newGraph' = TransactionGraph newHeads (transactionsForGraph newGraph)
239− newHeads = M.delete headNameToDelete (transactionHeadsForGraph newGraph)
240− pure (newDiscon, newGraph')
241
215
242--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
216--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
243graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
217graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
@@ -281,43 +255,91 @@ evalROGraphOp discon graph ShowGraph = do
281 return graphRel
255 return graphRel
282-}
256-}
283
257
284−--execute the merge strategy against the transactions, returning a new transaction to be added to the graph
258+-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph
285−-- a successful merge should also remove a head
286−mergeTransactions :: U.UUID -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
259+createMergeTransaction :: U.UUID -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
287−mergeTransactions newUUID (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do
260+createMergeTransaction newUUID (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do
288 selectedTrans <- validateHeadName selectedBranch graph t2
261 selectedTrans <- validateHeadName selectedBranch graph t2
289 pure $ Transaction newUUID (MergeTransactionInfo (transactionUUID trans1) (transactionUUID trans2) S.empty) (transactionContext selectedTrans)
262 pure $ Transaction newUUID (MergeTransactionInfo (transactionUUID trans1) (transactionUUID trans2) S.empty) (transactionContext selectedTrans)
290
263
291−mergeTransactions newUUID UnionMergeStrategy graph t2 = undefined
264+--createMergeTransaction newUUID UnionMergeStrategy graph t2 = undefined
292−
293
265
294-- | 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.
266-- | 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.
295validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
267validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
268+validateHeadName headName graph (t1, t2) = do
296−validateHeadName headName graph (t1, t2) = case transactionForHead headName graph of
269+ case transactionForHead headName graph of
297− Nothing -> Left SelectedHeadMismatchMergeError
270+ Nothing -> Left SelectedHeadMismatchMergeError
298− Just trans -> if trans /= t1 && trans /= t2 then
271+ Just trans -> if trans /= t1 && trans /= t2 then
299− Left SelectedHeadMismatchMergeError
272+ Left SelectedHeadMismatchMergeError
300 else
273 else
301− Right trans
274+ Right trans
302
275
303−-- | 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. The incoming subgraph's heads remain unchanged in the return value.
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.
304−subGraphToFirstCommonAncestor :: TransactionGraph -> TransactionGraph -> Transaction -> Transaction -> Either RelationalError TransactionGraph
277+subGraphToFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> TransactionGraph -> Transaction -> Transaction -> Either RelationalError TransactionGraph
305−subGraphToFirstCommonAncestor origGraph subGraph trans1 trans2 = do
278+subGraphToFirstCommonAncestor origGraph resultHeads subGraph trans1 trans2 = do
306 let t1id = transactionUUID trans1
279 let t1id = transactionUUID trans1
307 t2id = transactionUUID trans2
280 t2id = transactionUUID trans2
281+ validChildIds = traceShowId $ S.map transactionUUID (transactionsForGraph subGraph)
282+ filterTransSet transSet = S.map (\t -> filterChildTransactions t validChildIds) transSet
308 if t1id == t2id then
283 if t1id == t2id then
309− Right subGraph
284+ --also filter child transactions
285+ Right (TransactionGraph resultHeads (S.union (transactionsForGraph subGraph) (filterTransSet (S.singleton trans1))))
310− else if U.null t1id || U.null t2id then --no common ancestor
286+ else if U.null t1id || U.null t2id then --no common ancestor
311− Left (NoCommonTransactionAncestorError t1id t2id)
287+ Left (NoCommonTransactionAncestorError t1id t2id)
312− else do
288+ else do
313− parentTrans1 <- oneParent trans1
289+ parentTrans1 <- oneParent trans1
314− parentTrans2 <- oneParent trans2
290+ parentTrans2 <- oneParent trans2
315− --add transactions to graph
291+ --add transactions to graph
316− let subGraph' = TransactionGraph headNames newTrans
292+ let subGraph' = TransactionGraph resultHeads newTrans
317− headNames = transactionHeadsForGraph subGraph
318− newTrans = S.union (transactionsForGraph subGraph) (S.fromList [parentTrans1, parentTrans2])
293+ newTrans = S.union (transactionsForGraph subGraph) (filterTransSet (S.fromList [trans1, trans2]))
319− subGraphToFirstCommonAncestor origGraph subGraph' parentTrans1 parentTrans2
294+ subGraphToFirstCommonAncestor origGraph resultHeads subGraph' parentTrans1 parentTrans2
320 where
295 where
321 oneParent (Transaction _ (TransactionInfo parentId _) _) = transactionForUUID parentId origGraph
296 oneParent (Transaction _ (TransactionInfo parentId _) _) = transactionForUUID parentId origGraph
322 oneParent (Transaction _ (MergeTransactionInfo parentId _ _) _) = transactionForUUID parentId origGraph
297 oneParent (Transaction _ (MergeTransactionInfo parentId _ _) _) = transactionForUUID parentId origGraph
323
298
299+
300+mergeTransactions :: U.UUID -> U.UUID -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
301+mergeTransactions newUUID parentUUID mergeStrategy (headNameA, headNameB) graph = do
302+ let transactionForHeadErr name = case transactionForHead name graph of
303+ Nothing -> Left (NoSuchHeadNameError name)
304+ Just t -> Right t
305+ transA <- transactionForHeadErr headNameA
306+ transB <- transactionForHeadErr headNameB
307+ let transAid = transactionUUID transA
308+ transBid = transactionUUID transB
309+ headNameToDelete <- if parentUUID == transAid then
310+ pure headNameB
311+ else if parentUUID == transBid then
312+ pure headNameA
313+ else
314+ Left (MergeTransactionError (DisconnectedTransactionNotAMergeHeadError parentUUID))
315+
316+ disconParent <- transactionForUUID parentUUID graph
317+ let subHeads = M.filterWithKey (\k _ -> elem k [headNameA, headNameB]) (transactionHeadsForGraph graph)
318+ subGraph <- subGraphToFirstCommonAncestor graph subHeads emptyTransactionGraph transA transB
319+ --traceShowM ("hello\n" ++ showGraphStructureX subGraph)
320+ case createMergeTransaction newUUID mergeStrategy subGraph (transA, transB) of
321+ Left err -> Left (MergeTransactionError err)
322+ Right mergedTrans -> case headNameForTransaction disconParent graph of
323+ Nothing -> Left (TransactionIsNotAHeadError parentUUID)
324+ Just headName -> do
325+ let newDiscon = newDisconnectedTransaction mergedTransUUID (transactionContext mergedTrans)
326+ mergedTransUUID = transactionUUID mergedTrans
327+ (_, newGraph) <- addDisconnectedTransaction mergedTransUUID headName newDiscon graph
328+ let newGraph' = TransactionGraph newHeads (transactionsForGraph newGraph)
329+ newHeads = M.delete headNameToDelete (transactionHeadsForGraph newGraph)
330+ pure (newDiscon, newGraph')
331+
332+--TEMPORARY COPY/PASTE
333+showTransactionStructureX :: Transaction -> TransactionGraph -> String
334+showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionUUID trans) ++ " " ++ parentTransactionsInfo
335+ where
336+ headInfo = maybe "" show (headNameForTransaction trans graph)
337+ parentTransactionsInfo = if isRootTransaction trans graph then "root" else case parentTransactions trans graph of
338+ Left err -> show err
339+ Right parentTransSet -> concat $ S.toList $ S.map (show . transactionUUID) parentTransSet
340+
341+showGraphStructureX :: TransactionGraph -> String
342+showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet
343+ where
344+ folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n"
345+ headsInfo = show $ M.map transactionUUID heads
project-m36.cabal+8
@@ -392,6 +392,14 @@ Test-Suite test-persistent-driver
392 GHC-Options: -Wall
392 GHC-Options: -Wall
393 C-sources: ProjectM36/DirectoryFsync.c
393 C-sources: ProjectM36/DirectoryFsync.c
394
394
395+Test-Suite test-transactiongraph-merge
396+ Default-Language: Haskell2010
397+ type: exitcode-stdio-1.0
398+ main-is: test/TransactionGraph/Merge.hs
399+ Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, distributed-process, distributed-process-extras, distributed-process-client-server, uuid, stm, deepseq, deepseq-generics, binary, unix, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, parsec, text, base64-bytestring, data-interval, filepath, template-haskell, transformers, aeson, persistent-template, conduit, persistent, either, path-pieces, http-api-data, stm-containers, list-t
400+ GHC-Options: -Wall
401+ C-sources: ProjectM36/DirectoryFsync.c
402+
395benchmark bench
403benchmark bench
396 Default-Language: Haskell2010
404 Default-Language: Haskell2010
397 type: exitcode-stdio-1.0
405 type: exitcode-stdio-1.0
test/TransactionGraph/Merge.hsnew file+107
@@ -0,0 +1,107 @@
1+-- tests for transaction merging
2+{-# LANGUAGE OverloadedStrings #-}
3+import Test.HUnit
4+import ProjectM36.Base
5+import ProjectM36.TransactionGraph
6+import ProjectM36.TransactionGraph.Show
7+import ProjectM36.DateExamples
8+import qualified Data.ByteString.Lazy as BS
9+import System.Exit
10+import Data.Word
11+import qualified Data.UUID as U
12+import qualified ProjectM36.DatabaseContext as DBC
13+import Debug.Trace
14+
15+main :: IO ()
16+main = do
17+ tcounts <- runTestTT testList
18+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
19+
20+testList :: Test
21+testList = TestList [
22+ testSubGraphToFirstAncestorBasic,
23+ testSubGraphToFirstAncestorSnipBranch
24+ --testSelectedBranchMerge
25+ ]
26+
27+-- | Create a transaction graph with two branches and no changes between them.
28+{-
29+root 1
30+|--- branchA aaaa
31+|--- branchB bbbb
32+-}
33+basicTransactionGraph :: IO TransactionGraph
34+basicTransactionGraph = do
35+ let bsGraph = bootstrapTransactionGraph uuidRoot DBC.empty --dateExamples
36+ rootTrans = case transactionForHead "master" bsGraph of
37+ Just trans -> trans
38+ Nothing -> error "bonk"
39+ uuidA = fakeUUID 10
40+ uuidB = fakeUUID 11
41+ uuidRoot = fakeUUID 1
42+ rootContext = transactionContext rootTrans
43+ (_, bsGraph') <- addTransaction "branchA" uuidA rootContext rootTrans bsGraph
44+ (_, bsGraph'') <- addTransaction "branchB" uuidB rootContext rootTrans bsGraph'
45+ pure bsGraph''
46+
47+addTransaction :: HeadName -> U.UUID -> DatabaseContext -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)
48+addTransaction headName newTransUUID context parentTrans graph = case addTransactionToGraph headName parentTrans newTransUUID context graph of
49+ Left err -> assertFailure (show err) >> error ""
50+ Right (t,g) -> pure (t,g)
51+
52+fakeUUID :: Word8 -> U.UUID
53+fakeUUID x = case U.fromByteString (BS.concat (replicate 4 w32)) of
54+ Nothing -> error "impossible uuid"
55+ Just u -> u
56+ where w32 = BS.pack (replicate 4 x)
57+
58+assertEither :: (Show a) => Either a b -> IO b
59+assertEither x = case x of
60+ Left err -> assertFailure (show err) >> undefined
61+ Right val -> pure val
62+
63+assertGraph :: TransactionGraph -> IO ()
64+assertGraph graph = case validateGraph graph of
65+ Nothing -> pure ()
66+ Just errs -> assertFailure (show errs)
67+
68+assertMaybe :: Maybe a -> String -> IO a
69+assertMaybe x msg = case x of
70+ Nothing -> assertFailure msg >> undefined
71+ Just x' -> pure x'
72+
73+-- | Test that a subgraph of the basic graph is equal to the original graph (nothing to filter).
74+testSubGraphToFirstAncestorBasic :: Test
75+testSubGraphToFirstAncestorBasic = TestCase $ do
76+ graph <- basicTransactionGraph
77+ assertGraph graph
78+ transA <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA"
79+ transB <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB"
80+ subgraph <- assertEither $ subGraphToFirstCommonAncestor graph (transactionHeadsForGraph graph) emptyTransactionGraph transA transB
81+ assertEqual "no graph changes" subgraph graph
82+
83+testSubGraphToFirstAncestorSnipBranch :: Test
84+testSubGraphToFirstAncestorSnipBranch = TestCase $ do
85+ baseGraph <- basicTransactionGraph
86+ transA <- assertMaybe (transactionForHead "branchA" baseGraph) "failed to get branchA"
87+ transB <- assertMaybe (transactionForHead "branchB" baseGraph) "failed to get branchB"
88+ rootTrans <- assertEither (transactionForUUID (fakeUUID 1) baseGraph)
89+ (_, graph) <- addTransaction "branchC" (fakeUUID 12) (transactionContext transA) rootTrans baseGraph
90+ subgraph <- assertEither $ subGraphToFirstCommonAncestor graph (transactionHeadsForGraph graph) emptyTransactionGraph transA transB
91+ assertGraph subgraph
92+ -- putStrLn $ showGraphStructure graph
93+ putStrLn $ showGraphStructure subgraph
94+ putStrLn $ showGraphStructure baseGraph
95+ assertEqual "failed to snip branch" (transactionHeadsForGraph subgraph) (transactionHeadsForGraph baseGraph)
96+ pure ()
97+
98+testSelectedBranchMerge :: Test
99+testSelectedBranchMerge = TestCase $ do
100+ graph <- basicTransactionGraph
101+ assertGraph graph
102+ -- putStrLn (showGraphStructure graph)
103+
104+ let eGraph' = mergeTransactions (fakeUUID 3) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") graph
105+ (_, graph') <- assertEither eGraph'
106+ assertGraph graph'
107+ pure ()