b522248 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP: transaction graph reads and writes now working

-add persistence mode -add database config type

commitb5222484b664afa0b7dff974bafa4a6741e111be authorAgentM <agentm@themactionfaction.com> dateThu 9 Jul 2015, 20:56 (11 years ago) parentfde4091

9 files changed+100−59

compare with master

unifiedsplit

ProjectM36/Base.hs+3 ProjectM36/Transaction/Persist.hs+16−9 ProjectM36/TransactionGraph.hs−1 ProjectM36/TransactionGraph/Persist.hs+31−19 ProjectM36/TransactionGraph/Show.hs−1 TutorialD/Interpreter.hs+25−21 TutorialD/Interpreter/Base.hs+7 TutorialD/tutd.hs+12−8 project-m36.cabal+6

ProjectM36/Base.hs+3

@@ -261,3 +261,6 @@ data AttributeNames = AttributeNames (S.Set AttributeName) |

261261

262262instance Binary AttributeNames

263263

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

265+ MinimalPersistence --fsync off

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

ProjectM36/Transaction/Persist.hs+16−9

@@ -10,6 +10,12 @@ import System.FilePath

1010import System.Directory

1111import qualified Data.Text as T

1212import 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

1319

1420tempTransactionDir :: FilePath -> U.UUID -> FilePath

1521tempTransactionDir dbdir transUUID = dbdir </> "." ++ U.toString transUUID

@@ -18,16 +24,16 @@ transactionDir :: FilePath -> U.UUID -> FilePath

1824transactionDir dbdir transUUID = dbdir </> U.toString transUUID

1925

2026transactionInfoPath :: FilePath -> FilePath

21−transactionInfoPath = (</>) "info"

27+transactionInfoPath transdir = transdir </> "info"

2228

2329relvarsDir :: FilePath -> FilePath

24−relvarsDir = (</>) "relvars"

30+relvarsDir transdir = transdir </> "relvars"

2531

2632incDepsDir :: FilePath -> FilePath

27−incDepsDir = (</>) "incdeps"

33+incDepsDir transdir = transdir </> "incdeps"

2834

2935atomFuncsDir :: FilePath -> FilePath

30−atomFuncsDir = (</>) "atomfuncs"

36+atomFuncsDir transdir = transdir </> "atomfuncs"

3137

3238readTransaction :: FilePath -> U.UUID -> IO (Either PersistenceError Transaction)

3339readTransaction dbdir transUUID = do

@@ -39,7 +45,8 @@ readTransaction dbdir transUUID = do

3945 relvars <- readRelVars transDir

4046 transInfo <- liftM B.decode $ BS.readFile (transactionInfoPath transDir)

4147 incDeps <- readIncDeps transDir

42− atomFuncs <- readAtomFuncs transDir

48+ --atomFuncs <- readAtomFuncs transDir -- not yet supported since there is no bytecode to serialize yet

49+ let atomFuncs = basicAtomFunctions

4350 let newContext = DatabaseContext { inclusionDependencies = incDeps,

4451 relationVariables = relvars,

4552 atomFunctions = atomFuncs }

@@ -75,19 +82,19 @@ writeRelVars transDir relvars = mapM_ (writeRelVar transDir) $ M.toList relvars

7582readRelVars :: FilePath -> IO (M.Map RelVarName Relation)

7683readRelVars transDir = do

7784 let relvarsPath = relvarsDir transDir

78− relvarNames <- getDirectoryContents relvarsPath

85+ relvarNames <- getDirectoryNames relvarsPath

7986 relvars <- mapM (\name -> do

8087 rel <- liftM B.decode $ BS.readFile (relvarsPath </> name)

8188 return (T.pack name, rel)) relvarNames

8289 return $ M.fromList relvars

8390

8491writeAtomFuncs :: FilePath -> AtomFunctions -> IO ()

85−writeAtomFuncs transDir funcs = mapM_ (writeAtomFunc (atomFuncsDir transDir)) $ HS.toList funcs

