git.iko.soy/project-m36
on master help sign in
Merge branch 'transaction_persistence'

Conflicts: project-m36.cabal

commit3e72e529d3afbf18f562e842d5c5cef33af743b7 authorAgentM <agentm@themactionfaction.com> dateTue 14 Jul 2015, 17:18 (11 years ago) parent6247771b2943c6
16 files changed+663−174
compare with master
unifiedsplit
ProjectM36/Base.hs+50−11 ProjectM36/DatabaseContext.hs+9 ProjectM36/Error.hs+6−1 ProjectM36/HashSetBinary.hs+11 ProjectM36/Transaction.hs+3−127 ProjectM36/Transaction/Persist.hs+131 ProjectM36/TransactionGraph.hs+128 ProjectM36/TransactionGraph/Persist.hs+152 ProjectM36/Transaction/Show.hs → ProjectM36/TransactionGraph/Show.hs+2−2 TutorialD/Interpreter.hs+28−22 TutorialD/Interpreter/Base.hs+7 TutorialD/Interpreter/TransactionGraphOperator.hs+2−1 TutorialD/tutd.hs+58−5 project-m36.cabal+11−2 test/TransactionGraph/Persist.hs+61 test/TutorialD/Interpreter.hs+4−3
ProjectM36/Base.hs+50−11
@@ -12,6 +12,9 @@ import GHC.Generics (Generic)
1212import qualified Data.Vector as V
1313import qualified Data.List as L
1414import qualified Data.Text as T
15+import Data.Binary
16+import Data.Vector.Binary()
17+import ProjectM36.HashSetBinary()
1518
1619type StringType = T.Text
1720
@@ -23,7 +26,9 @@ data Atom = StringAtom StringType |
2326
2427instance NFData Atom where rnf = genericRnf
2528
26−instance Hash.Hashable Atom
29+instance Hash.Hashable Atom
30+
31+instance Binary Atom
2732
2833data AtomType = StringAtomType |
2934 IntAtomType |
@@ -33,6 +38,7 @@ data AtomType = StringAtomType |
3338 deriving (Eq, Show, Generic)
3439
3540instance NFData AtomType where rnf = genericRnf
41+instance Binary AtomType
3642
3743type AttributeName = T.Text
3844
@@ -42,6 +48,8 @@ instance Hash.Hashable Attribute where
4248 hashWithSalt salt (Attribute attrName _) = Hash.hashWithSalt salt attrName
4349
4450instance NFData Attribute where rnf = genericRnf
51+
52+instance Binary Attribute
4553
4654type Attributes = V.Vector Attribute
4755
@@ -68,6 +76,8 @@ instance Hash.Hashable RelationTuple where
6876--maybe the attribute->int mapping should be stored once in the relation and then passed down when needed
6977data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Generic)
7078
79+instance Binary RelationTuple
80+
7181instance Eq RelationTuple where
7282 (==) tuple1@(RelationTuple attrs1 _) tuple2@(RelationTuple attrs2 _) = attributesEqual attrs1 attrs2 && atomsEqual
7383 where
@@ -91,6 +101,8 @@ instance Hash.Hashable Relation where
91101 HS.toList tupSet
92102 where
93103 sortedAttrs = map snd (sortedAttributesIndices attrs)
104+
105+instance Binary Relation
94106
95107data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show, Generic)
96108data RelationSizeInfinite = RelationSizeInfinite
@@ -115,17 +127,23 @@ data RelationalExpr where
115127 NotEquals :: RelationalExpr -> RelationalExpr -> RelationalExpr
116128 Extend :: TupleExpr -> RelationalExpr -> RelationalExpr
117129 --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend
118− deriving (Show,Eq)
130+ deriving (Show,Eq, Generic)
131+
132+instance Binary RelationalExpr
119133
120134data DatabaseContext = DatabaseContext {
121135 inclusionDependencies :: M.Map IncDepName InclusionDependency,
122136 relationVariables :: M.Map RelVarName Relation,
123137 atomFunctions :: AtomFunctions
124− } deriving (Show)
138+ } deriving (Show, Generic)
139+
140+--instance Binary DatabaseContext
125141
126142type IncDepName = StringType
127143
128−data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq)
144+data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq, Generic)
145+
146+instance Binary InclusionDependency
129147
130148--Database context expressions modify the database context while relational expressions do not
131149data DatabaseExpr where
@@ -150,7 +168,9 @@ data RestrictionPredicateExpr where
150168 RelationalExprPredicate :: RelationalExpr -> RestrictionPredicateExpr --type must be same as true and false relations (no attributes)
151169 AtomExprPredicate :: AtomExpr -> RestrictionPredicateExpr --atom must evaluate to boolean
152170 AttributeEqualityPredicate :: AttributeName -> AtomExpr -> RestrictionPredicateExpr -- relationalexpr must result in relation with single tuple
153− deriving (Show, Eq)
171+ deriving (Show, Eq, Generic)
172+
173+instance Binary RestrictionPredicateExpr
154174
155175-- child + parent links
156176-- the string represents the branch name and can be used to find the named HEADs
@@ -169,10 +189,14 @@ transactionHeadsForGraph (TransactionGraph heads _) = heads
169189
170190data TransactionInfo = TransactionInfo UUID (S.Set UUID) | -- 1 parent + n children
171191 MergeTransactionInfo UUID UUID (S.Set UUID) -- 2 parents, n children
172− deriving(Show)
192+ deriving(Show, Generic)
193+
194+instance Binary TransactionInfo
173195
174196data Transaction = Transaction UUID TransactionInfo DatabaseContext -- self uuid
175− deriving (Show)
197+ deriving (Show, Generic)
198+
199+--instance Binary Transaction
176200
177201--represents an "in-progress" transaction which has not yet been added to the transaction graph
178202--one the transaction is "complete", it is committed and no longer can be changed
@@ -184,6 +208,9 @@ transactionUUID (Transaction uuid _ _) = uuid
184208
185209transactionContext :: Transaction -> DatabaseContext
186210transactionContext (Transaction _ _ context) = context
211+
212+transactionInfo :: Transaction -> TransactionInfo
213+transactionInfo (Transaction _ info _) = info
187214
188215instance Eq Transaction where
189216 (Transaction uuidA _ _) == (Transaction uuidB _ _) = uuidA == uuidB
@@ -196,11 +223,15 @@ data AtomExpr = AttributeAtomExpr AttributeName |
196223 NakedAtomExpr Atom |
197224 FunctionAtomExpr AtomFunctionName [AtomExpr] |
198225 RelationAtomExpr RelationalExpr
199− deriving (Eq,Show)
226+ deriving (Eq,Show,Generic)
227+
228+instance Binary AtomExpr
200229
201230--used to extend a relation
202231data TupleExpr = AttributeTupleExpr AttributeName AtomExpr
203− deriving (Show, Eq)
232+ deriving (Show, Eq, Generic)
233+
234+instance Binary TupleExpr
204235
205236--enumerates the list of functions available to be run as part of tuple expressions
206237type AtomFunctions = HS.HashSet AtomFunction
@@ -223,7 +254,15 @@ instance Show AtomFunction where
223254 show aFunc = T.unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes
224255 where
225256 showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))
226−
257+
227258data AttributeNames = AttributeNames (S.Set AttributeName) |
228259 InvertedAttributeNames (S.Set AttributeName)
229− deriving (Eq, Show)
260+ deriving (Eq, Show, Generic)
261+
262+instance Binary AttributeNames
263+
264+--used for global dbms configuration- per-transaction flag is elsewhere
265+data PersistenceStrategy = NoPersistence | --no filesystem persistence/memory-only database
266+ MinimalPersistence FilePath --fsync off
267+ --CrashSafePersistence FilePath --full fsync- not yet implemented
268+ deriving (Show, Read)
ProjectM36/DatabaseContext.hsnew file+9
@@ -0,0 +1,9 @@
1+module ProjectM36.DatabaseContext where
2+import ProjectM36.Base
3+import qualified Data.Map as M
4+import qualified Data.HashSet as HS
5+
6+empty :: DatabaseContext
7+empty = DatabaseContext { inclusionDependencies = M.empty,
8+ relationVariables = M.empty,
9+ atomFunctions = HS.empty }
ProjectM36/Error.hs+6−1
@@ -34,5 +34,10 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)
3434 | AtomFunctionTypeError AtomFunctionName Int AtomType AtomType --arg number
3535 deriving (Show,Eq,Generic)
3636
37+instance NFData RelationalError where rnf = genericRnf
38+
39+data PersistenceError = InvalidDirectoryError FilePath |
40+ MissingTransactionError U.UUID
41+ deriving (Show, Eq)
3742
38−instance NFData RelationalError where rnf = genericRnf
43+
ProjectM36/HashSetBinary.hsnew file+11
@@ -0,0 +1,11 @@
1+module ProjectM36.HashSetBinary where
2+import Data.Hashable
3+import qualified Data.HashSet as HS
4+import Data.Binary
5+
6+instance (Binary a, Hashable a, Eq a) => Binary (HS.HashSet a) where
7+ put = put . HS.toList
8+ get = do
9+ list <- get :: (Binary a, Hashable a, Eq a) => Get [a]
10+ return (HS.fromList list)
11+
ProjectM36/Transaction.hs+3−127
@@ -2,137 +2,13 @@
22module ProjectM36.Transaction where
33import qualified Data.UUID as U
44import ProjectM36.Base
5−import ProjectM36.Error
65import qualified Data.Set as S
7−import qualified Data.Map as M
8−import Control.Applicative ((<$>))
9−import Control.Monad
106
11−bootstrapTransactionGraph :: U.UUID -> DatabaseContext -> TransactionGraph
12−bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions
13− where
14− bootstrapHeads = M.singleton "master" freshTransaction
15− freshTransaction = Transaction freshUUID (TransactionInfo U.nil S.empty) context
16− bootstrapTransactions = S.singleton freshTransaction
17−
18−transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction
19−transactionForHead headName (TransactionGraph heads _) = M.lookup headName heads
20−
21−headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName
22−headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then
23− Nothing
24− else
25− Just $ (head . M.keys) matchingTrans
26− where
27− matchingTrans = M.filter (transaction ==) heads
28−
29−transactionForUUID :: U.UUID -> TransactionGraph -> Either RelationalError Transaction
30−transactionForUUID uuid graph = if S.null matchingTrans then
31− Left $ NoSuchTransactionError uuid
32− else
33− Right $ head (S.toList matchingTrans)
34− where
35− matchingTrans = S.filter (\(Transaction uuidMatch _ _) -> uuidMatch == uuid) (transactionsForGraph graph)
36−
37−transactionsForUUIDs :: S.Set U.UUID -> TransactionGraph -> Either RelationalError (S.Set Transaction)
38−transactionsForUUIDs uuidSet graph = do
39− transList <- forM (S.toList uuidSet) ((flip transactionForUUID) graph)
40− return (S.fromList transList)
41−
42−isRootTransaction :: Transaction -> TransactionGraph -> Bool
43−isRootTransaction (Transaction _ (TransactionInfo pUUID _) _) _ = U.null pUUID
44−isRootTransaction (Transaction _ (MergeTransactionInfo _ _ _) _) _ = False
45−
46−-- the first transaction has no parent - all other do have parents- merges have two parents
47−parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
48−parentTransactions (Transaction _ (TransactionInfo pUUID _) _) graph = do
49− trans <- transactionForUUID pUUID graph
50− return (S.singleton trans)
51−
52−parentTransactions (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _ ) graph = transactionsForUUIDs (S.fromList [pUUID1, pUUID2]) graph
53−
54−
55−childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
56−childTransactions (Transaction _ (TransactionInfo _ children) _) = transactionsForUUIDs children
57−childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transactionsForUUIDs children
58−
59−
607--create a disconnected transaction with a parent
618newDisconnectedTransaction :: U.UUID -> DatabaseContext -> DisconnectedTransaction
629newDisconnectedTransaction parentUUID context = DisconnectedTransaction parentUUID context
6310
64−{-
65−addBranch :: HeadName -> Transaction -> TransactionGraph -> Maybe TransactionGraph
66−addBranch newBranchName branchPoint graph@(TransactionGraph heads transSet) = if not (S.member branchPoint transSet) then Nothing else Just $ TransactionGraph newHeads transSet
67− where
68− newHeads = M.insert newBranchName branchPoint heads
69−-}
70−
71−-- create a new commit and add it to the heads
72−-- 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)
73−addBranch :: U.UUID -> HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
74−addBranch newUUID newBranchName branchPoint graph = addTransactionToGraph newBranchName branchPoint newUUID (transactionContext branchPoint) graph
75−
76−--adds a disconnected transaction to a transaction graph at some head
77−addDisconnectedTransaction :: U.UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
78−addDisconnectedTransaction newUUID headName (DisconnectedTransaction parentUUID context) graph = do
79− parentTrans <- transactionForUUID parentUUID graph
80− addTransactionToGraph headName parentTrans newUUID context graph
81−
82−-- create a new transaction on "newHeadName" with the branchPointTrans
83−addTransactionToGraph :: HeadName -> Transaction -> U.UUID -> DatabaseContext -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
84−addTransactionToGraph newHeadName branchPointTrans newUUID newContext (TransactionGraph heads transSet) = do
85− let freshTransaction = Transaction newUUID (TransactionInfo (transactionUUID branchPointTrans) S.empty) newContext
86− -- there are two parents for MergeTransactions! not implemented
87− --update parentTransaction to add child
88− let parentTransaction = branchPointTrans
89− let updatedTransSet = (S.insert freshTransaction <$> S.insert parentTransaction <$> S.delete parentTransaction) transSet
90− let updatedGraph = TransactionGraph (M.insert newHeadName freshTransaction heads) updatedTransSet
91− return (freshTransaction, updatedGraph)
11+transactionParentUUIDs :: Transaction -> S.Set U.UUID
12+transactionParentUUIDs (Transaction _ (TransactionInfo pUUID _) _) = S.singleton pUUID
13+transactionParentUUIDs (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _) = S.fromList [pUUID1, pUUID2]
9214
93−validateGraph :: TransactionGraph -> Maybe [RelationalError]
94−validateGraph graph@(TransactionGraph _ transSet) = do
95− --check that all UUIDs are unique in the graph
96− --uuids = map transactionUUID transSet
97− --check that all heads appear in the transSet
98− --check that all forward and backward links are in place
99− _ <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)
100− mapM (walkChildTransactions S.empty graph) (S.toList transSet)
101−
102−--verify that all parent links exist and that all children exist
103−--maybe verify that all parents end at UUID nil and all children end at leaves
104−walkParentTransactions :: S.Set U.UUID -> TransactionGraph -> Transaction -> Maybe RelationalError
105−walkParentTransactions seenTransSet graph trans =
106− let transUUID = transactionUUID trans in
107− if transUUID == U.nil then
108− Nothing
109− else if S.member transUUID seenTransSet then
110− Just $ TransactionGraphCycleError transUUID
111− else
112− let parentTransSetOrError = parentTransactions trans graph in
113− case parentTransSetOrError of
114− Left err -> Just err
115− Right parentTransSet -> do
116− walk <- mapM (walkParentTransactions (S.insert transUUID seenTransSet) graph) (S.toList parentTransSet)
117− case walk of
118− err:_ -> Just err
119− _ -> Nothing
120−
121−--refactor: needless duplication in these two functions
122−walkChildTransactions :: S.Set U.UUID -> TransactionGraph -> Transaction -> Maybe RelationalError
123−walkChildTransactions seenTransSet graph trans =
124− let transUUID = transactionUUID trans in
125− if childTransactions trans graph == Right S.empty then
126− Nothing
127− else if S.member transUUID seenTransSet then
128− Just $ TransactionGraphCycleError transUUID
129− else
130− let childTransSetOrError = childTransactions trans graph in
131− case childTransSetOrError of
132− Left err -> Just err
133− Right childTransSet -> do
134− walk <- mapM (walkChildTransactions (S.insert transUUID seenTransSet) graph) (S.toList childTransSet)
135− case walk of
136− err:_ -> Just err
137− _ -> Nothing
138−
ProjectM36/Transaction/Persist.hsnew file+131
@@ -0,0 +1,131 @@
1+module ProjectM36.Transaction.Persist where
2+import ProjectM36.Base
3+import ProjectM36.Error
4+import qualified Data.Map as M
5+import qualified Data.HashSet as HS
6+import qualified Data.UUID as U
7+import qualified Data.Binary as B
8+import qualified Data.ByteString.Lazy as BS
9+import System.FilePath
10+import System.Directory
11+import qualified Data.Text as T
12+import Control.Monad
13+import ProjectM36.RelationalExpression (basicAtomFunctions)
14+
15+getDirectoryNames :: FilePath -> IO [FilePath]
16+getDirectoryNames path = do
17+ subpaths <- getDirectoryContents path
18+ return $ filter (\n -> n `notElem` ["..", "."]) subpaths
19+
20+tempTransactionDir :: FilePath -> U.UUID -> FilePath
21+tempTransactionDir dbdir transUUID = dbdir </> "." ++ U.toString transUUID
22+
23+transactionDir :: FilePath -> U.UUID -> FilePath
24+transactionDir dbdir transUUID = dbdir </> U.toString transUUID
25+
26+transactionInfoPath :: FilePath -> FilePath
27+transactionInfoPath transdir = transdir </> "info"
28+
29+relvarsDir :: FilePath -> FilePath
30+relvarsDir transdir = transdir </> "relvars"
31+
32+incDepsDir :: FilePath -> FilePath
33+incDepsDir transdir = transdir </> "incdeps"
34+
35+atomFuncsDir :: FilePath -> FilePath
36+atomFuncsDir transdir = transdir </> "atomfuncs"
37+
38+readTransaction :: FilePath -> U.UUID -> IO (Either PersistenceError Transaction)
39+readTransaction dbdir transUUID = do
40+ let transDir = transactionDir dbdir transUUID
41+ transDirExists <- doesDirectoryExist transDir
42+ if not transDirExists then
43+ return $ Left $ MissingTransactionError transUUID
44+ else do
45+ relvars <- readRelVars transDir
46+ transInfo <- liftM B.decode $ BS.readFile (transactionInfoPath transDir)
47+ incDeps <- readIncDeps transDir
48+ --atomFuncs <- readAtomFuncs transDir -- not yet supported since there is no bytecode to serialize yet
49+ let atomFuncs = basicAtomFunctions
50+ let newContext = DatabaseContext { inclusionDependencies = incDeps,
51+ relationVariables = relvars,
52+ atomFunctions = atomFuncs }
53+
54+ return $ Right $ Transaction transUUID transInfo newContext
55+
56+writeTransaction :: FilePath -> Transaction -> IO ()
57+writeTransaction dbdir trans = do
58+ let tempTransDir = tempTransactionDir dbdir (transactionUUID trans)
59+ finalTransDir = transactionDir dbdir (transactionUUID trans)
60+ context = transactionContext trans
61+ transDirExists <- doesDirectoryExist finalTransDir
62+ if not transDirExists then do
63+ --create sub directories
64+ mapM_ createDirectory [tempTransDir, relvarsDir tempTransDir, incDepsDir tempTransDir, atomFuncsDir tempTransDir]
65+ writeRelVars tempTransDir (relationVariables context)
66+ writeIncDeps tempTransDir (inclusionDependencies context)
67+ writeAtomFuncs tempTransDir (atomFunctions context)
68+ BS.writeFile (transactionInfoPath tempTransDir) (B.encode $ transactionInfo trans)
69+ --move the temp directory to final location
70+ renameDirectory tempTransDir finalTransDir
71+ else
72+ return ()
73+
74+writeRelVar :: FilePath -> (RelVarName, Relation) -> IO ()
75+writeRelVar transDir (relvarName, rel) = do
76+ let relvarPath = relvarsDir transDir </> T.unpack relvarName
77+ BS.writeFile relvarPath (B.encode rel)
78+
79+writeRelVars :: FilePath -> (M.Map RelVarName Relation) -> IO ()
80+writeRelVars transDir relvars = mapM_ (writeRelVar transDir) $ M.toList relvars
81+
82+readRelVars :: FilePath -> IO (M.Map RelVarName Relation)
83+readRelVars transDir = do
84+ let relvarsPath = relvarsDir transDir
85+ relvarNames <- getDirectoryNames relvarsPath
86+ relvars <- mapM (\name -> do
87+ rel <- liftM B.decode $ BS.readFile (relvarsPath </> name)
88+ return (T.pack name, rel)) relvarNames
89+ return $ M.fromList relvars
90+
91+writeAtomFuncs :: FilePath -> AtomFunctions -> IO ()
92+writeAtomFuncs transDir funcs = mapM_ (writeAtomFunc transDir) $ HS.toList funcs
93+
94+--all the atom functions are in one file (???)
95+readAtomFuncs :: FilePath -> IO (AtomFunctions)
96+readAtomFuncs transDir = do
97+ funcNames <- getDirectoryNames (atomFuncsDir transDir)
98+ funcs <- mapM (readAtomFunc transDir) (map T.pack funcNames)
99+ return $ HS.fromList funcs
100+
101+--to write the atom functions, we really some bytecode to write (GHCi bytecode?)
102+writeAtomFunc :: FilePath -> AtomFunction -> IO ()
103+writeAtomFunc transDir func = do
104+ let atomFuncPath = atomFuncsDir transDir </> T.unpack (atomFuncName func)
105+ BS.writeFile atomFuncPath BS.empty
106+
107+readAtomFunc :: FilePath -> AtomFunctionName -> IO (AtomFunction)
108+readAtomFunc transDir funcName = do
109+ let atomFuncPath = atomFuncsDir transDir </> T.unpack funcName
110+ _ <- BS.readFile atomFuncPath
111+ return undefined
112+
113+writeIncDep :: FilePath -> (IncDepName, InclusionDependency) -> IO ()
114+writeIncDep transDir (incDepName, incDep) = do
115+ BS.writeFile (incDepsDir transDir </> T.unpack incDepName) $ B.encode incDep
116+
117+writeIncDeps :: FilePath -> M.Map IncDepName InclusionDependency -> IO ()
118+writeIncDeps transDir incdeps = mapM_ (writeIncDep transDir) $ M.toList incdeps
119+
120+readIncDep :: FilePath -> IncDepName -> IO (IncDepName, InclusionDependency)
121+readIncDep transDir incdepName = do
122+ let incDepPath = incDepsDir transDir </> T.unpack incdepName
123+ incDepData <- BS.readFile incDepPath
124+ return $ (incdepName, B.decode incDepData)
125+
126+readIncDeps :: FilePath -> IO (M.Map IncDepName InclusionDependency)
127+readIncDeps transDir = do
128+ let incDepsPath = incDepsDir transDir
129+ incDepNames <- getDirectoryNames incDepsPath
130+ incDeps <- mapM (readIncDep transDir) (map T.pack incDepNames)
131+ return $ M.fromList incDeps
ProjectM36/TransactionGraph.hsnew file+128
@@ -0,0 +1,128 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module ProjectM36.TransactionGraph where
3+import ProjectM36.Base
4+import ProjectM36.Error
5+import qualified Data.UUID as U
6+import qualified Data.Set as S
7+import qualified Data.Map as M
8+import Control.Applicative ((<$>))
9+import Control.Monad
10+
11+bootstrapTransactionGraph :: U.UUID -> DatabaseContext -> TransactionGraph
12+bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions
13+ where
14+ bootstrapHeads = M.singleton "master" freshTransaction
15+ freshTransaction = Transaction freshUUID (TransactionInfo U.nil S.empty) context
16+ bootstrapTransactions = S.singleton freshTransaction
17+
18+emptyTransactionGraph :: TransactionGraph
19+emptyTransactionGraph = TransactionGraph M.empty S.empty
20+
21+transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction
22+transactionForHead headName (TransactionGraph heads _) = M.lookup headName heads
23+
24+headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName
25+headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then
26+ Nothing
27+ else
28+ Just $ (head . M.keys) matchingTrans
29+ where
30+ matchingTrans = M.filter (transaction ==) heads
31+
32+transactionForUUID :: U.UUID -> TransactionGraph -> Either RelationalError Transaction
33+transactionForUUID uuid graph = if S.null matchingTrans then
34+ Left $ NoSuchTransactionError uuid
35+ else
36+ Right $ head (S.toList matchingTrans)
37+ where
38+ matchingTrans = S.filter (\(Transaction uuidMatch _ _) -> uuidMatch == uuid) (transactionsForGraph graph)
39+
40+transactionsForUUIDs :: S.Set U.UUID -> TransactionGraph -> Either RelationalError (S.Set Transaction)
41+transactionsForUUIDs uuidSet graph = do
42+ transList <- forM (S.toList uuidSet) ((flip transactionForUUID) graph)
43+ return (S.fromList transList)
44+
45+isRootTransaction :: Transaction -> TransactionGraph -> Bool
46+isRootTransaction (Transaction _ (TransactionInfo pUUID _) _) _ = U.null pUUID
47+isRootTransaction (Transaction _ (MergeTransactionInfo _ _ _) _) _ = False
48+
49+-- the first transaction has no parent - all other do have parents- merges have two parents
50+parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
51+parentTransactions (Transaction _ (TransactionInfo pUUID _) _) graph = do
52+ trans <- transactionForUUID pUUID graph
53+ return (S.singleton trans)
54+
55+parentTransactions (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _ ) graph = transactionsForUUIDs (S.fromList [pUUID1, pUUID2]) graph
56+
57+
58+childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)
59+childTransactions (Transaction _ (TransactionInfo _ children) _) = transactionsForUUIDs children
60+childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transactionsForUUIDs children
61+
62+-- create a new commit and add it to the heads
63+-- 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)
64+addBranch :: U.UUID -> HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
65+addBranch newUUID newBranchName branchPoint graph = addTransactionToGraph newBranchName branchPoint newUUID (transactionContext branchPoint) graph
66+
67+--adds a disconnected transaction to a transaction graph at some head
68+addDisconnectedTransaction :: U.UUID -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
69+addDisconnectedTransaction newUUID headName (DisconnectedTransaction parentUUID context) graph = do
70+ parentTrans <- transactionForUUID parentUUID graph
71+ addTransactionToGraph headName parentTrans newUUID context graph
72+
73+-- create a new transaction on "newHeadName" with the branchPointTrans
74+addTransactionToGraph :: HeadName -> Transaction -> U.UUID -> DatabaseContext -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)
75+addTransactionToGraph newHeadName branchPointTrans newUUID newContext (TransactionGraph heads transSet) = do
76+ let freshTransaction = Transaction newUUID (TransactionInfo (transactionUUID branchPointTrans) S.empty) newContext
77+ -- there are two parents for MergeTransactions! not implemented
78+ --update parentTransaction to add child
79+ let parentTransaction = branchPointTrans
80+ let updatedTransSet = (S.insert freshTransaction <$> S.insert parentTransaction <$> S.delete parentTransaction) transSet
81+ let updatedGraph = TransactionGraph (M.insert newHeadName freshTransaction heads) updatedTransSet
82+ return (freshTransaction, updatedGraph)
83+
84+validateGraph :: TransactionGraph -> Maybe [RelationalError]
85+validateGraph graph@(TransactionGraph _ transSet) = do
86+ --check that all UUIDs are unique in the graph
87+ --uuids = map transactionUUID transSet
88+ --check that all heads appear in the transSet
89+ --check that all forward and backward links are in place
90+ _ <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)
91+ mapM (walkChildTransactions S.empty graph) (S.toList transSet)
92+
93+--verify that all parent links exist and that all children exist
94+--maybe verify that all parents end at UUID nil and all children end at leaves
95+walkParentTransactions :: S.Set U.UUID -> TransactionGraph -> Transaction -> Maybe RelationalError
96+walkParentTransactions seenTransSet graph trans =
97+ let transUUID = transactionUUID trans in
98+ if transUUID == U.nil then
99+ Nothing
100+ else if S.member transUUID seenTransSet then
101+ Just $ TransactionGraphCycleError transUUID
102+ else
103+ let parentTransSetOrError = parentTransactions trans graph in
104+ case parentTransSetOrError of
105+ Left err -> Just err
106+ Right parentTransSet -> do
107+ walk <- mapM (walkParentTransactions (S.insert transUUID seenTransSet) graph) (S.toList parentTransSet)
108+ case walk of
109+ err:_ -> Just err
110+ _ -> Nothing
111+
112+--refactor: needless duplication in these two functions
113+walkChildTransactions :: S.Set U.UUID -> TransactionGraph -> Transaction -> Maybe RelationalError
114+walkChildTransactions seenTransSet graph trans =
115+ let transUUID = transactionUUID trans in
116+ if childTransactions trans graph == Right S.empty then
117+ Nothing
118+ else if S.member transUUID seenTransSet then
119+ Just $ TransactionGraphCycleError transUUID
120+ else
121+ let childTransSetOrError = childTransactions trans graph in
122+ case childTransSetOrError of
123+ Left err -> Just err
124+ Right childTransSet -> do
125+ walk <- mapM (walkChildTransactions (S.insert transUUID seenTransSet) graph) (S.toList childTransSet)
126+ case walk of
127+ err:_ -> Just err
128+ _ -> Nothing
ProjectM36/TransactionGraph/Persist.hsnew file+152
@@ -0,0 +1,152 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module ProjectM36.TransactionGraph.Persist where
3+import ProjectM36.Error
4+import ProjectM36.TransactionGraph
5+import ProjectM36.Transaction
6+import ProjectM36.Transaction.Persist
7+import ProjectM36.Base
8+import System.Directory
9+import System.Posix.Files
10+import System.FilePath
11+import System.IO.Temp
12+import Data.List
13+import qualified Data.UUID as U
14+import qualified Data.Set as S
15+import qualified Data.Map as M
16+import qualified Data.Text as T
17+import Control.Monad (foldM)
18+import Data.Either (isRight)
19+import Data.Maybe (catMaybes)
20+
21+
22+{-
23+The "m36v1" file at the top-level of the destination directory contains the the transaction graph as a set of UUIDs referencing their parents (1 or more)
24+Each Transaction is written to it own directory named by its UUID. Partially written transactions UUIDs are prefixed with a "." to indicate incompleteness in the graph.
25+
26+-}
27+
28+transactionLogPath :: FilePath -> FilePath
29+transactionLogPath dbdir = dbdir </> "m36v1"
30+
31+headsPath :: FilePath -> FilePath
32+headsPath dbdir = dbdir </> "heads"
33+
34+{-
35+verify that the database directory is valid or bootstrap it
36+-note: checking for the existence of every transaction may be prohibitively expensive
37+-}
38+
39+setupDatabaseDir :: FilePath -> TransactionGraph -> IO (Maybe PersistenceError)
40+setupDatabaseDir dbdir bootstrapGraph = do
41+ dbdirExists <- doesDirectoryExist dbdir
42+ m36exists <- doesFileExist (transactionLogPath dbdir)
43+ if dbdirExists && m36exists then
44+ return Nothing
45+ else if not m36exists then do
46+ bootstrapDatabaseDir dbdir bootstrapGraph
47+ return Nothing
48+ else
49+ return $ Just (InvalidDirectoryError dbdir)
50+
51+{-
52+initialize a database directory with the graph from which to bootstrap
53+-}
54+bootstrapDatabaseDir :: FilePath -> TransactionGraph -> IO ()
55+bootstrapDatabaseDir dbdir bootstrapGraph = do
56+ createDirectory dbdir
57+ transactionGraphPersist dbdir bootstrapGraph
58+ putStrLn "Bootstrapped DB."
59+
60+
61+{-
62+incrementally updates an existing database directory
63+--algorithm:
64+-check that all heads have been written
65+-assume that all non-head transactions have already been written because this is an incremental (and concurrent!) write method
66+--store the head names with a symlink to the transaction under "heads"
67+-}
68+transactionGraphPersist :: FilePath -> TransactionGraph -> IO ()
69+transactionGraphPersist destDirectory graph = do
70+ mapM_ (writeTransaction destDirectory) $ M.elems (transactionHeadsForGraph graph)
71+ writeGraphUUIDFile destDirectory graph
72+ transactionGraphHeadsPersist destDirectory graph
73+ return ()
74+
75+{-
76+write graph heads to a file which can be atomically swapped
77+-}
78+--writing the heads in a directory is a synchronization nightmare, so just write the binary to a file and swap atomically
79+transactionGraphHeadsPersist :: FilePath -> TransactionGraph -> IO ()
80+transactionGraphHeadsPersist dbdir graph = do
81+ let headFileStr :: (HeadName, Transaction) -> String
82+ headFileStr (headName, trans) = T.unpack headName ++ " " ++ U.toString (transactionUUID trans)
83+ withTempDirectory dbdir ".heads.tmp" $ \tempHeadsDir -> do
84+ let tempHeadsPath = tempHeadsDir </> "heads"
85+ headsStrLines = map headFileStr $ M.toList (transactionHeadsForGraph graph)
86+ writeFile tempHeadsPath $ intercalate "\n" headsStrLines
87+ rename tempHeadsPath (headsPath dbdir)
88+
89+transactionGraphHeadsLoad :: FilePath -> IO [(HeadName,U.UUID)]
90+transactionGraphHeadsLoad dbdir = do
91+ headsData <- readFile (headsPath dbdir)
92+ let headsAssocs = map (\l -> let headName:uuidStr:[] = words l in
93+ (headName,uuidStr)
94+ ) (lines headsData)
95+ return [(T.pack headName, uuid) | (headName, Just uuid) <- map (\(h,u) -> (h, U.fromString u)) headsAssocs]
96+
97+{-
98+load any transactions which are not already part of the incoming transaction graph
99+-}
100+
101+--ALERT I need to figure out how to manage the transaction heads (branch names)
102+transactionGraphLoad :: FilePath -> TransactionGraph -> IO (Either PersistenceError TransactionGraph)
103+transactionGraphLoad dbdir graphIn = do
104+ --optimization: perform tail-bisection search to find last-recorded transaction in the existing stream- replay the rest
105+ --read in all missing transactions from transaction directories and add to graph
106+ uuidInfo <- readGraphUUIDFile dbdir
107+ freshHeadsAssoc <- transactionGraphHeadsLoad dbdir
108+ case uuidInfo of
109+ Left err -> return $ Left err
110+ Right info -> do
111+ let folder = \eitherGraph transUUID -> case eitherGraph of
112+ Left err -> return $ Left err
113+ Right graph -> readTransactionIfNecessary dbdir transUUID graph
114+ loadedGraph <- foldM folder (Right graphIn) (map fst info)
115+ case loadedGraph of
116+ Left err -> return $ Left err
117+ Right freshGraph -> do
118+ let maybeTransHeads = [(headName, transactionForUUID uuid freshGraph) | (headName, uuid) <- freshHeadsAssoc]
119+ freshHeads = M.fromList [(headName,trans) | (headName, Right trans) <- maybeTransHeads]
120+ return $ Right $ TransactionGraph freshHeads (transactionsForGraph freshGraph)
121+
122+{-
123+if the transaction with the UUID argument is not yet part of the graph, then read the transaction and add it - this does not update the heads
124+-}
125+readTransactionIfNecessary :: FilePath -> U.UUID -> TransactionGraph -> IO (Either PersistenceError TransactionGraph)
126+readTransactionIfNecessary dbdir transUUID graphIn = do
127+ if isRight $ transactionForUUID transUUID graphIn then
128+ --the transaction is already known and loaded- done
129+ return $ Right graphIn
130+ else do
131+ trans <- readTransaction dbdir transUUID
132+ case trans of
133+ Left err -> return $ Left err
134+ Right trans' -> return $ Right $ TransactionGraph (transactionHeadsForGraph graphIn) (S.insert trans' (transactionsForGraph graphIn))
135+
136+writeGraphUUIDFile :: FilePath -> TransactionGraph -> IO ()
137+writeGraphUUIDFile destDirectory (TransactionGraph _ transSet) = writeFile graphFile uuidInfo
138+ where
139+ graphFile = destDirectory </> "m36v1"
140+ uuidInfo = intercalate "\n" graphLines
141+ graphLines = S.toList $ S.map graphLine transSet
142+ graphLine trans = U.toString (transactionUUID trans) ++ " " ++ intercalate " " (S.toList (S.map U.toString $ transactionParentUUIDs trans))
143+
144+readGraphUUIDFile :: FilePath -> IO (Either PersistenceError [(U.UUID, [U.UUID])])
145+readGraphUUIDFile dbdir = do
146+ --read in all transactions' uuids
147+ let grapher line = let uuids = catMaybes (map U.fromString (words line)) in
148+ (head uuids, tail uuids)
149+ --warning: uses lazy IO
150+ graphUUIDData <- readFile (transactionLogPath dbdir)
151+ return $ Right (map grapher $ lines graphUUIDData)
152+
ProjectM36/Transaction/Show.hs → ProjectM36/TransactionGraph/Show.hsrenamed+2−2
@@ -1,11 +1,11 @@
11{-# LANGUAGE OverloadedStrings #-}
2−module ProjectM36.Transaction.Show where
2+module ProjectM36.TransactionGraph.Show where
33import ProjectM36.Base
44import ProjectM36.Relation
55import ProjectM36.Tuple
66import ProjectM36.TupleSet
77import ProjectM36.Error
8−import ProjectM36.Transaction
8+import ProjectM36.TransactionGraph
99import qualified ProjectM36.Attribute as A
1010import qualified Data.HashSet as HS
1111import qualified Data.Set as S
TutorialD/Interpreter.hs+28−22
@@ -5,7 +5,7 @@ import TutorialD.Interpreter.RODatabaseContextOperator
55import TutorialD.Interpreter.DatabaseExpr
66import TutorialD.Interpreter.TransactionGraphOperator
77import ProjectM36.Base
8−import ProjectM36.Transaction
8+import ProjectM36.TransactionGraph
99import Text.Parsec
1010import Text.Parsec.String
1111import Control.Monad.State
@@ -41,43 +41,49 @@ promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.appen
4141 Nothing -> T.pack (show $ transactionUUID parentTrans)
4242 Just headName -> headName
4343
44−interpret :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (TutorialDOperatorResult, DisconnectedTransaction, TransactionGraph)
44+interpret :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (TutorialDOperatorResult, DisconnectedTransaction, TransactionGraph, TransactionGraphWasUpdated)
4545interpret freshUUID discon@(DisconnectedTransaction parentUUID context) graph inputString = case parse interpreterParserP "" inputString of
46− Left err -> (DisplayErrorResult (T.pack $ show err), discon, graph)
47− Right (RODatabaseContextOp execOp) -> (evalRODatabaseContextOp context execOp, discon, graph)
46+ Left err -> (DisplayErrorResult (T.pack $ show err), discon, graph, False)
47+ Right (RODatabaseContextOp execOp) -> (evalRODatabaseContextOp context execOp, discon, graph, False)
4848 Right (DatabaseExprOp execOp) -> case evalDatabaseExpr True context execOp of
49− Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph)
50− Right context' -> (QuietSuccessResult, DisconnectedTransaction parentUUID context', graph)
49+ Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph, False)
50+ Right context' -> (QuietSuccessResult, DisconnectedTransaction parentUUID context', graph, False)
5151 Right (GraphOp execOp) -> case evalGraphOp freshUUID discon graph execOp of
52− Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph)
53− Right (discon', graph', result') -> (result', discon', graph')
52+ Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph, False)
53+ Right (discon', graph', result') -> (result', discon', graph', True)
54+
55+data InterpreterConfig = InterpreterConfig {
56+ persistenceStrategy :: PersistenceStrategy
57+ }
5458
55−
56−
57−reprLoop :: DisconnectedTransaction -> TransactionGraph -> IO ()
58−reprLoop currentTransaction graph = do
59+reprLoop :: InterpreterConfig -> DisconnectedTransaction -> TransactionGraph -> IO ()
60+reprLoop config currentTransaction graph = do
5961 homeDirectory <- getHomeDirectory
6062 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
6163
6264 maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText currentTransaction graph))
6365
64− let roloop = reprLoop currentTransaction graph
66+ let roloop = reprLoop config currentTransaction graph
6567 case maybeLine of
6668 Nothing -> return ()
6769 Just line -> do
6870 newUUID <- nextRandom
69− case interpret newUUID currentTransaction graph line of
71+ let (opResult, disconTrans, updatedGraph, graphWasUpdated) = interpret newUUID currentTransaction graph line
72+ when graphWasUpdated $ processPersistence (persistenceStrategy config) updatedGraph
73+ case (opResult, disconTrans, updatedGraph) of
7074 (QuitResult, _, _) -> return ()
71− (DisplayErrorResult err, _, _) -> TIO.hPutStrLn stderr ("ERR: " `T.append` err) >> roloop
72− (DisplayIOResult outio, updatedTrans, updatedGraph) -> do
75+ (DisplayErrorResult err, _, _) -> TIO.hPutStrLn stderr ("ERROR: " `T.append` err) >> roloop
76+ (DisplayIOResult outio, updatedTrans', updatedGraph') -> do
7377 outio
74− reprLoop updatedTrans updatedGraph
75− (DisplayResult out, updatedTrans, updatedGraph) -> do
78+ reprLoop config updatedTrans' updatedGraph'
79+ (DisplayResult out, updatedTrans', updatedGraph') -> do
7680 TIO.putStrLn out
77− reprLoop updatedTrans updatedGraph
78− (QuietSuccessResult, updatedTrans, updatedGraph) -> do
79− TIO.putStrLn "Done."
80− reprLoop updatedTrans updatedGraph
81+ --assume that the DisplayResult type implies that the transaction graph was not updated
82+ reprLoop config updatedTrans' updatedGraph'
83+ (QuietSuccessResult, updatedTrans', updatedGraph') -> do
84+ --save the current transaction graph
85+ TIO.putStrLn "Done."
86+ reprLoop config updatedTrans' updatedGraph'
8187
8288--used by :dumpGraph
8389{-
TutorialD/Interpreter/Base.hs+7
@@ -10,6 +10,7 @@ import qualified Data.List as L
1010import qualified Data.Vector as V
1111import qualified Data.Text.IO as TIO
1212import System.IO
13+import ProjectM36.TransactionGraph.Persist
1314
1415lexer :: Token.TokenParser ()
1516lexer = Token.makeTokenParser tutD
@@ -67,6 +68,8 @@ data TutorialDOperatorResult = QuitResult |
6768 DisplayIOResult (IO ()) |
6869 DisplayErrorResult StringType |
6970 QuietSuccessResult
71+
72+type TransactionGraphWasUpdated = Bool
7073
7174displayOpResult :: TutorialDOperatorResult -> IO ()
7275displayOpResult QuitResult = return ()
@@ -74,3 +77,7 @@ displayOpResult (DisplayResult out) = TIO.putStrLn out
7477displayOpResult (DisplayIOResult ioout) = ioout
7578displayOpResult (DisplayErrorResult err) = TIO.hPutStrLn stderr ("ERR: " `T.append` err)
7679displayOpResult QuietSuccessResult = return ()
80+
81+processPersistence :: PersistenceStrategy -> TransactionGraph -> IO ()
82+processPersistence NoPersistence _ = return ()
83+processPersistence (MinimalPersistence dbdir) graph = transactionGraphPersist dbdir graph
TutorialD/Interpreter/TransactionGraphOperator.hs+2−1
@@ -8,7 +8,8 @@ import qualified Data.UUID as U
88import qualified Data.Text as T
99import ProjectM36.Error
1010import ProjectM36.Transaction
11−import ProjectM36.Transaction.Show
11+import ProjectM36.TransactionGraph
12+import ProjectM36.TransactionGraph.Show
1213import ProjectM36.Relation.Show.Term
1314
1415--operators which manipulate a transaction graph
TutorialD/tutd.hs+58−5
@@ -1,16 +1,69 @@
11{-# LANGUAGE OverloadedStrings #-}
22import TutorialD.Interpreter
33import ProjectM36.RelationalExpression
4+import ProjectM36.TransactionGraph
5+import ProjectM36.TransactionGraph.Persist
46import ProjectM36.Transaction
57import ProjectM36.Base
8+import System.IO
9+import Options.Applicative
610import Data.UUID.V4 (nextRandom)
11+import qualified Data.Text as T
12+import System.Exit
713
14+{-
15+invocation:
16+tutd
17+-no arguments indicates to run without persistence
18+tutd -d /database-directory
19+-persist to the database directory
20+-}
21+parseArgs :: Parser InterpreterConfig
22+parseArgs = InterpreterConfig <$> parsePersistenceStrategy
23+
24+parsePersistenceStrategy :: Parser PersistenceStrategy
25+parsePersistenceStrategy = do
26+ MinimalPersistence <$> strOption (short 'd' <>
27+ long "database-directory" <>
28+ metavar "DIRECTORY" <>
29+ showDefaultWith show
30+ )
31+ <|> pure NoPersistence
32+
33+
34+
35+
36+configSetup :: InterpreterConfig -> IO (TransactionGraph)
37+configSetup config = do
38+ let failHard msg = do
39+ hPutStrLn stderr msg
40+ exitFailure
41+ firstGraphUUID <- nextRandom
42+ let bootstrapGraph = bootstrapTransactionGraph firstGraphUUID dateExamples
43+ case persistenceStrategy config of
44+ --create date examples graph for now- probably should be empty context in the future
45+ NoPersistence -> do { putStrLn "Running without filesystem persistence."; return bootstrapGraph}
46+ MinimalPersistence dbdir -> do
47+ err <- setupDatabaseDir dbdir bootstrapGraph
48+ case err of
49+ Just err' -> failHard ("Failed to configure database: " ++ show err')
50+ Nothing -> do
51+ graph <- transactionGraphLoad dbdir emptyTransactionGraph
52+ case graph of
53+ Left err' -> failHard ("Failed to load graph: " ++ show err')
54+ Right graph' -> return graph'
55+
56+opts :: ParserInfo InterpreterConfig
57+opts = info parseArgs idm
58+
859main :: IO ()
960main = do
10− freshUUID <- nextRandom
61+ interpreterConfig <- execParser opts
1162 let currentHeadName = "master"
12− let newGraph = bootstrapTransactionGraph freshUUID dateExamples
13− let headTransaction = case transactionForHead currentHeadName newGraph of { Just x -> x; _ -> undefined}
14− let currentTransaction = newDisconnectedTransaction (transactionUUID headTransaction) (transactionContext headTransaction)
15− reprLoop currentTransaction newGraph
63+ freshGraph <- configSetup interpreterConfig
64+ case transactionForHead currentHeadName freshGraph of
65+ Nothing -> hPutStrLn stderr $ "Failed to find head transaction for " ++ T.unpack currentHeadName ++ "."
66+ Just headTransaction -> do
67+ let currentTransaction = newDisconnectedTransaction (transactionUUID headTransaction) (transactionContext headTransaction)
68+ reprLoop interpreterConfig currentTransaction freshGraph
1669
project-m36.cabal+11−2
@@ -7,10 +7,12 @@ Category: Relational Algebra
77Cabal-Version: >= 1.2
88
99Library
10− Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid,cassava,text,bytestring,deepseq,deepseq-generics,vector,parallel,monad-parallel,transformers,gnuplot
10+ Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid,cassava,text,bytestring,deepseq,deepseq-generics,vector,parallel,monad-parallel,transformers,gnuplot,binary,filepath,directory,vector-binary-instances,unix,temporary
1111 Exposed-Modules: ProjectM36.Error,
1212 ProjectM36.Transaction,
13− ProjectM36.Transaction.Show,
13+ ProjectM36.TransactionGraph,
14+ ProjectM36.TransactionGraph.Show,
15+ ProjectM36.TransactionGraph.Persist,
1416 ProjectM36.Base,
1517 ProjectM36.Attribute,
1618 ProjectM36.AttributeNames,
@@ -19,6 +21,7 @@ Library
1921 ProjectM36.Atom,
2022 ProjectM36.AtomFunction,
2123 ProjectM36.Key,
24+ ProjectM36.DatabaseContext,
2225 ProjectM36.RelationalExpression,
2326 ProjectM36.Relation.Show.HTML,
2427 ProjectM36.StaticOptimizer,
@@ -70,6 +73,12 @@ Test-Suite test-static-optimizer
7073 Build-Depends: base,HUnit,Cabal
7174 GHC-Options: -Wall
7275
76+Test-Suite test-transactiongraph-persist
77+ type: exitcode-stdio-1.0
78+ main-is: test/TransactionGraph/Persist.hs
79+ Build-Depends: base,HUnit,Cabal
80+ GHC-Options: -Wall
81+
7382benchmark bench
7483 type: exitcode-stdio-1.0
7584 main-is: benchmark/Relation.hs
test/TransactionGraph/Persist.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# LANGUAGE OverloadedStrings,LambdaCase #-}
2+import Test.HUnit
3+import ProjectM36.Base
4+import ProjectM36.TransactionGraph.Persist
5+import ProjectM36.TransactionGraph
6+import ProjectM36.RelationalExpression
7+import ProjectM36.Transaction
8+import System.IO.Temp
9+import System.Exit
10+import Data.Either
11+import Data.UUID.V4 (nextRandom)
12+import System.FilePath
13+import TutorialD.Interpreter.DatabaseExpr
14+
15+main :: IO ()
16+main = do
17+ tcounts <- runTestTT testList
18+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
19+
20+testList :: Test
21+testList = TestList [testBootstrapDB, testDBSimplePersistence]
22+
23+{- bootstrap a database, ensure that it can be read -}
24+testBootstrapDB :: Test
25+testBootstrapDB = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do
26+ let dbdir = tempdir </> "dbdir"
27+ freshUUID <- nextRandom
28+ _ <- bootstrapDatabaseDir dbdir (bootstrapTransactionGraph freshUUID dateExamples)
29+ loadedGraph <- transactionGraphLoad dbdir emptyTransactionGraph
30+ assertBool "transactionGraphLoad" $ isRight loadedGraph
31+
32+{- create a database with several transactions, ensure that all transactions can be read -}
33+testDBSimplePersistence :: Test
34+testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do
35+ let dbdir = tempdir </> "dbdir"
36+ freshUUID <- nextRandom
37+ let graph = bootstrapTransactionGraph freshUUID dateExamples
38+ bootstrapDatabaseDir dbdir graph
39+ case transactionForHead "master" graph of
40+ Nothing -> assertFailure "Failed to retrieve head transaction for master branch."
41+ Just headTrans -> do
42+ case interpretDatabaseExpr (transactionContext headTrans) "x:=S" of
43+ Left err -> assertFailure (show err)
44+ Right context' -> do
45+ freshUUID' <- nextRandom
46+ let newdiscon = newDisconnectedTransaction (transactionUUID headTrans) context'
47+ addTrans = addDisconnectedTransaction freshUUID' "master" newdiscon graph
48+ --add a transaction to the graph
49+ case addTrans of
50+ Left err -> assertFailure (show err)
51+ Right (_, graph') -> do
52+ --persist the new graph
53+ transactionGraphPersist dbdir graph'
54+ --reload the graph from the filesystem and confirm that the transaction is present
55+ graphErr <- transactionGraphLoad dbdir emptyTransactionGraph
56+ case graphErr of
57+ Left err -> assertFailure (show err)
58+ Right graph'' -> assertBool "graph equality" $ graph'' == graph'
59+
60+
61+
test/TutorialD/Interpreter.hs+4−3
@@ -9,6 +9,7 @@ import ProjectM36.TupleSet
99import ProjectM36.Error
1010import ProjectM36.Base
1111import ProjectM36.Transaction
12+import ProjectM36.TransactionGraph
1213import qualified ProjectM36.Attribute as A
1314import qualified Data.HashSet as HS
1415import qualified Data.Map as M
@@ -135,7 +136,7 @@ transactionRollbackTest = TestCase $ do
135136 Left err -> assertFailure (show err)
136137 Right newContext -> do
137138 let discon = newDisconnectedTransaction firstUUID newContext
138− let (_, (DisconnectedTransaction _ newContext2), newGraph) = interpret freshUUID discon graph ":rollback"
139+ let (_, (DisconnectedTransaction _ newContext2), newGraph, _) = interpret freshUUID discon graph ":rollback"
139140 assertEqual "validate context" (M.lookup "x" (relationVariables newContext2)) Nothing
140141 assertEqual "validate graph" graph newGraph
141142
@@ -161,7 +162,7 @@ transactionJumpTest = TestCase $ do
161162 Left err -> assertFailure (show err)
162163 Right (_, graph) -> do
163164 --jump to the first transaction
164− let (_, (DisconnectedTransaction parentUUID newContext3), newGraph) = interpret freshUUID discon graph (":jump " ++ show firstUUID)
165+ let (_, (DisconnectedTransaction parentUUID newContext3), newGraph, _) = interpret freshUUID discon graph (":jump " ++ show firstUUID)
165166 assertEqual "validate discon" parentUUID firstUUID
166167 assertEqual "validate discon2" Nothing (M.lookup "x" (relationVariables newContext3))
167168 assertEqual "validate graph" transactionUUIDs (S.map transactionUUID (transactionsForGraph newGraph))
@@ -184,7 +185,7 @@ transactionBranchTest = TestCase $ do
184185 Left err -> assertFailure (show err)
185186 Right (_, graph) -> do
186187 --add a third transaction to the "test" branch
187− let (_, _, newGraph) = interpret freshUUID2 origDiscon graph ":branch test"
188+ let (_, _, newGraph, _) = interpret freshUUID2 origDiscon graph ":branch test"
188189 assertEqual "verify test head" freshUUID2 $ maybeTransUUID (transactionForHead "test" newGraph)
189190 assertEqual "verify master head" freshUUID1 $ maybeTransUUID (transactionForHead "master" newGraph)
190191 where