git.iko.soy/project-m36
on 2fbb67a help sign in
project-m36/src/lib/ProjectM36/TransactionGraph.hs
546 lines 31 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
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)
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) = mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) graph
269evalGraphOp _ _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of
270 Nothing -> Left (NoSuchHeadNameError branchName)
271 Just _ -> Right (discon, TransactionGraph (M.delete branchName graphHeads) transSet)
273--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
274graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
275graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _ transSet) = do
276 tupleMatrix <- mapM tupleGenerator (S.toList transSet)
277 mkRelationFromList attrs tupleMatrix
278 where
279 attrs = A.attributesFromList [Attribute "id" TextAtomType,
280 Attribute "stamp" DateTimeAtomType,
281 Attribute "parents" (RelationAtomType parentAttributes),
282 Attribute "current" BoolAtomType,
283 Attribute "head" TextAtomType
284 ]
285 parentAttributes = A.attributesFromList [Attribute "id" TextAtomType]
286 tupleGenerator transaction = case transactionParentsRelation transaction graph of
287 Left err -> Left err
288 Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),
289 DateTimeAtom (timestamp transaction),
290 RelationAtom parentTransRel,
291 BoolAtom $ parentId == transactionId transaction,
292 TextAtom $ fromMaybe "" (headNameForTransaction transaction graph)
293 ]
295transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
296transactionParentsRelation trans graph =
297 if isRootTransaction trans then
298 mkRelation attrs emptyTupleSet
299 else do
300 parentTransSet <- parentTransactions trans graph
301 let tuples = map trans2tuple (S.toList parentTransSet)
302 mkRelationFromTuples attrs tuples
303 where
304 attrs = A.attributesFromList [Attribute "id" TextAtomType]
305 trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (TextAtom (T.pack (show $ transactionId trans2)))
307{-
308--display transaction graph as relation
309evalROGraphOp :: DisconnectedTransaction -> TransactionGraph -> ROTransactionGraphOperator -> Either RelationalError Relation
310evalROGraphOp discon graph ShowGraph = do
311 graphRel <- graphAsRelation discon graph
312 return graphRel
313-}
315-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph
316createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
317createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do
318 let selectedTrans = validateHeadName selectedBranch graph t2
319 Transaction newId (TransactionInfo {
320 parents = NE.fromList [transactionId trans1,
321 transactionId trans2],
322 stamp = stamp' }) . schemas <$> selectedTrans
324-- merge functions, relvars, individually
325createMergeTransaction stamp' newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp' newId strat graph t2
327-- merge function, relvars, but, on error, just take the component from the preferred branch
328createMergeTransaction stamp' newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction stamp' newId strat graph t2
330-- | 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.
331validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
332validateHeadName headName graph (t1, t2) =
333 case transactionForHead headName graph of
334 Nothing -> Left SelectedHeadMismatchMergeError
335 Just trans -> if trans /= t1 && trans /= t2 then
336 Left SelectedHeadMismatchMergeError
337 else
338 Right trans
340-- 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.
341subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph
342subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans traverseSet = do
343 let currentid = transactionId currentTrans'
344 goalid = transactionId goalTrans
345 if currentTrans' == goalTrans then
346 Right (TransactionGraph resultHeads traverseSet) -- add filter
347 --catch root transaction to improve error?
348 else do
349 currentTransChildren <- childTransactions currentTrans' origGraph
350 let searchChildren = S.difference (S.insert currentTrans' traverseSet) currentTransChildren
351 searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans' traverseSet)
352 childSearches = map searchChild (S.toList searchChildren)
353 errors = lefts childSearches
354 pathsFound = rights childSearches
355 realErrors = filter (/= FailedToFindTransactionError goalid) errors
356 -- report any non-search-related errors
357 unless (null realErrors) (Left (head realErrors))
358 -- if no paths found, search the parent
359 if null pathsFound then
360 case oneParent currentTrans' of
361 Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)
362 Left err -> Left err
363 Right currentTransParent ->
364 subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans' traverseSet)
365 else -- we found a path
366 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))
367 where
368 oneParent (Transaction _ tinfo _) = transactionForId (NE.head (parents tinfo)) origGraph
370-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.
371pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)
372pathToTransaction graph currentTransaction targetTransaction accumTransSet = do
373 let targetId = transactionId targetTransaction
374 if transactionId targetTransaction == transactionId currentTransaction then
375 Right accumTransSet
376 else do
377 currentTransChildren <- childTransactions currentTransaction graph
378 if null currentTransChildren then
379 Left (FailedToFindTransactionError targetId)
380 else do
381 let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) (S.toList currentTransChildren)
382 let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)
383 paths = rights searches
384 if not (null realErrors) then -- found some real errors
385 Left (head realErrors)
386 else if null paths then -- failed to find transaction in all children
387 Left (FailedToFindTransactionError targetId)
388 else --we have some paths!
389 Right (S.unions paths)
391mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
392mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) graph = do
393 let transactionForHeadErr name = case transactionForHead name graph of
394 Nothing -> Left (NoSuchHeadNameError name)
395 Just t -> Right t
396 transA <- transactionForHeadErr headNameA
397 transB <- transactionForHeadErr headNameB
398 disconParent <- transactionForId parentId graph
399 let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph)
400 subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty
401 subGraph' <- filterSubGraph subGraph subHeads
402 case createMergeTransaction stamp' newId mergeStrategy subGraph' (transA, transB) of
403 Left err -> Left (MergeTransactionError err)
404 Right mergedTrans ->
405 case headNameForTransaction disconParent graph of
406 Nothing -> Left (TransactionIsNotAHeadError parentId)
407 Just headName -> do
408 (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph
409 case checkConstraints (concreteDatabaseContext mergedTrans) newId graph of
410 Left err -> Left err
411 Right _ -> do
412 let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)
413 newDiscon = Discon.freshTransaction newId (schemas newTrans)
414 pure (newDiscon, newGraph')
416--TEMPORARY COPY/PASTE
417showTransactionStructureX :: Transaction -> TransactionGraph -> String
418showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo
419 where
420 headInfo = maybe "" show (headNameForTransaction trans graph)
421 parentTransactionsInfo = if isRootTransaction trans then "root" else case parentTransactions trans graph of
422 Left err -> show err
423 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet
425showGraphStructureX :: TransactionGraph -> String
426showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet
427 where
428 folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n"
429 headsInfo = show $ M.map transactionId heads
431-- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph.
432filterSubGraph :: TransactionGraph -> TransactionHeads -> Either RelationalError TransactionGraph
433filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet
434 where
435 validIds = S.map transactionId (transactionsForGraph graph)
436 newTransSet = S.map (filterTransaction validIds) (transactionsForGraph graph)
437 newHeads = M.map (filterTransaction validIds) heads
439--helper function for commonalities in union merge
440createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
441createUnionMergeTransaction stamp' newId strategy graph (t1,t2) = do
442 let contextA = concreteDatabaseContext t1
443 contextB = concreteDatabaseContext t2
445 preference <- case strategy of
446 UnionMergeStrategy -> pure PreferNeither
447 UnionPreferMergeStrategy preferBranch ->
448 case transactionForHead preferBranch graph of
449 Nothing -> Left (PreferredHeadMissingMergeError preferBranch)
450 Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond
451 badStrat -> Left (InvalidMergeStrategyError badStrat)
453 incDeps <- unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)
454 relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)
455 atomFuncs <- unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)
456 notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB)
457 types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)
458 dbcFuncs <- unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)
459 -- TODO: add merge of subschemas
460 let newContext = DatabaseContext {
461 inclusionDependencies = incDeps,
462 relationVariables = relVars,
463 atomFunctions = atomFuncs,
464 dbcFunctions = dbcFuncs,
465 notifications = notifs,
466 typeConstructorMapping = types
467 }
468 newSchemas = Schemas newContext (subschemas t1)
469 pure (Transaction newId (TransactionInfo {
470 parents = NE.fromList [transactionId t1,
471 transactionId t2],
472 stamp = stamp'}) newSchemas)
474lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction
475lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph
476lookupTransaction graph (TransactionIdHeadNameLookup headName backtracks) = case transactionForHead headName graph of
477 Nothing -> Left (NoSuchHeadNameError headName)
478 Just headTrans -> do
479 traversedId <- traverseGraph graph (transactionId headTrans) backtracks
480 transactionForId traversedId graph
482traverseGraph :: TransactionGraph -> TransactionId -> [TransactionIdHeadBacktrack] -> Either RelationalError TransactionId
483traverseGraph graph = foldM (backtrackGraph graph)
485backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrack -> Either RelationalError TransactionId
486-- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily
487backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do
488 trans <- transactionForId currentTid graph
489 let parentIds' = S.toList (parentIds trans)
490 if length parentIds' < 1 then
491 Left RootTransactionTraversalError
492 else do
493 parentTrans <- transactionForId (head parentIds') graph
494 if steps == 1 then
495 pure (transactionId parentTrans)
496 else
497 backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1))
499backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do
500 trans <- transactionForId currentTid graph
501 let parentIds' = parentIds trans
502 if S.size parentIds' < 1 then
503 Left RootTransactionTraversalError
504 else if S.size parentIds' < steps then
505 Left (ParentCountTraversalError (S.size parentIds') steps)
506 else
507 pure (S.elemAt (steps - 1) parentIds')
509backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp') = do
510 trans <- transactionForId currentTid graph
511 let parentIds' = parentIds trans
512 if timestamp trans <= stamp' then
513 pure currentTid
514 else if S.null parentIds' then
515 Left RootTransactionTraversalError
516 else
517 let arbitraryParent = head (S.toList parentIds') in
518 backtrackGraph graph arbitraryParent btrack
520-- | 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.
521--this is not a GraphOp because it combines multiple graph operations
522autoMergeToHead :: UTCTime -> (TransactionId, TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
523autoMergeToHead stamp' (tempBranchTransId, tempCommitTransId, mergeTransId) discon mergeToHeadName strat graph = do
524 let tempBranchName = "mergebranch_" <> U.toText tempBranchTransId
525 --create the temp branch
526 (discon', graph') <- evalGraphOp stamp' tempBranchTransId discon graph (Branch tempBranchName)
528 --commit to the new branch- possible future optimization: don't require fsync for this- create a temp commit type
529 (discon'', graph'') <- evalGraphOp stamp' tempCommitTransId discon' graph' Commit
531 --jump to merge head
532 (discon''', graph''') <- evalGraphOp stamp' tempBranchTransId discon'' graph'' (JumpToHead mergeToHeadName)
534 --create the merge
535 (discon'''', graph'''') <- evalGraphOp stamp' mergeTransId discon''' graph''' (MergeTransactions strat tempBranchName mergeToHeadName)
537 --delete the temp branch
538 (discon''''', graph''''') <- evalGraphOp stamp' tempBranchTransId discon'''' graph'''' (DeleteBranch tempBranchName)
539 {-
540 let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''')
541 traceShowM rel
542-}
544 pure (discon''''', graph''''')