2aba32a · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

add commit timestamps

2aba32aAgentM9 years ago

docs/transaction_graph_operators.markdown+40−4

compare with master

unifiedsplit

@@ -56,19 +56,21 @@ In order to navigate the transaction graph, one must specify transaction UUIDs.

57```

58TutorialD (master/main): :showgraph

59−┌───────┬──────┬────────────────────────────────────┬───────┐

59+┌─────────────┬──────────┬──────────────────────────────────────┬────────────────────────────┬──────────────────────────────┐

60−│current│head │id │parents│

60+│current::Bool│head::Text│id::Text │parents::relation {id::Text}│stamp::DateTime │

61−├───────┼──────┼────────────────────────────────────┼───────┤

61+├─────────────┼──────────┼──────────────────────────────────────┼────────────────────────────┼──────────────────────────────┤

62+

62<big result elided>

63<big result elided>

63```

64```

64The "current" attribute is a boolean value. If true, the transaction is the parent of the current database context. Commits will be children of this transaction.

65The "current" attribute is a boolean value. If true, the transaction is the parent of the current database context. Commits will be children of this transaction.

66−The "head attribute is a boolean value indicating whether or not the transaction is a "head" node of its graph. Head nodes are nodes which have no children.

67+The "head" attribute is a boolean value indicating whether or not the transaction is a "head" node of its graph. Head nodes are nodes which have no children.

68The "id" attribute is the UUID needed in order to navigate the graph.

69The "id" attribute is the UUID needed in order to navigate the graph.

70The "parents" attribute is a subrelation holding all parent transaction UUIDs for the given transaction.

71The "parents" attribute is a subrelation holding all parent transaction UUIDs for the given transaction.

73+The "stamp" attribute marks the time when the transaction was opened.

73#### Branch

75#### Branch

@@ -109,3 +111,37 @@ TutorialD (11b601c9-f46b-42b0-a2ce-cf18ced31b7f):

109```

111```

110

112

111Note that the ```tutd``` prompt now indicates that the mutable database context now refers to a specific transaction by UUID.

113Note that the ```tutd``` prompt now indicates that the mutable database context now refers to a specific transaction by UUID.

114+

115+#### Walk Back To Time

116+

117+Each transaction is committed along with a creation timestamp. From any point in the graph, one can "walk back" until the commit timestamp is past a given timestamp threshold.

118+

119+```

120+TutorialD (master/main): x:=true

121+TutorialD (master/main): :commit

122+TutorialD (master/main): :showgraph

123+┌─────────────┬──────────┬──────────────────────────────────────┬────────────────────────────────────────┬──────────────────────────────┐

124+│current::Bool│head::Text│id::Text │parents::relation {id::Text} │stamp::DateTime │

125+├─────────────┼──────────┼──────────────────────────────────────┼────────────────────────────────────────┼──────────────────────────────┤

126+│True │"master" │"b4c3bd0a-c594-456f-8e1b-8e296c939df4"│┌──────────────────────────────────────┐│2017-08-10 16:45:34.635582 UTC│

127+│ │ │ ││id::Text ││ │

128+│ │ │ │├──────────────────────────────────────┤│ │

129+│ │ │ ││"5e441752-f78d-4a0d-b7f6-b2716ab82a4d"││ │

130+│ │ │ │└──────────────────────────────────────┘│ │

131+│False │"" │"5e441752-f78d-4a0d-b7f6-b2716ab82a4d"│┌────────┐ │2017-08-10 16:43:59.160044 UTC│

132+│ │ │ ││id::Text│ │ │

133+│ │ │ │└────────┘ │ │

134+└─────────────┴──────────┴──────────────────────────────────────┴────────────────────────────────────────┴──────────────────────────────┘

135+

136+TutorialD (master/main): :walkbacktotime "2017-08-10 16:44:00"

137+TutorialD (<unknown>/main): :showexpr x

138+ERR: RelVarNotDefinedError "x"

