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