92+writeAtomFuncs transDir funcs = mapM_ (writeAtomFunc transDir) $ HS.toList funcs

8693

8794--all the atom functions are in one file (???)

8895readAtomFuncs :: FilePath -> IO (AtomFunctions)

8996readAtomFuncs transDir = do

90− funcNames <- getDirectoryContents (incDepsDir transDir)

97+ funcNames <- getDirectoryNames (atomFuncsDir transDir)

9198 funcs <- mapM (readAtomFunc transDir) (map T.pack funcNames)

9299 return $ HS.fromList funcs

93100

@@ -119,6 +126,6 @@ readIncDep transDir incdepName = do

119126readIncDeps :: FilePath -> IO (M.Map IncDepName InclusionDependency)

120127readIncDeps transDir = do

121128 let incDepsPath = incDepsDir transDir

122− incDepNames <- getDirectoryContents incDepsPath

129+ incDepNames <- getDirectoryNames incDepsPath

123130 incDeps <- mapM (readIncDep transDir) (map T.pack incDepNames)

124131 return $ M.fromList incDeps

ProjectM36/TransactionGraph.hs−1

@@ -8,7 +8,6 @@ import qualified Data.Map as M

88import Control.Applicative ((<$>))

99import Control.Monad

1010

11−

1211bootstrapTransactionGraph :: U.UUID -> DatabaseContext -> TransactionGraph

1312bootstrapTransactionGraph freshUUID context = TransactionGraph bootstrapHeads bootstrapTransactions

1413 where

ProjectM36/TransactionGraph/Persist.hs+31−19

@@ -18,6 +18,7 @@ import Control.Monad (foldM)

1818import Data.Either (isRight)

1919import Data.Maybe (catMaybes)

2020

21+

2122{-

2223The "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)

2324Each 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,10 +26,10 @@ Each Transaction is written to it own directory named by its UUID. Partially wri

2526-}

2627

2728transactionLogPath :: FilePath -> FilePath

28−transactionLogPath = (</>) "m36v1"

29+transactionLogPath dbdir = dbdir </> "m36v1"

2930

30−headsDir :: FilePath -> FilePath

31−headsDir = (</>) "heads"

31+headsPath :: FilePath -> FilePath

32+headsPath dbdir = dbdir </> "heads"

3233

