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