59a15ae · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP automerge

-work on refactoring Client.commit code to separate out STM component

commit59a15ae5f2d22e556be2e48e89d924fde8fbcfae authorAgentM <agentm@themactionfaction.com> dateTue 25 Jul 2017, 11:29 (9 years ago) parenta2d81ee

7 files changed+79−6

compare with master

unifiedsplit

src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs+1−1 src/lib/ProjectM36/Client.hs+36−1 src/lib/ProjectM36/Server.hs+2 src/lib/ProjectM36/Server/EntryPoints.hs+10 src/lib/ProjectM36/Server/RemoteCallTypes.hs+5−1 src/lib/ProjectM36/TransactionGraph.hs+1−3 test/TransactionGraph/Automerge.hs+24

src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs+1−1

@@ -34,7 +34,7 @@ deleteBranchP = do

3434commitTransactionP :: Parser TransactionGraphOperator

3535commitTransactionP = do

3636 reservedOp ":commit"

37− return $ Commit ForbidEmptyCommitOption

37+ pure Commit

3838

3939rollbackTransactionP :: Parser TransactionGraphOperator

4040rollbackTransactionP = do

src/lib/ProjectM36/Client.hs+36−1

@@ -27,6 +27,7 @@ module ProjectM36.Client

2727 setCurrentSchemaName,

2828 transactionGraphAsRelation,

2929 relationVariablesAsRelation,

30+ disconnectedTransactionIsDirty,

3031 headName,

3132 remoteDBLookupName,

3233 defaultServerPort,

@@ -49,6 +50,7 @@ module ProjectM36.Client

4950 callTestTimeout_,

5051 RelationCardinality(..),

5152 TransactionGraphOperator(..),

53+ ProjectM36.Client.autoMergeToHead,

5254 transactionGraph_,

5355 disconnectedTransaction_,

5456 TransGraphRelationalExpr,

@@ -96,6 +98,7 @@ import Control.Monad.State

9698import Control.Monad.Trans.Reader

9799import qualified ProjectM36.RelationalExpression as RE

98100import ProjectM36.DatabaseContext (basicDatabaseContext)

101+import qualified ProjectM36.TransactionGraph as Graph

99102import ProjectM36.TransactionGraph

100103import qualified ProjectM36.Transaction as Trans

101104import ProjectM36.TransactionGraph.Persist

@@ -556,9 +559,30 @@ executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excMaybe

556559 newSession = Session newDiscon (Sess.schemaName session)

557560 STMMap.insert newSession sessionId sessions

558561 pure Nothing

559−

560562executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)

561563

564+-- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing).

565+autoMergeToHead :: SessionId -> Connection -> MergeStrategy -> HeadName -> IO (Either RelationalError ())

566+autoMergeToHead sessionId (InProcessConnection conf) strat headName' = do

567+ let sessions = ipSessions conf

568+ tvar = ipTransactionGraph conf

569+ id1 <- nextRandom

570+ id2 <- nextRandom

571+ atomically $ do

572+ eSession <- sessionForSessionId sessionId sessions

573+ case eSession of

574+ Left err -> pure (Left err)

575+ Right session -> do

576+ graph <- readTVar tvar

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

578+ Left err -> pure (Left err)

579+ Right (discon', graph') -> do

580+ writeTVar tvar graph'

581+ let newSession = Session discon' (Sess.schemaName session)

582+ STMMap.insert newSession sessionId sessions

583+ execute

584+autoMergeToHead sessionId conn@(RemoteProcessConnection _) strat headName' = remoteCall conn (ExecuteAutoMergeToHead sessionId strat headName')

585+

562586-- | Execute a database context IO-monad-based expression for the given session and connection. `DatabaseContextIOExpr` modify the DatabaseContext but cannot be purely implemented.

563587--this is almost completely identical to executeDatabaseContextExpr above

564588executeDatabaseContextIOExpr :: SessionId -> Connection -> DatabaseContextIOExpr -> IO (Maybe RelationalError)

@@ -865,6 +889,17 @@ atomTypesAsRelation sessionId (InProcessConnection conf) = do

865889 Left err -> pure (Left err)

866890 Right rel -> pure (Right rel)

867891atomTypesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveAtomTypesAsRelation sessionId)

892+

893+disconnectedTransactionIsDirty :: SessionId -> Connection -> IO (Either RelationalError Bool)

894+disconnectedTransactionIsDirty sessionId (InProcessConnection conf) = do

