3e72e52 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

Merge branch 'transaction_persistence'

3e72e52AgentM11 years ago

ProjectM36/Base.hs+50−11

compare with master

unifiedsplit

@@ -12,6 +12,9 @@ import GHC.Generics (Generic)

12import qualified Data.Vector as V

13import qualified Data.List as L

14import qualified Data.Text as T

15+import Data.Binary

16+import Data.Vector.Binary()

17+import ProjectM36.HashSetBinary()

16type StringType = T.Text

19type StringType = T.Text

@@ -23,7 +26,9 @@ data Atom = StringAtom StringType |

24instance NFData Atom where rnf = genericRnf

27instance NFData Atom where rnf = genericRnf

26−instance Hash.Hashable Atom

29+instance Hash.Hashable Atom

30+

31+instance Binary Atom

28data AtomType = StringAtomType |

33data AtomType = StringAtomType |

29 IntAtomType |

34 IntAtomType |

@@ -33,6 +38,7 @@ data AtomType = StringAtomType |

33 deriving (Eq, Show, Generic)

38 deriving (Eq, Show, Generic)

35instance NFData AtomType where rnf = genericRnf

40instance NFData AtomType where rnf = genericRnf

41+instance Binary AtomType

37type AttributeName = T.Text

43type AttributeName = T.Text

@@ -42,6 +48,8 @@ instance Hash.Hashable Attribute where

42 hashWithSalt salt (Attribute attrName _) = Hash.hashWithSalt salt attrName

48 hashWithSalt salt (Attribute attrName _) = Hash.hashWithSalt salt attrName

44instance NFData Attribute where rnf = genericRnf

50instance NFData Attribute where rnf = genericRnf

51+

52+instance Binary Attribute

46type Attributes = V.Vector Attribute

54type Attributes = V.Vector Attribute

@@ -68,6 +76,8 @@ instance Hash.Hashable RelationTuple where

68--maybe the attribute->int mapping should be stored once in the relation and then passed down when needed

76--maybe the attribute->int mapping should be stored once in the relation and then passed down when needed

69data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Generic)

77data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Generic)

79+instance Binary RelationTuple

80+

71instance Eq RelationTuple where

81instance Eq RelationTuple where

72 (==) tuple1@(RelationTuple attrs1 _) tuple2@(RelationTuple attrs2 _) = attributesEqual attrs1 attrs2 && atomsEqual

82 (==) tuple1@(RelationTuple attrs1 _) tuple2@(RelationTuple attrs2 _) = attributesEqual attrs1 attrs2 && atomsEqual

73 where

83 where

@@ -91,6 +101,8 @@ instance Hash.Hashable Relation where

91 HS.toList tupSet

101 HS.toList tupSet

92 where

102 where

93 sortedAttrs = map snd (sortedAttributesIndices attrs)

103 sortedAttrs = map snd (sortedAttributesIndices attrs)

104+

105+instance Binary Relation

106

95data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show, Generic)

107data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show, Generic)

96data RelationSizeInfinite = RelationSizeInfinite

108data RelationSizeInfinite = RelationSizeInfinite

@@ -115,17 +127,23 @@ data RelationalExpr where

115 NotEquals :: RelationalExpr -> RelationalExpr -> RelationalExpr

127 NotEquals :: RelationalExpr -> RelationalExpr -> RelationalExpr

116 Extend :: TupleExpr -> RelationalExpr -> RelationalExpr

128 Extend :: TupleExpr -> RelationalExpr -> RelationalExpr

117 --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend

129 --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

119

133

120data DatabaseContext = DatabaseContext {

134data DatabaseContext = DatabaseContext {

121 inclusionDependencies :: M.Map IncDepName InclusionDependency,

135 inclusionDependencies :: M.Map IncDepName InclusionDependency,

122 relationVariables :: M.Map RelVarName Relation,

136 relationVariables :: M.Map RelVarName Relation,

123 atomFunctions :: AtomFunctions

137 atomFunctions :: AtomFunctions

124− } deriving (Show)

138+ } deriving (Show, Generic)