3334{-

3435verify that the database directory is valid or bootstrap it

@@ -54,6 +55,8 @@ bootstrapDatabaseDir :: FilePath -> TransactionGraph -> IO ()

5455bootstrapDatabaseDir dbdir bootstrapGraph = do

5556 createDirectory dbdir

5657 transactionGraphPersist dbdir bootstrapGraph

58+ putStrLn "Bootstrapped DB."

59+

5760

5861{-

5962incrementally updates an existing database directory

@@ -70,24 +73,26 @@ transactionGraphPersist destDirectory graph = do

7073 return ()

7174

7275{-

73−write a head datum to the file system

74−1. create a symlink in a temporary directory

75−2. atomically rename it

76+write graph heads to a file which can be atomically swapped

7677-}

77−--should updating all the heads be atomic (create temp directory and new symlinks for every persistence?

78+--writing the heads in a directory is a synchronization nightmare, so just write the binary to a file and swap atomically

7879transactionGraphHeadsPersist :: FilePath -> TransactionGraph -> IO ()

7980transactionGraphHeadsPersist dbdir graph = do

80− let writeHead headsPath (headName, trans) = do

81− let symlinkPath = ".." </> U.toString (transactionUUID trans)

82− createSymbolicLink symlinkPath (headsPath </> T.unpack headName)

83− finalHeadsDir = headsDir dbdir

84− withTempDirectory dbdir ".headsdir.XXXXX" $ \newHeadsDir -> do

85− let tempHeadsDir = (newHeadsDir </> "heads")

86− createDirectory tempHeadsDir

87− mapM_ (writeHead tempHeadsDir) $ M.toList (transactionHeadsForGraph graph)

88− --move the new heads dir into place atomically

89− renameDirectory tempHeadsDir finalHeadsDir

90−

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]

9196

9297{-

9398load any transactions which are not already part of the incoming transaction graph

@@ -99,13 +104,20 @@ transactionGraphLoad dbdir graphIn = do

99104 --optimization: perform tail-bisection search to find last-recorded transaction in the existing stream- replay the rest

100105 --read in all missing transactions from transaction directories and add to graph

101106 uuidInfo <- readGraphUUIDFile dbdir

107+ freshHeadsAssoc <- transactionGraphHeadsLoad dbdir

102108 case uuidInfo of

103109 Left err -> return $ Left err

104110 Right info -> do

105111 let folder = \eitherGraph transUUID -> case eitherGraph of

106112 Left err -> return $ Left err

107113 Right graph -> readTransactionIfNecessary dbdir transUUID graph

108− foldM folder (Right graphIn) (map fst info)

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)

109121

110122{-

111123if 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

ProjectM36/TransactionGraph/Show.hs−1

@@ -5,7 +5,6 @@ import ProjectM36.Relation

55import ProjectM36.Tuple

66import ProjectM36.TupleSet

77import ProjectM36.Error

8−import ProjectM36.Transaction

98import ProjectM36.TransactionGraph

109import qualified ProjectM36.Attribute as A

1110import qualified Data.HashSet as HS

TutorialD/Interpreter.hs+25−21

@@ -6,7 +6,6 @@ import TutorialD.Interpreter.DatabaseExpr

66import TutorialD.Interpreter.TransactionGraphOperator

77import ProjectM36.Base

88import ProjectM36.TransactionGraph

9−import ProjectM36.TransactionGraph.Persist

109import Text.Parsec

1110import Text.Parsec.String

1211import Control.Monad.State

@@ -42,45 +41,50 @@ promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.appen

4241 Nothing -> T.pack (show $ transactionUUID parentTrans)

4342 Just headName -> headName

4443

45−interpret :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (TutorialDOperatorResult, DisconnectedTransaction, TransactionGraph)

44+interpret :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (TutorialDOperatorResult, DisconnectedTransaction, TransactionGraph, TransactionGraphWasUpdated)

4645interpret freshUUID discon@(DisconnectedTransaction parentUUID context) graph inputString = case parse interpreterParserP "" inputString of

47− Left err -> (DisplayErrorResult (T.pack $ show err), discon, graph)

48− 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)

4948 Right (DatabaseExprOp execOp) -> case evalDatabaseExpr True context execOp of

50− Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph)

51− 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)

5251 Right (GraphOp execOp) -> case evalGraphOp freshUUID discon graph execOp of

53− Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph)

54− 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+ databaseDirectory :: FilePath

58+ }

5559

56−reprLoop :: FilePath -> DisconnectedTransaction -> TransactionGraph -> IO ()

57−reprLoop transGraphDir currentTransaction graph = do

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

61+reprLoop config currentTransaction graph = do

5862 homeDirectory <- getHomeDirectory

5963 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}

6064

6165 maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText currentTransaction graph))

6266

63− let roloop = reprLoop transGraphDir currentTransaction graph

67+ let roloop = reprLoop config currentTransaction graph

6468 case maybeLine of

6569 Nothing -> return ()

6670 Just line -> do

6771 newUUID <- nextRandom

68− case interpret newUUID currentTransaction graph line of

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

73+ when graphWasUpdated $ processPersistence (databaseDirectory config) (persistenceStrategy config) updatedGraph

74+ case (opResult, disconTrans, updatedGraph) of

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

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

71− (DisplayIOResult outio, updatedTrans, updatedGraph) -> do

77+ (DisplayIOResult outio, updatedTrans', updatedGraph') -> do

7278 outio