139+```

140+

141+In the above example, we start with a fresh database and commit relvar ```x```. Then, using the displayed graph, we walk back to a time before the stamp provided from the graph display and discover that, indeed, ```x``` was not defined in that point in time.

142+

143+Note that all timestamps are in UTC time.

144+

145+If you choose to walk back in time before the database existed, you will see a ```RootTransactionTraversalError```.

146+

147+Note that some transactions, specifically merge transactions, can have multiple parents. In such walk back scenarios, an arbitrary parent is chosen to continue the search. For more precise control, use the other search/jump strategies to set your current transaction behind the merge transaction and then walk back.

project-m36.cabal+2−2

@@ -298,7 +298,7 @@ Test-Suite test-tutoriald-atomfunctionscript

298 type: exitcode-stdio-1.0

299 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator

300 main-is: test/TutorialD/Interpreter/AtomFunctionScript.hs

301− Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups

301+ Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups, time

302 GHC-Options: -Wall

303 Hs-Source-Dirs: ./src/bin, ./test, .

304 CPP-Options: -DPROJECTM36_VERSION="v0.1"

@@ -309,7 +309,7 @@ Test-Suite test-tutoriald-databasecontextfunctionscript

309 type: exitcode-stdio-1.0

310 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator

311 main-is: test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs

312− Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups

312+ Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups, time

313 GHC-Options: -Wall

314 Hs-Source-Dirs: ./src/bin, ./test, .

315 CPP-Options: -DPROJECTM36_VERSION="v0.1"

src/bin/TutorialD/Interpreter/Base.hs+14−3

@@ -1,10 +1,12 @@

1{-# LANGUAGE DeriveGeneric, CPP #-}

2module TutorialD.Interpreter.Base where

3+import ProjectM36.Base

4+import ProjectM36.AtomType

5+import ProjectM36.Relation

3import Text.Megaparsec

7import Text.Megaparsec

4import Text.Megaparsec.Text

8import Text.Megaparsec.Text

5import qualified Text.Megaparsec.Lexer as Lex

9import qualified Text.Megaparsec.Lexer as Lex

6−import ProjectM36.Base

7−import ProjectM36.AtomType

8import Data.Text hiding (count)

10import Data.Text hiding (count)

9import System.Random

11import System.Random

10import qualified Data.Text as T

12import qualified Data.Text as T

@@ -17,9 +19,10 @@ import GHC.Generics

17import Data.Monoid

19import Data.Monoid

18import Control.Monad (void)

20import Control.Monad (void)

19import qualified Data.UUID as U

21import qualified Data.UUID as U

20−import ProjectM36.Relation

21import Control.Monad.Random

22import Control.Monad.Random

22import Data.List.NonEmpty as NE

23import Data.List.NonEmpty as NE

24+import Data.Time.Clock

25+import Data.Time.Format

24displayOpResult :: TutorialDOperatorResult -> IO ()

27displayOpResult :: TutorialDOperatorResult -> IO ()

25displayOpResult QuitResult = return ()

28displayOpResult QuitResult = return ()

@@ -155,3 +158,11 @@ uuidP = do

155 case U.fromString uuidStr of

158 case U.fromString uuidStr of

156 Nothing -> fail "Invalid uuid string"

159 Nothing -> fail "Invalid uuid string"

157 Just uuid -> return uuid

160 Just uuid -> return uuid

161+

162+utcTimeP :: Parser UTCTime

163+utcTimeP = do

164+ timeStr <- quotedString

165+ case parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack timeStr) of

166+ Nothing -> fail "invalid datetime input, use \"YYYY-MM-DD HH:MM:SS\""

167+ Just stamp -> pure stamp

168+

src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs+2−1

@@ -25,7 +25,8 @@ transactionIdLookupP = (TransactionIdLookup <$> uuidP) <|>

26transactionIdHeadBacktrackP :: Parser TransactionIdHeadBacktrack

27transactionIdHeadBacktrackP = (string "~" *> (TransactionIdHeadParentBacktrack <$> backtrackP)) <|>

28− (string "^" *> (TransactionIdHeadBranchBacktrack <$> backtrackP))

28+ (string "^" *> (TransactionIdHeadBranchBacktrack <$> backtrackP)) <|>

29+ (string "@" *> (TransactionStampHeadBacktrack <$> utcTimeP))

30backtrackP :: Parser Int

31backtrackP :: Parser Int

31backtrackP = do

32backtrackP = do

src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs+6

@@ -19,6 +19,11 @@ jumpToTransactionP = do

19 reservedOp ":jump"

20 uuid <- uuidP

21 return $ JumpToTransaction uuid

22+

23+walkBackToTimeP :: Parser TransactionGraphOperator

24+walkBackToTimeP = do

25+ reservedOp ":walkbacktotime"

26+ WalkBackToTime <$> utcTimeP

23branchTransactionP :: Parser TransactionGraphOperator

28branchTransactionP :: Parser TransactionGraphOperator

24branchTransactionP = do

29branchTransactionP = do

@@ -69,6 +74,7 @@ transactionGraphOpP :: Parser TransactionGraphOperator

69transactionGraphOpP =

74transactionGraphOpP =

70 jumpToHeadP

75 jumpToHeadP

71 <|> jumpToTransactionP

76 <|> jumpToTransactionP

77+ <|> walkBackToTimeP

72 <|> branchTransactionP

78 <|> branchTransactionP

73 <|> deleteBranchP

79 <|> deleteBranchP

74 <|> commitTransactionP

80 <|> commitTransactionP

src/lib/ProjectM36/Base.hs+2−2

@@ -362,8 +362,8 @@ transactionHeadsForGraph :: TransactionGraph -> TransactionHeads

362transactionHeadsForGraph (TransactionGraph heads _) = heads

363

364-- | Every transaction has context-specific information attached to it.

365−data TransactionInfo = TransactionInfo TransactionId (S.Set TransactionId) | -- 1 parent + n children

365+data TransactionInfo = TransactionInfo TransactionId (S.Set TransactionId) UTCTime | -- 1 parent + n children

366− MergeTransactionInfo TransactionId TransactionId (S.Set TransactionId) -- 2 parents, n children

366+ MergeTransactionInfo TransactionId TransactionId (S.Set TransactionId) UTCTime -- 2 parents, n children

367 deriving(Show, Generic)

368

369instance Binary TransactionInfo

src/lib/ProjectM36/Client.hs+7−3

@@ -144,6 +144,7 @@ import Data.Binary (Binary)

144import GHC.Generics (Generic)

145import Control.DeepSeq (force)

146import System.IO

147+import Data.Time.Clock

147

148

148type Hostname = String

149type Hostname = String

149

150

@@ -283,8 +284,9 @@ connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection)

283--create a new in-memory database/transaction graph

284--create a new in-memory database/transaction graph

284connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths) = do

285connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths) = do

285 freshId <- nextRandom

286 freshId <- nextRandom

287+ stamp <- getCurrentTime

286 let bootstrapContext = basicDatabaseContext

288 let bootstrapContext = basicDatabaseContext

287− freshGraph = bootstrapTransactionGraph freshId bootstrapContext

289+ freshGraph = bootstrapTransactionGraph stamp freshId bootstrapContext

288 case strat of

290 case strat of

289 --create date examples graph for now- probably should be empty context in the future

291 --create date examples graph for now- probably should be empty context in the future

290 NoPersistence -> do

292 NoPersistence -> do

@@ -571,12 +573,13 @@ autoMergeToHead sessionId (InProcessConnection conf) strat headName' = do

571 id1 <- nextRandom

573 id1 <- nextRandom

572 id2 <- nextRandom

574 id2 <- nextRandom

573 id3 <- nextRandom

575 id3 <- nextRandom

576+ stamp <- getCurrentTime

574 commitLock_ sessionId conf $ \graph -> do

577 commitLock_ sessionId conf $ \graph -> do

575 eSession <- sessionForSessionId sessionId sessions

578 eSession <- sessionForSessionId sessionId sessions

576 case eSession of

579 case eSession of

577 Left err -> pure (Left err)

580 Left err -> pure (Left err)

578 Right session ->

581 Right session ->

579− case Graph.autoMergeToHead (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph of

582+ case Graph.autoMergeToHead stamp (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph of

580 Left err -> pure (Left err)

583 Left err -> pure (Left err)

581 Right (discon', graph') ->

584 Right (discon', graph') ->

582 pure (Right (discon', graph', [id1, id2, id3]))

585 pure (Right (discon', graph', [id1, id2, id3]))

@@ -636,13 +639,14 @@ executeGraphExpr :: SessionId -> Connection -> TransactionGraphOperator -> IO (E

636executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do

639executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do

637 let sessions = ipSessions conf

640 let sessions = ipSessions conf

638 freshId <- nextRandom

641 freshId <- nextRandom

642+ stamp <- getCurrentTime

639 commitLock_ sessionId conf $ \updatedGraph -> do

643 commitLock_ sessionId conf $ \updatedGraph -> do

640 eSession <- sessionForSessionId sessionId sessions

644 eSession <- sessionForSessionId sessionId sessions

641 case eSession of

645 case eSession of

642 Left err -> pure (Left err)

646 Left err -> pure (Left err)

643 Right session -> do

647 Right session -> do

644 let discon = Sess.disconnectedTransaction session

648 let discon = Sess.disconnectedTransaction session

645− case evalGraphOp freshId discon updatedGraph graphExpr of

649+ case evalGraphOp stamp freshId discon updatedGraph graphExpr of

646 Left err -> pure (Left err)

650 Left err -> pure (Left err)

647 Right (discon', graph') -> do

651 Right (discon', graph') -> do

648 --if freshId appears in the graph, then we need to pass it on

652 --if freshId appears in the graph, then we need to pass it on

src/lib/ProjectM36/Transaction.hs+13−8

@@ -2,24 +2,29 @@ module ProjectM36.Transaction where

2import ProjectM36.Base

3import qualified Data.Set as S

4import qualified Data.UUID as U

5+import Data.Time.Clock

7+transactionTimestamp :: Transaction -> UTCTime

8+transactionTimestamp (Transaction _ (TransactionInfo _ _ stamp) _) = stamp

9+transactionTimestamp (Transaction _ (MergeTransactionInfo _ _ _ stamp) _) = stamp

6transactionParentIds :: Transaction -> S.Set TransactionId

11transactionParentIds :: Transaction -> S.Set TransactionId

7−transactionParentIds (Transaction _ (TransactionInfo pId _) _) = S.singleton pId

12+transactionParentIds (Transaction _ (TransactionInfo pId _ _) _) = S.singleton pId

8−transactionParentIds (Transaction _ (MergeTransactionInfo pId1 pId2 _) _) = S.fromList [pId1, pId2]

13+transactionParentIds (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _) = S.fromList [pId1, pId2]

10transactionChildIds :: Transaction -> S.Set TransactionId

15transactionChildIds :: Transaction -> S.Set TransactionId

11−transactionChildIds (Transaction _ (TransactionInfo _ children) _) = children

16+transactionChildIds (Transaction _ (TransactionInfo _ children _) _) = children

12−transactionChildIds (Transaction _ (MergeTransactionInfo _ _ children) _) = children

17+transactionChildIds (Transaction _ (MergeTransactionInfo _ _ children _) _) = children

14-- | Create a new transaction which is identical to the original except that a new set of child transaction ids is added.

19-- | Create a new transaction which is identical to the original except that a new set of child transaction ids is added.

15transactionSetChildren :: Transaction -> S.Set TransactionId -> Transaction

20transactionSetChildren :: Transaction -> S.Set TransactionId -> Transaction

16−transactionSetChildren t@(Transaction _ (TransactionInfo pId _) schemas') childIds = Transaction (transactionId t) (TransactionInfo pId childIds) schemas'

21+transactionSetChildren t@(Transaction _ (TransactionInfo pId _ stamp) schemas') childIds = Transaction (transactionId t) (TransactionInfo pId childIds stamp) schemas'

17−transactionSetChildren t@(Transaction _ (MergeTransactionInfo pId1 pId2 _) schemas') childIds = Transaction (transactionId t) (MergeTransactionInfo pId1 pId2 childIds) schemas'

22+transactionSetChildren t@(Transaction _ (MergeTransactionInfo pId1 pId2 _ stamp) schemas') childIds = Transaction (transactionId t) (MergeTransactionInfo pId1 pId2 childIds stamp) schemas'

19-- | Return the same transaction but referencing only the specific child transactions. This is useful when traversing a graph and returning a subgraph. This doesn't filter parent transactions because it assumes a head-to-root traversal.

24-- | Return the same transaction but referencing only the specific child transactions. This is useful when traversing a graph and returning a subgraph. This doesn't filter parent transactions because it assumes a head-to-root traversal.

20filterTransactionInfoTransactions :: S.Set TransactionId -> TransactionInfo -> TransactionInfo

25filterTransactionInfoTransactions :: S.Set TransactionId -> TransactionInfo -> TransactionInfo

21−filterTransactionInfoTransactions filterIds (TransactionInfo parentId childIds) = TransactionInfo (filterParent parentId filterIds) (S.intersection childIds filterIds)

26+filterTransactionInfoTransactions filterIds (TransactionInfo parentId childIds stamp) = TransactionInfo (filterParent parentId filterIds) (S.intersection childIds filterIds) stamp

22−filterTransactionInfoTransactions filterIds (MergeTransactionInfo parentIdA parentIdB childIds) = MergeTransactionInfo (filterParent parentIdA filterIds) (filterParent parentIdB filterIds) (S.intersection childIds filterIds)

27+filterTransactionInfoTransactions filterIds (MergeTransactionInfo parentIdA parentIdB childIds stamp) = MergeTransactionInfo (filterParent parentIdA filterIds) (filterParent parentIdB filterIds) (S.intersection childIds filterIds) stamp

24filterParent :: TransactionId -> S.Set TransactionId -> TransactionId

29filterParent :: TransactionId -> S.Set TransactionId -> TransactionId

25filterParent parentId validIds = if S.member parentId validIds then parentId else U.nil

30filterParent parentId validIds = if S.member parentId validIds then parentId else U.nil

src/lib/ProjectM36/TransactionGraph.hs+72−44

@@ -7,16 +7,19 @@ import ProjectM36.Relation

7import ProjectM36.TupleSet

8import ProjectM36.Tuple

9import ProjectM36.RelationalExpression

10+import ProjectM36.TransactionGraph.Merge

11+import qualified ProjectM36.DisconnectedTransaction as Discon

12+

10import qualified Data.Vector as V

13import qualified Data.Vector as V

11import qualified ProjectM36.Attribute as A

14import qualified ProjectM36.Attribute as A

12import qualified Data.UUID as U

15import qualified Data.UUID as U

13import qualified Data.Set as S

16import qualified Data.Set as S

14import qualified Data.Map as M

17import qualified Data.Map as M

15import Control.Monad

18import Control.Monad

19+import Data.Time.Clock

16import qualified Data.Text as T

20import qualified Data.Text as T

17import GHC.Generics

21import GHC.Generics

18import Data.Binary

22import Data.Binary

19−import ProjectM36.TransactionGraph.Merge

20import Data.Either (lefts, rights, isRight)

23import Data.Either (lefts, rights, isRight)

21import Data.Monoid

24import Data.Monoid

22import Control.Arrow

25import Control.Arrow

@@ -35,13 +38,15 @@ data TransactionIdLookup = TransactionIdLookup TransactionId |

36-- | Used for git-style head backtracking such as topic~3^2.

39-- | Used for git-style head backtracking such as topic~3^2.

37data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- ^ git equivalent of ~: walk back n parents, arbitrarily choosing a parent when a choice must be made

40data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- ^ git equivalent of ~: walk back n parents, arbitrarily choosing a parent when a choice must be made

38− TransactionIdHeadBranchBacktrack Int -- ^ git equivalent of ^: walk back one parent level to the nth arbitrarily-chosen parent

41+ TransactionIdHeadBranchBacktrack Int | -- ^ git equivalent of ^: walk back one parent level to the nth arbitrarily-chosen parent

42+ TransactionStampHeadBacktrack UTCTime -- ^ git equivalent of 'git-rev-list -n 1 --before X' find the first transaction which was created before the timestamp

39 deriving (Show, Eq, Binary, Generic)

43 deriving (Show, Eq, Binary, Generic)

42-- | Operators which manipulate a transaction graph and which transaction the current 'Session' is based upon.

46-- | Operators which manipulate a transaction graph and which transaction the current 'Session' is based upon.

43data TransactionGraphOperator = JumpToHead HeadName |

47data TransactionGraphOperator = JumpToHead HeadName |

44 JumpToTransaction TransactionId |

48 JumpToTransaction TransactionId |

49+ WalkBackToTime UTCTime |

45 Branch HeadName |

50 Branch HeadName |

46 DeleteBranch HeadName |

51 DeleteBranch HeadName |

47 MergeTransactions MergeStrategy HeadName HeadName |

52 MergeTransactions MergeStrategy HeadName HeadName |

@@ -56,12 +61,12 @@ isCommit _ = False

56data ROTransactionGraphOperator = ShowGraph

61data ROTransactionGraphOperator = ShowGraph

57 deriving Show

62 deriving Show

59−bootstrapTransactionGraph :: TransactionId -> DatabaseContext -> TransactionGraph

64+bootstrapTransactionGraph :: UTCTime -> TransactionId -> DatabaseContext -> TransactionGraph

60−bootstrapTransactionGraph freshId context = TransactionGraph bootstrapHeads bootstrapTransactions

65+bootstrapTransactionGraph stamp freshId context = TransactionGraph bootstrapHeads bootstrapTransactions

61 where

66 where

62 bootstrapHeads = M.singleton "master" freshTransaction

67 bootstrapHeads = M.singleton "master" freshTransaction

63 newSchemas = Schemas context M.empty

68 newSchemas = Schemas context M.empty

64− freshTransaction = Transaction freshId (TransactionInfo U.nil S.empty) newSchemas

69+ freshTransaction = Transaction freshId (TransactionInfo U.nil S.empty stamp) newSchemas

65 bootstrapTransactions = S.singleton freshTransaction

70 bootstrapTransactions = S.singleton freshTransaction

67emptyTransactionGraph :: TransactionGraph

72emptyTransactionGraph :: TransactionGraph

@@ -98,33 +103,33 @@ transactionsForIds idSet graph = do

98 return (S.fromList transList)

103 return (S.fromList transList)

104

100isRootTransaction :: Transaction -> TransactionGraph -> Bool

105isRootTransaction :: Transaction -> TransactionGraph -> Bool

101−isRootTransaction (Transaction _ (TransactionInfo pId _) _) _ = U.null pId

106+isRootTransaction (Transaction _ (TransactionInfo pId _ _) _) _ = U.null pId

102isRootTransaction (Transaction _ MergeTransactionInfo{} _) _ = False

107isRootTransaction (Transaction _ MergeTransactionInfo{} _) _ = False

103

108

104-- the first transaction has no parent - all other do have parents- merges have two parents

109-- the first transaction has no parent - all other do have parents- merges have two parents

105parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

110parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

106−parentTransactions (Transaction _ (TransactionInfo pId _) _) graph = do

111+parentTransactions (Transaction _ (TransactionInfo pId _ _) _) graph = do

107 trans <- transactionForId pId graph

112 trans <- transactionForId pId graph

108 return (S.singleton trans)

113 return (S.singleton trans)

109

114

110−parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph

115+parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph

111

116

112

117

113childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

118childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)

114−childTransactions (Transaction _ (TransactionInfo _ children) _) = transactionsForIds children

119+childTransactions (Transaction _ (TransactionInfo _ children _) _) = transactionsForIds children

115−childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transactionsForIds children

120+childTransactions (Transaction _ (MergeTransactionInfo _ _ children _) _) = transactionsForIds children

116

121

117-- create a new commit and add it to the heads

122-- create a new commit and add it to the heads

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

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

119−addBranch :: TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

124+addBranch :: UTCTime -> TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

120−addBranch newId newBranchName branchPointId graph = do

125+addBranch stamp newId newBranchName branchPointId graph = do

121 parentTrans <- transactionForId branchPointId graph

126 parentTrans <- transactionForId branchPointId graph

122− let newTrans = Transaction newId (TransactionInfo branchPointId S.empty) (schemas parentTrans)

127+ let newTrans = Transaction newId (TransactionInfo branchPointId S.empty stamp) (schemas parentTrans)

123 addTransactionToGraph newBranchName newTrans graph

128 addTransactionToGraph newBranchName newTrans graph

124

129

125--adds a disconnected transaction to a transaction graph at some head

130--adds a disconnected transaction to a transaction graph at some head

126−addDisconnectedTransaction :: TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

131+addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

127−addDisconnectedTransaction newId headName (DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty) schemas')

132+addDisconnectedTransaction stamp newId headName (DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty stamp) schemas')

128

133

129

134

130addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

135addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)

@@ -201,20 +206,30 @@ walkChildTransactions seenTransSet graph trans =

201

206

202-- returns the new "current" transaction, updated graph, and tutorial d result

207-- returns the new "current" transaction, updated graph, and tutorial d result

203-- the current transaction is not part of the transaction graph until it is committed

208-- the current transaction is not part of the transaction graph until it is committed

204−evalGraphOp :: TransactionId -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

209+evalGraphOp :: UTCTime -> TransactionId -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

205

210

206−evalGraphOp _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId graph of

211+evalGraphOp _ _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId graph of

207 Left err -> Left err

212 Left err -> Left err

208 Right parentTrans -> Right (newTrans, graph)

213 Right parentTrans -> Right (newTrans, graph)

209 where

214 where

210 newTrans = DisconnectedTransaction jumpId (schemas parentTrans) False

215 newTrans = DisconnectedTransaction jumpId (schemas parentTrans) False

211

216

212-- switch from one head to another

217-- switch from one head to another

213−evalGraphOp _ _ graph (JumpToHead headName) =

218+evalGraphOp _ _ _ graph (JumpToHead headName) =

214 case transactionForHead headName graph of

219 case transactionForHead headName graph of

215 Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) False in

220 Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) False in

216 Right (disconnectedTrans, graph)

221 Right (disconnectedTrans, graph)

217 Nothing -> Left $ NoSuchHeadNameError headName

222 Nothing -> Left $ NoSuchHeadNameError headName

223+

224+evalGraphOp _ _ discon graph (WalkBackToTime backTime) = do

225+ let startTransId = Discon.parentId discon

226+ jumpDest <- backtrackGraph graph startTransId (TransactionStampHeadBacktrack backTime)

227+ case transactionForId jumpDest graph of

228+ Left err -> Left err

229+ Right trans -> do

230+ let disconnectedTrans = DisconnectedTransaction (transactionId trans) (schemas trans) False

231+ Right (disconnectedTrans, graph)

232+

218-- add new head pointing to branchPoint

233-- add new head pointing to branchPoint

219-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)

234-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)

220-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch

235-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch

@@ -230,15 +245,15 @@ evalGraphOp newId discon@(DisconnectedTransaction parentId disconContext) graph

230

245

231-- create a new commit and add it to the heads

246-- create a new commit and add it to the heads

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

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

233−evalGraphOp newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do

248+evalGraphOp stamp newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do

234 let newDiscon = DisconnectedTransaction newId schemas' False

249 let newDiscon = DisconnectedTransaction newId schemas' False

235− case addBranch newId newBranchName parentId graph of

250+ case addBranch stamp newId newBranchName parentId graph of

236 Left err -> Left err

251 Left err -> Left err

237 Right (_, newGraph) -> Right (newDiscon, newGraph)

252 Right (_, newGraph) -> Right (newDiscon, newGraph)

238

253

239-- add the disconnected transaction to the graph

254-- add the disconnected transaction to the graph

240-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction

255-- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction

241−evalGraphOp newTransId discon@(DisconnectedTransaction parentId schemas' _) graph Commit = case transactionForId parentId graph of

256+evalGraphOp stamp newTransId discon@(DisconnectedTransaction parentId schemas' _) graph Commit = case transactionForId parentId graph of

242 Left err -> Left err

257 Left err -> Left err

243 Right parentTransaction -> case headNameForTransaction parentTransaction graph of

258 Right parentTransaction -> case headNameForTransaction parentTransaction graph of

244 Nothing -> Left $ TransactionIsNotAHeadError parentId

259 Nothing -> Left $ TransactionIsNotAHeadError parentId

@@ -247,18 +262,18 @@ evalGraphOp newTransId discon@(DisconnectedTransaction parentId schemas' _) grap

247 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)

262 Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)

248 where

263 where

249 newDisconnectedTrans = DisconnectedTransaction newTransId schemas' False

264 newDisconnectedTrans = DisconnectedTransaction newTransId schemas' False

250− maybeUpdatedGraph = addDisconnectedTransaction newTransId headName discon graph

265+ maybeUpdatedGraph = addDisconnectedTransaction stamp newTransId headName discon graph

251

266

252-- refresh the disconnected transaction, return the same graph

267-- refresh the disconnected transaction, return the same graph

253−evalGraphOp _ (DisconnectedTransaction parentId _ _) graph Rollback = case transactionForId parentId graph of

268+evalGraphOp _ _ (DisconnectedTransaction parentId _ _) graph Rollback = case transactionForId parentId graph of

254 Left err -> Left err

269 Left err -> Left err

255 Right parentTransaction -> Right (newDiscon, graph)

270 Right parentTransaction -> Right (newDiscon, graph)

256 where

271 where

257 newDiscon = DisconnectedTransaction parentId (schemas parentTransaction) False

272 newDiscon = DisconnectedTransaction parentId (schemas parentTransaction) False

258

273

259−evalGraphOp newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph

274+evalGraphOp stamp newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions stamp newId parentId mergeStrategy (headNameA, headNameB) graph

260

275

261−evalGraphOp _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of

276+evalGraphOp _ _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of

262 Nothing -> Left (NoSuchHeadNameError branchName)

277 Nothing -> Left (NoSuchHeadNameError branchName)

263 Just _ -> Right (discon, TransactionGraph (M.delete branchName graphHeads) transSet)

278 Just _ -> Right (discon, TransactionGraph (M.delete branchName graphHeads) transSet)

264

279

@@ -269,6 +284,7 @@ graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _

269 mkRelationFromList attrs tupleMatrix

284 mkRelationFromList attrs tupleMatrix

270 where

285 where

271 attrs = A.attributesFromList [Attribute "id" TextAtomType,

286 attrs = A.attributesFromList [Attribute "id" TextAtomType,

287+ Attribute "stamp" DateTimeAtomType,

272 Attribute "parents" (RelationAtomType parentAttributes),

288 Attribute "parents" (RelationAtomType parentAttributes),

273 Attribute "current" BoolAtomType,

289 Attribute "current" BoolAtomType,

274 Attribute "head" TextAtomType

290 Attribute "head" TextAtomType

@@ -277,6 +293,7 @@ graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _

277 tupleGenerator transaction = case transactionParentsRelation transaction graph of

293 tupleGenerator transaction = case transactionParentsRelation transaction graph of

278 Left err -> Left err

294 Left err -> Left err

279 Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),

295 Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),

296+ DateTimeAtom (transactionTimestamp transaction),

280 RelationAtom parentTransRel,

297 RelationAtom parentTransRel,

281 BoolAtom $ parentId == transactionId transaction,

298 BoolAtom $ parentId == transactionId transaction,

282 TextAtom $ fromMaybe "" (headNameForTransaction transaction graph)

299 TextAtom $ fromMaybe "" (headNameForTransaction transaction graph)

@@ -303,16 +320,16 @@ evalROGraphOp discon graph ShowGraph = do

303-}

320-}

304

321

305-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph

322-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph

306−createMergeTransaction :: TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

323+createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

307−createMergeTransaction newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do

324+createMergeTransaction stamp newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do

308 selectedTrans <- validateHeadName selectedBranch graph t2

325 selectedTrans <- validateHeadName selectedBranch graph t2

309− pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty) (schemas selectedTrans)

326+ pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty stamp) (schemas selectedTrans)

310

327

311-- merge functions, relvars, individually

328-- merge functions, relvars, individually

312−createMergeTransaction newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction newId strat graph t2

329+createMergeTransaction stamp newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp newId strat graph t2

313

330

314-- merge function, relvars, but, on error, just take the component from the preferred branch

331-- merge function, relvars, but, on error, just take the component from the preferred branch

315−createMergeTransaction newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction newId strat graph t2

332+createMergeTransaction stamp newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction stamp newId strat graph t2

316

333

317-- | Returns the correct Transaction for the branch name in the graph and ensures that it is one of the two transaction arguments in the tuple.

334-- | Returns the correct Transaction for the branch name in the graph and ensures that it is one of the two transaction arguments in the tuple.

318validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

335validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

@@ -352,8 +369,8 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans trave

352 else -- we found a path

369 else -- we found a path

353 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))

370 Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))

354 where

371 where

355− oneParent (Transaction _ (TransactionInfo parentId _) _) = transactionForId parentId origGraph

372+ oneParent (Transaction _ (TransactionInfo parentId _ _) _) = transactionForId parentId origGraph

356− oneParent (Transaction _ (MergeTransactionInfo parentId _ _) _) = transactionForId parentId origGraph

373+ oneParent (Transaction _ (MergeTransactionInfo parentId _ _ _) _) = transactionForId parentId origGraph

357

374

358-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.

375-- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError.

359pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)

376pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction)

@@ -376,8 +393,8 @@ pathToTransaction graph currentTransaction targetTransaction accumTransSet = do

376 else --we have some paths!

393 else --we have some paths!

377 Right (S.unions paths)

394 Right (S.unions paths)

378

395

379−mergeTransactions :: TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

396+mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

380−mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph = do

397+mergeTransactions stamp newId parentId mergeStrategy (headNameA, headNameB) graph = do

381 let transactionForHeadErr name = case transactionForHead name graph of

398 let transactionForHeadErr name = case transactionForHead name graph of

382 Nothing -> Left (NoSuchHeadNameError name)

399 Nothing -> Left (NoSuchHeadNameError name)

383 Just t -> Right t

400 Just t -> Right t

@@ -387,7 +404,7 @@ mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph = do

387 let subHeads = M.filterWithKey (\k _ -> elem k [headNameA, headNameB]) (transactionHeadsForGraph graph)

404 let subHeads = M.filterWithKey (\k _ -> elem k [headNameA, headNameB]) (transactionHeadsForGraph graph)

388 subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty

405 subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty

389 subGraph' <- filterSubGraph subGraph subHeads

406 subGraph' <- filterSubGraph subGraph subHeads

390− case createMergeTransaction newId mergeStrategy subGraph' (transA, transB) of

407+ case createMergeTransaction stamp newId mergeStrategy subGraph' (transA, transB) of

391 Left err -> Left (MergeTransactionError err)

408 Left err -> Left (MergeTransactionError err)

392 Right mergedTrans -> case checkConstraints (concreteDatabaseContext mergedTrans) of

409 Right mergedTrans -> case checkConstraints (concreteDatabaseContext mergedTrans) of

393 Just err -> Left err

410 Just err -> Left err

@@ -423,8 +440,8 @@ filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet

423 newHeads = M.map (filterTransaction validIds) heads

440 newHeads = M.map (filterTransaction validIds) heads

424

441

425--helper function for commonalities in union merge

442--helper function for commonalities in union merge

426−createUnionMergeTransaction :: TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

443+createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction

427−createUnionMergeTransaction newId strategy graph (t1,t2) = do

444+createUnionMergeTransaction stamp newId strategy graph (t1,t2) = do

428 let contextA = concreteDatabaseContext t1

445 let contextA = concreteDatabaseContext t1

429 contextB = concreteDatabaseContext t2

446 contextB = concreteDatabaseContext t2

430

447

@@ -452,7 +469,7 @@ createUnionMergeTransaction newId strategy graph (t1,t2) = do

452 typeConstructorMapping = types

469 typeConstructorMapping = types

453 }

470 }

454 newSchemas = Schemas newContext (subschemas t1)

471 newSchemas = Schemas newContext (subschemas t1)

455− pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty) newSchemas)

472+ pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty stamp) newSchemas)

456

473

457lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction

474lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction

458lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

475lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

@@ -488,23 +505,34 @@ backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do

488 Left (ParentCountTraversalError (S.size parents) steps)

505 Left (ParentCountTraversalError (S.size parents) steps)

489 else

506 else

490 pure (S.elemAt (steps - 1) parents)

507 pure (S.elemAt (steps - 1) parents)

508+

509+backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp) = do

510+ trans <- transactionForId currentTid graph

511+ let parents = transactionParentIds trans

512+ if transactionTimestamp trans < stamp then

513+ pure currentTid

514+ else if S.null parents then

515+ Left RootTransactionTraversalError

516+ else

517+ let arbitraryParent = head (S.toList parents) in

518+ backtrackGraph graph arbitraryParent btrack

491

519

492-- | Create a temporary branch for commit, merge the result to head, delete the temporary branch. This is useful to atomically commit a transaction, avoiding a TransactionIsNotHeadError but trading it for a potential MergeError.

520-- | Create a temporary branch for commit, merge the result to head, delete the temporary branch. This is useful to atomically commit a transaction, avoiding a TransactionIsNotHeadError but trading it for a potential MergeError.

493--this is not a GraphOp because it combines multiple graph operations

521--this is not a GraphOp because it combines multiple graph operations

494−autoMergeToHead :: (TransactionId, TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

522+autoMergeToHead :: UTCTime -> (TransactionId, TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)

495−autoMergeToHead (tempBranchTransId, tempCommitTransId, mergeTransId) discon mergeToHeadName strat graph = do

523+autoMergeToHead stamp (tempBranchTransId, tempCommitTransId, mergeTransId) discon mergeToHeadName strat graph = do

496 let tempBranchName = "mergebranch_" <> U.toText tempBranchTransId

524 let tempBranchName = "mergebranch_" <> U.toText tempBranchTransId

497 --create the temp branch

525 --create the temp branch

498− (discon', graph') <- evalGraphOp tempBranchTransId discon graph (Branch tempBranchName)

526+ (discon', graph') <- evalGraphOp stamp tempBranchTransId discon graph (Branch tempBranchName)

499

527

500 --commit to the new branch- possible future optimization: don't require fsync for this- create a temp commit type

528 --commit to the new branch- possible future optimization: don't require fsync for this- create a temp commit type

501− (discon'', graph'') <- evalGraphOp tempCommitTransId discon' graph' Commit

529+ (discon'', graph'') <- evalGraphOp stamp tempCommitTransId discon' graph' Commit

502

530

503 --create the merge

531 --create the merge

504− (discon''', graph''') <- evalGraphOp mergeTransId discon'' graph'' (MergeTransactions strat tempBranchName mergeToHeadName)

532+ (discon''', graph''') <- evalGraphOp stamp mergeTransId discon'' graph'' (MergeTransactions strat tempBranchName mergeToHeadName)

505

533

506 --delete the temp branch

534 --delete the temp branch

507− (discon'''', graph'''') <- evalGraphOp tempBranchTransId discon''' graph''' (DeleteBranch tempBranchName)

535+ (discon'''', graph'''') <- evalGraphOp stamp tempBranchTransId discon''' graph''' (DeleteBranch tempBranchName)

508 {-

536 {-

509 let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''')

537 let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''')

510 traceShowM rel

538 traceShowM rel

src/lib/ProjectM36/TransactionGraph/Persist.hs+16−6

@@ -11,6 +11,7 @@ import System.Directory

11import System.FilePath

12import System.IO.Temp

13import System.IO

14+import Data.Time.Clock.POSIX

14import qualified Data.UUID as U

15import qualified Data.UUID as U

15import qualified Data.Set as S

16import qualified Data.Set as S

16import qualified Data.Map as M

17import qualified Data.Map as M

@@ -18,13 +19,15 @@ import qualified Data.Text as T

18import Data.Text.Encoding

19import Data.Text.Encoding

19import Control.Monad (foldM)

20import Control.Monad (foldM)

20import Data.Either (isRight)

21import Data.Either (isRight)

21−import Data.Maybe (mapMaybe)

22+import Data.Maybe (fromMaybe)

22import Control.Exception.Base

23import Control.Exception.Base

23import qualified Data.Text.IO as TIO

24import qualified Data.Text.IO as TIO

24import Data.ByteString (ByteString)

25import Data.ByteString (ByteString)

25import Data.Monoid

26import Data.Monoid

26import qualified Crypto.Hash.SHA256 as SHA256

27import qualified Crypto.Hash.SHA256 as SHA256

27import Control.Arrow

28import Control.Arrow

29+import Data.Time.Clock

30+import Data.Text.Read

29type LockFileHash = ByteString

32type LockFileHash = ByteString

@@ -144,7 +147,7 @@ transactionGraphLoad dbdir graphIn mScriptSession = do

144 let folder eitherGraph transId = case eitherGraph of

147 let folder eitherGraph transId = case eitherGraph of

145 Left err -> return $ Left err

148 Left err -> return $ Left err

146 Right graph -> readTransactionIfNecessary dbdir transId mScriptSession graph

149 Right graph -> readTransactionIfNecessary dbdir transId mScriptSession graph

147− loadedGraph <- foldM folder (Right graphIn) (map fst info)

150+ loadedGraph <- foldM folder (Right graphIn) (map (\(tid,_,_) -> tid) info)

148 case loadedGraph of

151 case loadedGraph of

149 Left err -> return $ Left err

152 Left err -> return $ Left err

150 Right freshGraph -> do

153 Right freshGraph -> do

@@ -173,18 +176,25 @@ writeGraphTransactionIdFile sync destDirectory (TransactionGraph _ transSet) = w

173 uuidInfo = T.intercalate "\n" graphLines

176 uuidInfo = T.intercalate "\n" graphLines

174 digest = SHA256.hash (encodeUtf8 uuidInfo)

177 digest = SHA256.hash (encodeUtf8 uuidInfo)

175 graphLines = S.toList $ S.map graphLine transSet

178 graphLines = S.toList $ S.map graphLine transSet

179+ epochTime = realToFrac . utcTimeToPOSIXSeconds . transactionTimestamp :: Transaction -> Double

180+ graphLine trans = U.toText (transactionId trans)

181+ <> " "

182+ <> T.pack (show (epochTime trans))

183+ <> " "

176− graphLine trans = U.toText (transactionId trans) <> " " <> T.intercalate " " (S.toList (S.map U.toText $ transactionParentIds trans))

184+ <> T.intercalate " " (S.toList (S.map U.toText $ transactionParentIds trans))

177

185

178readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash

186readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash

179readGraphTransactionIdFileDigest dbdir = do

187readGraphTransactionIdFileDigest dbdir = do

180 graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)

188 graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)

181 pure (SHA256.hash (encodeUtf8 graphTransactionIdData))

189 pure (SHA256.hash (encodeUtf8 graphTransactionIdData))

182

190

183−readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, [TransactionId])])

191+readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, UTCTime, [TransactionId])])

184readGraphTransactionIdFile dbdir = do

192readGraphTransactionIdFile dbdir = do

185 --read in all transactions' uuids

193 --read in all transactions' uuids

186− let grapher line = let tids = mapMaybe U.fromText (T.words line) in

194+ let grapher line = let tid:epochText:parentIds = T.words line in

187− (head tids, tail tids)

195+ (readUUID tid, readEpoch epochText, map readUUID parentIds)

196+ readUUID uuidText = fromMaybe (error "failed to read uuid") (U.fromText uuidText)

197+ readEpoch t = posixSecondsToUTCTime (realToFrac (either (error "failed to read epoch") fst (double t)))

188 --warning: uses lazy IO

198 --warning: uses lazy IO

189 graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)

199 graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)

190 return $ Right (map grapher $ T.lines graphTransactionIdData)

200 return $ Right (map grapher $ T.lines graphTransactionIdData)

test/TransactionGraph/Merge.hs+26−21

@@ -18,11 +18,16 @@ import qualified Data.UUID as U

18import qualified Data.Set as S

19import qualified Data.Map as M

20import Data.Maybe

21+import Data.Time.Clock

22+import Data.Time.Calendar

22import Control.Monad.State hiding (join)

24import Control.Monad.State hiding (join)

24{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

26{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

28+testTime :: UTCTime

29+testTime = UTCTime (fromGregorian 1980 01 01) (secondsToDiffTime 1000)

30+

26main :: IO ()

31main :: IO ()

27main = do

32main = do

28 tcounts <- runTestTT testList

33 tcounts <- runTestTT testList

@@ -51,14 +56,14 @@ createTrans tid info ctx = Transaction tid info (Schemas ctx M.empty)

52basicTransactionGraph :: IO TransactionGraph

57basicTransactionGraph :: IO TransactionGraph

53basicTransactionGraph = do

58basicTransactionGraph = do

54− let bsGraph = bootstrapTransactionGraph uuidRoot DBC.basicDatabaseContext

59+ let bsGraph = bootstrapTransactionGraph testTime uuidRoot DBC.basicDatabaseContext

55 rootTrans = fromMaybe (error "bonk") (transactionForHead "master" bsGraph)

60 rootTrans = fromMaybe (error "bonk") (transactionForHead "master" bsGraph)

56 uuidA = fakeUUID 10

61 uuidA = fakeUUID 10

57 uuidB = fakeUUID 11

62 uuidB = fakeUUID 11

58 uuidRoot = fakeUUID 1

63 uuidRoot = fakeUUID 1

59 rootContext = concreteDatabaseContext rootTrans

64 rootContext = concreteDatabaseContext rootTrans

60− (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo uuidRoot S.empty) rootContext) bsGraph

65+ (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo uuidRoot S.empty testTime) rootContext) bsGraph

61− (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo uuidRoot S.empty) rootContext) bsGraph'

66+ (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo uuidRoot S.empty testTime) rootContext) bsGraph'

62 pure bsGraph''

67 pure bsGraph''

64addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)

69addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)

@@ -102,7 +107,7 @@ testSubGraphToFirstAncestorSnipBranch = TestCase $ do

102 baseGraph <- basicTransactionGraph

107 baseGraph <- basicTransactionGraph

103 transA <- assertMaybe (transactionForHead "branchA" baseGraph) "failed to get branchA"

108 transA <- assertMaybe (transactionForHead "branchA" baseGraph) "failed to get branchA"

104 transB <- assertMaybe (transactionForHead "branchB" baseGraph) "failed to get branchB"

109 transB <- assertMaybe (transactionForHead "branchB" baseGraph) "failed to get branchB"

105− (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TransactionInfo (fakeUUID 1) S.empty) (concreteDatabaseContext transA)) baseGraph

110+ (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TransactionInfo (fakeUUID 1) S.empty testTime) (concreteDatabaseContext transA)) baseGraph

106 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) transA transB S.empty

111 subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) transA transB S.empty

107 assertGraph subgraph

112 assertGraph subgraph

108 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)

113 let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)

@@ -114,18 +119,18 @@ testSubGraphToFirstAncestorMoreTransactions = TestCase $ do

114 graph <- basicTransactionGraph

119 graph <- basicTransactionGraph

115 assertGraph graph

120 assertGraph graph

116

121

117− -- add another relvar to branchB

122+-- add another relvar to branchB

118 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"

123 branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"

119 (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of

124 (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of

120 (Just err, _) -> assertFailure (show err) >> undefined

125 (Just err, _) -> assertFailure (show err) >> undefined

121 (Nothing, context) -> pure context

126 (Nothing, context) -> pure context

122− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) updatedBranchBContext) graph

127+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph

123 branchBTrans' <- assertMaybe (transactionForHead "branchB" graph') "failed to get branchB head"

128 branchBTrans' <- assertMaybe (transactionForHead "branchB" graph') "failed to get branchB head"

124 assertEqual "branchB id 3" (fakeUUID 3) (transactionId branchBTrans')

129 assertEqual "branchB id 3" (fakeUUID 3) (transactionId branchBTrans')

125

130

126 -- add another transaction to branchA

131 -- add another transaction to branchA

127 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"

132 branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"

128− (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty) (concreteDatabaseContext branchATrans)) graph'

133+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) (concreteDatabaseContext branchATrans)) graph'

129 branchATrans' <- assertMaybe (transactionForHead "branchA" graph'') "failed to get branchA head"

134 branchATrans' <- assertMaybe (transactionForHead "branchA" graph'') "failed to get branchA head"

130 assertEqual "branchA id 4" (fakeUUID 4) (transactionId branchATrans')

135 assertEqual "branchA id 4" (fakeUUID 4) (transactionId branchATrans')

131

136

@@ -146,9 +151,9 @@ testSelectedBranchMerge = TestCase $ do

146 (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of

151 (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of

147 (Just err, _) -> assertFailure (show err) >> undefined

152 (Just err, _) -> assertFailure (show err) >> undefined

148 (Nothing, context) -> pure context

153 (Nothing, context) -> pure context

149− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) updatedBranchBContext) graph

154+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph

150 --create the merge transaction in the graph

155 --create the merge transaction in the graph

151− let eGraph' = mergeTransactions (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") graph'

156+ let eGraph' = mergeTransactions testTime (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") graph'

152

157

153 (_, graph'') <- assertEither eGraph'

158 (_, graph'') <- assertEither eGraph'

154

159

@@ -174,10 +179,10 @@ testUnionPreferMergeStrategy = TestCase $ do

174 branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName branchBRelVar (relationVariables (concreteDatabaseContext branchBTrans))}

179 branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName branchBRelVar (relationVariables (concreteDatabaseContext branchBTrans))}

175 conflictRelVarName = "conflictRelVar"

180 conflictRelVarName = "conflictRelVar"

176

181

177− (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchATrans) S.empty) branchAContext) graph

182+ (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchATrans) S.empty testTime) branchAContext) graph

178− (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchBTrans) S.empty) branchBContext) graph'

183+ (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchBTrans) S.empty testTime) branchBContext) graph'

179 -- validate that the conflict is hidden because we preferred a branch

184 -- validate that the conflict is hidden because we preferred a branch

180− let merged = mergeTransactions (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB") graph''

185+ let merged = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB") graph''

181 case merged of

186 case merged of

182 Left err -> assertFailure ("expected merge success: " ++ show err)

187 Left err -> assertFailure ("expected merge success: " ++ show err)

183 Right (discon, _) ->

188 Right (discon, _) ->

@@ -200,11 +205,11 @@ testUnionMergeStrategy = TestCase $ do

200 branchAOnlyIncDepName = "branchAOnlyIncDep"

205 branchAOnlyIncDepName = "branchAOnlyIncDep"

201 branchBOnlyRelVarName = "branchBOnlyRelVar"

206 branchBOnlyRelVarName = "branchBOnlyRelVar"

202 branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue)

207 branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue)

203− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) updatedBranchBContext) graph

208+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph

204− (discon, _) <- assertEither $ mergeTransactions (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB") graph'

209+ (discon, _) <- assertEither $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB") graph'

205 assertEqual "branchBOnlyRelVar should appear in the merge" (M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))) (Just relationTrue)

210 assertEqual "branchBOnlyRelVar should appear in the merge" (M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))) (Just relationTrue)

206− (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty) updatedBranchAContext) graph'

211+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) updatedBranchAContext) graph'

207− let eMergeGraph = mergeTransactions (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''

212+ let eMergeGraph = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''

208 case eMergeGraph of

213 case eMergeGraph of

209 Left err -> assertFailure ("expected merge success: " ++ show err)

214 Left err -> assertFailure ("expected merge success: " ++ show err)

210 Right (_, mergeGraph) -> do

215 Right (_, mergeGraph) -> do

@@ -219,8 +224,8 @@ testUnionMergeStrategy = TestCase $ do

219 conflictRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []

224 conflictRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []

220 let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName conflictRelVar (relationVariables updatedBranchAContext) }

225 let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName conflictRelVar (relationVariables updatedBranchAContext) }

221 conflictBranchATrans <- assertMaybe (transactionForHead "branchA" graph'') "retrieving head transaction for expected conflict"

226 conflictBranchATrans <- assertMaybe (transactionForHead "branchA" graph'') "retrieving head transaction for expected conflict"

222− (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TransactionInfo (transactionId conflictBranchATrans) S.empty) conflictContextA) graph''

227+ (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TransactionInfo (transactionId conflictBranchATrans) S.empty testTime) conflictContextA) graph''

223− let failingMerge = mergeTransactions (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph'''

228+ let failingMerge = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph'''

224 case failingMerge of

229 case failingMerge of

225 Right _ -> assertFailure "expected merge failure"

230 Right _ -> assertFailure "expected merge failure"

226 Left err -> assertEqual "merge failure" err (MergeTransactionError StrategyViolatesRelationVariableMergeError)

231 Left err -> assertEqual "merge failure" err (MergeTransactionError StrategyViolatesRelationVariableMergeError)

@@ -247,12 +252,12 @@ testUnionMergeIncDepViolation = TestCase $ do

247

252

248

253

249 --add the rv in new commits to both branches

254 --add the rv in new commits to both branches

250− (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) branchBContext) graph

255+ (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) branchBContext) graph

251

256

252− (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty) branchAContext) graph'

257+ (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) branchAContext) graph'

253

258

254 --check that the union merge fails due to a violated constraint

259 --check that the union merge fails due to a violated constraint

255− let eMerge = mergeTransactions (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''

260+ let eMerge = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''

256 case eMerge of

261 case eMerge of

257 Left (InclusionDependencyCheckError incDepName') -> assertEqual "incdep violation name" incDepName incDepName'

262 Left (InclusionDependencyCheckError incDepName') -> assertEqual "incdep violation name" incDepName incDepName'

258 Left err -> assertFailure ("other error: " ++ show err)

263 Left err -> assertFailure ("other error: " ++ show err)

test/TransactionGraph/Persist.hs+6−3

@@ -15,6 +15,7 @@ import System.FilePath

15import TutorialD.Interpreter.DatabaseContextExpr

16import qualified Data.Map as M

17import qualified Data.Set as S

18+import Data.Time.Clock

19main :: IO ()

20main :: IO ()

20main = do

21main = do

@@ -31,7 +32,8 @@ testBootstrapDB :: Test

31testBootstrapDB = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do

32testBootstrapDB = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do

32 let dbdir = tempdir </> "dbdir"

33 let dbdir = tempdir </> "dbdir"

33 freshId <- nextRandom

34 freshId <- nextRandom

35+ stamp <- getCurrentTime

34− _ <- bootstrapDatabaseDir NoDiskSync dbdir (bootstrapTransactionGraph freshId dateExamples)

36+ _ <- bootstrapDatabaseDir NoDiskSync dbdir (bootstrapTransactionGraph stamp freshId dateExamples)

35 loadedGraph <- transactionGraphLoad dbdir emptyTransactionGraph Nothing

37 loadedGraph <- transactionGraphLoad dbdir emptyTransactionGraph Nothing

36 assertBool "transactionGraphLoad" $ isRight loadedGraph

38 assertBool "transactionGraphLoad" $ isRight loadedGraph

@@ -40,7 +42,8 @@ testDBSimplePersistence :: Test

40testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do

42testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do

41 let dbdir = tempdir </> "dbdir"

43 let dbdir = tempdir </> "dbdir"

42 freshId <- nextRandom

44 freshId <- nextRandom

45+ stamp <- getCurrentTime

43− let graph = bootstrapTransactionGraph freshId dateExamples

46+ let graph = bootstrapTransactionGraph stamp freshId dateExamples

44 _ <- bootstrapDatabaseDir NoDiskSync dbdir graph

47 _ <- bootstrapDatabaseDir NoDiskSync dbdir graph

45 case transactionForHead "master" graph of

48 case transactionForHead "master" graph of

46 Nothing -> assertFailure "Failed to retrieve head transaction for master branch."

49 Nothing -> assertFailure "Failed to retrieve head transaction for master branch."

@@ -50,7 +53,7 @@ testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp

50 Right context' -> do

53 Right context' -> do

51 freshId' <- nextRandom

54 freshId' <- nextRandom

52 let newdiscon = DisconnectedTransaction (transactionId headTrans) (Schemas context' M.empty) True

55 let newdiscon = DisconnectedTransaction (transactionId headTrans) (Schemas context' M.empty) True

53− addTrans = addDisconnectedTransaction freshId' "master" newdiscon graph

56+ addTrans = addDisconnectedTransaction stamp freshId' "master" newdiscon graph

54 --add a transaction to the graph

57 --add a transaction to the graph

55 case addTrans of

58 case addTrans of

56 Left err -> assertFailure (show err)

59 Left err -> assertFailure (show err)

test/TutorialD/Interpreter.hs+8−2

@@ -318,6 +318,13 @@ testTransGraphRelationalExpr = TestCase $ do

318 let testBranchBacktrack = TransactionIdHeadNameLookup "testbranch" [TransactionIdHeadParentBacktrack 1]

319 backtrackRel <- executeTransGraphRelationalExpr sessionId dbconn (Equals (RelationVariable "s" testBranchBacktrack) (RelationVariable "s" masterMarker))

320 assertEqual "backtrack to master" (Right relationTrue) backtrackRel

321+

322+ --test walkback to time (stay in current location)

323+ now <- getCurrentTime

324+ headId <- headTransactionId sessionId dbconn

325+ _ <- executeGraphExpr sessionId dbconn (WalkBackToTime now)

326+ headId' <- headTransactionId sessionId dbconn

327+ assertEqual "transaction walk back stays in place" headId headId'

321

328

322 --test branch deletion

329 --test branch deletion

323 mapM_ (executeTutorialD sessionId dbconn) [

330 mapM_ (executeTutorialD sessionId dbconn) [

@@ -329,8 +336,7 @@ testTransGraphRelationalExpr = TestCase $ do

329 case eEvald of

336 case eEvald of

330 DisplayErrorResult err -> assertEqual "testbranch deletion" (show (NoSuchHeadNameError "testbranch")) (unpack err)

337 DisplayErrorResult err -> assertEqual "testbranch deletion" (show (NoSuchHeadNameError "testbranch")) (unpack err)

331 _ -> assertFailure "failed to delete branch"

338 _ -> assertFailure "failed to delete branch"

332−

339+

333−

334testMultiAttributeRename :: Test

340testMultiAttributeRename :: Test

335testMultiAttributeRename = TestCase $ assertTutdEqual dateExamples renamedRel "x:=s rename {city as town, status as price} where false"

341testMultiAttributeRename = TestCase $ assertTutdEqual dateExamples renamedRel "x:=s rename {city as town, status as price} where false"

336 where

342 where