139+

140+--instance Binary DatabaseContext

125

141

126type IncDepName = StringType

142type IncDepName = StringType

127

143

128−data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq)

144+data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq, Generic)

145+

146+instance Binary InclusionDependency

129

147

130--Database context expressions modify the database context while relational expressions do not

148--Database context expressions modify the database context while relational expressions do not

131data DatabaseExpr where

149data DatabaseExpr where

@@ -150,7 +168,9 @@ data RestrictionPredicateExpr where

150 RelationalExprPredicate :: RelationalExpr -> RestrictionPredicateExpr --type must be same as true and false relations (no attributes)

168 RelationalExprPredicate :: RelationalExpr -> RestrictionPredicateExpr --type must be same as true and false relations (no attributes)

151 AtomExprPredicate :: AtomExpr -> RestrictionPredicateExpr --atom must evaluate to boolean

169 AtomExprPredicate :: AtomExpr -> RestrictionPredicateExpr --atom must evaluate to boolean

152 AttributeEqualityPredicate :: AttributeName -> AtomExpr -> RestrictionPredicateExpr -- relationalexpr must result in relation with single tuple

170 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

154

174

155-- child + parent links

175-- child + parent links

156-- the string represents the branch name and can be used to find the named HEADs

176-- the string represents the branch name and can be used to find the named HEADs

@@ -169,10 +189,14 @@ transactionHeadsForGraph (TransactionGraph heads _) = heads

169

189

170data TransactionInfo = TransactionInfo UUID (S.Set UUID) | -- 1 parent + n children

190data TransactionInfo = TransactionInfo UUID (S.Set UUID) | -- 1 parent + n children

171 MergeTransactionInfo UUID UUID (S.Set UUID) -- 2 parents, n children

191 MergeTransactionInfo UUID UUID (S.Set UUID) -- 2 parents, n children

172− deriving(Show)

192+ deriving(Show, Generic)

193+

194+instance Binary TransactionInfo

173

195

174data Transaction = Transaction UUID TransactionInfo DatabaseContext -- self uuid

196data Transaction = Transaction UUID TransactionInfo DatabaseContext -- self uuid

175− deriving (Show)

197+ deriving (Show, Generic)

198+

199+--instance Binary Transaction

176

200

177--represents an "in-progress" transaction which has not yet been added to the transaction graph

201--represents an "in-progress" transaction which has not yet been added to the transaction graph

178--one the transaction is "complete", it is committed and no longer can be changed

202--one the transaction is "complete", it is committed and no longer can be changed

@@ -184,6 +208,9 @@ transactionUUID (Transaction uuid _ _) = uuid

184

208

185transactionContext :: Transaction -> DatabaseContext

209transactionContext :: Transaction -> DatabaseContext

186transactionContext (Transaction _ _ context) = context

210transactionContext (Transaction _ _ context) = context

211+

212+transactionInfo :: Transaction -> TransactionInfo

213+transactionInfo (Transaction _ info _) = info

187

214

188instance Eq Transaction where

215instance Eq Transaction where

189 (Transaction uuidA _ _) == (Transaction uuidB _ _) = uuidA == uuidB

216 (Transaction uuidA _ _) == (Transaction uuidB _ _) = uuidA == uuidB

@@ -196,11 +223,15 @@ data AtomExpr = AttributeAtomExpr AttributeName |

196 NakedAtomExpr Atom |

223 NakedAtomExpr Atom |

197 FunctionAtomExpr AtomFunctionName [AtomExpr] |

224 FunctionAtomExpr AtomFunctionName [AtomExpr] |

198 RelationAtomExpr RelationalExpr

225 RelationAtomExpr RelationalExpr

199− deriving (Eq,Show)

226+ deriving (Eq,Show,Generic)

227+

228+instance Binary AtomExpr

200

229

201--used to extend a relation

230--used to extend a relation

202data TupleExpr = AttributeTupleExpr AttributeName AtomExpr

231data TupleExpr = AttributeTupleExpr AttributeName AtomExpr

