{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | A simplified client interface for Project:M36 database access.
module ProjectM36.Client.Simple (
  simpleConnectProjectM36,
  simpleConnectProjectM36At,
  withTransaction,
  withTransactionUsing,
  execute,
  executeOrErr,
  query,
  queryOrErr,
  cancelTransaction,
  orCancelTransaction,
  rollback,
  close,
  Atom(..),
  AtomType(..),
  Db,
  DbConn,
  DbError(..),
  RelationalError(..),
  Attribute(..),
  C.Atomable(toAtom, fromAtom),
  C.ConnectionInfo(..),
  C.PersistenceStrategy(..),
  C.NotificationCallback,
  C.emptyNotificationCallback,
  C.DatabaseContextExprBase(..),
  C.DatabaseContextExpr,  
  C.RelationalExprBase(..)
  ) where

import Control.Exception.Base
import Control.Monad.Reader
import ProjectM36.Base
import qualified ProjectM36.Client as C
import ProjectM36.Error

type DbConn = (C.SessionId, C.Connection)

newtype Db a = Db {Db a -> ReaderT DbConn IO a
runDb :: ReaderT DbConn IO a}
  deriving (a -> Db b -> Db a
(a -> b) -> Db a -> Db b
(forall a b. (a -> b) -> Db a -> Db b)
-> (forall a b. a -> Db b -> Db a) -> Functor Db
forall a b. a -> Db b -> Db a
forall a b. (a -> b) -> Db a -> Db b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Db b -> Db a
$c<$ :: forall a b. a -> Db b -> Db a
fmap :: (a -> b) -> Db a -> Db b
$cfmap :: forall a b. (a -> b) -> Db a -> Db b
Functor, Functor Db
a -> Db a
Functor Db
-> (forall a. a -> Db a)
-> (forall a b. Db (a -> b) -> Db a -> Db b)
-> (forall a b c. (a -> b -> c) -> Db a -> Db b -> Db c)
-> (forall a b. Db a -> Db b -> Db b)
-> (forall a b. Db a -> Db b -> Db a)
-> Applicative Db
Db a -> Db b -> Db b
Db a -> Db b -> Db a
Db (a -> b) -> Db a -> Db b
(a -> b -> c) -> Db a -> Db b -> Db c
forall a. a -> Db a
forall a b. Db a -> Db b -> Db a
forall a b. Db a -> Db b -> Db b
forall a b. Db (a -> b) -> Db a -> Db b
forall a b c. (a -> b -> c) -> Db a -> Db b -> Db c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Db a -> Db b -> Db a
$c<* :: forall a b. Db a -> Db b -> Db a
*> :: Db a -> Db b -> Db b
$c*> :: forall a b. Db a -> Db b -> Db b
liftA2 :: (a -> b -> c) -> Db a -> Db b -> Db c
$cliftA2 :: forall a b c. (a -> b -> c) -> Db a -> Db b -> Db c
<*> :: Db (a -> b) -> Db a -> Db b
$c<*> :: forall a b. Db (a -> b) -> Db a -> Db b
pure :: a -> Db a
$cpure :: forall a. a -> Db a
$cp1Applicative :: Functor Db
Applicative, Applicative Db
a -> Db a
Applicative Db
-> (forall a b. Db a -> (a -> Db b) -> Db b)
-> (forall a b. Db a -> Db b -> Db b)
-> (forall a. a -> Db a)
-> Monad Db
Db a -> (a -> Db b) -> Db b
Db a -> Db b -> Db b
forall a. a -> Db a
forall a b. Db a -> Db b -> Db b
forall a b. Db a -> (a -> Db b) -> Db b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Db a
$creturn :: forall a. a -> Db a
>> :: Db a -> Db b -> Db b
$c>> :: forall a b. Db a -> Db b -> Db b
>>= :: Db a -> (a -> Db b) -> Db b
$c>>= :: forall a b. Db a -> (a -> Db b) -> Db b
$cp1Monad :: Applicative Db
Monad, Monad Db
Monad Db -> (forall a. IO a -> Db a) -> MonadIO Db
IO a -> Db a
forall a. IO a -> Db a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> Db a
$cliftIO :: forall a. IO a -> Db a
$cp1MonadIO :: Monad Db
MonadIO)

-- This exception type should never be observable by the API users.
-- It merely carries errors which end up as RelError at the end of a transaction.
newtype TransactionCancelled = TransactionCancelled DbError deriving Int -> TransactionCancelled -> ShowS
[TransactionCancelled] -> ShowS
TransactionCancelled -> String
(Int -> TransactionCancelled -> ShowS)
-> (TransactionCancelled -> String)
-> ([TransactionCancelled] -> ShowS)
-> Show TransactionCancelled
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransactionCancelled] -> ShowS
$cshowList :: [TransactionCancelled] -> ShowS
show :: TransactionCancelled -> String
$cshow :: TransactionCancelled -> String
showsPrec :: Int -> TransactionCancelled -> ShowS
$cshowsPrec :: Int -> TransactionCancelled -> ShowS
Show
instance Exception TransactionCancelled

