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