203− deriving (Show, Eq)

232+ deriving (Show, Eq, Generic)

233+

234+instance Binary TupleExpr

204

235

205--enumerates the list of functions available to be run as part of tuple expressions

236--enumerates the list of functions available to be run as part of tuple expressions

206type AtomFunctions = HS.HashSet AtomFunction

237type AtomFunctions = HS.HashSet AtomFunction

@@ -223,7 +254,15 @@ instance Show AtomFunction where

223 show aFunc = T.unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes

254 show aFunc = T.unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes

224 where

255 where

225 showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))

256 showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))

226−

257+

227data AttributeNames = AttributeNames (S.Set AttributeName) |

258data AttributeNames = AttributeNames (S.Set AttributeName) |

228 InvertedAttributeNames (S.Set AttributeName)

259 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

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)

34 | AtomFunctionTypeError AtomFunctionName Int AtomType AtomType --arg number

35 deriving (Show,Eq,Generic)

37+instance NFData RelationalError where rnf = genericRnf

38+

39+data PersistenceError = InvalidDirectoryError FilePath |

40+ MissingTransactionError U.UUID

41+ deriving (Show, Eq)

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

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 @@

2module ProjectM36.Transaction where

3import qualified Data.UUID as U

4import ProjectM36.Base

5−import ProjectM36.Error

6import qualified Data.Set as S

5import qualified Data.Set as S

7−import qualified Data.Map as M

8−import Control.Applicative ((<$>))

9−import Control.Monad

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−

60--create a disconnected transaction with a parent

7--create a disconnected transaction with a parent

61newDisconnectedTransaction :: U.UUID -> DatabaseContext -> DisconnectedTransaction

8newDisconnectedTransaction :: U.UUID -> DatabaseContext -> DisconnectedTransaction

62newDisconnectedTransaction parentUUID context = DisconnectedTransaction parentUUID context

9newDisconnectedTransaction parentUUID context = DisconnectedTransaction parentUUID context

64−{-

11+transactionParentUUIDs :: Transaction -> S.Set U.UUID

65−addBranch :: HeadName -> Transaction -> TransactionGraph -> Maybe TransactionGraph

12+transactionParentUUIDs (Transaction _ (TransactionInfo pUUID _) _) = S.singleton pUUID

66−addBranch newBranchName branchPoint graph@(TransactionGraph heads transSet) = if not (S.member branchPoint transSet) then Nothing else Just $ TransactionGraph newHeads transSet

13+transactionParentUUIDs (Transaction _ (MergeTransactionInfo pUUID1 pUUID2 _) _) = S.fromList [pUUID1, pUUID2]

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)

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 @@

1{-# LANGUAGE OverloadedStrings #-}

2−module ProjectM36.Transaction.Show where

2+module ProjectM36.TransactionGraph.Show where

3import ProjectM36.Base

4import ProjectM36.Relation

5import ProjectM36.Tuple

6import ProjectM36.TupleSet

7import ProjectM36.Error

8−import ProjectM36.Transaction

8+import ProjectM36.TransactionGraph

9import qualified ProjectM36.Attribute as A

10import qualified Data.HashSet as HS

11import qualified Data.Set as S

TutorialD/Interpreter.hs+28−22

@@ -5,7 +5,7 @@ import TutorialD.Interpreter.RODatabaseContextOperator

5import TutorialD.Interpreter.DatabaseExpr

6import TutorialD.Interpreter.TransactionGraphOperator

7import ProjectM36.Base

8−import ProjectM36.Transaction

8+import ProjectM36.TransactionGraph

9import Text.Parsec

10import Text.Parsec.String

11import Control.Monad.State

@@ -41,43 +41,49 @@ promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.appen

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

42 Just headName -> headName

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

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

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

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

46+ Left err -> (DisplayErrorResult (T.pack $ show err), discon, graph, False)

47− Right (RODatabaseContextOp execOp) -> (evalRODatabaseContextOp context execOp, discon, graph)

47+ Right (RODatabaseContextOp execOp) -> (evalRODatabaseContextOp context execOp, discon, graph, False)

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

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

49+ Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph, False)

