git.iko.soy/project-m36
on 7bc78ff help sign in
project-m36/ProjectM36/TransactionGraph.hs
244 lines 14 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
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
17--operators which manipulate a transaction graph
18data TransactionGraphOperator = JumpToHead HeadName |
19 JumpToTransaction U.UUID |
20 Branch HeadName |
21 Commit |
22 Rollback
24data ROTransactionGraphOperator = ShowGraph
26bootstrapTransactionGraph :: U.UUID -> DatabaseContext -> TransactionGraph
27bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions
28 where
29 bootstrapHeads = M.singleton "master" freshTransaction
30 freshTransaction = Transaction freshUUID (TransactionInfo U.nil S.empty) context
31 bootstrapTransactions = S.singleton freshTransaction
33emptyTransactionGraph :: TransactionGraph
34emptyTransactionGraph = TransactionGraph M.empty S.empty
36transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction
37transactionForHead headName (TransactionGraph heads _) = M.lookup headName heads
39headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName
40headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then
41 Nothing
42 else
43 Just $ (head . M.keys) matchingTrans
44 where
45 matchingTrans = M.filter (transaction ==) heads
47transactionForUUID :: U.UUID -> TransactionGraph -> Either RelationalError Transaction
48transactionForUUID uuid graph = if S.null matchingTrans then
49 Left $ NoSuchTransactionError uuid
50 else
51 Right $ head (S.toList matchingTrans)
52 where
53 matchingTrans = S.filter (\(Transaction uuidMatch _ _) -> uuidMatch == uuid) (transactionsForGraph graph)
55transactionsForUUIDs :: S.Set U.UUID -> TransactionGraph -> Either RelationalError (S.Set Transaction)
56transactionsForUUIDs uuidSet graph = do
57 transList <- forM (S.toList uuidSet) ((flip transactionForUUID) graph)
58 return (S.fromList transList)
60isRootTransaction :: Transaction -> TransactionGraph -> Bool
61isRootTransaction (Transaction _ (TransactionInfo pUUID _) _) _ = U.null pUUID
62isRootTransaction (Transaction _ (MergeTransactionInfo _ _ _) _) _ = False
64-- the first transaction has no parent - all other do have parents- merges have two parents
65parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
66parentTransactions (Transaction _ (TransactionInfo pUUID _) _) graph = do
67 trans <- transactionForUUID pUUID graph
68 return (S.singleton trans)
70parentTransactions (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _ ) graph = transactionsForUUIDs (S.fromList [pUUID1, pUUID2]) graph
73childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
74childTransactions (Transaction _ (TransactionInfo _ children) _) = transactionsForUUIDs children
75childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transactionsForUUIDs children
77-- create a new commit and add it to the heads
78-- 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)
79addBranch :: U.UUID -> HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
80addBranch newUUID newBranchName branchPoint graph = addTransactionToGraph newBranchName branchPoint newUUID (transactionContext branchPoint) graph
82--adds a disconnected transaction to a transaction graph at some head
83addDisconnectedTransaction :: U.UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
84addDisconnectedTransaction newUUID headName (DisconnectedTransaction parentUUID context) graph = do
85 parentTrans <- transactionForUUID parentUUID graph
86 addTransactionToGraph headName parentTrans newUUID context graph
88-- create a new transaction on "newHeadName" with the branchPointTrans
89addTransactionToGraph :: HeadName -> Transaction -> U.UUID -> DatabaseContext -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
90addTransactionToGraph newHeadName branchPointTrans newUUID newContext (TransactionGraph heads transSet) = do
91 let freshTransaction = Transaction newUUID (TransactionInfo (transactionUUID branchPointTrans) S.empty) newContext
92 -- there are two parents for MergeTransactions! not implemented
93 --update parentTransaction to add child
94 let parentTransaction = branchPointTrans
95 let updatedTransSet = (S.insert freshTransaction <$> S.insert parentTransaction <$> S.delete parentTransaction) transSet
96 let updatedGraph = TransactionGraph (M.insert newHeadName freshTransaction heads) updatedTransSet
97 return (freshTransaction, updatedGraph)
99validateGraph :: TransactionGraph -> Maybe [RelationalError]
100validateGraph graph@(TransactionGraph _ transSet) = do
101 --check that all UUIDs are unique in the graph
102 --uuids = map transactionUUID transSet
103 --check that all heads appear in the transSet
104 --check that all forward and backward links are in place
105 _ <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)
106 mapM (walkChildTransactions S.empty graph) (S.toList transSet)
108--verify that all parent links exist and that all children exist
109--maybe verify that all parents end at UUID nil and all children end at leaves
110walkParentTransactions :: S.Set U.UUID -> TransactionGraph -> Transaction -> Maybe RelationalError
111walkParentTransactions seenTransSet graph trans =
112 let transUUID = transactionUUID trans in
113 if transUUID == U.nil then
114 Nothing
115 else if S.member transUUID seenTransSet then
116 Just $ TransactionGraphCycleError transUUID
117 else
118 let parentTransSetOrError = parentTransactions trans graph in
119 case parentTransSetOrError of
120 Left err -> Just err
121 Right parentTransSet -> do
122 walk <- mapM (walkParentTransactions (S.insert transUUID seenTransSet) graph) (S.toList parentTransSet)
123 case walk of
124 err:_ -> Just err
125 _ -> Nothing
127--refactor: needless duplication in these two functions
128walkChildTransactions :: S.Set U.UUID -> TransactionGraph -> Transaction -> Maybe RelationalError
129walkChildTransactions seenTransSet graph trans =
130 let transUUID = transactionUUID trans in
131 if childTransactions trans graph == Right S.empty then
132 Nothing
133 else if S.member transUUID seenTransSet then
134 Just $ TransactionGraphCycleError transUUID
135 else
136 let childTransSetOrError = childTransactions trans graph in
137 case childTransSetOrError of
138 Left err -> Just err
139 Right childTransSet -> do
140 walk <- mapM (walkChildTransactions (S.insert transUUID seenTransSet) graph) (S.toList childTransSet)
141 case walk of
142 err:_ -> Just err
143 _ -> Nothing
145-- returns the new "current" transaction, updated graph, and tutorial d result
146-- the current transaction is not part of the transaction graph until it is committed
147evalGraphOp :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)
149--affects only disconncted transaction
150evalGraphOp _ _ graph (JumpToTransaction jumpUUID) = case transactionForUUID jumpUUID graph of
151 Left err -> Left err
152 Right parentTrans -> Right (newTrans, graph)
153 where
154 newTrans = DisconnectedTransaction jumpUUID (transactionContext parentTrans)
156-- switch from one head to another
157-- affects only disconnectedtransaction
158evalGraphOp _ _ graph (JumpToHead headName) =
159 case transactionForHead headName graph of
160 Just newHeadTransaction -> let disconnectedTrans = newDisconnectedTransaction (transactionUUID newHeadTransaction) (transactionContext newHeadTransaction) in
161 Right (disconnectedTrans, graph)
162 Nothing -> Left $ NoSuchHeadNameError headName
163-- add new head pointing to branchPoint
164-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)
165-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch
166 {-
167evalGraphOp newUUID discon@(DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
168 Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")
169 Just parentTrans -> case addBranch newBranchName parentTrans graph of
170 Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")
171 Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")
172 where
173 newDiscon = DisconnectedTransaction (transactionUUID parentTrans) disconContext
174-}
176-- create a new commit and add it to the heads
177-- 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)
178evalGraphOp newUUID (DisconnectedTransaction parentUUID disconContext) graph (Branch newBranchName) = case transactionForUUID parentUUID graph of
179 Left err -> Left err
180 Right parentTrans -> case addBranch newUUID newBranchName parentTrans graph of
181 Left err -> Left err
182 Right (_, newGraph) -> Right (newDiscon, newGraph)
183 where
184 newDiscon = DisconnectedTransaction newUUID disconContext
186-- add the disconnected transaction to the graph
187-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction
188evalGraphOp newTransUUID discon@(DisconnectedTransaction parentUUID context) graph Commit = case transactionForUUID parentUUID graph of
189 Left err -> Left err
190 Right parentTransaction -> case headNameForTransaction parentTransaction graph of
191 Nothing -> Left $ TransactionIsNotAHeadError parentUUID
192 Just headName -> case maybeUpdatedGraph of
193 Left err-> Left err
194 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)
195 where
196 newDisconnectedTrans = newDisconnectedTransaction newTransUUID context
197 maybeUpdatedGraph = addDisconnectedTransaction newTransUUID headName discon graph
199-- refresh the disconnected transaction, return the same graph
200evalGraphOp _ (DisconnectedTransaction parentUUID _) graph Rollback = case transactionForUUID parentUUID graph of
201 Left err -> Left err
202 Right parentTransaction -> Right (newDiscon, graph)
203 where
204 newDiscon = newDisconnectedTransaction parentUUID (transactionContext parentTransaction)
206--display transaction graph as relation
207evalROGraphOp :: DisconnectedTransaction -> TransactionGraph -> ROTransactionGraphOperator -> Either RelationalError Relation
208evalROGraphOp discon graph ShowGraph = do
209 graphRel <- graphAsRelation discon graph
210 return graphRel
212--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction
213graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation
214graphAsRelation (DisconnectedTransaction parentUUID _) graph@(TransactionGraph _ transSet) = do
215 tupleMatrix <- mapM tupleGenerator (S.toList transSet)
216 mkRelationFromList attrs tupleMatrix
217 where
218 attrs = A.attributesFromList [Attribute "id" StringAtomType,
219 Attribute "parents" (RelationAtomType parentAttributes),
220 Attribute "current" BoolAtomType,
221 Attribute "head" StringAtomType
222 ]
223 parentAttributes = A.attributesFromList [Attribute "id" StringAtomType]
224 tupleGenerator transaction = case transactionParentsRelation transaction graph of
225 Left err -> Left err
226 Right parentTransRel -> Right [StringAtom $ T.pack $ show (transactionUUID transaction),
227 RelationAtom parentTransRel,
228 BoolAtom $ parentUUID == transactionUUID transaction,
229 StringAtom $ case headNameForTransaction transaction graph of
230 Just headName -> headName
231 Nothing -> ""
232 ]
234transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation
235transactionParentsRelation trans graph = do
236 if isRootTransaction trans graph then do
237 mkRelation attrs emptyTupleSet
238 else do
239 parentTransSet <- parentTransactions trans graph
240 let tuples = map trans2tuple (S.toList parentTransSet)
241 mkRelationFromTuples attrs tuples
242 where
243 attrs = A.attributesFromList [Attribute "id" StringAtomType]
244 trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (StringAtom (T.pack (show $ transactionUUID trans2)))