@@ -2,15 +2,16 @@
22module ProjectM36.Client.Simple (
33 withDBConnection,
44 withTransaction,
5− executeDatabaseContextExpr,
6− executeRelationalExpr,
5+ execute,
6+ query,
7+ rollback,
78 Atom(..),
89 AtomType(..),
910 DBError(..),
1011 Attribute(..),
1112 C.ConnectionInfo(..),
1213 C.PersistenceStrategy(..),
13− C.NotificationCallback(..),
14+ C.NotificationCallback,
1415 C.emptyNotificationCallback,
1516 C.DatabaseContextExpr(..),
1617 C.RelationalExprBase(..)
@@ -28,12 +29,12 @@ data DBError = ConnError C.ConnectionError |
2829 deriving (Eq, Show)
2930
3031newtype DB a = DB {runDB :: ReaderT (C.SessionId, C.Connection) IO a}
31− deriving (Functor, Applicative, Monad, MonadIO)
32+ deriving (Functor, Applicative, Monad)
3233
3334-- | Opens a connection in the 'DB' monad and closes it after running the monad.
3435withDBConnection :: C.ConnectionInfo -> DB (Either DBError a) -> IO (Either DBError a)
3536withDBConnection connInfo block = bracket (C.connectProjectM36 connInfo) (\eConn -> case eConn of
36− Left err -> pure (Right ())
37+ Left _ -> pure (Right ())
3738 Right conn -> C.close conn >> pure (Right ())) $ \eConn -> do
3839 case eConn of
3940 Left err -> pure (Left (ConnError err))
@@ -52,28 +53,34 @@ wrapClientIO func = DB $ do
5253 Left err -> pure (Left (RelError err))
5354 Right val -> pure (Right val)
5455
55−-- | Atomically commits the result of the database context expression to disk on the server or restores the initial state.
56−withTransaction :: C.DatabaseContextExpr -> DB (Either DBError ())
57−withTransaction expr = do
58− ret <- executeDatabaseContextExpr expr
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)
5960 case ret of
6061 Left err -> pure (Left err)
6162 Right _ -> do
6263 eCurrentHead <- wrapClientIO C.headName
6364 case eCurrentHead of
6465 Left err -> pure (Left err)
65− Right currentHead ->
66− wrapClientIO (\sess conn -> C.autoMergeToHead sess conn C.UnionMergeStrategy currentHead)
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 ())
6776
6877-- | Execute a 'DatabaseContextExpr' in the 'DB' monad. Database context expressions manipulate the state of the database.
69−executeDatabaseContextExpr :: C.DatabaseContextExpr -> DB (Either DBError ())
70−executeDatabaseContextExpr expr = DB $ do
71− (sess, conn) <- ask
72− eErr <- liftIO $ C.executeDatabaseContextExpr sess conn expr
73− case eErr of
74− Left err -> pure (Left (RelError err))
75− Right () -> pure (Right ())
78+execute :: C.DatabaseContextExpr -> DB (Either DBError ())
79+execute expr = wrapClientIO (\sess conn -> C.executeDatabaseContextExpr sess conn expr)
7680
77−-- | Execute a 'RelationalExpr' in the 'DB' monad. Relational expressions perform read-only queries against the current database state.
78−executeRelationalExpr :: C.RelationalExpr -> DB (Either DBError Relation)
79−executeRelationalExpr expr = wrapClientIO (\sess conn -> C.executeRelationalExpr sess conn expr)
81+-- | 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)
84+
85+rollback :: DB (Either DBError ())
86+rollback = wrapClientIO C.rollback