@@ -1,10 +1,11 @@
11{-# LANGUAGE GeneralizedNewtypeDeriving #-}
22module ProjectM36.Client.Simple (
3− withDBConnection,
3+ simpleConnectProjectM36,
44 withTransaction,
55 execute,
66 query,
77 rollback,
8+ close,
89 Atom(..),
910 AtomType(..),
1011 DBError(..),
@@ -16,71 +17,82 @@ module ProjectM36.Client.Simple (
1617 C.DatabaseContextExpr(..),
1718 C.RelationalExprBase(..)
1819 ) where
19−-- | A simplified, monad-based client for Project:M36 database access.
20+-- | A simplified client interface for Project:M36 database access.
2021import ProjectM36.Error
2122import ProjectM36.Base
2223import qualified ProjectM36.Client as C
2324import Control.Monad.Reader
2425import Control.Exception.Base
2526
26−-- | A union of connection and other errors that can be returned from 'withDBConnection'.
27−data DBError = ConnError C.ConnectionError |
28− RelError RelationalError
29− deriving (Eq, Show)
27+type DBConn = (C.SessionId, C.Connection)
3028
3129newtype DB a = DB {runDB :: ReaderT (C.SessionId, C.Connection) IO a}
3230 deriving (Functor, Applicative, Monad)
31+
32+newtype TransactionCancelled = TransactionCancelled DBError deriving Show
33+instance Exception TransactionCancelled
3334
34−-- | Opens a connection in the 'DB' monad and closes it after running the monad.
35−withDBConnection :: C.ConnectionInfo -> DB (Either DBError a) -> IO (Either DBError a)
36−withDBConnection connInfo block = bracket (C.connectProjectM36 connInfo) (\eConn -> case eConn of
37− Left _ -> pure (Right ())
38− Right conn -> C.close conn >> pure (Right ())) $ \eConn -> do
35+-- | A simple alternative to 'connectProjectM36' which includes simple session management
36+simpleConnectProjectM36 :: C.ConnectionInfo -> IO (Either DBError DBConn)
37+simpleConnectProjectM36 connInfo = do
38+ eConn <- C.connectProjectM36 connInfo
3939 case eConn of
4040 Left err -> pure (Left (ConnError err))
4141 Right conn -> do
4242 eSess <- C.createSessionAtHead conn "master"
4343 case eSess of
44− Left err -> pure (Left (RelError err))
45− Right session ->
46− runReaderT (runDB block) (session, conn)
47−
48−wrapClientIO :: (C.SessionId -> C.Connection -> IO (Either RelationalError a)) -> DB (Either DBError a)
49−wrapClientIO func = DB $ do
44+ Left err -> do
45+ C.close conn
46+ pure (Left (RelError err))
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
60+ block = runReaderT (runDB dbm) (sess, conn)
61+ handler :: TransactionCancelled -> IO (Either DBError a)
62+ handler (TransactionCancelled err) = pure (Left err)
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
5078 (sess, conn) <- ask
51− ret <- liftIO (func sess conn)
79+ ret <- liftIO $ C.executeDatabaseContextExpr sess conn expr
5280 case ret of
53− Left err -> pure (Left (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
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)
81+ Left err -> liftIO $ cancelTransaction (RelError err)
82+ Right _ -> pure ()
8083
8184-- | 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)
83−query expr = wrapClientIO (\sess conn -> C.executeRelationalExpr sess conn expr)
85+query :: C.RelationalExpr -> DB Relation
86+query expr = DB $ do
87+ (sess, conn) <- ask
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
8496
85−rollback :: DB (Either DBError ())
86−rollback = wrapClientIO C.rollback
97+cancelTransaction :: DBError -> IO ()
98+cancelTransaction err = throwIO (TransactionCancelled err)