git.iko.soy/project-m36
on cfa7253 help sign in
project-m36/src/lib/ProjectM36/TransactionGraph.hs
558 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
97transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction
98transactionForId tid graph
99 | tid == U.nil =
100 Left RootTransactionTraversalError
101 | S.null matchingTrans =
102 Left $ NoSuchTransactionError tid
103 | otherwise =
104 Right $ head (S.toList matchingTrans)
105 where
106 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
108transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction)
109transactionsForIds idSet graph =
110 S.fromList <$> forM (S.toList idSet) (`transactionForId` graph)
112-- | A root transaction terminates a graph and has no parents.
113isRootTransaction :: Transaction -> Bool
114isRootTransaction trans = diffs trans == TD.root
116-- the first transaction has no parent - all other do have parents- merges have two parents
117parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
118parentTransactions trans graph = transactionsForIds (parentIds trans) graph
120childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
121childTransactions trans graph = transactionsForIds childIds graph
122 where
123 childIds = S.map transactionId (S.filter filt (transactionsForGraph graph))
124 filt trans' = S.member (transactionId trans) (parentIds trans')
126-- create a new commit and add it to the heads
127-- 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)
128addBranch :: UTCTime -> TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
129addBranch stamp' newId newBranchName branchPointId graph = do
130 parentTrans <- transactionForId branchPointId graph
131 let newTrans = Transaction newId (TransactionInfo {
132 parents = TD.single branchPointId NoOperation,
133 stamp = stamp'}) (schemas parentTrans)
134 addTransactionToGraph newBranchName newTrans graph
136--adds a disconnected transaction to a transaction graph at some head
137addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
138addDisconnectedTransaction stamp' newId headName discon@(DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName newTrans
139 where
140 newTrans = Transaction newId (TransactionInfo {
141 parents = TD.single parentId (Discon.diffExpr discon),
142 stamp = stamp'}) schemas'
145addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
146addTransactionToGraph headName newTrans graph = do
147 let parentIds' = parentIds newTrans
148 newId = transactionId newTrans
149 validateIds ids = mapM (`transactionForId` graph) (S.toList ids)
150 childTs <- childTransactions newTrans graph
151 --validate that the parent transactions are in the graph
152 _ <- validateIds parentIds'
153 when (S.size parentIds' < 1) (Left $ NewTransactionMissingParentError newId)
154 --if the headName already exists, ensure that it refers to a parent
155 case transactionForHead headName graph of
156 Nothing -> pure () -- any headName is OK
157 Just trans -> when (S.notMember (transactionId trans) parentIds') (Left (HeadNameSwitchingHeadProhibitedError headName))
158 --validate that the transaction has no children
159 unless (S.null childTs) (Left $ NewTransactionMayNotHaveChildrenError newId)
160 --validate that the trasaction's id is unique
161 when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))
163 let updatedTransSet = S.insert newTrans (transactionsForGraph graph)
164 updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph)
165 pure (newTrans, TransactionGraph updatedHeads updatedTransSet)
167validateGraph :: TransactionGraph -> Maybe [RelationalError]
168validateGraph graph@(TransactionGraph _ transSet) = do
169 --check that all transaction ids are unique in the graph
170 --FINISH ME!
171 --uuids = map transactionId transSet
172 --check that all heads appear in the transSet
173 --check that all forward and backward links are in place
174 mapM_ (walkParentTransactions S.empty graph) (S.toList transSet)
175 mapM (walkChildTransactions S.empty graph) (S.toList transSet)
177--verify that all parent links exist and that all children exist
178--maybe verify that all parents end at transaction id nil and all children end at leaves
179walkParentTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
180walkParentTransactions seenTransSet graph trans =
181 let transId = transactionId trans in
182 if transId == U.nil then
183 Nothing
184 else if S.member transId seenTransSet then
185 Just $ TransactionGraphCycleError transId
186 else
187 let parentTransSetOrError = parentTransactions trans graph in
188 case parentTransSetOrError of
189 Left err -> Just err
190 Right parentTransSet -> do
191 walk <- mapM (walkParentTransactions (S.insert transId seenTransSet) graph) (S.toList parentTransSet)
192 case walk of
193 err:_ -> Just err
194 _ -> Nothing
196--refactor: needless duplication in these two functions
197walkChildTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
198walkChildTransactions seenTransSet graph trans =
199 let transId = transactionId trans in
200 if childTransactions trans graph == Right S.empty then
201 Nothing
202 else if S.member transId seenTransSet then
203 Just $ TransactionGraphCycleError transId
204 else
205 let childTransSetOrError = childTransactions trans graph in
206 case childTransSetOrError of
207 Left err -> Just err
208 Right childTransSet -> do
209 walk <- mapM (walkChildTransactions (S.insert transId seenTransSet) graph) (S.toList childTransSet)
210 case walk of
211 err:_ -> Just err
212 _ -> Nothing
214-- returns the new "current" transaction, updated graph, and tutorial d result
215-- the current transaction is not part of the transaction graph until it is committed
216evalGraphOp :: UTCTime -> TransactionId -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
218evalGraphOp _ _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId graph of
219 Left err -> Left err
220 Right parentTrans -> Right (newTrans, graph)
221 where
222 newTrans = DisconnectedTransaction jumpId (schemas parentTrans) NoOperation
224-- switch from one head to another
225evalGraphOp _ _ _ graph (JumpToHead headName) =
226 case transactionForHead headName graph of
227 Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) NoOperation in
228 Right (disconnectedTrans, graph)
229 Nothing -> Left $ NoSuchHeadNameError headName
231evalGraphOp _ _ discon graph (WalkBackToTime backTime) = do
232 let startTransId = Discon.parentId discon
233 jumpDest <- backtrackGraph graph startTransId (TransactionStampHeadBacktrack backTime)
234 case transactionForId jumpDest graph of
235 Left err -> Left err
236 Right trans -> do
237 let disconnectedTrans = Discon.freshTransaction (transactionId trans) (schemas trans)
238 Right (disconnectedTrans, graph)
240-- add new head pointing to branchPoint
241-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)
242-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch
243 {-
244evalGraphOp newId discon@(DisconnectedTransaction parentId disconContext) graph (Branch newBranchName) = case transactionForId parentId graph of
245 Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")
246 Just parentTrans -> case addBranch newBranchName parentTrans graph of
247 Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")
248 Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")
249 where
250 newDiscon = DisconnectedTransaction (transactionId parentTrans) disconContext
251-}
253-- create a new commit and add it to the heads
254-- 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)
255evalGraphOp stamp' newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do
256 let newDiscon = Discon.freshTransaction newId schemas'
257 case addBranch stamp' newId newBranchName parentId graph of
258 Left err -> Left err
259 Right (_, newGraph) -> Right (newDiscon, newGraph)
261-- add the disconnected transaction to the graph
262-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
263evalGraphOp stamp' newTransId discon@(DisconnectedTransaction parentId schemas' _) graph Commit = case transactionForId parentId graph of
264 Left err -> Left err
265 Right parentTransaction -> case headNameForTransaction parentTransaction graph of
266 Nothing -> Left $ TransactionIsNotAHeadError parentId
267 Just headName -> case maybeUpdatedGraph of
268 Left err-> Left err
269 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)
270 where
271 newDisconnectedTrans = Discon.freshTransaction newTransId schemas'
272 maybeUpdatedGraph = addDisconnectedTransaction stamp' newTransId headName discon graph
274-- refresh the disconnected transaction, return the same graph
275evalGraphOp _ _ (DisconnectedTransaction parentId _ _) graph Rollback = case transactionForId parentId graph of
276 Left err -> Left err
277 Right parentTransaction -> Right (newDiscon, graph)
278 where
279 newDiscon = Discon.freshTransaction parentId (schemas parentTransaction)
281evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) graph
283evalGraphOp _ _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of
284 Nothing -> Left (NoSuchHeadNameError branchName)
285 Just _ -> Right (discon, TransactionGraph (M.delete branchName graphHeads) transSet)
287--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
288graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
289graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _ transSet) = do
290 tupleMatrix <- mapM tupleGenerator (S.toList transSet)
291 mkRelationFromList attrs tupleMatrix
292 where
293 attrs = A.attributesFromList [Attribute "id" TextAtomType,
294 Attribute "stamp" DateTimeAtomType,
295 Attribute "parents" (RelationAtomType parentAttributes),
296 Attribute "current" BoolAtomType,
297 Attribute "head" TextAtomType
298 ]
299 parentAttributes = A.attributesFromList [Attribute "id" TextAtomType]
300 tupleGenerator transaction = case transactionParentsRelation transaction graph of
301 Left err -> Left err
302 Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),
303 DateTimeAtom (timestamp transaction),
304 RelationAtom parentTransRel,
305 BoolAtom $ parentId == transactionId transaction,
306 TextAtom $ fromMaybe "" (headNameForTransaction transaction graph)
307 ]
309transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
310transactionParentsRelation trans graph =
311 if isRootTransaction trans then
312 mkRelation attrs emptyTupleSet
313 else do
314 parentTransSet <- parentTransactions trans graph
315 let tuples = map trans2tuple (S.toList parentTransSet)
316 mkRelationFromTuples attrs tuples
317 where
318 attrs = A.attributesFromList [Attribute "id" TextAtomType]
319 trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (TextAtom (T.pack (show $ transactionId trans2)))
321{-
322--display transaction graph as relation
323evalROGraphOp :: DisconnectedTransaction -> TransactionGraph -> ROTransactionGraphOperator -> Either RelationalError Relation
324evalROGraphOp discon graph ShowGraph = do
325 graphRel <- graphAsRelation discon graph
326 return graphRel
327-}
329-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph
330createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
331createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do
332 let selectedTrans = validateHeadName selectedBranch graph t2
333 Transaction newId (TransactionInfo {
334 parents = NE.fromList [(transactionId trans1, undefined),
335 (transactionId trans2, undefined)],
336 stamp = stamp' }) . schemas <$> selectedTrans
338-- merge functions, relvars, individually
339createMergeTransaction stamp' newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp' newId strat graph t2
341-- merge function, relvars, but, on error, just take the component from the preferred branch
342createMergeTransaction stamp' newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction stamp' newId strat graph t2
344-- | 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.
345validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
346validateHeadName headName graph (t1, t2) =
347 case transactionForHead headName graph of
348 Nothing -> Left SelectedHeadMismatchMergeError
349 Just trans -> if trans /= t1 && trans /= t2 then
350 Left SelectedHeadMismatchMergeError
351 else
352 Right trans
354-- 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.
355subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph
356subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans traverseSet = do
357 let currentid = transactionId currentTrans
358 goalid = transactionId goalTrans
359 if currentTrans == goalTrans then
360 Right (TransactionGraph resultHeads traverseSet) -- add filter
361 --catch root transaction to improve error?
362 else do
363 currentTransChildren <- childTransactions currentTrans origGraph
364 let searchChildren = S.difference (S.insert currentTrans traverseSet) currentTransChildren
365 searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans traverseSet)
366 childSearches = map searchChild (S.toList searchChildren)
367 errors = lefts childSearches
368 pathsFound = rights childSearches
369 realErrors = filter (/= FailedToFindTransactionError goalid) errors
370 -- report any non-search-related errors
371 unless (null realErrors) (Left (head realErrors))
372 -- if no paths found, search the parent
373 if null pathsFound then
374 case oneParent currentTrans of
375 Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)
376 Left err -> Left err
377 Right currentTransParent ->
378 subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans traverseSet)
379 else -- we found a path
380 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))
381 where
382 oneParent (Transaction _ tinfo _) = transactionForId (fst (NE.head (parents tinfo))) origGraph
384-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.
385pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)
386pathToTransaction graph currentTransaction targetTransaction accumTransSet = do
387 let targetId = transactionId targetTransaction
388 if transactionId targetTransaction == transactionId currentTransaction then
389 Right accumTransSet
390 else do
391 currentTransChildren <- childTransactions currentTransaction graph
392 if null currentTransChildren then
393 Left (FailedToFindTransactionError targetId)
394 else do
395 let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) (S.toList currentTransChildren)
396 let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)
397 paths = rights searches
398 if not (null realErrors) then -- found some real errors
399 Left (head realErrors)
400 else if null paths then -- failed to find transaction in all children
401 Left (FailedToFindTransactionError targetId)
402 else --we have some paths!
403 Right (S.unions paths)
405mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
406mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) graph = do
407 let transactionForHeadErr name = case transactionForHead name graph of
408 Nothing -> Left (NoSuchHeadNameError name)
409 Just t -> Right t
410 transA <- transactionForHeadErr headNameA
411 transB <- transactionForHeadErr headNameB
412 disconParent <- transactionForId parentId graph
413 let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph)
414 subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty
415 subGraph' <- filterSubGraph subGraph subHeads
416 case createMergeTransaction stamp' newId mergeStrategy subGraph' (transA, transB) of
417 Left err -> Left (MergeTransactionError err)
418 Right mergedTrans -> case checkConstraints (concreteDatabaseContext mergedTrans) of
419 Left err -> Left err
420 Right _ -> case headNameForTransaction disconParent graph of
421 Nothing -> Left (TransactionIsNotAHeadError parentId)
422 Just headName -> do
423 (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph
424 let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)
425 newDiscon = Discon.freshTransaction newId (schemas newTrans)
426 pure (newDiscon, newGraph')
428--TEMPORARY COPY/PASTE
429showTransactionStructureX :: Transaction -> TransactionGraph -> String
430showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo
431 where
432 headInfo = maybe "" show (headNameForTransaction trans graph)
433 parentTransactionsInfo = if isRootTransaction trans then "root" else case parentTransactions trans graph of
434 Left err -> show err
435 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet
437showGraphStructureX :: TransactionGraph -> String
438showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet
439 where
440 folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n"
441 headsInfo = show $ M.map transactionId heads
443-- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph.
444filterSubGraph :: TransactionGraph -> TransactionHeads -> Either RelationalError TransactionGraph
445filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet
446 where
447 validIds = S.map transactionId (transactionsForGraph graph)
448 newTransSet = S.map (filterTransaction validIds) (transactionsForGraph graph)
449 newHeads = M.map (filterTransaction validIds) heads
451--helper function for commonalities in union merge
452createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
453createUnionMergeTransaction stamp' newId strategy graph (t1,t2) = do
454 let contextA = concreteDatabaseContext t1
455 contextB = concreteDatabaseContext t2
457 preference <- case strategy of
458 UnionMergeStrategy -> pure PreferNeither
459 UnionPreferMergeStrategy preferBranch ->
460 case transactionForHead preferBranch graph of
461 Nothing -> Left (PreferredHeadMissingMergeError preferBranch)
462 Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond
463 badStrat -> Left (InvalidMergeStrategyError badStrat)
465 incDeps <- unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)
466 relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)
467 atomFuncs <- unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)
468 notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB)
469 types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)
470 dbcFuncs <- unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)
471 -- TODO: add merge of subschemas
472 let newContext = DatabaseContext {
473 inclusionDependencies = incDeps,
474 relationVariables = relVars,
475 atomFunctions = atomFuncs,
476 dbcFunctions = dbcFuncs,
477 notifications = notifs,
478 typeConstructorMapping = types
479 }
480 newSchemas = Schemas newContext (subschemas t1)
481 pure (Transaction newId (TransactionInfo {
482 parents = NE.fromList [(transactionId t1, undefined),
483 (transactionId t2, undefined)],
484 stamp = stamp'}) newSchemas)
486lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction
487lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph
488lookupTransaction graph (TransactionIdHeadNameLookup headName backtracks) = case transactionForHead headName graph of
489 Nothing -> Left (NoSuchHeadNameError headName)
490 Just headTrans -> do
491 traversedId <- traverseGraph graph (transactionId headTrans) backtracks
492 transactionForId traversedId graph
494traverseGraph :: TransactionGraph -> TransactionId -> [TransactionIdHeadBacktrack] -> Either RelationalError TransactionId
495traverseGraph graph = foldM (backtrackGraph graph)
497backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrack -> Either RelationalError TransactionId
498-- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily
499backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do
500 trans <- transactionForId currentTid graph
501 let parentIds' = S.toList (parentIds trans)
502 if length parentIds' < 1 then
503 Left RootTransactionTraversalError
504 else do
505 parentTrans <- transactionForId (head parentIds') graph
506 if steps == 1 then
507 pure (transactionId parentTrans)
508 else
509 backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1))
511backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do
512 trans <- transactionForId currentTid graph
513 let parentIds' = parentIds trans
514 if S.size parentIds' < 1 then
515 Left RootTransactionTraversalError
516 else if S.size parentIds' < steps then
517 Left (ParentCountTraversalError (S.size parentIds') steps)
518 else
519 pure (S.elemAt (steps - 1) parentIds')
521backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp') = do
522 trans <- transactionForId currentTid graph
523 let parentIds' = parentIds trans
524 if timestamp trans <= stamp' then
525 pure currentTid
526 else if S.null parentIds' then
527 Left RootTransactionTraversalError
528 else
529 let arbitraryParent = head (S.toList parentIds') in
530 backtrackGraph graph arbitraryParent btrack
532-- | 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.
533--this is not a GraphOp because it combines multiple graph operations
534autoMergeToHead :: UTCTime -> (TransactionId, TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
535autoMergeToHead stamp' (tempBranchTransId, tempCommitTransId, mergeTransId) discon mergeToHeadName strat graph = do
536 let tempBranchName = "mergebranch_" <> U.toText tempBranchTransId
537 --create the temp branch
538 (discon', graph') <- evalGraphOp stamp' tempBranchTransId discon graph (Branch tempBranchName)
540 --commit to the new branch- possible future optimization: don't require fsync for this- create a temp commit type
541 (discon'', graph'') <- evalGraphOp stamp' tempCommitTransId discon' graph' Commit
543 --jump to merge head
544 (discon''', graph''') <- evalGraphOp stamp' tempBranchTransId discon'' graph'' (JumpToHead mergeToHeadName)
546 --create the merge
547 (discon'''', graph'''') <- evalGraphOp stamp' mergeTransId discon''' graph''' (MergeTransactions strat tempBranchName mergeToHeadName)
549 --delete the temp branch
550 (discon''''', graph''''') <- evalGraphOp stamp' tempBranchTransId discon'''' graph'''' (DeleteBranch tempBranchName)
551 {-
552 let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''')
553 traceShowM rel
554-}
556 pure (discon''''', graph''''')