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