git.iko.soy/project-m36
on master help sign in
WIP: branch on persistence strategy (mem or fs)

-still need to fix the command line parsing -added some basic transaction persistence tests

commitd2940fb8be7076ac8ed97f24d15c0c4fb0fd53e9 authorAgentM <agentm@themactionfaction.com> dateFri 10 Jul 2015, 20:02 (11 years ago) parentb522248
6 files changed+124−29
compare with master
unifiedsplit
ProjectM36/Base.hs+3−2 TutorialD/Interpreter.hs+2−3 TutorialD/Interpreter/Base.hs+3−3 TutorialD/tutd.hs+52−18 test/TransactionGraph/Persist.hs+61 test/TutorialD/Interpreter.hs+3−3
ProjectM36/Base.hs+3−2
@@ -262,5 +262,6 @@ data AttributeNames = AttributeNames (S.Set AttributeName) |
262262instance Binary AttributeNames
263263
264264data PersistenceStrategy = NoPersistence | --no filesystem persistence/memory-only database
265− MinimalPersistence --fsync off
266− --CrashSafePersistence --full fsync- not yet implemented
265+ MinimalPersistence FilePath --fsync off
266+ --CrashSafePersistence FilePath --full fsync- not yet implemented
267+ deriving (Show, Read)
TutorialD/Interpreter.hs+2−3
@@ -53,8 +53,7 @@ interpret freshUUID discon@(DisconnectedTransaction parentUUID context) graph in
5353 Right (discon', graph', result') -> (result', discon', graph', True)
5454
5555data InterpreterConfig = InterpreterConfig {
56− persistenceStrategy :: PersistenceStrategy,
57− databaseDirectory :: FilePath
56+ persistenceStrategy :: PersistenceStrategy
5857 }
5958
6059reprLoop :: InterpreterConfig -> DisconnectedTransaction -> TransactionGraph -> IO ()
@@ -70,7 +69,7 @@ reprLoop config currentTransaction graph = do
7069 Just line -> do
7170 newUUID <- nextRandom
7271 let (opResult, disconTrans, updatedGraph, graphWasUpdated) = interpret newUUID currentTransaction graph line
73− when graphWasUpdated $ processPersistence (databaseDirectory config) (persistenceStrategy config) updatedGraph
72+ when graphWasUpdated $ processPersistence (persistenceStrategy config) updatedGraph
7473 case (opResult, disconTrans, updatedGraph) of
7574 (QuitResult, _, _) -> return ()
7675 (DisplayErrorResult err, _, _) -> TIO.hPutStrLn stderr ("ERROR: " `T.append` err) >> roloop
TutorialD/Interpreter/Base.hs+3−3
@@ -75,6 +75,6 @@ displayOpResult (DisplayIOResult ioout) = ioout
7575displayOpResult (DisplayErrorResult err) = TIO.hPutStrLn stderr ("ERR: " `T.append` err)
7676displayOpResult QuietSuccessResult = return ()
7777
78−processPersistence :: FilePath -> PersistenceStrategy -> TransactionGraph -> IO ()
79−processPersistence _ NoPersistence _ = return ()
80−processPersistence dbdir MinimalPersistence graph = transactionGraphPersist dbdir graph
78+processPersistence :: PersistenceStrategy -> TransactionGraph -> IO ()
79+processPersistence NoPersistence _ = return ()
80+processPersistence (MinimalPersistence dbdir) graph = transactionGraphPersist dbdir graph
TutorialD/tutd.hs+52−18
@@ -6,28 +6,62 @@ import ProjectM36.TransactionGraph.Persist
66import ProjectM36.Transaction
77import ProjectM36.Base
88import System.IO
9+import Options.Applicative
10+import Text.Read (readEither)
911import Data.UUID.V4 (nextRandom)
1012import qualified Data.Text as T
13+import System.Exit
1114
15+{-
16+invocation:
17+tutd
18+-no arguments indicates to run without persistence
19+tutd -d /database-directory -p MinimalPersistence
20+-persist to the database directory
21+-}
22+parseArgs :: Parser InterpreterConfig
23+parseArgs = InterpreterConfig <$> parsePersistenceStrategy
24+
25+parsePersistenceStrategy :: Parser PersistenceStrategy
26+parsePersistenceStrategy = option (eitherReader readEither)
27+ (short 'p' <>
28+ long "persistence-strategy" <>
29+ metavar "strategy" <>
30+ value NoPersistence <>
31+ showDefaultWith show
32+ )
33+
34+configSetup :: InterpreterConfig -> IO (TransactionGraph)
35+configSetup config = do
36+ let failHard msg = do
37+ hPutStrLn stderr msg
38+ exitFailure
39+ firstGraphUUID <- nextRandom
40+ let bootstrapGraph = bootstrapTransactionGraph firstGraphUUID dateExamples
41+ case persistenceStrategy config of
42+ --create date examples graph for now- probably should be empty context in the future
43+ NoPersistence -> return bootstrapGraph
44+ MinimalPersistence dbdir -> do
45+ err <- setupDatabaseDir dbdir bootstrapGraph
46+ case err of
47+ Just err' -> failHard ("Failed to configure database: " ++ show err')
48+ Nothing -> do
49+ graph <- transactionGraphLoad dbdir emptyTransactionGraph
50+ case graph of
51+ Left err' -> failHard ("Failed to load graph: " ++ show err')
52+ Right graph' -> return graph'
53+
54+opts :: ParserInfo InterpreterConfig
55+opts = info parseArgs idm
56+
1257main :: IO ()
1358main = do
14− freshUUID <- nextRandom
59+ interpreterConfig <- execParser opts
1560 let currentHeadName = "master"
16− --if the database is empty, bootstrap it with the bootstrap graph
17− bootstrapGraph = bootstrapTransactionGraph freshUUID dateExamples
18− interpreterConfig = InterpreterConfig { persistenceStrategy = MinimalPersistence,
19− databaseDirectory = "/tmp/testdb" }
20− dbdir = databaseDirectory interpreterConfig
21− err <- setupDatabaseDir dbdir bootstrapGraph
22− case err of
23− Just err' -> hPutStrLn stderr $ "Database setup failed: " ++ show err'
24− Nothing -> do
25− freshGraph <- transactionGraphLoad dbdir emptyTransactionGraph
26− case freshGraph of
27− Left err'' -> hPutStrLn stderr $ "Database load failed: " ++ show err''
28− Right freshGraph' -> case transactionForHead currentHeadName freshGraph' of
29− Nothing -> hPutStrLn stderr $ "Failed to find head transaction for " ++ T.unpack currentHeadName ++ "."
30− Just headTransaction -> do
31− let currentTransaction = newDisconnectedTransaction (transactionUUID headTransaction) (transactionContext headTransaction)
32− reprLoop interpreterConfig currentTransaction freshGraph'
61+ freshGraph <- configSetup interpreterConfig
62+ case transactionForHead currentHeadName freshGraph of
63+ Nothing -> hPutStrLn stderr $ "Failed to find head transaction for " ++ T.unpack currentHeadName ++ "."
64+ Just headTransaction -> do
65+ let currentTransaction = newDisconnectedTransaction (transactionUUID headTransaction) (transactionContext headTransaction)
66+ reprLoop interpreterConfig currentTransaction freshGraph
3367
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+3−3
@@ -136,7 +136,7 @@ transactionRollbackTest = TestCase $ do
136136 Left err -> assertFailure (show err)
137137 Right newContext -> do
138138 let discon = newDisconnectedTransaction firstUUID newContext
139− let (_, (DisconnectedTransaction _ newContext2), newGraph) = interpret freshUUID discon graph ":rollback"
139+ let (_, (DisconnectedTransaction _ newContext2), newGraph, _) = interpret freshUUID discon graph ":rollback"
140140 assertEqual "validate context" (M.lookup "x" (relationVariables newContext2)) Nothing
141141 assertEqual "validate graph" graph newGraph
142142
@@ -162,7 +162,7 @@ transactionJumpTest = TestCase $ do
162162 Left err -> assertFailure (show err)
163163 Right (_, graph) -> do
164164 --jump to the first transaction
165− 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)
166166 assertEqual "validate discon" parentUUID firstUUID
167167 assertEqual "validate discon2" Nothing (M.lookup "x" (relationVariables newContext3))
168168 assertEqual "validate graph" transactionUUIDs (S.map transactionUUID (transactionsForGraph newGraph))
@@ -185,7 +185,7 @@ transactionBranchTest = TestCase $ do
185185 Left err -> assertFailure (show err)
186186 Right (_, graph) -> do
187187 --add a third transaction to the "test" branch
188− let (_, _, newGraph) = interpret freshUUID2 origDiscon graph ":branch test"
188+ let (_, _, newGraph, _) = interpret freshUUID2 origDiscon graph ":branch test"
189189 assertEqual "verify test head" freshUUID2 $ maybeTransUUID (transactionForHead "test" newGraph)
190190 assertEqual "verify master head" freshUUID1 $ maybeTransUUID (transactionForHead "master" newGraph)
191191 where