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