-- | A simple alternative to 'connectProjectM36' which includes simple session management.
simpleConnectProjectM36At :: HeadName -> C.ConnectionInfo -> IO (Either DbError DbConn)
simpleConnectProjectM36At :: HeadName -> ConnectionInfo -> IO (Either DbError DbConn)
simpleConnectProjectM36At HeadName
headName ConnectionInfo
connInfo = do
  Either ConnectionError Connection
eConn <- ConnectionInfo -> IO (Either ConnectionError Connection)
C.connectProjectM36 ConnectionInfo
connInfo
  case Either ConnectionError Connection
eConn of
    Left ConnectionError
err -> Either DbError DbConn -> IO (Either DbError DbConn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DbError -> Either DbError DbConn
forall a b. a -> Either a b
Left (ConnectionError -> DbError
ConnError ConnectionError
err))
    Right Connection
conn -> do
      Either RelationalError SessionId
eSess <- Connection -> HeadName -> IO (Either RelationalError SessionId)
C.createSessionAtHead Connection
conn HeadName
headName
      case Either RelationalError SessionId
eSess of
        Left RelationalError
err -> do
          Connection -> IO ()
C.close Connection
conn
          Either DbError DbConn -> IO (Either DbError DbConn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DbError -> Either DbError DbConn
forall a b. a -> Either a b
Left (RelationalError -> DbError
RelError RelationalError
err))
        Right SessionId
sess -> Either DbError DbConn -> IO (Either DbError DbConn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DbConn -> Either DbError DbConn
forall a b. b -> Either a b
Right (SessionId
sess, Connection
conn))

-- | Same as 'simpleConnectProjectM36At' but always connects to the @master@ branch.
simpleConnectProjectM36 :: C.ConnectionInfo -> IO (Either DbError DbConn)
simpleConnectProjectM36 :: ConnectionInfo -> IO (Either DbError DbConn)
simpleConnectProjectM36 = HeadName -> ConnectionInfo -> IO (Either DbError DbConn)
simpleConnectProjectM36At HeadName
"master"

-- | Closes the database connection.
close :: DbConn -> IO ()
close :: DbConn -> IO ()
close (SessionId
_ , Connection
conn) = Connection -> IO ()
C.close Connection
conn

-- | Runs a Db monad which may include some database updates. If an exception or error occurs, the transaction is rolled back. Otherwise, the transaction is committed to the head of the current branch.
withTransaction :: DbConn -> Db a -> IO (Either DbError a)
withTransaction :: DbConn -> Db a -> IO (Either DbError a)
withTransaction DbConn
sessconn = DbConn -> MergeStrategy -> Db a -> IO (Either DbError a)
forall a. DbConn -> MergeStrategy -> Db a -> IO (Either DbError a)
withTransactionUsing DbConn
sessconn MergeStrategy
UnionMergeStrategy

-- | Same as 'withTransaction' except that the merge strategy can be specified.
withTransactionUsing :: DbConn -> MergeStrategy -> Db a -> IO (Either DbError a)
withTransactionUsing :: DbConn -> MergeStrategy -> Db a -> IO (Either DbError a)
withTransactionUsing (SessionId
sess, Connection
conn) MergeStrategy
strat Db a
dbm = do
  Either RelationalError HeadName
eHeadName <- SessionId -> Connection -> IO (Either RelationalError HeadName)
C.headName SessionId
sess Connection
conn
  case Either RelationalError HeadName
eHeadName of
    Left RelationalError
