git.iko.soy/project-m36
on fbfa2ea help sign in
project-m36/src/lib/ProjectM36/TransactionGraph.hs
546 lines 31 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 ProjectM36.RelationalExpression
10import ProjectM36.TransactionGraph.Merge
11import qualified ProjectM36.DisconnectedTransaction as Discon
13import qualified Data.Vector as V
14import qualified ProjectM36.Attribute as A
15import qualified Data.UUID as U
16import qualified Data.Set as S
17import qualified Data.Map as M
18import Control.Monad
19import Data.Time.Clock
20import qualified Data.Text as T
21import GHC.Generics
22import Data.Binary
23import Data.Either (lefts, rights, isRight)
24import Data.Monoid
25import Control.Arrow
26import Data.Maybe
28{-
29import Debug.Trace
30import Control.Monad.Reader
31import qualified ProjectM36.DisconnectedTransaction as D
32-}
34-- | Record a lookup for a specific transaction in the graph.
35data TransactionIdLookup = TransactionIdLookup TransactionId |
36 TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]
37 deriving (Show, Eq, Binary, Generic)
39-- | Used for git-style head backtracking such as topic~3^2.
40data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- ^ git equivalent of ~: walk back n parents, arbitrarily choosing a parent when a choice must be made
41 TransactionIdHeadBranchBacktrack Int | -- ^ git equivalent of ^: walk back one parent level to the nth arbitrarily-chosen parent
42 TransactionStampHeadBacktrack UTCTime -- ^ git equivalent of 'git-rev-list -n 1 --before X' find the first transaction which was created before the timestamp
43 deriving (Show, Eq, Binary, Generic)
46-- | Operators which manipulate a transaction graph and which transaction the current 'Session' is based upon.
47data TransactionGraphOperator = JumpToHead HeadName |
48 JumpToTransaction TransactionId |
49 WalkBackToTime UTCTime |
50 Branch HeadName |
51 DeleteBranch HeadName |
52 MergeTransactions MergeStrategy HeadName HeadName |
53 Commit |
54 Rollback
55 deriving (Eq, Show, Binary, Generic)
57isCommit :: TransactionGraphOperator -> Bool
58isCommit Commit = True
59isCommit _ = False
61data ROTransactionGraphOperator = ShowGraph
62 deriving Show
64bootstrapTransactionGraph :: UTCTime -> TransactionId -> DatabaseContext -> TransactionGraph
65bootstrapTransactionGraph stamp freshId context = TransactionGraph bootstrapHeads bootstrapTransactions
66 where
67 bootstrapHeads = M.singleton "master" freshTransaction
68 newSchemas = Schemas context M.empty
69 freshTransaction = Transaction freshId (TransactionInfo U.nil S.empty stamp) newSchemas
70 bootstrapTransactions = S.singleton freshTransaction
72emptyTransactionGraph :: TransactionGraph
73emptyTransactionGraph = TransactionGraph M.empty S.empty
75transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction
76transactionForHead headName graph = M.lookup headName (transactionHeadsForGraph graph)
78headList :: TransactionGraph -> [(HeadName, TransactionId)]
79headList graph = map (second transactionId) (M.assocs (transactionHeadsForGraph graph))
81headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName
82headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then
83 Nothing
84 else
85 Just $ (head . M.keys) matchingTrans
86 where
87 matchingTrans = M.filter (transaction ==) heads
89transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction
90transactionForId tid graph
91 | tid == U.nil =
92 Left RootTransactionTraversalError
93 | S.null matchingTrans =
94 Left $ NoSuchTransactionError tid
95 | otherwise =
96 Right $ head (S.toList matchingTrans)
97 where
98 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
100transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction)
101transactionsForIds idSet graph = do
102 transList <- forM (S.toList idSet) (`transactionForId` graph)
103 return (S.fromList transList)
105isRootTransaction :: Transaction -> TransactionGraph -> Bool
106isRootTransaction (Transaction _ (TransactionInfo pId _ _) _) _ = U.null pId
107isRootTransaction (Transaction _ MergeTransactionInfo{} _) _ = False
109-- the first transaction has no parent - all other do have parents- merges have two parents
110parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
111parentTransactions (Transaction _ (TransactionInfo pId _ _) _) graph = do
112 trans <- transactionForId pId graph
113 return (S.singleton trans)
115parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph
118childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
119childTransactions (Transaction _ (TransactionInfo _ children _) _) = transactionsForIds children
120childTransactions (Transaction _ (MergeTransactionInfo _ _ children _) _) = transactionsForIds children
122-- create a new commit and add it to the heads
123-- 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)
124addBranch :: UTCTime -> TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
125addBranch stamp newId newBranchName branchPointId graph = do
126 parentTrans <- transactionForId branchPointId graph
127 let newTrans = Transaction newId (TransactionInfo branchPointId S.empty stamp) (schemas parentTrans)
128 addTransactionToGraph newBranchName newTrans graph
130--adds a disconnected transaction to a transaction graph at some head
131addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
132addDisconnectedTransaction stamp newId headName (DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty stamp) schemas')
135addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
136addTransactionToGraph headName newTrans graph = do
137 let parentIds = transactionParentIds newTrans
138 childIds = transactionChildIds newTrans
139 newId = transactionId newTrans
140 validateIds ids = mapM (`transactionForId` graph) (S.toList ids)
141 addChildTransaction trans = transactionSetChildren trans (S.insert newId (transactionChildIds trans))
142 --validate that the parent transactions are in the graph
143 _ <- validateIds parentIds
144 when (S.size parentIds < 1) (Left $ NewTransactionMissingParentError newId)
145 --if the headName already exists, ensure that it refers to a parent
146 case transactionForHead headName graph of
147 Nothing -> pure () -- any headName is OK
148 Just trans -> when (S.notMember (transactionId trans) parentIds) (Left (HeadNameSwitchingHeadProhibitedError headName))
149 --validate that the transaction has no children
150 unless (S.null childIds) (Left $ NewTransactionMayNotHaveChildrenError newId)
151 --validate that the trasaction's id is unique
152 when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))
153 --update the parent transactions to point to the new transaction
154 parents <- mapM (`transactionForId` graph) (S.toList parentIds)
155 let updatedParents = S.map addChildTransaction (S.fromList parents)
156 updatedTransSet = S.insert newTrans (S.union updatedParents (transactionsForGraph graph))
157 updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph)
158 pure (newTrans, TransactionGraph updatedHeads updatedTransSet)
160validateGraph :: TransactionGraph -> Maybe [RelationalError]
161validateGraph graph@(TransactionGraph _ transSet) = do
162 --check that all transaction ids are unique in the graph
163 --FINISH ME!
164 --uuids = map transactionId transSet
165 --check that all heads appear in the transSet
166 --check that all forward and backward links are in place
167 _ <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)
168 mapM (walkChildTransactions S.empty graph) (S.toList transSet)
170--verify that all parent links exist and that all children exist
171--maybe verify that all parents end at transaction id nil and all children end at leaves
172walkParentTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
173walkParentTransactions seenTransSet graph trans =
174 let transId = transactionId trans in
175 if transId == U.nil then
176 Nothing
177 else if S.member transId seenTransSet then
178 Just $ TransactionGraphCycleError transId
179 else
180 let parentTransSetOrError = parentTransactions trans graph in
181 case parentTransSetOrError of
182 Left err -> Just err
183 Right parentTransSet -> do
184 walk <- mapM (walkParentTransactions (S.insert transId seenTransSet) graph) (S.toList parentTransSet)
185 case walk of
186 err:_ -> Just err
187 _ -> Nothing
189--refactor: needless duplication in these two functions
190walkChildTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
191walkChildTransactions seenTransSet graph trans =
192 let transId = transactionId trans in
193 if childTransactions trans graph == Right S.empty then
194 Nothing
195 else if S.member transId seenTransSet then
196 Just $ TransactionGraphCycleError transId
197 else
198 let childTransSetOrError = childTransactions trans graph in
199 case childTransSetOrError of
200 Left err -> Just err
201 Right childTransSet -> do
202 walk <- mapM (walkChildTransactions (S.insert transId seenTransSet) graph) (S.toList childTransSet)
203 case walk of
204 err:_ -> Just err
205 _ -> Nothing
207-- returns the new "current" transaction, updated graph, and tutorial d result
208-- the current transaction is not part of the transaction graph until it is committed
209evalGraphOp :: UTCTime -> TransactionId -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
211evalGraphOp _ _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId graph of
212 Left err -> Left err
213 Right parentTrans -> Right (newTrans, graph)
214 where
215 newTrans = DisconnectedTransaction jumpId (schemas parentTrans) False
217-- switch from one head to another
218evalGraphOp _ _ _ graph (JumpToHead headName) =
219 case transactionForHead headName graph of
220 Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) False in
221 Right (disconnectedTrans, graph)
222 Nothing -> Left $ NoSuchHeadNameError headName
224evalGraphOp _ _ discon graph (WalkBackToTime backTime) = do
225 let startTransId = Discon.parentId discon
226 jumpDest <- backtrackGraph graph startTransId (TransactionStampHeadBacktrack backTime)
227 case transactionForId jumpDest graph of
228 Left err -> Left err
229 Right trans -> do
230 let disconnectedTrans = DisconnectedTransaction (transactionId trans) (schemas trans) False
231 Right (disconnectedTrans, graph)
233-- add new head pointing to branchPoint
234-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)
235-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch
236 {-
237evalGraphOp newId discon@(DisconnectedTransaction parentId disconContext) graph (Branch newBranchName) = case transactionForId parentId graph of
238 Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")
239 Just parentTrans -> case addBranch newBranchName parentTrans graph of
240 Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")
241 Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")
242 where
243 newDiscon = DisconnectedTransaction (transactionId parentTrans) disconContext
244-}
246-- create a new commit and add it to the heads
247-- 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)
248evalGraphOp stamp newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do
249 let newDiscon = DisconnectedTransaction newId schemas' False
250 case addBranch stamp newId newBranchName parentId graph of
251 Left err -> Left err
252 Right (_, newGraph) -> Right (newDiscon, newGraph)
254-- add the disconnected transaction to the graph
255-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
256evalGraphOp stamp newTransId discon@(DisconnectedTransaction parentId schemas' _) graph Commit = case transactionForId parentId graph of
257 Left err -> Left err
258 Right parentTransaction -> case headNameForTransaction parentTransaction graph of
259 Nothing -> Left $ TransactionIsNotAHeadError parentId
260 Just headName -> case maybeUpdatedGraph of
261 Left err-> Left err
262 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)
263 where
264 newDisconnectedTrans = DisconnectedTransaction newTransId schemas' False
265 maybeUpdatedGraph = addDisconnectedTransaction stamp newTransId headName discon graph
267-- refresh the disconnected transaction, return the same graph
268evalGraphOp _ _ (DisconnectedTransaction parentId _ _) graph Rollback = case transactionForId parentId graph of
269 Left err -> Left err
270 Right parentTransaction -> Right (newDiscon, graph)
271 where
272 newDiscon = DisconnectedTransaction parentId (schemas parentTransaction) False
274evalGraphOp stamp newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions stamp newId parentId mergeStrategy (headNameA, headNameB) graph
276evalGraphOp _ _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of
277 Nothing -> Left (NoSuchHeadNameError branchName)
278 Just _ -> Right (discon, TransactionGraph (M.delete branchName graphHeads) transSet)
280--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
281graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
282graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _ transSet) = do
283 tupleMatrix <- mapM tupleGenerator (S.toList transSet)
284 mkRelationFromList attrs tupleMatrix
285 where
286 attrs = A.attributesFromList [Attribute "id" TextAtomType,
287 Attribute "stamp" DateTimeAtomType,
288 Attribute "parents" (RelationAtomType parentAttributes),
289 Attribute "current" BoolAtomType,
290 Attribute "head" TextAtomType
291 ]
292 parentAttributes = A.attributesFromList [Attribute "id" TextAtomType]
293 tupleGenerator transaction = case transactionParentsRelation transaction graph of
294 Left err -> Left err
295 Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),
296 DateTimeAtom (transactionTimestamp transaction),
297 RelationAtom parentTransRel,
298 BoolAtom $ parentId == transactionId transaction,
299 TextAtom $ fromMaybe "" (headNameForTransaction transaction graph)
300 ]
302transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
303transactionParentsRelation trans graph =
304 if isRootTransaction trans graph then
305 mkRelation attrs emptyTupleSet
306 else do
307 parentTransSet <- parentTransactions trans graph
308 let tuples = map trans2tuple (S.toList parentTransSet)
309 mkRelationFromTuples attrs tuples
310 where
311 attrs = A.attributesFromList [Attribute "id" TextAtomType]
312 trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (TextAtom (T.pack (show $ transactionId trans2)))
314{-
315--display transaction graph as relation
316evalROGraphOp :: DisconnectedTransaction -> TransactionGraph -> ROTransactionGraphOperator -> Either RelationalError Relation
317evalROGraphOp discon graph ShowGraph = do
318 graphRel <- graphAsRelation discon graph
319 return graphRel
320-}
322-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph
323createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
324createMergeTransaction stamp newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do
325 selectedTrans <- validateHeadName selectedBranch graph t2
326 pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty stamp) (schemas selectedTrans)
328-- merge functions, relvars, individually
329createMergeTransaction stamp newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp newId strat graph t2
331-- merge function, relvars, but, on error, just take the component from the preferred branch
332createMergeTransaction stamp newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction stamp newId strat graph t2
334-- | 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.
335validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
336validateHeadName headName graph (t1, t2) =
337 case transactionForHead headName graph of
338 Nothing -> Left SelectedHeadMismatchMergeError
339 Just trans -> if trans /= t1 && trans /= t2 then
340 Left SelectedHeadMismatchMergeError
341 else
342 Right trans
344-- 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.
345subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph
346subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans traverseSet = do
347 let currentid = transactionId currentTrans
348 goalid = transactionId goalTrans
349 if currentTrans == goalTrans then
350 Right (TransactionGraph resultHeads traverseSet) -- add filter
351 --catch root transaction to improve error?
352 else do
353 currentTransChildren <- S.fromList <$> mapM (`transactionForId` origGraph) (S.toList (transactionChildIds currentTrans))
354 let searchChildren = S.difference (S.insert currentTrans traverseSet) currentTransChildren
355 searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans traverseSet)
356 childSearches = map searchChild (S.toList searchChildren)
357 errors = lefts childSearches
358 pathsFound = rights childSearches
359 realErrors = filter (/= FailedToFindTransactionError goalid) errors
360 -- report any non-search-related errors
361 unless (null realErrors) (Left (head realErrors))
362 -- if no paths found, search the parent
363 if null pathsFound then
364 case oneParent currentTrans of
365 Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)
366 Left err -> Left err
367 Right currentTransParent ->
368 subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans traverseSet)
369 else -- we found a path
370 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))
371 where
372 oneParent (Transaction _ (TransactionInfo parentId _ _) _) = transactionForId parentId origGraph
373 oneParent (Transaction _ (MergeTransactionInfo parentId _ _ _) _) = transactionForId parentId origGraph
375-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.
376pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)
377pathToTransaction graph currentTransaction targetTransaction accumTransSet = do
378 let targetId = transactionId targetTransaction
379 if transactionId targetTransaction == transactionId currentTransaction then
380 Right accumTransSet
381 else do
382 currentTransChildren <- mapM (`transactionForId` graph) (S.toList (transactionChildIds currentTransaction))
383 if null currentTransChildren then
384 Left (FailedToFindTransactionError targetId)
385 else do
386 let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) currentTransChildren
387 let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)
388 paths = rights searches
389 if not (null realErrors) then -- found some real errors
390 Left (head realErrors)
391 else if null paths then -- failed to find transaction in all children
392 Left (FailedToFindTransactionError targetId)
393 else --we have some paths!
394 Right (S.unions paths)
396mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
397mergeTransactions stamp newId parentId mergeStrategy (headNameA, headNameB) graph = do
398 let transactionForHeadErr name = case transactionForHead name graph of
399 Nothing -> Left (NoSuchHeadNameError name)
400 Just t -> Right t
401 transA <- transactionForHeadErr headNameA
402 transB <- transactionForHeadErr headNameB
403 disconParent <- transactionForId parentId graph
404 let subHeads = M.filterWithKey (\k _ -> elem k [headNameA, headNameB]) (transactionHeadsForGraph graph)
405 subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty
406 subGraph' <- filterSubGraph subGraph subHeads
407 case createMergeTransaction stamp newId mergeStrategy subGraph' (transA, transB) of
408 Left err -> Left (MergeTransactionError err)
409 Right mergedTrans -> case checkConstraints (concreteDatabaseContext mergedTrans) of
410 Just err -> Left err
411 Nothing -> case headNameForTransaction disconParent graph of
412 Nothing -> Left (TransactionIsNotAHeadError parentId)
413 Just headName -> do
414 (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph
415 let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)
416 newDiscon = DisconnectedTransaction newId (schemas newTrans) False
417 pure (newDiscon, newGraph')
419--TEMPORARY COPY/PASTE
420showTransactionStructureX :: Transaction -> TransactionGraph -> String
421showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo
422 where
423 headInfo = maybe "" show (headNameForTransaction trans graph)
424 parentTransactionsInfo = if isRootTransaction trans graph then "root" else case parentTransactions trans graph of
425 Left err -> show err
426 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet
428showGraphStructureX :: TransactionGraph -> String
429showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet
430 where
431 folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n"
432 headsInfo = show $ M.map transactionId heads
434-- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph.
435filterSubGraph :: TransactionGraph -> TransactionHeads -> Either RelationalError TransactionGraph
436filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet
437 where
438 validIds = S.map transactionId (transactionsForGraph graph)
439 newTransSet = S.map (filterTransaction validIds) (transactionsForGraph graph)
440 newHeads = M.map (filterTransaction validIds) heads
442--helper function for commonalities in union merge
443createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
444createUnionMergeTransaction stamp newId strategy graph (t1,t2) = do
445 let contextA = concreteDatabaseContext t1
446 contextB = concreteDatabaseContext t2
448 preference <- case strategy of
449 UnionMergeStrategy -> pure PreferNeither
450 UnionPreferMergeStrategy preferBranch ->
451 case transactionForHead preferBranch graph of
452 Nothing -> Left (PreferredHeadMissingMergeError preferBranch)
453 Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond
454 badStrat -> Left (InvalidMergeStrategyError badStrat)
456 incDeps <- unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)
457 relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)
458 atomFuncs <- unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)
459 notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB)
460 types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)
461 dbcFuncs <- unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)
462 -- TODO: add merge of subschemas
463 let newContext = DatabaseContext {
464 inclusionDependencies = incDeps,
465 relationVariables = relVars,
466 atomFunctions = atomFuncs,
467 dbcFunctions = dbcFuncs,
468 notifications = notifs,
469 typeConstructorMapping = types
470 }
471 newSchemas = Schemas newContext (subschemas t1)
472 pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty stamp) newSchemas)
474lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction
475lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph
476lookupTransaction graph (TransactionIdHeadNameLookup headName backtracks) = case transactionForHead headName graph of
477 Nothing -> Left (NoSuchHeadNameError headName)
478 Just headTrans -> do
479 traversedId <- traverseGraph graph (transactionId headTrans) backtracks
480 transactionForId traversedId graph
482traverseGraph :: TransactionGraph -> TransactionId -> [TransactionIdHeadBacktrack] -> Either RelationalError TransactionId
483traverseGraph graph = foldM (backtrackGraph graph)
485backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrack -> Either RelationalError TransactionId
486-- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily
487backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do
488 trans <- transactionForId currentTid graph
489 let parents = S.toAscList (transactionParentIds trans)
490 if length parents < 1 then
491 Left RootTransactionTraversalError
492 else do
493 parentTrans <- transactionForId (head parents) graph
494 if steps == 1 then
495 pure (transactionId parentTrans)
496 else
497 backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1))
499backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do
500 trans <- transactionForId currentTid graph
501 let parents = transactionParentIds trans
502 if S.size parents < 1 then
503 Left RootTransactionTraversalError
504 else if S.size parents < steps then
505 Left (ParentCountTraversalError (S.size parents) steps)
506 else
507 pure (S.elemAt (steps - 1) parents)
509backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp) = do
510 trans <- transactionForId currentTid graph
511 let parents = transactionParentIds trans
512 if transactionTimestamp trans < stamp then
513 pure currentTid
514 else if S.null parents then
515 Left RootTransactionTraversalError
516 else
517 let arbitraryParent = head (S.toList parents) in
518 backtrackGraph graph arbitraryParent btrack
520-- | Create a temporary branch for commit, merge the result to head, delete the temporary branch. This is useful to atomically commit a transaction, avoiding a TransactionIsNotHeadError but trading it for a potential MergeError.
521--this is not a GraphOp because it combines multiple graph operations
522autoMergeToHead :: UTCTime -> (TransactionId, TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
523autoMergeToHead stamp (tempBranchTransId, tempCommitTransId, mergeTransId) discon mergeToHeadName strat graph = do
524 let tempBranchName = "mergebranch_" <> U.toText tempBranchTransId
525 --create the temp branch
526 (discon', graph') <- evalGraphOp stamp tempBranchTransId discon graph (Branch tempBranchName)
528 --commit to the new branch- possible future optimization: don't require fsync for this- create a temp commit type
529 (discon'', graph'') <- evalGraphOp stamp tempCommitTransId discon' graph' Commit
531 --jump to merge head
532 (discon''', graph''') <- evalGraphOp stamp tempBranchTransId discon'' graph'' (JumpToHead mergeToHeadName)
534 --create the merge
535 (discon'''', graph'''') <- evalGraphOp stamp mergeTransId discon''' graph''' (MergeTransactions strat tempBranchName mergeToHeadName)
537 --delete the temp branch
538 (discon''''', graph''''') <- evalGraphOp stamp tempBranchTransId discon'''' graph'''' (DeleteBranch tempBranchName)
539 {-
540 let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''')
541 traceShowM rel
542-}
544 pure (discon''''', graph''''')