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

git.iko.soy/project-m36

add commit timestamps

the timestamp is from the start of the transaction creation, not when it is committed (a few milliseconds later typically)- this is identical to postgresql's now() stamp resolves #123

commit2aba32aafbf535e7a6bd3c7f380027b19f4f1855 authorAgentM <agentm@themactionfaction.com> dateThu 10 Aug 2017, 12:57 (9 years ago) parentdeb38d8

13 files changed+214−99

compare with master

unifiedsplit

docs/transaction_graph_operators.markdown+40−4 project-m36.cabal+2−2 src/bin/TutorialD/Interpreter/Base.hs+14−3 src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs+2−1 src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs+6 src/lib/ProjectM36/Base.hs+2−2 src/lib/ProjectM36/Client.hs+7−3 src/lib/ProjectM36/Transaction.hs+13−8 src/lib/ProjectM36/TransactionGraph.hs+72−44 src/lib/ProjectM36/TransactionGraph/Persist.hs+16−6 test/TransactionGraph/Merge.hs+26−21 test/TransactionGraph/Persist.hs+6−3 test/TutorialD/Interpreter.hs+8−2

docs/transaction_graph_operators.markdown+40−4

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

5656

5757```

5858TutorialD (master/main): :showgraph

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

60−│current│head │id │parents│

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

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

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

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

62+

6263<big result elided>

6364```

6465The "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.

6566

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.

6768

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

6970

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

7172

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

7274

7375#### Branch

7476

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

