git.iko.soy/project-m36
on master help sign in
switch to withTransaction monad and throwing an exception to terminate the DB monad
e29d8d9AgentM
src/lib/ProjectM36/Client.hs+26−1
compare with master
unifiedsplit
@@ -89,7 +89,8 @@ module ProjectM36.Client
89 Atomable(..),
89 Atomable(..),
90 TupleExprBase(..),
90 TupleExprBase(..),
91 AtomExprBase(..),
91 AtomExprBase(..),
92− RestrictionPredicateExprBase(..)
92+ RestrictionPredicateExprBase(..),
93+ withTransaction
93 ) where
94 ) where
94import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well
95import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well
95import qualified ProjectM36.Base as B
96import qualified ProjectM36.Base as B
@@ -1029,3 +1030,27 @@ writeDisconAndGraph_ graphTvar sessionId session sessions discon graph = do
1029 let newSession = Session discon (Sess.schemaName session)
1030 let newSession = Session discon (Sess.schemaName session)
1030 STMMap.insert newSession sessionId sessions
1031 STMMap.insert newSession sessionId sessions
1031-}
1032-}
1033+
1034+-- | Runs an IO monad, commits the result when the monad returns no errors, otherwise, rolls back the changes and the error.
1035+withTransaction :: SessionId -> Connection -> IO (Either RelationalError a) -> IO (Either RelationalError ()) -> IO (Either RelationalError a)
1036+withTransaction sessionId conn io successFunc = bracketOnError (pure ()) (const do_rollback) block
1037+ where
1038+ do_rollback = rollback sessionId conn
1039+ block _ = do
1040+ eErr <- io
1041+ case eErr of
1042+ Left err -> do
1043+ _ <- do_rollback
1044+ pure (Left err)
1045+ Right val -> do
1046+ eIsDirty <- disconnectedTransactionIsDirty sessionId conn
1047+ case eIsDirty of
1048+ Left err -> pure (Left err)
1049+ Right dirty -> do
1050+ if dirty then do
1051+ res <- successFunc
1052+ case res of
1053+ Left err -> pure (Left err)
1054+ Right _ -> pure (Right val)
1055+ else -- no updates executed, so don't create a commit
1056+ pure (Right val)
src/lib/ProjectM36/Client/Simple.hs+61−49
@@ -1,10 +1,11 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2module ProjectM36.Client.Simple (
2module ProjectM36.Client.Simple (
3− withDBConnection,
3+ simpleConnectProjectM36,
4 withTransaction,
4 withTransaction,
5 execute,
5 execute,
6 query,
6 query,
7 rollback,
7 rollback,
8+ close,
8 Atom(..),
9 Atom(..),
9 AtomType(..),
10 AtomType(..),
10 DBError(..),
11 DBError(..),
@@ -16,71 +17,82 @@ module ProjectM36.Client.Simple (
16 C.DatabaseContextExpr(..),
17 C.DatabaseContextExpr(..),
17 C.RelationalExprBase(..)
18 C.RelationalExprBase(..)
18 ) where
19 ) where
19−-- | A simplified, monad-based client for Project:M36 database access.
20+-- | A simplified client interface for Project:M36 database access.
20import ProjectM36.Error
21import ProjectM36.Error
21import ProjectM36.Base
22import ProjectM36.Base
22import qualified ProjectM36.Client as C
23import qualified ProjectM36.Client as C
23import Control.Monad.Reader
24import Control.Monad.Reader
24import Control.Exception.Base
25import Control.Exception.Base
25
26
26−-- | A union of connection and other errors that can be returned from 'withDBConnection'.
27+type DBConn = (C.SessionId, C.Connection)
27−data DBError = ConnError C.ConnectionError |
28− RelError RelationalError
29− deriving (Eq, Show)
30
28
31newtype DB a = DB {runDB :: ReaderT (C.SessionId, C.Connection) IO a}
29newtype DB a = DB {runDB :: ReaderT (C.SessionId, C.Connection) IO a}
32 deriving (Functor, Applicative, Monad)
30 deriving (Functor, Applicative, Monad)
31+
32+newtype TransactionCancelled = TransactionCancelled DBError deriving Show
33+instance Exception TransactionCancelled
33
34
34−-- | Opens a connection in the 'DB' monad and closes it after running the monad.
35+-- | A simple alternative to 'connectProjectM36' which includes simple session management
35−withDBConnection :: C.ConnectionInfo -> DB (Either DBError a) -> IO (Either DBError a)
36+simpleConnectProjectM36 :: C.ConnectionInfo -> IO (Either DBError DBConn)
36−withDBConnection connInfo block = bracket (C.connectProjectM36 connInfo) (\eConn -> case eConn of
37+simpleConnectProjectM36 connInfo = do
37− Left _ -> pure (Right ())
38+ eConn <- C.connectProjectM36 connInfo
38− Right conn -> C.close conn >> pure (Right ())) $ \eConn -> do
39 case eConn of
39 case eConn of
40 Left err -> pure (Left (ConnError err))
40 Left err -> pure (Left (ConnError err))
41 Right conn -> do
41 Right conn -> do
42 eSess <- C.createSessionAtHead conn "master"
42 eSess <- C.createSessionAtHead conn "master"
43 case eSess of
43 case eSess of
44+ Left err -> do
45+ C.close conn
44− Left err -> pure (Left (RelError err))
46+ pure (Left (RelError err))
45− Right session ->
47+ Right sess -> pure (Right (sess, conn))
48+
49+close :: DBConn -> IO ()
50+close (_ , conn) = C.close conn
51+
52+-- | Runs an IO monad which may include some database updates. If an exception or error occurs, the transaction is rolled back. Otherwise, the transaction is committed.
53+withTransaction :: DBConn -> DB a -> IO (Either DBError a)
54+withTransaction (sess, conn) dbm = do
55+ eHeadName <- C.headName sess conn
56+ case eHeadName of
57+ Left err -> pure (Left (RelError err))
58+ Right headName -> do
59+ let successFunc = C.autoMergeToHead sess conn UnionMergeStrategy headName
46− runReaderT (runDB block) (session, conn)
60+ block = runReaderT (runDB dbm) (sess, conn)
47−
61+ handler :: TransactionCancelled -> IO (Either DBError a)
48−wrapClientIO :: (C.SessionId -> C.Connection -> IO (Either RelationalError a)) -> DB (Either DBError a)
62+ handler (TransactionCancelled err) = pure (Left err)
49−wrapClientIO func = DB $ do
63+ handle handler $ do
64+ ret <- C.withTransaction sess conn (block >>= pure . Right) successFunc
65+ case ret of
66+ Left err -> pure (Left (RelError err))
67+ Right val -> pure (Right val)
68+
69+-- | A union of connection and other errors that can be returned from 'withDBConnection'.
70+data DBError = ConnError C.ConnectionError |
71+ RelError RelationalError |
72+ TransactionRolledBack
73+ deriving (Eq, Show)
74+
75+-- | Execute a 'DatabaseContextExpr' in the 'DB' monad. Database context expressions manipulate the state of the database. In case of an error, the transaction is terminated and the connection's session is rolled back.
76+execute :: C.DatabaseContextExpr -> DB ()
77+execute expr = DB $ do
50 (sess, conn) <- ask
78 (sess, conn) <- ask
51− ret <- liftIO (func sess conn)
79+ ret <- liftIO $ C.executeDatabaseContextExpr sess conn expr
52 case ret of
80 case ret of
53− Left err -> pure (Left (RelError err))
81+ Left err -> liftIO $ cancelTransaction (RelError err)
54− Right val -> pure (Right val)
55−
56−-- | Atomically commits the result of the database context expressions to disk on the server or restores the initial state.
57−withTransaction :: [C.DatabaseContextExpr] -> DB (Either DBError ())
58−withTransaction exprs = do
59− ret <- execute (MultipleExpr exprs)
60− case ret of
61− Left err -> pure (Left err)
62− Right _ -> do
82+ Right _ -> pure ()
63− eCurrentHead <- wrapClientIO C.headName
64− case eCurrentHead of
65− Left err -> pure (Left err)
66− Right currentHead -> do
67− --only add a commit if something actually changed
68− eIsDirty <- wrapClientIO C.disconnectedTransactionIsDirty
69− case eIsDirty of
70− Left err -> pure (Left err)
71− Right isDirty ->
72− if isDirty then
73− wrapClientIO (\sess conn -> C.autoMergeToHead sess conn C.UnionMergeStrategy currentHead)
74− else
75− pure (Right ())
76−
77−-- | Execute a 'DatabaseContextExpr' in the 'DB' monad. Database context expressions manipulate the state of the database.
78−execute :: C.DatabaseContextExpr -> DB (Either DBError ())
79−execute expr = wrapClientIO (\sess conn -> C.executeDatabaseContextExpr sess conn expr)
80
83
81-- | Run a 'RelationalExpr' query in the 'DB' monad. Relational expressions perform read-only queries against the current database state.
84-- | Run a 'RelationalExpr' query in the 'DB' monad. Relational expressions perform read-only queries against the current database state.
82−query :: C.RelationalExpr -> DB (Either DBError Relation)
85+query :: C.RelationalExpr -> DB Relation
86+query expr = DB $ do
87+ (sess, conn) <- ask
83−query expr = wrapClientIO (\sess conn -> C.executeRelationalExpr sess conn expr)
88+ ret <- lift $ C.executeRelationalExpr sess conn expr
89+ case ret of
90+ Left err -> liftIO $ cancelTransaction (RelError err) >> error "impossible"
91+ Right rel -> pure rel
92+
93+-- | Unconditionally roll back the current transaction and throw an exception to terminate the execution of the DB monad.
94+rollback :: DB ()
95+rollback = DB $ lift $ cancelTransaction TransactionRolledBack
84
96
85−rollback :: DB (Either DBError ())
97+cancelTransaction :: DBError -> IO ()
86−rollback = wrapClientIO C.rollback
98+cancelTransaction err = throwIO (TransactionCancelled err)
test/Client/Simple.hs+10−8
@@ -31,13 +31,14 @@ testSimpleCommitSuccess = TestCase $
31 let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir </> "db")) emptyNotificationCallback []
31 let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir </> "db")) emptyNotificationCallback []
32 relExpr = Union (RelationVariable "x" ()) (RelationVariable "y" ())
32 relExpr = Union (RelationVariable "x" ()) (RelationVariable "y" ())
33
33
34− Right _ <- withDBConnection connInfo $ do
34+ dbconn <- assertEither (simpleConnectProjectM36 connInfo)
35− Right _ <- withTransaction [
35+ Right rel <- withTransaction dbconn $ do
36+
36− Assign "x" (ExistingRelation relationTrue),
37+ execute (Assign "x" (ExistingRelation relationTrue))
37− Assign "y" (ExistingRelation relationFalse)
38+ execute (Assign "y" (ExistingRelation relationFalse))
38− ]
39 query relExpr
39 query relExpr
40
40
41+ assertEqual "true/false simple" relationTrue rel
41 -- re-open with standard API and validate that the relvars are available
42 -- re-open with standard API and validate that the relvars are available
42 conn <- assertEither $ C.connectProjectM36 connInfo
43 conn <- assertEither $ C.connectProjectM36 connInfo
43
44
@@ -50,10 +51,11 @@ testSimpleCommitFailure = TestCase $ do
50 let failAttrs = attributesFromList [Attribute "fail" IntAtomType]
51 let failAttrs = attributesFromList [Attribute "fail" IntAtomType]
51 err <- withSystemTempDirectory "m36tempdb" $ \tempdir -> do
52 err <- withSystemTempDirectory "m36tempdb" $ \tempdir -> do
52 let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir </> "db")) emptyNotificationCallback []
53 let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir </> "db")) emptyNotificationCallback []
53− withDBConnection connInfo $ do
54+ dbconn <- assertEither (simpleConnectProjectM36 connInfo)
55+ withTransaction dbconn $ do
54− Right _ <- withTransaction [Assign "x" (ExistingRelation relationTrue)]
56+ execute $ Assign "x" (ExistingRelation relationTrue)
55 --cause error
57 --cause error
56− withTransaction [Assign "x" (MakeStaticRelation failAttrs emptyTupleSet)]
58+ execute $ Assign "x" (MakeStaticRelation failAttrs emptyTupleSet)
57 let expectedErr = Left (RelError (RelVarAssignmentTypeMismatchError V.empty failAttrs))
59 let expectedErr = Left (RelError (RelVarAssignmentTypeMismatchError V.empty failAttrs))
58 assertEqual "dbc error" expectedErr err
60 assertEqual "dbc error" expectedErr err
59
61