d2940fb · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP: branch on persistence strategy (mem or fs)

d2940fbAgentM11 years ago

ProjectM36/Base.hs+3−2

compare with master

unifiedsplit

@@ -262,5 +262,6 @@ data AttributeNames = AttributeNames (S.Set AttributeName) |

262instance Binary AttributeNames

263

264data PersistenceStrategy = NoPersistence | --no filesystem persistence/memory-only database

265− MinimalPersistence --fsync off

265+ MinimalPersistence FilePath --fsync off

266− --CrashSafePersistence --full fsync- not yet implemented

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

53 Right (discon', graph', result') -> (result', discon', graph', True)

55data InterpreterConfig = InterpreterConfig {

56− persistenceStrategy :: PersistenceStrategy,

56+ persistenceStrategy :: PersistenceStrategy

57− databaseDirectory :: FilePath

58 }

57 }

60reprLoop :: InterpreterConfig -> DisconnectedTransaction -> TransactionGraph -> IO ()

59reprLoop :: InterpreterConfig -> DisconnectedTransaction -> TransactionGraph -> IO ()

@@ -70,7 +69,7 @@ reprLoop config currentTransaction graph = do

70 Just line -> do

69 Just line -> do

71 newUUID <- nextRandom

70 newUUID <- nextRandom

72 let (opResult, disconTrans, updatedGraph, graphWasUpdated) = interpret newUUID currentTransaction graph line

71 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

74 case (opResult, disconTrans, updatedGraph) of

73 case (opResult, disconTrans, updatedGraph) of

75 (QuitResult, _, _) -> return ()

74 (QuitResult, _, _) -> return ()

76 (DisplayErrorResult err, _, _) -> TIO.hPutStrLn stderr ("ERROR: " `T.append` err) >> roloop

75 (DisplayErrorResult err, _, _) -> TIO.hPutStrLn stderr ("ERROR: " `T.append` err) >> roloop

TutorialD/Interpreter/Base.hs+3−3

@@ -75,6 +75,6 @@ displayOpResult (DisplayIOResult ioout) = ioout

75displayOpResult (DisplayErrorResult err) = TIO.hPutStrLn stderr ("ERR: " `T.append` err)

76displayOpResult QuietSuccessResult = return ()

78−processPersistence :: FilePath -> PersistenceStrategy -> TransactionGraph -> IO ()

78+processPersistence :: PersistenceStrategy -> TransactionGraph -> IO ()

79−processPersistence _ NoPersistence _ = return ()

79+processPersistence NoPersistence _ = return ()

80−processPersistence dbdir MinimalPersistence graph = transactionGraphPersist dbdir graph

80+processPersistence (MinimalPersistence dbdir) graph = transactionGraphPersist dbdir graph

TutorialD/tutd.hs+52−18

@@ -6,28 +6,62 @@ import ProjectM36.TransactionGraph.Persist

6import ProjectM36.Transaction

7import ProjectM36.Base

8import System.IO

9+import Options.Applicative

10+import Text.Read (readEither)

9import Data.UUID.V4 (nextRandom)

11import Data.UUID.V4 (nextRandom)

10import qualified Data.Text as T

12import qualified Data.Text as T

13+import System.Exit

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+

12main :: IO ()

57main :: IO ()

13main = do

58main = do

14− freshUUID <- nextRandom

59+ interpreterConfig <- execParser opts

15 let currentHeadName = "master"

60 let currentHeadName = "master"

16− --if the database is empty, bootstrap it with the bootstrap graph

61+ freshGraph <- configSetup interpreterConfig

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

62+ case transactionForHead currentHeadName freshGraph of

29− Nothing -> hPutStrLn stderr $ "Failed to find head transaction for " ++ T.unpack currentHeadName ++ "."

63+ Nothing -> hPutStrLn stderr $ "Failed to find head transaction for " ++ T.unpack currentHeadName ++ "."

30− Just headTransaction -> do

64+ Just headTransaction -> do

31− let currentTransaction = newDisconnectedTransaction (transactionUUID headTransaction) (transactionContext headTransaction)

65+ let currentTransaction = newDisconnectedTransaction (transactionUUID headTransaction) (transactionContext headTransaction)

32− reprLoop interpreterConfig currentTransaction freshGraph'

66+ reprLoop interpreterConfig currentTransaction freshGraph

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

136 Left err -> assertFailure (show err)

137 Right newContext -> do

138 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"

140 assertEqual "validate context" (M.lookup "x" (relationVariables newContext2)) Nothing

141 assertEqual "validate graph" graph newGraph

142

@@ -162,7 +162,7 @@ transactionJumpTest = TestCase $ do

162 Left err -> assertFailure (show err)

163 Right (_, graph) -> do

164 --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)

166 assertEqual "validate discon" parentUUID firstUUID

167 assertEqual "validate discon2" Nothing (M.lookup "x" (relationVariables newContext3))

168 assertEqual "validate graph" transactionUUIDs (S.map transactionUUID (transactionsForGraph newGraph))

@@ -185,7 +185,7 @@ transactionBranchTest = TestCase $ do

185 Left err -> assertFailure (show err)

186 Right (_, graph) -> do

187 --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"

189 assertEqual "verify test head" freshUUID2 $ maybeTransUUID (transactionForHead "test" newGraph)

190 assertEqual "verify master head" freshUUID1 $ maybeTransUUID (transactionForHead "master" newGraph)

191 where