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