err -> Either DbError a -> IO (Either DbError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DbError -> Either DbError a
forall a b. a -> Either a b
Left (RelationalError -> DbError
RelError RelationalError
err))
    Right HeadName
headName -> do
      let successFunc :: IO (Either RelationalError ())
successFunc = SessionId
-> Connection
-> MergeStrategy
-> HeadName
-> IO (Either RelationalError ())
C.autoMergeToHead SessionId
sess Connection
conn MergeStrategy
strat HeadName
headName
          block :: IO a
block = ReaderT DbConn IO a -> DbConn -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Db a -> ReaderT DbConn IO a
forall a. Db a -> ReaderT DbConn IO a
runDb Db a
dbm) (SessionId
sess, Connection
conn)
          handler :: TransactionCancelled -> IO (Either DbError a)
          handler :: TransactionCancelled -> IO (Either DbError a)
handler (TransactionCancelled DbError
err) = Either DbError a -> IO (Either DbError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DbError -> Either DbError a
forall a b. a -> Either a b
Left DbError
err)
      (TransactionCancelled -> IO (Either DbError a))
-> IO (Either DbError a) -> IO (Either DbError a)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle TransactionCancelled -> IO (Either DbError a)
forall a. TransactionCancelled -> IO (Either DbError a)
handler (IO (Either DbError a) -> IO (Either DbError a))
-> IO (Either DbError a) -> IO (Either DbError a)
forall a b. (a -> b) -> a -> b
$ do
        Either RelationalError a
ret <- SessionId
-> Connection
-> IO (Either RelationalError a)
-> IO (Either RelationalError ())
-> IO (Either RelationalError a)
forall a.
SessionId
-> Connection
-> IO (Either RelationalError a)
-> IO (Either RelationalError ())
-> IO (Either RelationalError a)
C.withTransaction SessionId
sess Connection
conn (a -> Either RelationalError a
forall a b. b -> Either a b
Right (a -> Either RelationalError a)
-> IO a -> IO (Either RelationalError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
block) IO (Either RelationalError ())
successFunc
        case Either RelationalError a
ret of
          Left RelationalError
err  -> Either DbError a -> IO (Either DbError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DbError -> Either DbError a
forall a b. a -> Either a b
Left (RelationalError -> DbError
RelError RelationalError
err))
          Right a
val -> Either DbError a -> IO (Either DbError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either DbError a
forall a b. b -> Either a b
Right a
val)

-- | A union of connection and other errors that can be returned from 'withTransaction'.
data DbError = ConnError C.ConnectionError |
               RelError RelationalError |
               TransactionRolledBack
               deriving (DbError -> DbError -> Bool
(DbError -> DbError -> Bool)
-> (DbError -> DbError -> Bool) -> Eq DbError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DbError -> DbError -> Bool
$c/= :: DbError -> DbError -> Bool
== :: DbError -> DbError -> Bool
$c== :: DbError -> DbError -> Bool
Eq, Int -> DbError -> ShowS
[DbError] -> ShowS
DbError -> String
(Int -> DbError -> ShowS)
-> (DbError -> String) -> ([DbError] -> ShowS) -> Show DbError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DbError] -> ShowS
$cshowList :: [DbError] -> ShowS
show :: DbError -> String
$cshow :: DbError -> String
showsPrec :: Int -> DbError -> ShowS
$cshowsPrec :: Int -> DbError -> ShowS
Show)

-- | 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.
execute :: C.DatabaseContextExpr -> Db ()
execute :: DatabaseContextExpr -> Db ()
execute = Either RelationalError () -> Db ()
forall a. Either RelationalError a -> Db a
orCancelTransaction (Either RelationalError () -> Db ())
-> (DatabaseContextExpr -> Db (Either RelationalError ()))
-> DatabaseContextExpr
-> Db ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DatabaseContextExpr -> Db (Either RelationalError ())
executeOrErr

-- | Run a 'RelationalExpr' query in the 'DB' monad. Relational expressions perform read-only queries against the current database state.
query :: C.RelationalExpr -> Db Relation
query :: RelationalExpr -> Db Relation
query = Either RelationalError Relation -> Db Relation
forall a. Either RelationalError a -> Db a
orCancelTransaction (Either RelationalError Relation -> Db Relation)
-> (RelationalExpr -> Db (Either RelationalError Relation))
-> RelationalExpr
-> Db Relation
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< RelationalExpr -> Db (Either RelationalError Relation)
queryOrErr

