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