895+ let sessions = ipSessions conf

896+ atomically $ do

897+ eSession <- sessionForSessionId sessionId sessions

898+ case eSession of

899+ Left err -> pure (Left err)

900+ Right session -> do

901+ pure (Right (isDirty session))

902+disconnectedTransactionIsDirty sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveSessionIsDirty sessionId)

868903

869904--used only for testing- we expect this to throw an exception

870905callTestTimeout_ :: SessionId -> Connection -> IO Bool

src/lib/ProjectM36/Server.hs+2

@@ -40,6 +40,8 @@ serverDefinition testBool ti = defaultProcess {

4040 handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn),

4141 handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),

4242 handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),

43+ handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn),

44+ handleCall (\conn (ExecuteAutoMergeToHead sessionId strat headName') -> handleExecuteAutoMergeToHead ti sessionId conn strat headName'),

4345 handleCall (\conn Logout -> handleLogout ti conn)

4446 ] ++ testModeHandlers,

4547 unhandledMessagePolicy = Terminate

src/lib/ProjectM36/Server/EntryPoints.hs+10

@@ -140,5 +140,15 @@ handleTestTimeout ti _ conn = do

140140 ret <- timeoutOrDie ti (threadDelay 100000 >> pure True)

141141 reply ret conn

142142

143+handleRetrieveSessionIsDirty :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Bool)

144+handleRetrieveSessionIsDirty ti sessionId conn = do

145+ ret <- timeoutOrDie ti (disconnectedTransactionIsDirty sessionId conn)

146+ reply ret conn

147+

148+handleExecuteAutoMergeToHead :: Timeout -> SessionId -> Connection -> MergeStrategy -> HeadName -> Reply (Either RelationalError ())

149+handleExecuteAutoMergeToHead ti sessionId conn strat headName' = do

150+ ret <- timeoutOrDie ti (autoMergeToHead sessionId conn strat headName')

151+ reply ret conn

152+

143153

144154

src/lib/ProjectM36/Server/RemoteCallTypes.hs+5−1

@@ -54,4 +54,8 @@ data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId

5454data RetrieveCurrentSchemaName = RetrieveCurrentSchemaName SessionId

5555 deriving (Binary, Generic)

5656data TestTimeout = TestTimeout SessionId

57− deriving (Binary, Generic)

57+ deriving (Binary, Generic)

58+data RetrieveSessionIsDirty = RetrieveSessionIsDirty SessionId

59+ deriving (Binary, Generic)

60+data ExecuteAutoMergeToHead = ExecuteAutoMergeToHead SessionId MergeStrategy HeadName

61+ deriving (Binary, Generic)

src/lib/ProjectM36/TransactionGraph.hs+1−3

@@ -29,9 +29,6 @@ data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- git

2929 TransactionIdHeadBranchBacktrack Int -- git ^: walk back one parent level to the nth arbitrarily-chosen parent

3030 deriving (Show, Eq, Binary, Generic)

3131

32−data MergeCommitOption = NoMergeCommitOption | --no special handling

33− AutoMergeToHeadCommitOption -- branch, merge to current branch, commit- all-in-one in order to take advantage of atomic STM

34−

3532--operators which manipulate a transaction graph

3633data TransactionGraphOperator = JumpToHead HeadName |

3734 JumpToTransaction TransactionId |

@@ -481,6 +478,7 @@ backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do

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

482479

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

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

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

485483autoMergeToHead (tempTransId, newCommitTransId) discon mergeToHeadName strat graph = do

486484 let tempBranchName = "mergebranch_" <> U.toText tempTransId

test/TransactionGraph/Automerge.hsnew file+24

@@ -0,0 +1,24 @@

1+import Test.HUnit

2+import ProjectM36.Client

3+import TutorialD.Interpreter.TestBase

4+import Data.UUID.V4 (nextRandom)

6+import System.Exit

8+main :: IO ()

9+main = do

10+ tcounts <- runTestTT testList

11+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

12+

13+testList :: Test

14+testList = TestList [testAutomergeSuccess,

15+ testAutomergeFailure]

16+

17+testAutomergeSuccess :: Test

18+testAutomergeFailure = TestCase $ do

19+ (sessionId, conn) <- dateExamplesConnection

20+ sessionPastId <- createSessionAtHead "master"

21+ executeTutorialD sessionId conn "insert s relation{tuple{city \"New City\", s# "S6", sname "Samuels", status 50}}"

22+ commit sessionId conn

23+

24+