73− reprLoop transGraphDir updatedTrans updatedGraph

74− (DisplayResult out, updatedTrans, updatedGraph) -> do

79+ reprLoop config updatedTrans' updatedGraph'

80+ (DisplayResult out, updatedTrans', updatedGraph') -> do

7581 TIO.putStrLn out

82+ --assume that the DisplayResult type implies that the transaction graph was not updated

83+ reprLoop config updatedTrans' updatedGraph'

84+ (QuietSuccessResult, updatedTrans', updatedGraph') -> do

7685 --save the current transaction graph

77− transactionGraphPersist transGraphDir updatedGraph

78− reprLoop transGraphDir updatedTrans updatedGraph

79− (QuietSuccessResult, updatedTrans, updatedGraph) -> do

80− --save the current transaction graph

81− transactionGraphPersist transGraphDir updatedGraph

8286 TIO.putStrLn "Done."

83− reprLoop transGraphDir updatedTrans updatedGraph

87+ reprLoop config updatedTrans' updatedGraph'

8488

8589--used by :dumpGraph

8690{-

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

@@ -64,6 +65,8 @@ data TutorialDOperatorResult = QuitResult |

6465 DisplayIOResult (IO ()) |

6566 DisplayErrorResult StringType |

6667 QuietSuccessResult

68+

69+type TransactionGraphWasUpdated = Bool

6770

6871displayOpResult :: TutorialDOperatorResult -> IO ()

6972displayOpResult QuitResult = return ()

@@ -71,3 +74,7 @@ displayOpResult (DisplayResult out) = TIO.putStrLn out

7174displayOpResult (DisplayIOResult ioout) = ioout

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

7376displayOpResult QuietSuccessResult = return ()

77+

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

79+processPersistence _ NoPersistence _ = return ()

80+processPersistence dbdir MinimalPersistence graph = transactionGraphPersist dbdir graph

TutorialD/tutd.hs+12−8

@@ -7,6 +7,7 @@ import ProjectM36.Transaction

77import ProjectM36.Base

88import System.IO

99import Data.UUID.V4 (nextRandom)

10+import qualified Data.Text as T

1011

1112main :: IO ()

1213main = do

@@ -14,16 +15,19 @@ main = do

1415 let currentHeadName = "master"

1516 --if the database is empty, bootstrap it with the bootstrap graph

1617 bootstrapGraph = bootstrapTransactionGraph freshUUID dateExamples

17− dbdir = "/tmp/testdb"

18− err <- setupDatabaseDir dbdir bootstrapGraph

18+ interpreterConfig = InterpreterConfig { persistenceStrategy = MinimalPersistence,

19+ databaseDirectory = "/tmp/testdb" }

20+ dbdir = databaseDirectory interpreterConfig

21+ err <- setupDatabaseDir dbdir bootstrapGraph

1922 case err of

20− Just err -> hPutStrLn stderr $ "Database setup failed: " ++ show err

23+ Just err' -> hPutStrLn stderr $ "Database setup failed: " ++ show err'

2124 Nothing -> do

2225 freshGraph <- transactionGraphLoad dbdir emptyTransactionGraph

2326 case freshGraph of

24− Left err -> hPutStrLn stderr $ "Database load failed: " ++ show err

25− Right freshGraph' -> do

26− let headTransaction = case transactionForHead currentHeadName freshGraph' of { Just x -> x; _ -> undefined}

27− currentTransaction = newDisconnectedTransaction (transactionUUID headTransaction) (transactionContext headTransaction)

28− reprLoop dbdir currentTransaction freshGraph'

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'

2933

project-m36.cabal+6

@@ -73,6 +73,12 @@ Test-Suite test-static-optimizer

7373 Build-Depends: base,HUnit,Cabal

7474 GHC-Options: -Wall

7575

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+

7682benchmark bench

7783 type: exitcode-stdio-1.0

7884 main-is: benchmark/Relation.hs