@@ -0,0 +1,79 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+module ProjectM36.Client.Simple (
3+ withDBConnection,
4+ withTransaction,
5+ executeDatabaseContextExpr,
6+ executeRelationalExpr,
7+ Atom(..),
8+ AtomType(..),
9+ DBError(..),
10+ Attribute(..),
11+ C.ConnectionInfo(..),
12+ C.PersistenceStrategy(..),
13+ C.NotificationCallback(..),
14+ C.emptyNotificationCallback,
15+ C.DatabaseContextExpr(..),
16+ C.RelationalExprBase(..)
17+ ) where
18+-- | A simplified, monad-based client for Project:M36 database access.
19+import ProjectM36.Error
20+import ProjectM36.Base
21+import qualified ProjectM36.Client as C
22+import Control.Monad.Reader
23+import Control.Exception.Base
24+
25+-- | A union of connection and other errors that can be returned from 'withDBConnection'.
26+data DBError = ConnError C.ConnectionError |
27+ RelError RelationalError
28+ deriving (Eq, Show)
29+
30+newtype DB a = DB {runDB :: ReaderT (C.SessionId, C.Connection) IO a}
31+ deriving (Functor, Applicative, Monad, MonadIO)
32+
33+-- | Opens a connection in the 'DB' monad and closes it after running the monad.
34+withDBConnection :: C.ConnectionInfo -> DB (Either DBError a) -> IO (Either DBError a)
35+withDBConnection connInfo block = bracket (C.connectProjectM36 connInfo) (\eConn -> case eConn of
36+ Left err -> pure (Right ())
37+ Right conn -> C.close conn >> pure (Right ())) $ \eConn -> do
38+ case eConn of
39+ Left err -> pure (Left (ConnError err))
40+ Right conn -> do
41+ eSess <- C.createSessionAtHead conn "master"
42+ case eSess of
43+ Left err -> pure (Left (RelError err))
44+ Right session ->
45+ runReaderT (runDB block) (session, conn)
46+
47+wrapClientIO :: (C.SessionId -> C.Connection -> IO (Either RelationalError a)) -> DB (Either DBError a)
48+wrapClientIO func = DB $ do
49+ (sess, conn) <- ask
50+ ret <- liftIO (func sess conn)
51+ case ret of
52+ Left err -> pure (Left (RelError err))
53+ Right val -> pure (Right val)
54+
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
59+ case ret of
60+ Left err -> pure (Left err)
61+ Right _ -> do
62+ eCurrentHead <- wrapClientIO C.headName
63+ case eCurrentHead of
64+ Left err -> pure (Left err)
65+ Right currentHead ->
66+ wrapClientIO (\sess conn -> C.autoMergeToHead sess conn C.UnionMergeStrategy currentHead)
67+
68+-- | 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 ())
76+
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)