git.iko.soy/project-m36
on 43dfe2c help sign in
project-m36/src/lib/ProjectM36/TransactionGraph.hs
547 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
12import qualified ProjectM36.TransactionDiffs as TD
14import qualified Data.Vector as V
15import qualified ProjectM36.Attribute as A
16import qualified Data.UUID as U
17import qualified Data.Set as S
18import qualified Data.Map as M
19import qualified Data.List.NonEmpty as NE
20import Control.Monad
21import Data.Time.Clock
22import qualified Data.Text as T
23import GHC.Generics
24import Data.Binary
25import Data.Either (lefts, rights, isRight)
26--import Data.Monoid
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 = fresh freshId 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
91transactionHeadsForGraph :: TransactionGraph -> TransactionHeads
92transactionHeadsForGraph (TransactionGraph hs _) = hs
94transactionsForGraph :: TransactionGraph -> S.Set Transaction
95transactionsForGraph (TransactionGraph _ ts) = ts
97transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction)
98transactionsForIds idSet graph =
99 S.fromList <$> forM (S.toList idSet) (`transactionForId` graph)
101-- | A root transaction terminates a graph and has no parents.
102isRootTransaction :: Transaction -> Bool
103isRootTransaction trans = diffs trans == TD.root
105-- the first transaction has no parent - all other do have parents- merges have two parents
106parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
107parentTransactions trans graph = transactionsForIds (parentIds trans) graph
109childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
110childTransactions trans graph = transactionsForIds childIds graph
111 where
112 childIds = S.map transactionId (S.filter filt (transactionsForGraph graph))
113 filt trans' = S.member (transactionId trans) (parentIds trans')
115-- create a new commit and add it to the heads
116-- 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)
117addBranch :: UTCTime -> TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
118addBranch stamp' newId newBranchName branchPointId graph = do
119 parentTrans <- transactionForId branchPointId graph
120 let newTrans = Transaction newId (TransactionInfo {
121 parents = TD.single branchPointId NoOperation,
122 stamp = stamp'}) (schemas parentTrans)
123 addTransactionToGraph newBranchName newTrans graph
125--adds a disconnected transaction to a transaction graph at some head
126addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
127addDisconnectedTransaction stamp' newId headName discon@(DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName newTrans
128 where
129 newTrans = Transaction newId (TransactionInfo {
130 parents = TD.single parentId (Discon.diffExpr discon),
131 stamp = stamp'}) schemas'
134addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
135addTransactionToGraph headName newTrans graph = do
136 let parentIds' = parentIds newTrans
137 newId = transactionId newTrans
138 validateIds ids = mapM (`transactionForId` graph) (S.toList ids)
139 childTs <- childTransactions newTrans graph
140 --validate that the parent transactions are in the graph
141 _ <- validateIds parentIds'
142 when (S.size parentIds' < 1) (Left $ NewTransactionMissingParentError newId)
143 --if the headName already exists, ensure that it refers to a parent
144 case transactionForHead headName graph of
145 Nothing -> pure () -- any headName is OK
146 Just trans -> when (S.notMember (transactionId trans) parentIds') (Left (HeadNameSwitchingHeadProhibitedError headName))
147 --validate that the transaction has no children
148 unless (S.null childTs) (Left $ NewTransactionMayNotHaveChildrenError newId)
149 --validate that the trasaction's id is unique
150 when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))
152 let updatedTransSet = S.insert newTrans (transactionsForGraph graph)
153 updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph)
154 pure (newTrans, TransactionGraph updatedHeads updatedTransSet)
156validateGraph :: TransactionGraph -> Maybe [RelationalError]
157validateGraph graph@(TransactionGraph _ transSet) = do
158 --check that all transaction ids are unique in the graph
159 --FINISH ME!
160 --uuids = map transactionId transSet
161 --check that all heads appear in the transSet
162 --check that all forward and backward links are in place
163 mapM_ (walkParentTransactions S.empty graph) (S.toList transSet)
164 mapM (walkChildTransactions S.empty graph) (S.toList transSet)
166--verify that all parent links exist and that all children exist
167--maybe verify that all parents end at transaction id nil and all children end at leaves
168walkParentTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
169walkParentTransactions seenTransSet graph trans =
170 let transId = transactionId trans in
171 if transId == U.nil then
172 Nothing
173 else if S.member transId seenTransSet then
174 Just $ TransactionGraphCycleError transId
175 else
176 let parentTransSetOrError = parentTransactions trans graph in
177 case parentTransSetOrError of
178 Left err -> Just err
179 Right parentTransSet -> do
180 walk <- mapM (walkParentTransactions (S.insert transId seenTransSet) graph) (S.toList parentTransSet)
181 case walk of
182 err:_ -> Just err
183 _ -> Nothing
185--refactor: needless duplication in these two functions
186walkChildTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
187walkChildTransactions seenTransSet graph trans =
188 let transId = transactionId trans in
189 if childTransactions trans graph == Right S.empty then
190 Nothing
191 else if S.member transId seenTransSet then
192 Just $ TransactionGraphCycleError transId
193 else
194 let childTransSetOrError = childTransactions trans graph in
195 case childTransSetOrError of
196 Left err -> Just err
197 Right childTransSet -> do
198 walk <- mapM (walkChildTransactions (S.insert transId seenTransSet) graph) (S.toList childTransSet)
199 case walk of
200 err:_ -> Just err
201 _ -> Nothing
203-- returns the new "current" transaction, updated graph, and tutorial d result
204-- the current transaction is not part of the transaction graph until it is committed
205evalGraphOp :: UTCTime -> TransactionId -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
207evalGraphOp _ _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId graph of
208 Left err -> Left err
209 Right parentTrans -> Right (newTrans, graph)
210 where
211 newTrans = DisconnectedTransaction jumpId (schemas parentTrans) NoOperation
213-- switch from one head to another
214evalGraphOp _ _ _ graph (JumpToHead headName) =
215 case transactionForHead headName graph of
216 Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) NoOperation in
217 Right (disconnectedTrans, graph)
218 Nothing -> Left $ NoSuchHeadNameError headName
220evalGraphOp _ _ discon graph (WalkBackToTime backTime) = do
221 let startTransId = Discon.parentId discon
222 jumpDest <- backtrackGraph graph startTransId (TransactionStampHeadBacktrack backTime)
223 case transactionForId jumpDest graph of
224 Left err -> Left err
225 Right trans -> do
226 let disconnectedTrans = Discon.freshTransaction (transactionId trans) (schemas trans)
227 Right (disconnectedTrans, graph)
229-- add new head pointing to branchPoint
230-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)
231-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch
232 {-
233evalGraphOp newId discon@(DisconnectedTransaction parentId disconContext) graph (Branch newBranchName) = case transactionForId parentId graph of
234 Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")
235 Just parentTrans -> case addBranch newBranchName parentTrans graph of
236 Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")
237 Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")
238 where
239 newDiscon = DisconnectedTransaction (transactionId parentTrans) disconContext
240-}
242-- create a new commit and add it to the heads
243-- 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)
244evalGraphOp stamp' newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do
245 let newDiscon = Discon.freshTransaction newId schemas'
246 case addBranch stamp' newId newBranchName parentId graph of
247 Left err -> Left err
248 Right (_, newGraph) -> Right (newDiscon, newGraph)
250-- add the disconnected transaction to the graph
251-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
252evalGraphOp stamp' newTransId discon@(DisconnectedTransaction parentId schemas' _) graph Commit = case transactionForId parentId graph of
253 Left err -> Left err
254 Right parentTransaction -> case headNameForTransaction parentTransaction graph of
255 Nothing -> Left $ TransactionIsNotAHeadError parentId
256 Just headName -> case maybeUpdatedGraph of
257 Left err-> Left err
258 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)
259 where
260 newDisconnectedTrans = Discon.freshTransaction newTransId schemas'
261 maybeUpdatedGraph = addDisconnectedTransaction stamp' newTransId headName discon graph
263-- refresh the disconnected transaction, return the same graph
264evalGraphOp _ _ (DisconnectedTransaction parentId _ _) graph Rollback = case transactionForId parentId graph of
265 Left err -> Left err
266 Right parentTransaction -> Right (newDiscon, graph)
267 where
268 newDiscon = Discon.freshTransaction parentId (schemas parentTransaction)
270evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) graph
272evalGraphOp _ _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of
273 Nothing -> Left (NoSuchHeadNameError branchName)
274 Just _ -> Right (discon, TransactionGraph (M.delete branchName graphHeads) transSet)
276--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
277graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
278graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _ transSet) = do
279 tupleMatrix <- mapM tupleGenerator (S.toList transSet)
280 mkRelationFromList attrs tupleMatrix
281 where
282 attrs = A.attributesFromList [Attribute "id" TextAtomType,
283 Attribute "stamp" DateTimeAtomType,
284 Attribute "parents" (RelationAtomType parentAttributes),
285 Attribute "current" BoolAtomType,
286 Attribute "head" TextAtomType
287 ]
288 parentAttributes = A.attributesFromList [Attribute "id" TextAtomType]
289 tupleGenerator transaction = case transactionParentsRelation transaction graph of
290 Left err -> Left err
291 Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),
292 DateTimeAtom (timestamp transaction),
293 RelationAtom parentTransRel,
294 BoolAtom $ parentId == transactionId transaction,
295 TextAtom $ fromMaybe "" (headNameForTransaction transaction graph)
296 ]
298transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
299transactionParentsRelation trans graph =
300 if isRootTransaction trans then
301 mkRelation attrs emptyTupleSet
302 else do
303 parentTransSet <- parentTransactions trans graph
304 let tuples = map trans2tuple (S.toList parentTransSet)
305 mkRelationFromTuples attrs tuples
306 where
307 attrs = A.attributesFromList [Attribute "id" TextAtomType]
308 trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (TextAtom (T.pack (show $ transactionId trans2)))
310{-
311--display transaction graph as relation
312evalROGraphOp :: DisconnectedTransaction -> TransactionGraph -> ROTransactionGraphOperator -> Either RelationalError Relation
313evalROGraphOp discon graph ShowGraph = do
314 graphRel <- graphAsRelation discon graph
315 return graphRel
316-}
318-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph
319createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
320createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do
321 let selectedTrans = validateHeadName selectedBranch graph t2
322 Transaction newId (TransactionInfo {
323 parents = NE.fromList [(transactionId trans1, undefined),
324 (transactionId trans2, undefined)],
325 stamp = stamp' }) . schemas <$> selectedTrans
327-- merge functions, relvars, individually
328createMergeTransaction stamp' newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp' newId strat graph t2
330-- merge function, relvars, but, on error, just take the component from the preferred branch
331createMergeTransaction stamp' newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction stamp' newId strat graph t2
333-- | 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.
334validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
335validateHeadName headName graph (t1, t2) =
336 case transactionForHead headName graph of
337 Nothing -> Left SelectedHeadMismatchMergeError
338 Just trans -> if trans /= t1 && trans /= t2 then
339 Left SelectedHeadMismatchMergeError
340 else
341 Right trans
343-- 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.
344subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph
345subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans traverseSet = do
346 let currentid = transactionId currentTrans
347 goalid = transactionId goalTrans
348 if currentTrans == goalTrans then
349 Right (TransactionGraph resultHeads traverseSet) -- add filter
350 --catch root transaction to improve error?
351 else do
352 currentTransChildren <- childTransactions currentTrans origGraph
353 let searchChildren = S.difference (S.insert currentTrans traverseSet) currentTransChildren
354 searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans traverseSet)
355 childSearches = map searchChild (S.toList searchChildren)
356 errors = lefts childSearches
357 pathsFound = rights childSearches
358 realErrors = filter (/= FailedToFindTransactionError goalid) errors
359 -- report any non-search-related errors
360 unless (null realErrors) (Left (head realErrors))
361 -- if no paths found, search the parent
362 if null pathsFound then
363 case oneParent currentTrans of
364 Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)
365 Left err -> Left err
366 Right currentTransParent ->
367 subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans traverseSet)
368 else -- we found a path
369 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))
370 where
371 oneParent (Transaction _ tinfo _) = transactionForId (fst (NE.head (parents tinfo))) origGraph
373-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.
374pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)
375pathToTransaction graph currentTransaction targetTransaction accumTransSet = do
376 let targetId = transactionId targetTransaction
377 if transactionId targetTransaction == transactionId currentTransaction then
378 Right accumTransSet
379 else do
380 currentTransChildren <- childTransactions currentTransaction graph
381 if null currentTransChildren then
382 Left (FailedToFindTransactionError targetId)
383 else do
384 let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) (S.toList currentTransChildren)
385 let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)
386 paths = rights searches
387 if not (null realErrors) then -- found some real errors
388 Left (head realErrors)
389 else if null paths then -- failed to find transaction in all children
390 Left (FailedToFindTransactionError targetId)
391 else --we have some paths!
392 Right (S.unions paths)
394mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
395mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) graph = do
396 let transactionForHeadErr name = case transactionForHead name graph of
397 Nothing -> Left (NoSuchHeadNameError name)
398 Just t -> Right t
399 transA <- transactionForHeadErr headNameA
400 transB <- transactionForHeadErr headNameB
401 disconParent <- transactionForId parentId graph
402 let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph)
403 subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty
404 subGraph' <- filterSubGraph subGraph subHeads
405 case createMergeTransaction stamp' newId mergeStrategy subGraph' (transA, transB) of
406 Left err -> Left (MergeTransactionError err)
407 Right mergedTrans -> case checkConstraints (concreteDatabaseContext mergedTrans) of
408 Left err -> Left err
409 Right _ -> case headNameForTransaction disconParent graph of
410 Nothing -> Left (TransactionIsNotAHeadError parentId)
411 Just headName -> do
412 (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph
413 let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)
414 newDiscon = Discon.freshTransaction newId (schemas newTrans)
415 pure (newDiscon, newGraph')
417--TEMPORARY COPY/PASTE
418showTransactionStructureX :: Transaction -> TransactionGraph -> String
419showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo
420 where
421 headInfo = maybe "" show (headNameForTransaction trans graph)
422 parentTransactionsInfo = if isRootTransaction trans then "root" else case parentTransactions trans graph of
423 Left err -> show err
424 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet
426showGraphStructureX :: TransactionGraph -> String
427showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet
428 where
429 folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n"
430 headsInfo = show $ M.map transactionId heads
432-- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph.
433filterSubGraph :: TransactionGraph -> TransactionHeads -> Either RelationalError TransactionGraph
434filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet
435 where
436 validIds = S.map transactionId (transactionsForGraph graph)
437 newTransSet = S.map (filterTransaction validIds) (transactionsForGraph graph)
438 newHeads = M.map (filterTransaction validIds) heads
440--helper function for commonalities in union merge
441createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
442createUnionMergeTransaction stamp' newId strategy graph (t1,t2) = do
443 let contextA = concreteDatabaseContext t1
444 contextB = concreteDatabaseContext t2
446 preference <- case strategy of
447 UnionMergeStrategy -> pure PreferNeither
448 UnionPreferMergeStrategy preferBranch ->
449 case transactionForHead preferBranch graph of
450 Nothing -> Left (PreferredHeadMissingMergeError preferBranch)
451 Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond
452 badStrat -> Left (InvalidMergeStrategyError badStrat)
454 incDeps <- unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)
455 relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)
456 atomFuncs <- unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)
457 notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB)
458 types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)
459 dbcFuncs <- unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)
460 -- TODO: add merge of subschemas
461 let newContext = DatabaseContext {
462 inclusionDependencies = incDeps,
463 relationVariables = relVars,
464 atomFunctions = atomFuncs,
465 dbcFunctions = dbcFuncs,
466 notifications = notifs,
467 typeConstructorMapping = types
468 }
469 newSchemas = Schemas newContext (subschemas t1)
470 pure (Transaction newId (TransactionInfo {
471 parents = NE.fromList [(transactionId t1, undefined),
472 (transactionId t2, undefined)],
473 stamp = 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 parentIds' = S.toList (parentIds trans)
491 if length parentIds' < 1 then
492 Left RootTransactionTraversalError
493 else do
494 parentTrans <- transactionForId (head parentIds') 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 parentIds' = parentIds trans
503 if S.size parentIds' < 1 then
504 Left RootTransactionTraversalError
505 else if S.size parentIds' < steps then
506 Left (ParentCountTraversalError (S.size parentIds') steps)
507 else
508 pure (S.elemAt (steps - 1) parentIds')
510backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp') = do
511 trans <- transactionForId currentTid graph
512 let parentIds' = parentIds trans
513 if timestamp trans <= stamp' then
514 pure currentTid
515 else if S.null parentIds' then
516 Left RootTransactionTraversalError
517 else
518 let arbitraryParent = head (S.toList parentIds') 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''''')