git.iko.soy/project-m36
on 01345d5 help sign in
project-m36/src/lib/ProjectM36/TransactionGraph.hs
427 lines 25 kB history raw
1{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}
2module ProjectM36.TransactionGraph where
3import ProjectM36.Base
4import ProjectM36.Error
5import ProjectM36.Transaction
6import ProjectM36.Relation
7import ProjectM36.TupleSet
8import ProjectM36.Tuple
9import qualified Data.Vector as V
10import qualified ProjectM36.Attribute as A
11import qualified Data.UUID as U
12import qualified Data.Set as S
13import qualified Data.Map as M
14import Control.Monad
15import qualified Data.Text as T
16import GHC.Generics
17import Data.Binary
18import ProjectM36.TransactionGraph.Merge
19import Data.Either (lefts, rights, isRight)
20--import Debug.Trace
22-- | Record a lookup for a specific transaction in the graph.
23data TransactionIdLookup = TransactionIdLookup TransactionId |
24 TransactionIdHeadNameLookup HeadName
25 deriving (Show, Eq, Binary, Generic)
27-- topic~3^2
28data TransactionIdHeadBacktrack = TransactionIdHeadParentBackTrack Int | -- git ~: walk back n parents, arbitrarily choosing a parent when a choice must be made
29 TransactionIdHeadBranchBackTrack Int -- git ^: walk back one parent level to the nth arbitrarily-chosen parent
31--operators which manipulate a transaction graph
32data TransactionGraphOperator = JumpToHead HeadName |
33 JumpToTransaction TransactionId |
34 Branch HeadName |
35 MergeTransactions MergeStrategy HeadName HeadName |
36 Commit |
37 Rollback
38 deriving (Eq, Show, Binary, Generic)
40data ROTransactionGraphOperator = ShowGraph
43bootstrapTransactionGraph :: TransactionId -> DatabaseContext -> TransactionGraph
44bootstrapTransactionGraph freshId context = TransactionGraph bootstrapHeads bootstrapTransactions
45 where
46 bootstrapHeads = M.singleton "master" freshTransaction
47 freshTransaction = Transaction freshId (TransactionInfo U.nil S.empty) context
48 bootstrapTransactions = S.singleton freshTransaction
50emptyTransactionGraph :: TransactionGraph
51emptyTransactionGraph = TransactionGraph M.empty S.empty
53transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction
54transactionForHead headName (TransactionGraph heads _) = M.lookup headName heads
56headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName
57headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then
58 Nothing
59 else
60 Just $ (head . M.keys) matchingTrans
61 where
62 matchingTrans = M.filter (transaction ==) heads
64transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction
65transactionForId tid graph = if tid == U.nil then
66 Left RootTransactionTraversalError
67 else if S.null matchingTrans then
68 Left $ NoSuchTransactionError tid
69 else
70 Right $ head (S.toList matchingTrans)
71 where
72 matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)
74transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction)
75transactionsForIds idSet graph = do
76 transList <- forM (S.toList idSet) ((flip transactionForId) graph)
77 return (S.fromList transList)
79isRootTransaction :: Transaction -> TransactionGraph -> Bool
80isRootTransaction (Transaction _ (TransactionInfo pId _) _) _ = U.null pId
81isRootTransaction (Transaction _ (MergeTransactionInfo _ _ _) _) _ = False
83-- the first transaction has no parent - all other do have parents- merges have two parents
84parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
85parentTransactions (Transaction _ (TransactionInfo pId _) _) graph = do
86 trans <- transactionForId pId graph
87 return (S.singleton trans)
89parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph
92childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
93childTransactions (Transaction _ (TransactionInfo _ children) _) = transactionsForIds children
94childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transactionsForIds children
96-- create a new commit and add it to the heads
97-- 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)
98addBranch :: TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
99addBranch newId newBranchName branchPointId graph = do
100 parentTrans <- transactionForId branchPointId graph
101 let newTrans = Transaction newId (TransactionInfo branchPointId S.empty) (transactionContext parentTrans)
102 addTransactionToGraph newBranchName newTrans graph
104--adds a disconnected transaction to a transaction graph at some head
105addDisconnectedTransaction :: TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
106addDisconnectedTransaction newId headName (DisconnectedTransaction parentId context) graph = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty) context) graph
108addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
109addTransactionToGraph headName newTrans graph = do
110 let parentIds = transactionParentIds newTrans
111 childIds = transactionChildIds newTrans
112 newId = transactionId newTrans
113 validateIds ids = mapM (\i -> transactionForId i graph) (S.toList ids)
114 addChildTransaction trans = transactionSetChildren trans (S.insert newId (transactionChildIds trans))
115 --validate that the parent transactions are in the graph
116 _ <- validateIds parentIds
117 when (S.size parentIds < 1) (Left $ NewTransactionMissingParentError newId)
118 --if the headName already exists, ensure that it refers to a parent
119 case transactionForHead headName graph of
120 Nothing -> pure () -- any headName is OK
121 Just trans -> when (S.notMember (transactionId trans) parentIds) (Left (HeadNameSwitchingHeadProhibitedError headName))
122 --validate that the transaction has no children
123 when (not (S.null childIds)) (Left $ NewTransactionMayNotHaveChildrenError newId)
124 --validate that the trasaction's id is unique
125 when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))
126 --update the parent transactions to point to the new transaction
127 parents <- mapM (\tid -> transactionForId tid graph) (S.toList parentIds)
128 let updatedParents = S.map addChildTransaction (S.fromList parents)
129 updatedTransSet = S.insert newTrans (S.union updatedParents (transactionsForGraph graph))
130 updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph)
131 pure (newTrans, (TransactionGraph updatedHeads updatedTransSet))
133validateGraph :: TransactionGraph -> Maybe [RelationalError]
134validateGraph graph@(TransactionGraph _ transSet) = do
135 --check that all transaction ids are unique in the graph
136 --FINISH ME!
137 --uuids = map transactionId transSet
138 --check that all heads appear in the transSet
139 --check that all forward and backward links are in place
140 _ <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)
141 mapM (walkChildTransactions S.empty graph) (S.toList transSet)
143--verify that all parent links exist and that all children exist
144--maybe verify that all parents end at transaction id nil and all children end at leaves
145walkParentTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
146walkParentTransactions seenTransSet graph trans =
147 let transId = transactionId trans in
148 if transId == U.nil then
149 Nothing
150 else if S.member transId seenTransSet then
151 Just $ TransactionGraphCycleError transId
152 else
153 let parentTransSetOrError = parentTransactions trans graph in
154 case parentTransSetOrError of
155 Left err -> Just err
156 Right parentTransSet -> do
157 walk <- mapM (walkParentTransactions (S.insert transId seenTransSet) graph) (S.toList parentTransSet)
158 case walk of
159 err:_ -> Just err
160 _ -> Nothing
162--refactor: needless duplication in these two functions
163walkChildTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError
164walkChildTransactions seenTransSet graph trans =
165 let transId = transactionId trans in
166 if childTransactions trans graph == Right S.empty then
167 Nothing
168 else if S.member transId seenTransSet then
169 Just $ TransactionGraphCycleError transId
170 else
171 let childTransSetOrError = childTransactions trans graph in
172 case childTransSetOrError of
173 Left err -> Just err
174 Right childTransSet -> do
175 walk <- mapM (walkChildTransactions (S.insert transId seenTransSet) graph) (S.toList childTransSet)
176 case walk of
177 err:_ -> Just err
178 _ -> Nothing
180-- returns the new "current" transaction, updated graph, and tutorial d result
181-- the current transaction is not part of the transaction graph until it is committed
182evalGraphOp :: TransactionId -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
184--affects only disconncted transaction
185evalGraphOp _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId graph of
186 Left err -> Left err
187 Right parentTrans -> Right (newTrans, graph)
188 where
189 newTrans = DisconnectedTransaction jumpId (transactionContext parentTrans)
191-- switch from one head to another
192-- affects only disconnectedtransaction
193evalGraphOp _ _ graph (JumpToHead headName) =
194 case transactionForHead headName graph of
195 Just newHeadTransaction -> let disconnectedTrans = newDisconnectedTransaction (transactionId newHeadTransaction) (transactionContext newHeadTransaction) in
196 Right (disconnectedTrans, graph)
197 Nothing -> Left $ NoSuchHeadNameError headName
198-- add new head pointing to branchPoint
199-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)
200-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch
201 {-
202evalGraphOp newId discon@(DisconnectedTransaction parentId disconContext) graph (Branch newBranchName) = case transactionForId parentId graph of
203 Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")
204 Just parentTrans -> case addBranch newBranchName parentTrans graph of
205 Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")
206 Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")
207 where
208 newDiscon = DisconnectedTransaction (transactionId parentTrans) disconContext
209-}
211-- create a new commit and add it to the heads
212-- 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)
213evalGraphOp newId (DisconnectedTransaction parentId disconContext) graph (Branch newBranchName) = case addBranch newId newBranchName parentId graph of
214 Left err -> Left err
215 Right (_, newGraph) -> Right (newDiscon, newGraph)
216 where
217 newDiscon = DisconnectedTransaction newId disconContext
219-- add the disconnected transaction to the graph
220-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
221evalGraphOp newTransId discon@(DisconnectedTransaction parentId context) graph Commit = case transactionForId parentId graph of
222 Left err -> Left err
223 Right parentTransaction -> case headNameForTransaction parentTransaction graph of
224 Nothing -> Left $ TransactionIsNotAHeadError parentId
225 Just headName -> case maybeUpdatedGraph of
226 Left err-> Left err
227 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)
228 where
229 newDisconnectedTrans = newDisconnectedTransaction newTransId context
230 maybeUpdatedGraph = addDisconnectedTransaction newTransId headName discon graph
232-- refresh the disconnected transaction, return the same graph
233evalGraphOp _ (DisconnectedTransaction parentId _) graph Rollback = case transactionForId parentId graph of
234 Left err -> Left err
235 Right parentTransaction -> Right (newDiscon, graph)
236 where
237 newDiscon = newDisconnectedTransaction parentId (transactionContext parentTransaction)
239-- a successful merge should remove a head
240evalGraphOp newId (DisconnectedTransaction parentId _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph
242--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
243graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
244graphAsRelation (DisconnectedTransaction parentId _) graph@(TransactionGraph _ transSet) = do
245 tupleMatrix <- mapM tupleGenerator (S.toList transSet)
246 mkRelationFromList attrs tupleMatrix
247 where
248 attrs = A.attributesFromList [Attribute "id" TextAtomType,
249 Attribute "parents" (RelationAtomType parentAttributes),
250 Attribute "current" BoolAtomType,
251 Attribute "head" TextAtomType
252 ]
253 parentAttributes = A.attributesFromList [Attribute "id" TextAtomType]
254 tupleGenerator transaction = case transactionParentsRelation transaction graph of
255 Left err -> Left err
256 Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),
257 RelationAtom parentTransRel,
258 BoolAtom $ parentId == transactionId transaction,
259 TextAtom $ case headNameForTransaction transaction graph of
260 Just headName -> headName
261 Nothing -> ""
262 ]
264transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
265transactionParentsRelation trans graph = do
266 if isRootTransaction trans graph then do
267 mkRelation attrs emptyTupleSet
268 else do
269 parentTransSet <- parentTransactions trans graph
270 let tuples = map trans2tuple (S.toList parentTransSet)
271 mkRelationFromTuples attrs tuples
272 where
273 attrs = A.attributesFromList [Attribute "id" TextAtomType]
274 trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (TextAtom (T.pack (show $ transactionId trans2)))
276{-
277--display transaction graph as relation
278evalROGraphOp :: DisconnectedTransaction -> TransactionGraph -> ROTransactionGraphOperator -> Either RelationalError Relation
279evalROGraphOp discon graph ShowGraph = do
280 graphRel <- graphAsRelation discon graph
281 return graphRel
282-}
284-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph
285createMergeTransaction :: TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
286createMergeTransaction newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do
287 selectedTrans <- validateHeadName selectedBranch graph t2
288 pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty) (transactionContext selectedTrans)
290-- merge functions, relvars, individually
291createMergeTransaction newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction newId strat graph t2
293-- merge function, relvars, but, on error, just take the component from the preferred branch
294createMergeTransaction newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction newId strat graph t2
296-- | 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.
297validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
298validateHeadName headName graph (t1, t2) = do
299 case transactionForHead headName graph of
300 Nothing -> Left SelectedHeadMismatchMergeError
301 Just trans -> if trans /= t1 && trans /= t2 then
302 Left SelectedHeadMismatchMergeError
303 else
304 Right trans
306-- 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.
307subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph
308subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans traverseSet = do
309 let currentid = transactionId currentTrans
310 goalid = transactionId goalTrans
311 if currentTrans == goalTrans then
312 Right (TransactionGraph resultHeads traverseSet) -- add filter
313 --catch root transaction to improve error?
314 else do
315 currentTransChildren <- liftM S.fromList $ mapM (flip transactionForId origGraph) (S.toList (transactionChildIds currentTrans))
316 let searchChildren = S.difference (S.insert currentTrans traverseSet) currentTransChildren
317 searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans traverseSet)
318 childSearches = map searchChild (S.toList searchChildren)
319 errors = lefts childSearches
320 pathsFound = rights childSearches
321 realErrors = filter (/= (FailedToFindTransactionError goalid)) errors
322 -- report any non-search-related errors
323 when (not (null realErrors)) (Left (head realErrors))
324 -- if no paths found, search the parent
325 if null pathsFound then
326 case oneParent currentTrans of
327 Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)
328 Left err -> Left err
329 Right currentTransParent -> do
330 subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans traverseSet)
331 else -- we found a path
332 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))
333 where
334 oneParent (Transaction _ (TransactionInfo parentId _) _) = transactionForId parentId origGraph
335 oneParent (Transaction _ (MergeTransactionInfo parentId _ _) _) = transactionForId parentId origGraph
337-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.
338pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)
339pathToTransaction graph currentTransaction targetTransaction accumTransSet = do
340 let targetId = transactionId targetTransaction
341 if transactionId targetTransaction == transactionId currentTransaction then do
342 Right accumTransSet
343 else do
344 currentTransChildren <- mapM (flip transactionForId graph) (S.toList (transactionChildIds currentTransaction))
345 if length currentTransChildren == 0 then
346 Left (FailedToFindTransactionError targetId)
347 else do
348 let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) currentTransChildren
349 let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)
350 paths = rights searches
351 if length realErrors > 0 then -- found some real errors
352 Left (head realErrors)
353 else if length paths == 0 then -- failed to find transaction in all children
354 Left (FailedToFindTransactionError targetId)
355 else --we have some paths!
356 Right (S.unions paths)
358mergeTransactions :: TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
359mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph = do
360 let transactionForHeadErr name = case transactionForHead name graph of
361 Nothing -> Left (NoSuchHeadNameError name)
362 Just t -> Right t
363 transA <- transactionForHeadErr headNameA
364 transB <- transactionForHeadErr headNameB
365 disconParent <- transactionForId parentId graph
366 let subHeads = M.filterWithKey (\k _ -> elem k [headNameA, headNameB]) (transactionHeadsForGraph graph)
367 subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty
368 subGraph' <- filterSubGraph subGraph subHeads
369 case createMergeTransaction newId mergeStrategy subGraph' (transA, transB) of
370 Left err -> Left (MergeTransactionError err)
371 Right mergedTrans -> case headNameForTransaction disconParent graph of
372 Nothing -> Left (TransactionIsNotAHeadError parentId)
373 Just headName -> do
374 (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph
375 let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)
376 newDiscon = newDisconnectedTransaction newId (transactionContext newTrans)
377 pure (newDiscon, newGraph')
379--TEMPORARY COPY/PASTE
380showTransactionStructureX :: Transaction -> TransactionGraph -> String
381showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo
382 where
383 headInfo = maybe "" show (headNameForTransaction trans graph)
384 parentTransactionsInfo = if isRootTransaction trans graph then "root" else case parentTransactions trans graph of
385 Left err -> show err
386 Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet
388showGraphStructureX :: TransactionGraph -> String
389showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet
390 where
391 folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n"
392 headsInfo = show $ M.map transactionId heads
394-- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph.
395filterSubGraph :: TransactionGraph -> TransactionHeads -> Either RelationalError TransactionGraph
396filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet
397 where
398 validIds = S.map transactionId (transactionsForGraph graph)
399 newTransSet = S.map (filterTransaction validIds) (transactionsForGraph graph)
400 newHeads = M.map (filterTransaction validIds) heads
402--helper function for commonalities in union merge
403createUnionMergeTransaction :: TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction
404createUnionMergeTransaction newId strategy graph (t1,t2) = do
405 let contextA = transactionContext t1
406 contextB = transactionContext t2
408 preference <- case strategy of
409 UnionMergeStrategy -> pure PreferNeither
410 UnionPreferMergeStrategy preferBranch -> do
411 case transactionForHead preferBranch graph of
412 Nothing -> Left (PreferredHeadMissingMergeError preferBranch)
413 Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond
414 badStrat -> Left (InvalidMergeStrategyError badStrat)
416 incDeps <- unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)
417 relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)
418 atomFuncs <- unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)
419 notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB)
420 types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)
421 pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty) (DatabaseContext incDeps relVars atomFuncs notifs types))
423lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction
424lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph
425lookupTransaction graph (TransactionIdHeadNameLookup headName) = case transactionForHead headName graph of
426 Just t -> Right t
427 Nothing -> Left (NoSuchHeadNameError headName)