64ed2f0 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

Merge branch '176_simple_client_update'

64ed2f0AgentM9 years ago

src/lib/ProjectM36/Client.hs+16−6

compare with master

unifiedsplit

@@ -582,7 +582,7 @@ executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excEither

582 pure (Right ())

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

584

585−-- | 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).

585+-- | 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). Alternatively, as an optimization, if a simple commit is possible (meaning that the head has not changed), then a fast-forward commit takes place instead.

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

587autoMergeToHead sessionId (InProcessConnection conf) strat headName' = do

588 let sessions = ipSessions conf

@@ -594,11 +594,21 @@ autoMergeToHead sessionId (InProcessConnection conf) strat headName' = do

594 eSession <- sessionForSessionId sessionId sessions

595 case eSession of

596 Left err -> pure (Left err)

597− Right session ->

597+ Right session ->

598+ case Graph.transactionForHead headName' graph of

599+ Nothing -> pure (Left (NoSuchHeadNameError headName'))

600+ Just headTrans -> do

601+ --attempt fast-forward commit, if possible

602+ let graphInfo = if Sess.parentId session == transactionId headTrans then do

603+ ret <- Graph.evalGraphOp stamp id1 (Sess.disconnectedTransaction session) graph Commit

604+ pure (ret, [id1])

605+ else do

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

606+ ret <- Graph.autoMergeToHead stamp (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph

607+ pure (ret, [id1,id2,id3])

608+ case graphInfo of

599− Left err -> pure (Left err)

609+ Left err -> pure (Left err)

600− Right (discon', graph') ->

610+ Right ((discon', graph'), transactionIdsAdded) ->

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

611+ pure (Right (discon', graph', transactionIdsAdded))

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

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

603

613

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

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

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

@@ -72,7 +72,7 @@ close (_ , conn) = C.close conn

72withTransaction :: DbConn -> Db a -> IO (Either DbError a)

73withTransaction sessconn = withTransactionUsing sessconn UnionMergeStrategy

75−-- | Same a 'withTransaction' except that the merge strategy can be specified.

75+-- | Same as 'withTransaction' except that the merge strategy can be specified.

76withTransactionUsing :: DbConn -> MergeStrategy -> Db a -> IO (Either DbError a)

77withTransactionUsing (sess, conn) strat dbm = do

78 eHeadName <- C.headName sess conn

test/Client/Simple.hs+14−8

@@ -3,11 +3,14 @@ import Test.HUnit

3import System.Exit

4import ProjectM36.Relation

5import qualified ProjectM36.Client as C

6+import ProjectM36.DateExamples

7+import ProjectM36.DatabaseContext

6import System.IO.Temp

8import System.IO.Temp

7import System.FilePath

9import System.FilePath

8import ProjectM36.TupleSet

10import ProjectM36.TupleSet

9import ProjectM36.Attribute

11import ProjectM36.Attribute

10import qualified Data.Vector as V

12import qualified Data.Vector as V

13+import qualified Data.Map as M

12main :: IO ()

15main :: IO ()

13main = do

16main = do

@@ -15,7 +18,7 @@ main = do

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

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

17testList :: Test

20testList :: Test

18−testList = TestList [testSimpleCommitSuccess, testSimpleCommitFailure]

21+testList = TestList [testSimpleCommitSuccess, testSimpleCommitFailure, testSimpleUpdate]

20assertEither :: (Show a) => IO (Either a b) -> IO b

23assertEither :: (Show a) => IO (Either a b) -> IO b

21assertEither x = do

24assertEither x = do

@@ -45,6 +48,7 @@ testSimpleCommitSuccess = TestCase $

45 eRes <- C.executeRelationalExpr sess conn relExpr

48 eRes <- C.executeRelationalExpr sess conn relExpr

46 assertEqual "x and y" (Right relationTrue) eRes

49 assertEqual "x and y" (Right relationTrue) eRes

51+

48testSimpleCommitFailure :: Test

52testSimpleCommitFailure :: Test

49testSimpleCommitFailure = TestCase $ do

53testSimpleCommitFailure = TestCase $ do

50 let failAttrs = attributesFromList [Attribute "fail" IntAtomType]

54 let failAttrs = attributesFromList [Attribute "fail" IntAtomType]

@@ -57,11 +61,13 @@ testSimpleCommitFailure = TestCase $ do

57 execute $ Assign "x" (MakeStaticRelation failAttrs emptyTupleSet)

61 execute $ Assign "x" (MakeStaticRelation failAttrs emptyTupleSet)

58 let expectedErr = Left (RelError (RelationTypeMismatchError V.empty failAttrs))

62 let expectedErr = Left (RelError (RelationTypeMismatchError V.empty failAttrs))

59 assertEqual "dbc error" expectedErr err

63 assertEqual "dbc error" expectedErr err

60−

61−

62−

64−

65+-- #176 default merge couldn't handle Update

65−

66+testSimpleUpdate :: Test

66−

67+testSimpleUpdate = TestCase $ do

67−

68+ let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []

69+ dbconn <- assertEither (simpleConnectProjectM36 connInfo)

70+ assertEither $ withTransaction dbconn $

71+ execute $ databaseContextAsDatabaseContextExpr dateExamples

72+ assertEither $ withTransaction dbconn $

73+ execute $ Update "s" (M.singleton "sname" (C.NakedAtomExpr (C.TextAtom "Blakey"))) (C.AttributeEqualityPredicate "sname" (C.NakedAtomExpr (C.TextAtom "Blake")))