50− Right context' -> (QuietSuccessResult, DisconnectedTransaction parentUUID context', graph)

50+ Right context' -> (QuietSuccessResult, DisconnectedTransaction parentUUID context', graph, False)

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

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

52+ Left err -> (DisplayErrorResult $ T.pack (show err), discon, graph, False)

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

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

54+

55+data InterpreterConfig = InterpreterConfig {

56+ persistenceStrategy :: PersistenceStrategy

57+ }

55−

56−

57−reprLoop :: DisconnectedTransaction -> TransactionGraph -> IO ()

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

58−reprLoop currentTransaction graph = do

60+reprLoop config currentTransaction graph = do

59 homeDirectory <- getHomeDirectory

61 homeDirectory <- getHomeDirectory

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

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

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

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

64− let roloop = reprLoop currentTransaction graph

66+ let roloop = reprLoop config currentTransaction graph

65 case maybeLine of

67 case maybeLine of

66 Nothing -> return ()

68 Nothing -> return ()

67 Just line -> do

69 Just line -> do

68 newUUID <- nextRandom

70 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

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

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

71− (DisplayErrorResult err, _, _) -> TIO.hPutStrLn stderr ("ERR: " `T.append` err) >> roloop

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

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

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

73 outio

77 outio

74− reprLoop updatedTrans updatedGraph

78+ reprLoop config updatedTrans' updatedGraph'

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

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

76 TIO.putStrLn out

80 TIO.putStrLn out

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

77− reprLoop updatedTrans updatedGraph

82+ reprLoop config updatedTrans' updatedGraph'

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

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

84+ --save the current transaction graph

79− TIO.putStrLn "Done."

85+ TIO.putStrLn "Done."

80− reprLoop updatedTrans updatedGraph

86+ reprLoop config updatedTrans' updatedGraph'

82--used by :dumpGraph

88--used by :dumpGraph

