git.iko.soy/project-m36
on f7fc888 help sign in
project-m36/src/lib/ProjectM36/TransactionGraph.hs
633 lines 35 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 ProjectM36.MerkleHash
13import qualified ProjectM36.DisconnectedTransaction as Discon
14import qualified ProjectM36.Attribute as A
16import Control.Monad.Except hiding (join)
17import Control.Monad.Reader hiding (join)
18import qualified Data.Vector as V
19import qualified Data.UUID as U
20import qualified Data.Set as S
21import qualified Data.Map as M
22import qualified Data.List.NonEmpty as NE
23import Data.Time.Clock
24import qualified Data.Text as T
25import GHC.Generics
26import Data.Binary as B
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, 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 | ValidateMerkleHashes
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 $ _unMerkleHash (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 $ addMerkleHash graph $
349 Transaction newId (TransactionInfo {
350 parents = NE.fromList [transactionId trans1,
351 transactionId trans2],
352 stamp = stamp',
353 merkleHash = mempty }) (schemas selectedTrans)
355-- merge functions, relvars, individually
356createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 =
357 createUnionMergeTransaction stamp' newId strat t2
359-- merge function, relvars, but, on error, just take the component from the preferred branch
360createMergeTransaction stamp' newId strat@(UnionPreferMergeStrategy _) t2 =
361 createUnionMergeTransaction stamp' newId strat t2
363-- | 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.
364validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction
365validateHeadName headName graph (t1, t2) =
366 case transactionForHead headName graph of
367 Nothing -> throwError (MergeTransactionError SelectedHeadMismatchMergeError)
368 Just trans -> if trans /= t1 && trans /= t2 then
369 throwError (MergeTransactionError SelectedHeadMismatchMergeError)
370 else
371 pure trans
373-- 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.
374subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph
375subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans traverseSet = do
376 let currentid = transactionId currentTrans'
377 goalid = transactionId goalTrans
378 if currentTrans' == goalTrans then
379 Right (TransactionGraph resultHeads traverseSet) -- add filter
380 --catch root transaction to improve error?
381 else do
382 currentTransChildren <- childTransactions currentTrans' origGraph
383 let searchChildren = S.difference (S.insert currentTrans' traverseSet) currentTransChildren
384 searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans' traverseSet)
385 childSearches = map searchChild (S.toList searchChildren)
386 errors = lefts childSearches
387 pathsFound = rights childSearches
388 realErrors = filter (/= FailedToFindTransactionError goalid) errors
389 -- report any non-search-related errors
390 unless (null realErrors) (Left (head realErrors))
391 -- if no paths found, search the parent
392 if null pathsFound then
393 case oneParent currentTrans' of
394 Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)
395 Left err -> Left err
396 Right currentTransParent ->
397 subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans' traverseSet)
398 else -- we found a path
399 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))
400 where
401 oneParent (Transaction _ tinfo _) = transactionForId (NE.head (parents tinfo)) origGraph
403-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.
404pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)
405pathToTransaction graph currentTransaction targetTransaction accumTransSet = do
406 let targetId = transactionId targetTransaction
407 if transactionId targetTransaction == transactionId currentTransaction then
408 Right accumTransSet
409 else do
410 currentTransChildren <- childTransactions currentTransaction graph
411 if null currentTransChildren then
412 Left (FailedToFindTransactionError targetId)
413 else do
414 let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) (S.toList currentTransChildren)
415 let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)
416 paths = rights searches
417 if not (null realErrors) then -- found some real errors
418 Left (head realErrors)
419 else if null paths then -- failed to find transaction in all children
420 Left (FailedToFindTransactionError targetId)
421 else --we have some paths!
422 Right (S.unions paths)
424mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> GraphRefRelationalExprM (DisconnectedTransaction, TransactionGraph)
425mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = do
426 graph <- gfGraph
427 let transactionForHeadErr name = case transactionForHead name graph of
428 Nothing -> throwError (NoSuchHeadNameError name)
429 Just t -> pure t
430 runE e = case e of
431 Left e' -> throwError e'
432 Right v -> pure v
433 transA <- transactionForHeadErr headNameA
434 transB <- transactionForHeadErr headNameB
435 disconParent <- gfTransForId parentId
436 let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph)
437 subGraph <- runE $ subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty
438 subGraph' <- runE $ filterSubGraph subGraph subHeads
439 mergedTrans <- local (const (freshGraphRefRelationalExprEnv Nothing subGraph')) $ createMergeTransaction stamp' newId mergeStrategy (transA, transB)
440 case headNameForTransaction disconParent graph of
441 Nothing -> throwError (TransactionIsNotAHeadError parentId)
442 Just headName -> do
443 (newTrans, newGraph) <- runE $ addTransactionToGraph headName mergedTrans graph
444 case checkConstraints (concreteDatabaseContext mergedTrans) newId graph of
445 Left err -> throwError err
446 Right _ -> do
447 let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)
448 newDiscon = Discon.freshTransaction newId (schemas newTrans)
449 pure (newDiscon, newGraph')
451--TEMPORARY COPY/PASTE
452showTransactionStructureX :: Transaction -> TransactionGraph -> String
453showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo
454 where
455 headInfo = maybe "" show (headNameForTransaction trans graph)
456 parentTransactionsInfo = if isRootTransaction trans then "root" else case parentTransactions trans graph of
457 Left err -> show err
458 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet
460showGraphStructureX :: TransactionGraph -> String
461showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet
462 where
463 folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n"
464 headsInfo = show $ M.map transactionId heads
466-- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph.
467filterSubGraph :: TransactionGraph -> TransactionHeads -> Either RelationalError TransactionGraph
468filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet
469 where
470 validIds = S.map transactionId (transactionsForGraph graph)
471 newTransSet = S.map (filterTransaction validIds) (transactionsForGraph graph)
472 newHeads = M.map (filterTransaction validIds) heads
474--helper function for commonalities in union merge
475createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction
476createUnionMergeTransaction stamp' newId strategy (t1,t2) = do
477 let contextA = concreteDatabaseContext t1
478 contextB = concreteDatabaseContext t2
479 liftMergeE x = case x of
480 Left e -> throwError (MergeTransactionError e)
481 Right t -> pure t
483 graph <- gfGraph
484 preference <- case strategy of
485 UnionMergeStrategy -> pure PreferNeither
486 UnionPreferMergeStrategy preferBranch ->
487 case transactionForHead preferBranch graph of
488 Nothing -> throwError (MergeTransactionError (PreferredHeadMissingMergeError preferBranch))
489 Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond
490 badStrat -> throwError (MergeTransactionError (InvalidMergeStrategyError badStrat))
492 incDeps <- liftMergeE $ unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)
493 relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)
494 atomFuncs <- liftMergeE $ unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)
495 notifs <- liftMergeE $ unionMergeMaps preference (notifications contextA) (notifications contextB)
496 types <- liftMergeE $ unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)
497 dbcFuncs <- liftMergeE $ unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)
498 -- TODO: add merge of subschemas
499 let newContext = DatabaseContext {
500 inclusionDependencies = incDeps,
501 relationVariables = relVars,
502 atomFunctions = atomFuncs,
503 dbcFunctions = dbcFuncs,
504 notifications = notifs,
505 typeConstructorMapping = types
506 }
507 newSchemas = Schemas newContext (subschemas t1)
508 pure $ addMerkleHash graph $
509 Transaction newId (TransactionInfo {
510 parents = NE.fromList [transactionId t1,
511 transactionId t2],
512 stamp = stamp',
513 merkleHash = mempty }) newSchemas
515lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction
516lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph
517lookupTransaction graph (TransactionIdHeadNameLookup headName backtracks) = case transactionForHead headName graph of
518 Nothing -> Left (NoSuchHeadNameError headName)
519 Just headTrans -> do
520 traversedId <- traverseGraph graph (transactionId headTrans) backtracks
521 transactionForId traversedId graph
523traverseGraph :: TransactionGraph -> TransactionId -> [TransactionIdHeadBacktrack] -> Either RelationalError TransactionId
524traverseGraph graph = foldM (backtrackGraph graph)
526backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrack -> Either RelationalError TransactionId
527-- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily
528backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do
529 trans <- transactionForId currentTid graph
531 let parentIds' = S.toAscList (parentIds trans)
532 case parentIds' of
533 [] -> Left RootTransactionTraversalError
534 firstParentId:_ -> do
535 parentTrans <- transactionForId firstParentId graph
536 if steps == 1 then
537 pure (transactionId parentTrans)
538 else
539 backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1))
541backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do
542 trans <- transactionForId currentTid graph
543 let parentIds' = parentIds trans
544 if S.size parentIds' < 1 then
545 Left RootTransactionTraversalError
546 else if S.size parentIds' < steps then
547 Left (ParentCountTraversalError (S.size parentIds') steps)
548 else
549 pure (S.elemAt (steps - 1) parentIds')
551backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp') = do
552 trans <- transactionForId currentTid graph
553 let parentIds' = parentIds trans
554 if timestamp trans <= stamp' then
555 pure currentTid
556 else if S.null parentIds' then
557 Left RootTransactionTraversalError
558 else
559 let arbitraryParent = head (S.toList parentIds') in
560 backtrackGraph graph arbitraryParent btrack
562-- | 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.
563--this is not a GraphOp because it combines multiple graph operations
564autoMergeToHead :: UTCTime -> (TransactionId, TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
565autoMergeToHead stamp' (tempBranchTransId, tempCommitTransId, mergeTransId) discon mergeToHeadName strat graph = do
566 let tempBranchName = "mergebranch_" <> U.toText tempBranchTransId
567 --create the temp branch
568 (discon', graph') <- evalGraphOp stamp' tempBranchTransId discon graph (Branch tempBranchName)
570 --commit to the new branch- possible future optimization: don't require fsync for this- create a temp commit type
571 (discon'', graph'') <- evalGraphOp stamp' tempCommitTransId discon' graph' Commit
573 --jump to merge head
574 (discon''', graph''') <- evalGraphOp stamp' tempBranchTransId discon'' graph'' (JumpToHead mergeToHeadName)
576 --create the merge
577 (discon'''', graph'''') <- evalGraphOp stamp' mergeTransId discon''' graph''' (MergeTransactions strat tempBranchName mergeToHeadName)
579 --delete the temp branch
580 (discon''''', graph''''') <- evalGraphOp stamp' tempBranchTransId discon'''' graph'''' (DeleteBranch tempBranchName)
581 {-
582 let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''')
583 traceShowM rel
584-}
586 pure (discon''''', graph''''')
589addMerkleHash :: TransactionGraph -> Transaction -> Transaction
590addMerkleHash graph trans = Transaction (transactionId trans) newInfo (schemas trans)
591 where
592 newInfo = (transactionInfo trans) { merkleHash = calculateMerkleHash trans graph }
594-- the new hash includes the parents' ids, the current id, and the hash of the context, and the merkle hashes of the parent transactions
595calculateMerkleHash :: Transaction -> TransactionGraph -> MerkleHash
596calculateMerkleHash trans graph = MerkleHash $ hashlazy (mconcat [transIds,
597 dbcBytes,
598 schemasBytes,
599 parentMerkleHashes])
600 where
601 parentMerkleHashes = BL.fromChunks $ map (_unMerkleHash . getMerkleHash) parentTranses
602 parentTranses =
603 case transactionsForIds (parentIds trans) graph of
604 Left RootTransactionTraversalError -> []
605 Left e -> error ("failed to find transaction in Merkle hash construction: " ++ show e)
606 Right t -> S.toList t
607 getMerkleHash t = merkleHash (transactionInfo t)
608 transIds = B.encode (transactionId trans : S.toList (parentIds trans))
609 dbcBytes = DBC.hashBytes (concreteDatabaseContext trans)
610 schemasBytes = B.encode (subschemas trans)
612validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError ()
613validateMerkleHash trans graph =
614 if expectedHash /= actualHash then
615 Left (MerkleValidationError (transactionId trans) expectedHash actualHash)
616 else
617 pure ()
618 where
619 expectedHash = merkleHash (transactionInfo trans)
620 actualHash = calculateMerkleHash trans graph
622data MerkleValidationError = MerkleValidationError TransactionId MerkleHash MerkleHash
623 deriving (Show, Eq, Generic)
625validateMerkleHashes :: TransactionGraph -> Either [MerkleValidationError] ()
626validateMerkleHashes graph =
627 if null errs then pure () else Left errs
628 where
629 errs = S.foldr validateTrans [] (transactionsForGraph graph)
630 validateTrans trans acc =
631 case validateMerkleHash trans graph of
632 Left err -> err : acc
633 _ -> acc