109111```

110112

111113Note 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

298298 type: exitcode-stdio-1.0

299299 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

300300 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

302302 GHC-Options: -Wall

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

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

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

309309 type: exitcode-stdio-1.0

310310 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

311311 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

313313 GHC-Options: -Wall

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

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

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

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

11{-# LANGUAGE DeriveGeneric, CPP #-}

22module TutorialD.Interpreter.Base where

3+import ProjectM36.Base

4+import ProjectM36.AtomType

5+import ProjectM36.Relation

37import Text.Megaparsec

48import Text.Megaparsec.Text

59import qualified Text.Megaparsec.Lexer as Lex

6−import ProjectM36.Base

7−import ProjectM36.AtomType

810import Data.Text hiding (count)

911import System.Random

1012import qualified Data.Text as T

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

1719import Data.Monoid

1820import Control.Monad (void)

1921import qualified Data.UUID as U

20−import ProjectM36.Relation

2122import Control.Monad.Random

2223import Data.List.NonEmpty as NE

24+import Data.Time.Clock

25+import Data.Time.Format

2326

2427displayOpResult :: TutorialDOperatorResult -> IO ()

2528displayOpResult QuitResult = return ()

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

155158 case U.fromString uuidStr of

156159 Nothing -> fail "Invalid uuid string"

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

2525

2626transactionIdHeadBacktrackP :: Parser TransactionIdHeadBacktrack

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

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

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

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

2930

3031backtrackP :: Parser Int

3132backtrackP = do

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

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

1919 reservedOp ":jump"

2020 uuid <- uuidP

2121 return $ JumpToTransaction uuid

22+

23+walkBackToTimeP :: Parser TransactionGraphOperator

24+walkBackToTimeP = do

25+ reservedOp ":walkbacktotime"

26+ WalkBackToTime <$> utcTimeP

2227

2328branchTransactionP :: Parser TransactionGraphOperator

2429branchTransactionP = do

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

6974transactionGraphOpP =

7075 jumpToHeadP

7176 <|> jumpToTransactionP

77+ <|> walkBackToTimeP

7278 <|> branchTransactionP

7379 <|> deleteBranchP

7480 <|> commitTransactionP

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

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

362362transactionHeadsForGraph (TransactionGraph heads _) = heads

363363

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

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

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

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

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

367367 deriving(Show, Generic)

368368

369369instance Binary TransactionInfo

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

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

144144import GHC.Generics (Generic)

145145import Control.DeepSeq (force)

146146import System.IO

147+import Data.Time.Clock

147148

148149type Hostname = String

149150

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

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

284285connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths) = do

285286 freshId <- nextRandom

287+ stamp <- getCurrentTime

286288 let bootstrapContext = basicDatabaseContext

287− freshGraph = bootstrapTransactionGraph freshId bootstrapContext

289+ freshGraph = bootstrapTransactionGraph stamp freshId bootstrapContext

288290 case strat of

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

290292 NoPersistence -> do

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

571573 id1 <- nextRandom

572574 id2 <- nextRandom

573575 id3 <- nextRandom

576+ stamp <- getCurrentTime

574577 commitLock_ sessionId conf $ \graph -> do

575578 eSession <- sessionForSessionId sessionId sessions

576579 case eSession of

577580 Left err -> pure (Left err)

578581 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

580583 Left err -> pure (Left err)

581584 Right (discon', graph') ->

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

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

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

637640 let sessions = ipSessions conf

638641 freshId <- nextRandom

642+ stamp <- getCurrentTime

639643 commitLock_ sessionId conf $ \updatedGraph -> do

640644 eSession <- sessionForSessionId sessionId sessions

641645 case eSession of

642646 Left err -> pure (Left err)

643647 Right session -> do

644648 let discon = Sess.disconnectedTransaction session

645− case evalGraphOp freshId discon updatedGraph graphExpr of

649+ case evalGraphOp stamp freshId discon updatedGraph graphExpr of

646650 Left err -> pure (Left err)

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

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

22import ProjectM36.Base

33import qualified Data.Set as S

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

510

611transactionParentIds :: Transaction -> S.Set TransactionId

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

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

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

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

914

1015transactionChildIds :: Transaction -> S.Set TransactionId

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

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

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

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

1318

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

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

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

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

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

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

1823

1924-- | 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.

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

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

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

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

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

2328

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

2530filterParent 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

77import ProjectM36.TupleSet

88import ProjectM36.Tuple

99import ProjectM36.RelationalExpression

10+import ProjectM36.TransactionGraph.Merge

11+import qualified ProjectM36.DisconnectedTransaction as Discon

12+

1013import qualified Data.Vector as V

1114import qualified ProjectM36.Attribute as A

1215import qualified Data.UUID as U

1316import qualified Data.Set as S

1417import qualified Data.Map as M

1518import Control.Monad

19+import Data.Time.Clock

1620import qualified Data.Text as T

1721import GHC.Generics

1822import Data.Binary

19−import ProjectM36.TransactionGraph.Merge

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

2124import Data.Monoid

2225import Control.Arrow

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

3538

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

3740data 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

3943 deriving (Show, Eq, Binary, Generic)

4044

4145

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

4347data TransactionGraphOperator = JumpToHead HeadName |

4448 JumpToTransaction TransactionId |

49+ WalkBackToTime UTCTime |

4550 Branch HeadName |

4651 DeleteBranch HeadName |

4752 MergeTransactions MergeStrategy HeadName HeadName |

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

5661data ROTransactionGraphOperator = ShowGraph

5762 deriving Show

5863

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

60−bootstrapTransactionGraph freshId context = TransactionGraph bootstrapHeads bootstrapTransactions

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

65+bootstrapTransactionGraph stamp freshId context = TransactionGraph bootstrapHeads bootstrapTransactions

6166 where

6267 bootstrapHeads = M.singleton "master" freshTransaction

6368 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

6570 bootstrapTransactions = S.singleton freshTransaction

6671

6772emptyTransactionGraph :: TransactionGraph

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

98103 return (S.fromList transList)

99104

100105isRootTransaction :: Transaction -> TransactionGraph -> Bool

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

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

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

103108

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

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

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

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

107112 trans <- transactionForId pId graph

108113 return (S.singleton trans)

109114

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

111116

112117

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

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

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

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

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

116121

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

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

120−addBranch newId newBranchName branchPointId graph = do

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

125+addBranch stamp newId newBranchName branchPointId graph = do

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

123128 addTransactionToGraph newBranchName newTrans graph

124129

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

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

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

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

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

128133

129134

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

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

201206

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

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

205210

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

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

207212 Left err -> Left err

208213 Right parentTrans -> Right (newTrans, graph)

209214 where

210215 newTrans = DisconnectedTransaction jumpId (schemas parentTrans) False

211216

212217-- switch from one head to another

213−evalGraphOp _ _ graph (JumpToHead headName) =

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

214219 case transactionForHead headName graph of

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

216221 Right (disconnectedTrans, graph)

217222 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+

218233-- add new head pointing to branchPoint

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

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

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

230245

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

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

234249 let newDiscon = DisconnectedTransaction newId schemas' False

235− case addBranch newId newBranchName parentId graph of

250+ case addBranch stamp newId newBranchName parentId graph of

236251 Left err -> Left err

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

238253

239254-- add the disconnected transaction to the graph

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

242257 Left err -> Left err

243258 Right parentTransaction -> case headNameForTransaction parentTransaction graph of

244259 Nothing -> Left $ TransactionIsNotAHeadError parentId

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

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

248263 where

249264 newDisconnectedTrans = DisconnectedTransaction newTransId schemas' False

250− maybeUpdatedGraph = addDisconnectedTransaction newTransId headName discon graph

265+ maybeUpdatedGraph = addDisconnectedTransaction stamp newTransId headName discon graph

251266

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

254269 Left err -> Left err

255270 Right parentTransaction -> Right (newDiscon, graph)

256271 where

257272 newDiscon = DisconnectedTransaction parentId (schemas parentTransaction) False

258273

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

260275

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

262277 Nothing -> Left (NoSuchHeadNameError branchName)

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

264279

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

269284 mkRelationFromList attrs tupleMatrix

270285 where

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

287+ Attribute "stamp" DateTimeAtomType,

272288 Attribute "parents" (RelationAtomType parentAttributes),

273289 Attribute "current" BoolAtomType,

274290 Attribute "head" TextAtomType

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

277293 tupleGenerator transaction = case transactionParentsRelation transaction graph of

278294 Left err -> Left err

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

296+ DateTimeAtom (transactionTimestamp transaction),

280297 RelationAtom parentTransRel,

281298 BoolAtom $ parentId == transactionId transaction,

282299 TextAtom $ fromMaybe "" (headNameForTransaction transaction graph)

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

303320-}

304321

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

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

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

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

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

310327

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

313330

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

316333

317334-- | 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.

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

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

352369 else -- we found a path

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

354371 where

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

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

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

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

357374

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

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

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

376393 else --we have some paths!

377394 Right (S.unions paths)

378395

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

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

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

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

381398 let transactionForHeadErr name = case transactionForHead name graph of

382399 Nothing -> Left (NoSuchHeadNameError name)

383400 Just t -> Right t

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

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

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

389406 subGraph' <- filterSubGraph subGraph subHeads

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

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

391408 Left err -> Left (MergeTransactionError err)

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

393410 Just err -> Left err

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

423440 newHeads = M.map (filterTransaction validIds) heads

424441

425442--helper function for commonalities in union merge

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

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

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

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

428445 let contextA = concreteDatabaseContext t1

429446 contextB = concreteDatabaseContext t2

430447

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

452469 typeConstructorMapping = types

453470 }

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

456473

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

458475lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph

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

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

489506 else

490507 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

491519

492520-- | 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.

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

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

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

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

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

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

497525 --create the temp branch

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

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

499527

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

502530

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

505533

506534 --delete the temp branch

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

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

508536 {-

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

510538 traceShowM rel

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

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

1111import System.FilePath

1212import System.IO.Temp

1313import System.IO

14+import Data.Time.Clock.POSIX

1415import qualified Data.UUID as U

1516import qualified Data.Set as S

1617import qualified Data.Map as M

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

1819import Data.Text.Encoding

1920import Control.Monad (foldM)

2021import Data.Either (isRight)

21−import Data.Maybe (mapMaybe)

22+import Data.Maybe (fromMaybe)

2223import Control.Exception.Base

2324import qualified Data.Text.IO as TIO

2425import Data.ByteString (ByteString)

2526import Data.Monoid

2627import qualified Crypto.Hash.SHA256 as SHA256

2728import Control.Arrow

29+import Data.Time.Clock

30+import Data.Text.Read

2831

2932type LockFileHash = ByteString

3033

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

144147 let folder eitherGraph transId = case eitherGraph of

145148 Left err -> return $ Left err

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

148151 case loadedGraph of

149152 Left err -> return $ Left err

150153 Right freshGraph -> do

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

173176 uuidInfo = T.intercalate "\n" graphLines

174177 digest = SHA256.hash (encodeUtf8 uuidInfo)

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

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

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

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

181+ <> " "

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

183+ <> " "

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

177185

178186readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash

179187readGraphTransactionIdFileDigest dbdir = do

180188 graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)

181189 pure (SHA256.hash (encodeUtf8 graphTransactionIdData))

182190

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

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

184192readGraphTransactionIdFile dbdir = do

185193 --read in all transactions' uuids

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

187− (head tids, tail tids)

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

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

188198 --warning: uses lazy IO

189199 graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)

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

test/TransactionGraph/Merge.hs+26−21

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

1818import qualified Data.Set as S

1919import qualified Data.Map as M

2020import Data.Maybe

21+import Data.Time.Clock

22+import Data.Time.Calendar

2123

2224import Control.Monad.State hiding (join)

2325

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

2527

28+testTime :: UTCTime

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

30+

2631main :: IO ()

2732main = do

2833 tcounts <- runTestTT testList

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

5156

5257basicTransactionGraph :: IO TransactionGraph

5358basicTransactionGraph = do

54− let bsGraph = bootstrapTransactionGraph uuidRoot DBC.basicDatabaseContext

59+ let bsGraph = bootstrapTransactionGraph testTime uuidRoot DBC.basicDatabaseContext

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

5661 uuidA = fakeUUID 10

5762 uuidB = fakeUUID 11

5863 uuidRoot = fakeUUID 1

5964 rootContext = concreteDatabaseContext rootTrans

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

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

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

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

6267 pure bsGraph''

6368

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

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

102107 baseGraph <- basicTransactionGraph

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

104109 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

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

107112 assertGraph subgraph

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

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

114119 graph <- basicTransactionGraph

115120 assertGraph graph

116121

117− -- add another relvar to branchB

122+-- add another relvar to branchB

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

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

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

121126 (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

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

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

125130

126131 -- add another transaction to branchA

127132 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'

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

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

131136

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

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

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

148153 (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

150155 --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'

152157

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

154159

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

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

175180 conflictRelVarName = "conflictRelVar"

176181

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

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

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

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

179184 -- 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''

181186 case merged of

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

183188 Right (discon, _) ->

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

200205 branchAOnlyIncDepName = "branchAOnlyIncDep"

201206 branchBOnlyRelVarName = "branchBOnlyRelVar"

202207 branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue)

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

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

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

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

205210 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'

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

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

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

208213 case eMergeGraph of

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

210215 Right (_, mergeGraph) -> do

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

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

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

221226 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''

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

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

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

224229 case failingMerge of

225230 Right _ -> assertFailure "expected merge failure"

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

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

247252

248253

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

251256

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'

253258

254259 --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''

256261 case eMerge of

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

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

test/TransactionGraph/Persist.hs+6−3

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

1515import TutorialD.Interpreter.DatabaseContextExpr

1616import qualified Data.Map as M

1717import qualified Data.Set as S

18+import Data.Time.Clock

1819

1920main :: IO ()

2021main = do

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

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

3233 let dbdir = tempdir </> "dbdir"

3334 freshId <- nextRandom

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

35+ stamp <- getCurrentTime

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

3537 loadedGraph <- transactionGraphLoad dbdir emptyTransactionGraph Nothing

3638 assertBool "transactionGraphLoad" $ isRight loadedGraph

3739

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

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

4143 let dbdir = tempdir </> "dbdir"

4244 freshId <- nextRandom

43− let graph = bootstrapTransactionGraph freshId dateExamples

45+ stamp <- getCurrentTime

46+ let graph = bootstrapTransactionGraph stamp freshId dateExamples

4447 _ <- bootstrapDatabaseDir NoDiskSync dbdir graph

4548 case transactionForHead "master" graph of

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

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

5053 Right context' -> do

5154 freshId' <- nextRandom

5255 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

5457 --add a transaction to the graph

5558 case addTrans of

5659 Left err -> assertFailure (show err)

test/TutorialD/Interpreter.hs+8−2

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

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

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

320320 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'

321328

322329 --test branch deletion

323330 mapM_ (executeTutorialD sessionId dbconn) [

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

329336 case eEvald of

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

331338 _ -> assertFailure "failed to delete branch"

332−

333−

339+

334340testMultiAttributeRename :: Test

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

336342 where