83{-

89{-

TutorialD/Interpreter/Base.hs+7

@@ -10,6 +10,7 @@ import qualified Data.List as L

10import qualified Data.Vector as V

11import qualified Data.Text.IO as TIO

12import System.IO

13+import ProjectM36.TransactionGraph.Persist

14lexer :: Token.TokenParser ()

15lexer :: Token.TokenParser ()

15lexer = Token.makeTokenParser tutD

16lexer = Token.makeTokenParser tutD

@@ -67,6 +68,8 @@ data TutorialDOperatorResult = QuitResult |

67 DisplayIOResult (IO ()) |

68 DisplayIOResult (IO ()) |

68 DisplayErrorResult StringType |

69 DisplayErrorResult StringType |

69 QuietSuccessResult

70 QuietSuccessResult

71+

72+type TransactionGraphWasUpdated = Bool

71displayOpResult :: TutorialDOperatorResult -> IO ()

74displayOpResult :: TutorialDOperatorResult -> IO ()

72displayOpResult QuitResult = return ()

75displayOpResult QuitResult = return ()

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

74displayOpResult (DisplayIOResult ioout) = ioout

77displayOpResult (DisplayIOResult ioout) = ioout

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

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

76displayOpResult QuietSuccessResult = return ()

79displayOpResult 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

8import qualified Data.Text as T

9import ProjectM36.Error

10import ProjectM36.Transaction

11−import ProjectM36.Transaction.Show

11+import ProjectM36.TransactionGraph

12+import ProjectM36.TransactionGraph.Show

12import ProjectM36.Relation.Show.Term

13import ProjectM36.Relation.Show.Term

14--operators which manipulate a transaction graph

15--operators which manipulate a transaction graph

TutorialD/tutd.hs+58−5

@@ -1,16 +1,69 @@

1{-# LANGUAGE OverloadedStrings #-}

2import TutorialD.Interpreter

3import ProjectM36.RelationalExpression

4+import ProjectM36.TransactionGraph

5+import ProjectM36.TransactionGraph.Persist

4import ProjectM36.Transaction

6import ProjectM36.Transaction

5import ProjectM36.Base

7import ProjectM36.Base

8+import System.IO

9+import Options.Applicative

6import Data.UUID.V4 (nextRandom)

10import Data.UUID.V4 (nextRandom)

11+import qualified Data.Text as T

12+import System.Exit

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+

8main :: IO ()

59main :: IO ()

9main = do

60main = do

10− freshUUID <- nextRandom

61+ interpreterConfig <- execParser opts

11 let currentHeadName = "master"

62 let currentHeadName = "master"

12− let newGraph = bootstrapTransactionGraph freshUUID dateExamples

63+ freshGraph <- configSetup interpreterConfig

13− let headTransaction = case transactionForHead currentHeadName newGraph of { Just x -> x; _ -> undefined}

64+ case transactionForHead currentHeadName freshGraph of

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

66+ Just headTransaction -> do

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

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

15− reprLoop currentTransaction newGraph

68+ reprLoop interpreterConfig currentTransaction freshGraph

project-m36.cabal+11−2

@@ -7,10 +7,12 @@ Category: Relational Algebra

7Cabal-Version: >= 1.2

9Library

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

11 Exposed-Modules: ProjectM36.Error,

12 ProjectM36.Transaction,

13− ProjectM36.Transaction.Show,

13+ ProjectM36.TransactionGraph,

14+ ProjectM36.TransactionGraph.Show,

15+ ProjectM36.TransactionGraph.Persist,

14 ProjectM36.Base,

16 ProjectM36.Base,

15 ProjectM36.Attribute,

17 ProjectM36.Attribute,

16 ProjectM36.AttributeNames,

18 ProjectM36.AttributeNames,

@@ -19,6 +21,7 @@ Library

19 ProjectM36.Atom,

21 ProjectM36.Atom,

20 ProjectM36.AtomFunction,

22 ProjectM36.AtomFunction,

21 ProjectM36.Key,

23 ProjectM36.Key,

24+ ProjectM36.DatabaseContext,

22 ProjectM36.RelationalExpression,

25 ProjectM36.RelationalExpression,

23 ProjectM36.Relation.Show.HTML,

26 ProjectM36.Relation.Show.HTML,

24 ProjectM36.StaticOptimizer,

27 ProjectM36.StaticOptimizer,

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

70 Build-Depends: base,HUnit,Cabal

73 Build-Depends: base,HUnit,Cabal

71 GHC-Options: -Wall

74 GHC-Options: -Wall

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+

73benchmark bench

82benchmark bench

74 type: exitcode-stdio-1.0

83 type: exitcode-stdio-1.0

75 main-is: benchmark/Relation.hs

84 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

9import ProjectM36.Error

10import ProjectM36.Base

11import ProjectM36.Transaction

12+import ProjectM36.TransactionGraph

12import qualified ProjectM36.Attribute as A

13import qualified ProjectM36.Attribute as A

13import qualified Data.HashSet as HS

14import qualified Data.HashSet as HS

14import qualified Data.Map as M

15import qualified Data.Map as M

@@ -135,7 +136,7 @@ transactionRollbackTest = TestCase $ do

135 Left err -> assertFailure (show err)

136 Left err -> assertFailure (show err)

136 Right newContext -> do

137 Right newContext -> do

137 let discon = newDisconnectedTransaction firstUUID newContext

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

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

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

140 assertEqual "validate graph" graph newGraph

141 assertEqual "validate graph" graph newGraph

141

142

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

161 Left err -> assertFailure (show err)

162 Left err -> assertFailure (show err)

162 Right (_, graph) -> do

163 Right (_, graph) -> do

163 --jump to the first transaction

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

165 assertEqual "validate discon" parentUUID firstUUID

166 assertEqual "validate discon" parentUUID firstUUID

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

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

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

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

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

184 Left err -> assertFailure (show err)

185 Left err -> assertFailure (show err)

185 Right (_, graph) -> do

186 Right (_, graph) -> do

186 --add a third transaction to the "test" branch

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

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

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

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

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

190 where

191 where