-- | Run a 'DatabaseContextExpr' update expression. If there is an error, just return it without cancelling the current transaction.
executeOrErr :: C.DatabaseContextExpr -> Db (Either RelationalError ())
executeOrErr :: DatabaseContextExpr -> Db (Either RelationalError ())
executeOrErr DatabaseContextExpr
expr = ReaderT DbConn IO (Either RelationalError ())
-> Db (Either RelationalError ())
forall a. ReaderT DbConn IO a -> Db a
Db (ReaderT DbConn IO (Either RelationalError ())
 -> Db (Either RelationalError ()))
-> ReaderT DbConn IO (Either RelationalError ())
-> Db (Either RelationalError ())
forall a b. (a -> b) -> a -> b
$ do
  (SessionId
sess, Connection
conn) <- ReaderT DbConn IO DbConn
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO (Either RelationalError ())
-> ReaderT DbConn IO (Either RelationalError ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either RelationalError ())
 -> ReaderT DbConn IO (Either RelationalError ()))
-> IO (Either RelationalError ())
-> ReaderT DbConn IO (Either RelationalError ())
forall a b. (a -> b) -> a -> b
$ SessionId
-> Connection
-> DatabaseContextExpr
-> IO (Either RelationalError ())
C.executeDatabaseContextExpr SessionId
sess Connection
conn DatabaseContextExpr
expr

-- | Run a 'RelationalExpr' query expression. If there is an error, just return it without cancelling the transaction.
queryOrErr :: C.RelationalExpr -> Db (Either RelationalError Relation)
queryOrErr :: RelationalExpr -> Db (Either RelationalError Relation)
queryOrErr RelationalExpr
expr = ReaderT DbConn IO (Either RelationalError Relation)
-> Db (Either RelationalError Relation)
forall a. ReaderT DbConn IO a -> Db a
Db (ReaderT DbConn IO (Either RelationalError Relation)
 -> Db (Either RelationalError Relation))
-> ReaderT DbConn IO (Either RelationalError Relation)
-> Db (Either RelationalError Relation)
forall a b. (a -> b) -> a -> b
$ do
  (SessionId
sess, Connection
conn) <- ReaderT DbConn IO DbConn
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO (Either RelationalError Relation)
-> ReaderT DbConn IO (Either RelationalError Relation)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either RelationalError Relation)
 -> ReaderT DbConn IO (Either RelationalError Relation))
-> IO (Either RelationalError Relation)
-> ReaderT DbConn IO (Either RelationalError Relation)
forall a b. (a -> b) -> a -> b
$ SessionId
-> Connection
-> RelationalExpr
-> IO (Either RelationalError Relation)
C.executeRelationalExpr SessionId
sess Connection
conn RelationalExpr
expr

-- | Unconditionally roll back the current transaction and throw an exception to terminate the execution of the Db monad.
rollback :: Db ()
rollback :: Db ()
rollback = DbError -> Db ()
forall a. DbError -> Db a
cancelTransaction DbError
TransactionRolledBack

-- | Cancel a transaction and carry some error information with it.
cancelTransaction :: DbError -> Db a
cancelTransaction :: DbError -> Db a
cancelTransaction DbError
err = IO a -> Db a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Db a) -> IO a -> Db a
forall a b. (a -> b) -> a -> b
$ TransactionCancelled -> IO a
forall e a. Exception e => e -> IO a
throwIO (DbError -> TransactionCancelled
TransactionCancelled DbError
err)

-- | Converts the 'Either' result from a 'Db' action into an immediate cancel in the case of error.
orCancelTransaction :: Either RelationalError a -> Db a
orCancelTransaction :: Either RelationalError a -> Db a
orCancelTransaction = (RelationalError -> Db a)
-> (a -> Db a) -> Either RelationalError a -> Db a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (DbError -> Db a
forall a. DbError -> Db a
cancelTransaction (DbError -> Db a)
-> (RelationalError -> DbError) -> RelationalError -> Db a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelationalError -> DbError
RelError) a -> Db a
forall (f :: * -> *) a. Applicative f => a -> f a
pure