{-# LANGUAGE DeriveAnyClass, DeriveGeneric, CPP, FlexibleContexts #-}
module ProjectM36.TransactionGraph where
import ProjectM36.Base
import ProjectM36.Error
import ProjectM36.Transaction
import ProjectM36.TransactionInfo as TI
import ProjectM36.Relation
import ProjectM36.TupleSet
import ProjectM36.Tuple
import ProjectM36.RelationalExpression
import ProjectM36.TransactionGraph.Merge
import ProjectM36.MerkleHash
import qualified ProjectM36.DisconnectedTransaction as Discon
import qualified ProjectM36.Attribute as A
import Control.Monad.Except hiding (join)
import Control.Monad.Reader hiding (join)
import qualified Data.Vector as V
import qualified Data.UUID as U
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.List.NonEmpty as NE
import Data.Time.Clock
import qualified Data.Text as T
import GHC.Generics
import Data.Binary as B
import Data.Either (lefts, rights, isRight)
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid
#endif
import Control.Arrow
import Data.Maybe
import Data.UUID.V4
import qualified Data.ByteString.Lazy as BL
import ProjectM36.DatabaseContext as DBC
import Crypto.Hash.SHA256
data TransactionIdLookup = TransactionIdLookup TransactionId |
TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]
deriving (Show, Eq, Binary, Generic)
data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int |
TransactionIdHeadBranchBacktrack Int |
TransactionStampHeadBacktrack UTCTime
deriving (Show, Eq, Binary, Generic)
data TransactionGraphOperator = JumpToHead HeadName |
JumpToTransaction TransactionId |
WalkBackToTime UTCTime |
Branch HeadName |
DeleteBranch HeadName |
MergeTransactions MergeStrategy HeadName HeadName |
Commit |
Rollback
deriving (Eq, Show, Binary, Generic)
isCommit :: TransactionGraphOperator -> Bool
isCommit Commit = True
isCommit _ = False
data ROTransactionGraphOperator = ShowGraph | ValidateMerkleHashes
deriving Show
bootstrapTransactionGraph :: UTCTime -> TransactionId -> DatabaseContext -> TransactionGraph
bootstrapTransactionGraph stamp' freshId context = TransactionGraph bootstrapHeads bootstrapTransactions
where
bootstrapHeads = M.singleton "master" freshTransaction
newSchemas = Schemas context M.empty
freshTransaction = fresh freshId stamp' newSchemas
hashedTransaction = Transaction freshId ((transactionInfo freshTransaction) { merkleHash = calculateMerkleHash freshTransaction emptyTransactionGraph }) newSchemas
bootstrapTransactions = S.singleton hashedTransaction
freshTransactionGraph :: DatabaseContext -> IO (TransactionGraph, TransactionId)
freshTransactionGraph ctx = do
now <- getCurrentTime
freshId <- nextRandom
pure (bootstrapTransactionGraph now freshId ctx, freshId)
emptyTransactionGraph :: TransactionGraph
emptyTransactionGraph = TransactionGraph M.empty S.empty
transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction
transactionForHead headName graph = M.lookup headName (transactionHeadsForGraph graph)
headList :: TransactionGraph -> [(HeadName, TransactionId)]
headList graph = map (second transactionId) (M.assocs (transactionHeadsForGraph graph))
headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName
headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then
Nothing
else
Just $ (head . M.keys) matchingTrans
where
matchingTrans = M.filter (transaction ==) heads
transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction)
transactionsForIds idSet graph =
S.fromList <$> forM (S.toList idSet) (`transactionForId` graph)
isRootTransaction :: Transaction -> Bool
isRootTransaction trans = parentIds trans == S.singleton U.nil
rootTransactions :: TransactionGraph -> S.Set Transaction
rootTransactions graph = S.filter isRootTransaction (transactionsForGraph graph)
parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
parentTransactions trans = transactionsForIds (parentIds trans)
childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
childTransactions trans graph = transactionsForIds childIds graph
where
childIds = S.map transactionId (S.filter filt (transactionsForGraph graph))
filt trans' = S.member (transactionId trans) (parentIds trans')
addBranch :: UTCTime -> TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
addBranch stamp' newId newBranchName branchPointId graph = do
parentTrans <- transactionForId branchPointId graph
let newTrans = Transaction newId (TI.singleParent branchPointId stamp') (schemas parentTrans)
addTransactionToGraph newBranchName newTrans graph
addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
addDisconnectedTransaction stamp' newId headName (DisconnectedTransaction parentId schemas' _) graph = addTransactionToGraph headName newTrans' graph
where
newTrans = Transaction newId newTInfo schemas'
newTInfo = TI.singleParent parentId stamp'
newTrans' = Transaction newId (newTInfo { merkleHash = newHash }) schemas'
newHash = calculateMerkleHash newTrans graph
addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
addTransactionToGraph headName newTrans graph = do
let parentIds' = parentIds newTrans
newId = transactionId newTrans
validateIds ids = mapM (`transactionForId` graph) (S.toList ids)
childTs <- childTransactions newTrans graph
_ <- validateIds parentIds'
when (S.size parentIds' < 1) (Left $ NewTransactionMissingParentError newId)
case transactionForHead headName graph of
Nothing -> pure ()
Just trans -> when (S.notMember (transactionId trans) parentIds') (Left (HeadNameSwitchingHeadProhibitedError headName))
unless (S.null childTs) (Left $ NewTransactionMayNotHaveChildrenError newId)
when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))
let newTrans' = newTransUncommittedReplace newTrans
updatedTransSet = S.insert newTrans' (transactionsForGraph graph)
updatedHeads = M.insert headName newTrans' (transactionHeadsForGraph graph)
pure (newTrans', TransactionGraph updatedHeads updatedTransSet)
newTransUncommittedReplace :: Transaction -> Transaction
newTransUncommittedReplace trans@(Transaction tid tinfo (Schemas ctx sschemas)) =
Transaction tid tinfo (Schemas fixedContext sschemas)
where
uncommittedReplace UncommittedContextMarker = TransactionMarker tid
uncommittedReplace marker = marker
relvars = relationVariables (concreteDatabaseContext trans)
fixedRelvars = M.map (fmap uncommittedReplace) relvars
fixedContext = ctx { relationVariables = fixedRelvars }
validateGraph :: TransactionGraph -> Maybe [RelationalError]
validateGraph graph@(TransactionGraph _ transSet) = do
mapM_ (walkParentTransactions S.empty graph) (S.toList transSet)
mapM (walkChildTransactions S.empty graph) (S.toList transSet)
walkParentTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
walkParentTransactions seenTransSet graph trans =
let transId = transactionId trans in
if transId == U.nil then
Nothing
else if S.member transId seenTransSet then
Just $ TransactionGraphCycleError transId
else
let parentTransSetOrError = parentTransactions trans graph in
case parentTransSetOrError of
Left err -> Just err
Right parentTransSet -> do
walk <- mapM (walkParentTransactions (S.insert transId seenTransSet) graph) (S.toList parentTransSet)
case walk of
err:_ -> Just err
_ -> Nothing
walkChildTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
walkChildTransactions seenTransSet graph trans =
let transId = transactionId trans in
if childTransactions trans graph == Right S.empty then
Nothing
else if S.member transId seenTransSet then
Just $ TransactionGraphCycleError transId
else
let childTransSetOrError = childTransactions trans graph in
case childTransSetOrError of
Left err -> Just err
Right childTransSet -> do
walk <- mapM (walkChildTransactions (S.insert transId seenTransSet) graph) (S.toList childTransSet)
case walk of
err:_ -> Just err
_ -> Nothing
evalGraphOp :: UTCTime -> TransactionId -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
evalGraphOp _ _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId graph of
Left err -> Left err
Right parentTrans -> Right (newTrans, graph)
where
newTrans = DisconnectedTransaction jumpId (schemas parentTrans) False
evalGraphOp _ _ _ graph (JumpToHead headName) =
case transactionForHead headName graph of
Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) False in
Right (disconnectedTrans, graph)
Nothing -> Left $ NoSuchHeadNameError headName
evalGraphOp _ _ discon graph (WalkBackToTime backTime) = do
let startTransId = Discon.parentId discon
jumpDest <- backtrackGraph graph startTransId (TransactionStampHeadBacktrack backTime)
case transactionForId jumpDest graph of
Left err -> Left err
Right trans -> do
let disconnectedTrans = Discon.freshTransaction (transactionId trans) (schemas trans)
Right (disconnectedTrans, graph)
evalGraphOp stamp' newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do
let newDiscon = Discon.freshTransaction newId schemas'
case addBranch stamp' newId newBranchName parentId graph of
Left err -> Left err
Right (_, newGraph) -> Right (newDiscon, newGraph)
evalGraphOp stamp' newTransId discon@(DisconnectedTransaction parentId schemas' _) graph Commit = case transactionForId parentId graph of
Left err -> Left err
Right parentTransaction -> case headNameForTransaction parentTransaction graph of
Nothing -> Left $ TransactionIsNotAHeadError parentId
Just headName -> case maybeUpdatedGraph of
Left err-> Left err
Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)
where
newDisconnectedTrans = Discon.freshTransaction newTransId schemas'
maybeUpdatedGraph = addDisconnectedTransaction stamp' newTransId headName discon graph
evalGraphOp _ _ (DisconnectedTransaction parentId _ _) graph Rollback = case transactionForId parentId graph of
Left err -> Left err
Right parentTransaction -> Right (newDiscon, graph)
where
newDiscon = Discon.freshTransaction parentId (schemas parentTransaction)
evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) =
runGraphRefRelationalExprM env $ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB)
where
env = freshGraphRefRelationalExprEnv Nothing graph
evalGraphOp _ _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of
Nothing -> Left (NoSuchHeadNameError branchName)
Just _ -> Right (discon, TransactionGraph (M.delete branchName graphHeads) transSet)
graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _ transSet) = do
tupleMatrix <- mapM tupleGenerator (S.toList transSet)
mkRelationFromList attrs tupleMatrix
where
attrs = A.attributesFromList [Attribute "id" TextAtomType,
Attribute "hash" ByteStringAtomType,
Attribute "stamp" DateTimeAtomType,
Attribute "parents" (RelationAtomType parentAttributes),
Attribute "current" BoolAtomType,
Attribute "head" TextAtomType
]
parentAttributes = A.attributesFromList [Attribute "id" TextAtomType]
tupleGenerator transaction = case transactionParentsRelation transaction graph of
Left err -> Left err
Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),
ByteStringAtom $ _unMerkleHash (merkleHash (transactionInfo transaction)),
DateTimeAtom (timestamp transaction),
RelationAtom parentTransRel,
BoolAtom $ parentId == transactionId transaction,
TextAtom $ fromMaybe "" (headNameForTransaction transaction graph)
]
transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
transactionParentsRelation trans graph =
if isRootTransaction trans then
mkRelation attrs emptyTupleSet
else do
parentTransSet <- parentTransactions trans graph
let tuples = map trans2tuple (S.toList parentTransSet)
mkRelationFromTuples attrs tuples
where
attrs = A.attributesFromList [Attribute "id" TextAtomType]
trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (TextAtom (T.pack (show $ transactionId trans2)))
createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction
createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) t2@(trans1, trans2) = do
graph <- gfGraph
selectedTrans <- validateHeadName selectedBranch graph t2
pure $ addMerkleHash graph $
Transaction newId (TransactionInfo {
parents = NE.fromList [transactionId trans1,
transactionId trans2],
stamp = stamp',
merkleHash = mempty }) (schemas selectedTrans)
createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 =
createUnionMergeTransaction stamp' newId strat t2
createMergeTransaction stamp' newId strat@(UnionPreferMergeStrategy _) t2 =
createUnionMergeTransaction stamp' newId strat t2
validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction
validateHeadName headName graph (t1, t2) =
case transactionForHead headName graph of
Nothing -> throwError (MergeTransactionError SelectedHeadMismatchMergeError)
Just trans -> if trans /= t1 && trans /= t2 then
throwError (MergeTransactionError SelectedHeadMismatchMergeError)
else
pure trans
subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph
subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans traverseSet = do
let currentid = transactionId currentTrans'
goalid = transactionId goalTrans
if currentTrans' == goalTrans then
Right (TransactionGraph resultHeads traverseSet)
else do
currentTransChildren <- childTransactions currentTrans' origGraph
let searchChildren = S.difference (S.insert currentTrans' traverseSet) currentTransChildren
searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans' traverseSet)
childSearches = map searchChild (S.toList searchChildren)
errors = lefts childSearches
pathsFound = rights childSearches
realErrors = filter (/= FailedToFindTransactionError goalid) errors
unless (null realErrors) (Left (head realErrors))
if null pathsFound then
case oneParent currentTrans' of
Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)
Left err -> Left err
Right currentTransParent ->
subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans' traverseSet)
else
Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))
where
oneParent (Transaction _ tinfo _) = transactionForId (NE.head (parents tinfo)) origGraph
pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)
pathToTransaction graph currentTransaction targetTransaction accumTransSet = do
let targetId = transactionId targetTransaction
if transactionId targetTransaction == transactionId currentTransaction then
Right accumTransSet
else do
currentTransChildren <- childTransactions currentTransaction graph
if null currentTransChildren then
Left (FailedToFindTransactionError targetId)
else do
let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) (S.toList currentTransChildren)
let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)
paths = rights searches
if not (null realErrors) then
Left (head realErrors)
else if null paths then
Left (FailedToFindTransactionError targetId)
else
Right (S.unions paths)
mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> GraphRefRelationalExprM (DisconnectedTransaction, TransactionGraph)
mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = do
graph <- gfGraph
let transactionForHeadErr name = case transactionForHead name graph of
Nothing -> throwError (NoSuchHeadNameError name)
Just t -> pure t
runE e = case e of
Left e' -> throwError e'
Right v -> pure v
transA <- transactionForHeadErr headNameA
transB <- transactionForHeadErr headNameB
disconParent <- gfTransForId parentId
let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph)
subGraph <- runE $ subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty
subGraph' <- runE $ filterSubGraph subGraph subHeads
mergedTrans <- local (const (freshGraphRefRelationalExprEnv Nothing subGraph')) $ createMergeTransaction stamp' newId mergeStrategy (transA, transB)
case headNameForTransaction disconParent graph of
Nothing -> throwError (TransactionIsNotAHeadError parentId)
Just headName -> do
(newTrans, newGraph) <- runE $ addTransactionToGraph headName mergedTrans graph
case checkConstraints (concreteDatabaseContext mergedTrans) newId graph of
Left err -> throwError err
Right _ -> do
let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)
newDiscon = Discon.freshTransaction newId (schemas newTrans)
pure (newDiscon, newGraph')
showTransactionStructureX :: Transaction -> TransactionGraph -> String
showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo
where
headInfo = maybe "" show (headNameForTransaction trans graph)
parentTransactionsInfo = if isRootTransaction trans then "root" else case parentTransactions trans graph of
Left err -> show err
Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet
showGraphStructureX :: TransactionGraph -> String
showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet
where
folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n"
headsInfo = show $ M.map transactionId heads
filterSubGraph :: TransactionGraph -> TransactionHeads -> Either RelationalError TransactionGraph
filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet
where
validIds = S.map transactionId (transactionsForGraph graph)
newTransSet = S.map (filterTransaction validIds) (transactionsForGraph graph)
newHeads = M.map (filterTransaction validIds) heads
createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction
createUnionMergeTransaction stamp' newId strategy (t1,t2) = do
let contextA = concreteDatabaseContext t1
contextB = concreteDatabaseContext t2
liftMergeE x = case x of
Left e -> throwError (MergeTransactionError e)
Right t -> pure t
graph <- gfGraph
preference <- case strategy of
UnionMergeStrategy -> pure PreferNeither
UnionPreferMergeStrategy preferBranch ->
case transactionForHead preferBranch graph of
Nothing -> throwError (MergeTransactionError (PreferredHeadMissingMergeError preferBranch))
Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond
badStrat -> throwError (MergeTransactionError (InvalidMergeStrategyError badStrat))
incDeps <- liftMergeE $ unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)
relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)
atomFuncs <- liftMergeE $ unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)
notifs <- liftMergeE $ unionMergeMaps preference (notifications contextA) (notifications contextB)
types <- liftMergeE $ unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)
dbcFuncs <- liftMergeE $ unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)
let newContext = DatabaseContext {
inclusionDependencies = incDeps,
relationVariables = relVars,
atomFunctions = atomFuncs,
dbcFunctions = dbcFuncs,
notifications = notifs,
typeConstructorMapping = types
}
newSchemas = Schemas newContext (subschemas t1)
pure $ addMerkleHash graph $
Transaction newId (TransactionInfo {
parents = NE.fromList [transactionId t1,
transactionId t2],
stamp = stamp',
merkleHash = mempty }) newSchemas
lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction
lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph
lookupTransaction graph (TransactionIdHeadNameLookup headName backtracks) = case transactionForHead headName graph of
Nothing -> Left (NoSuchHeadNameError headName)
Just headTrans -> do
traversedId <- traverseGraph graph (transactionId headTrans) backtracks
transactionForId traversedId graph
traverseGraph :: TransactionGraph -> TransactionId -> [TransactionIdHeadBacktrack] -> Either RelationalError TransactionId
traverseGraph graph = foldM (backtrackGraph graph)
backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrack -> Either RelationalError TransactionId
backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do
trans <- transactionForId currentTid graph
let parentIds' = S.toAscList (parentIds trans)
case parentIds' of
[] -> Left RootTransactionTraversalError
firstParentId:_ -> do
parentTrans <- transactionForId firstParentId graph
if steps == 1 then
pure (transactionId parentTrans)
else
backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1))
backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do
trans <- transactionForId currentTid graph
let parentIds' = parentIds trans
if S.size parentIds' < 1 then
Left RootTransactionTraversalError
else if S.size parentIds' < steps then
Left (ParentCountTraversalError (S.size parentIds') steps)
else
pure (S.elemAt (steps - 1) parentIds')
backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp') = do
trans <- transactionForId currentTid graph
let parentIds' = parentIds trans
if timestamp trans <= stamp' then
pure currentTid
else if S.null parentIds' then
Left RootTransactionTraversalError
else
let arbitraryParent = head (S.toList parentIds') in
backtrackGraph graph arbitraryParent btrack
autoMergeToHead :: UTCTime -> (TransactionId, TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
autoMergeToHead stamp' (tempBranchTransId, tempCommitTransId, mergeTransId) discon mergeToHeadName strat graph = do
let tempBranchName = "mergebranch_" <> U.toText tempBranchTransId
(discon', graph') <- evalGraphOp stamp' tempBranchTransId discon graph (Branch tempBranchName)
(discon'', graph'') <- evalGraphOp stamp' tempCommitTransId discon' graph' Commit
(discon''', graph''') <- evalGraphOp stamp' tempBranchTransId discon'' graph'' (JumpToHead mergeToHeadName)
(discon'''', graph'''') <- evalGraphOp stamp' mergeTransId discon''' graph''' (MergeTransactions strat tempBranchName mergeToHeadName)
(discon''''', graph''''') <- evalGraphOp stamp' tempBranchTransId discon'''' graph'''' (DeleteBranch tempBranchName)
pure (discon''''', graph''''')
addMerkleHash :: TransactionGraph -> Transaction -> Transaction
addMerkleHash graph trans = Transaction (transactionId trans) newInfo (schemas trans)
where
newInfo = (transactionInfo trans) { merkleHash = calculateMerkleHash trans graph }
calculateMerkleHash :: Transaction -> TransactionGraph -> MerkleHash
calculateMerkleHash trans graph = MerkleHash $ hashlazy (mconcat [transIds,
dbcBytes,
schemasBytes,
parentMerkleHashes])
where
parentMerkleHashes = BL.fromChunks $ map (_unMerkleHash . getMerkleHash) parentTranses
parentTranses =
case transactionsForIds (parentIds trans) graph of
Left RootTransactionTraversalError -> []
Left e -> error ("failed to find transaction in Merkle hash construction: " ++ show e)
Right t -> S.toList t
getMerkleHash t = merkleHash (transactionInfo t)
transIds = B.encode (transactionId trans : S.toList (parentIds trans))
dbcBytes = DBC.hashBytes (concreteDatabaseContext trans)
schemasBytes = B.encode (subschemas trans)
validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError ()
validateMerkleHash trans graph =
if expectedHash /= actualHash then
Left (MerkleValidationError (transactionId trans) expectedHash actualHash)
else
pure ()
where
expectedHash = merkleHash (transactionInfo trans)
actualHash = calculateMerkleHash trans graph
data MerkleValidationError = MerkleValidationError TransactionId MerkleHash MerkleHash
deriving (Show, Eq, Generic)
validateMerkleHashes :: TransactionGraph -> Either [MerkleValidationError] ()
validateMerkleHashes graph =
if null errs then pure () else Left errs
where
errs = S.foldr validateTrans [] (transactionsForGraph graph)
validateTrans trans acc =
case validateMerkleHash trans graph of
Left err -> err : acc
_ -> acc