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