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