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