{-# LANGUAGE MonoLocalBinds #-}
module ProjectM36.Server.EntryPoints where
import ProjectM36.Base hiding (inclusionDependencies)
import ProjectM36.IsomorphicSchema
import ProjectM36.Client as C
import ProjectM36.Error
import Control.Distributed.Process (Process, ProcessId)
import Control.Distributed.Process.ManagedProcess (ProcessReply)
import Control.Distributed.Process.ManagedProcess.Server (reply)
import Control.Distributed.Process.Async (async, task, waitCancelTimeout, AsyncResult(..))
import Control.Monad.IO.Class (liftIO)
import Data.Map
import Control.Concurrent (threadDelay)
import Data.Typeable
import Data.Binary
timeoutOrDie :: (Binary a, Typeable a) => Timeout -> IO a -> Process (Either ServerError a)
timeoutOrDie micros act =
if micros == 0 then
liftIO act >>= \x -> pure (Right x)
else do
asyncUnit <- async (task (liftIO act))
asyncRes <- waitCancelTimeout micros asyncUnit
case asyncRes of
AsyncDone x -> pure (Right x)
AsyncCancelled -> pure (Left RequestTimeoutError)
AsyncFailed reason -> pure (Left (ProcessDiedError (show reason)))
AsyncLinkFailed reason -> pure (Left (ProcessDiedError (show reason)))
AsyncPending -> pure (Left (ProcessDiedError "process pending"))
type Timeout = Int
type Reply a = Process (ProcessReply (Either ServerError a) Connection)
handleExecuteRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Reply (Either RelationalError Relation)
handleExecuteRelationalExpr ti sessionId conn expr = do
ret <- timeoutOrDie ti (executeRelationalExpr sessionId conn expr)
reply ret conn
handleExecuteDataFrameExpr :: Timeout -> SessionId -> Connection -> DataFrameExpr -> Reply (Either RelationalError DataFrame)
handleExecuteDataFrameExpr ti sessionId conn expr = do
ret <- timeoutOrDie ti (executeDataFrameExpr sessionId conn expr)
reply ret conn
handleExecuteDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError ())
handleExecuteDatabaseContextExpr ti sessionId conn dbexpr = do
ret <- timeoutOrDie ti (executeDatabaseContextExpr sessionId conn dbexpr)
reply ret conn
handleExecuteDatabaseContextIOExpr :: Timeout -> SessionId -> Connection -> DatabaseContextIOExpr -> Reply (Either RelationalError ())
handleExecuteDatabaseContextIOExpr ti sessionId conn dbexpr = do
ret <- timeoutOrDie ti (executeDatabaseContextIOExpr sessionId conn dbexpr)
reply ret conn
handleExecuteHeadName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError HeadName)
handleExecuteHeadName ti sessionId conn = do
ret <- timeoutOrDie ti (headName sessionId conn)
reply ret conn
handleLogin :: Timeout -> Connection -> ProcessId -> Reply Bool
handleLogin ti conn newClientProcessId = do
ret <- timeoutOrDie ti (addClientNode conn newClientProcessId)
case ret of
Right () -> reply (Right True) conn
Left err -> reply (Left err) conn
handleExecuteGraphExpr :: Timeout -> SessionId -> Connection -> TransactionGraphOperator -> Reply (Either RelationalError ())
handleExecuteGraphExpr ti sessionId conn graphExpr = do
ret <- timeoutOrDie ti (executeGraphExpr sessionId conn graphExpr)
reply ret conn
handleExecuteTransGraphRelationalExpr :: Timeout -> SessionId -> Connection -> TransGraphRelationalExpr -> Reply (Either RelationalError Relation)
handleExecuteTransGraphRelationalExpr ti sessionId conn graphExpr = do
ret <- timeoutOrDie ti (executeTransGraphRelationalExpr sessionId conn graphExpr)
reply ret conn
handleExecuteTypeForRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Reply (Either RelationalError Relation)
handleExecuteTypeForRelationalExpr ti sessionId conn relExpr = do
ret <- timeoutOrDie ti (typeForRelationalExpr sessionId conn relExpr)
reply ret conn
handleRetrieveInclusionDependencies :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError (Map IncDepName InclusionDependency))
handleRetrieveInclusionDependencies ti sessionId conn = do
ret <- timeoutOrDie ti (inclusionDependencies sessionId conn)
reply ret conn
handleRetrievePlanForDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError GraphRefDatabaseContextExpr)
handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr = do
ret <- timeoutOrDie ti (planForDatabaseContextExpr sessionId conn dbExpr)
reply ret conn
handleRetrieveTransactionGraph :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)
handleRetrieveTransactionGraph ti sessionId conn = do
ret <- timeoutOrDie ti (transactionGraphAsRelation sessionId conn)
reply ret conn
handleRetrieveHeadTransactionId :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError TransactionId)
handleRetrieveHeadTransactionId ti sessionId conn = do
ret <- timeoutOrDie ti (headTransactionId sessionId conn)
reply ret conn
handleCreateSessionAtCommit :: Timeout -> Connection -> TransactionId -> Reply (Either RelationalError SessionId)
handleCreateSessionAtCommit ti conn commitId = do
ret <- timeoutOrDie ti (createSessionAtCommit conn commitId)
reply ret conn
handleCreateSessionAtHead :: Timeout -> Connection -> HeadName -> Reply (Either RelationalError SessionId)
handleCreateSessionAtHead ti conn headn = do
ret <- timeoutOrDie ti (createSessionAtHead conn headn)
reply ret conn
handleCloseSession :: Timeout -> SessionId -> Connection -> Reply ()
handleCloseSession ti sessionId conn = do
ret <- timeoutOrDie ti (closeSession sessionId conn)
case ret of
Right () -> reply (Right ()) conn
Left err -> reply (Left err) conn
handleRetrieveAtomTypesAsRelation :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)
handleRetrieveAtomTypesAsRelation ti sessionId conn = do
ret <- timeoutOrDie ti (atomTypesAsRelation sessionId conn)
reply ret conn
handleRetrieveRelationVariableSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)
handleRetrieveRelationVariableSummary ti sessionId conn = do
ret <- timeoutOrDie ti (relationVariablesAsRelation sessionId conn)
reply ret conn
handleRetrieveAtomFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)
handleRetrieveAtomFunctionSummary ti sessionId conn = do
ret <- timeoutOrDie ti (atomFunctionsAsRelation sessionId conn)
reply ret conn
handleRetrieveDatabaseContextFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)
handleRetrieveDatabaseContextFunctionSummary ti sessionId conn = do
ret <- timeoutOrDie ti (databaseContextFunctionsAsRelation sessionId conn)
reply ret conn
handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError SchemaName)
handleRetrieveCurrentSchemaName ti sessionId conn = do
ret <- timeoutOrDie ti (currentSchemaName sessionId conn)
reply ret conn
handleExecuteSchemaExpr :: Timeout -> SessionId -> Connection -> SchemaExpr -> Reply (Either RelationalError ())
handleExecuteSchemaExpr ti sessionId conn schemaExpr = do
ret <- timeoutOrDie ti (executeSchemaExpr sessionId conn schemaExpr)
reply ret conn
handleLogout :: Timeout -> Connection -> Reply Bool
handleLogout _ =
reply (pure True)
handleTestTimeout :: Timeout -> SessionId -> Connection -> Reply Bool
handleTestTimeout ti _ conn = do
ret <- timeoutOrDie ti (threadDelay 100000 >> pure True)
reply ret conn
handleRetrieveSessionIsDirty :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Bool)
handleRetrieveSessionIsDirty ti sessionId conn = do
ret <- timeoutOrDie ti (disconnectedTransactionIsDirty sessionId conn)
reply ret conn
handleExecuteAutoMergeToHead :: Timeout -> SessionId -> Connection -> MergeStrategy -> HeadName -> Reply (Either RelationalError ())
handleExecuteAutoMergeToHead ti sessionId conn strat headName' = do
ret <- timeoutOrDie ti (autoMergeToHead sessionId conn strat headName')
reply ret conn
handleRetrieveTypeConstructorMapping :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError TypeConstructorMapping)
handleRetrieveTypeConstructorMapping ti sessionId conn = do
ret <- timeoutOrDie ti (C.typeConstructorMapping sessionId conn)
reply ret conn
handleValidateMerkleHashes :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError ())
handleValidateMerkleHashes ti sessionId conn = do
ret <- timeoutOrDie ti (C.validateMerkleHashes sessionId conn)
reply ret conn