git.iko.soy/project-m36
on d64cdeb help sign in
project-m36/src/lib/ProjectM36/Server/EntryPoints.hs
157 lines 7.7 kB history raw
1module ProjectM36.Server.EntryPoints where
2import ProjectM36.Base hiding (inclusionDependencies)
3import ProjectM36.IsomorphicSchema
4import ProjectM36.Client as C
5import ProjectM36.Error
6import Control.Distributed.Process (Process, ProcessId)
7import Control.Distributed.Process.ManagedProcess (ProcessReply)
8import Control.Distributed.Process.ManagedProcess.Server (reply)
9import Control.Distributed.Process.Async (async, task, waitCancelTimeout, AsyncResult(..))
10import Control.Distributed.Process.Serializable (Serializable)
11import Control.Monad.IO.Class (liftIO)
12import Data.Map
13import Control.Concurrent (threadDelay)
15timeoutOrDie :: Serializable a => Timeout -> IO a -> Process (Either ServerError a)
16timeoutOrDie micros act =
17 if micros == 0 then
18 liftIO act >>= \x -> pure (Right x)
19 else do
20 asyncUnit <- async (task (liftIO act))
21 asyncRes <- waitCancelTimeout micros asyncUnit
22 case asyncRes of
23 AsyncDone x -> pure (Right x)
24 AsyncCancelled -> pure (Left RequestTimeoutError)
25 AsyncFailed reason -> pure (Left (ProcessDiedError (show reason)))
26 AsyncLinkFailed reason -> pure (Left (ProcessDiedError (show reason)))
27 AsyncPending -> pure (Left (ProcessDiedError "process pending"))
29type Timeout = Int
31type Reply a = Process (ProcessReply (Either ServerError a) Connection)
33handleExecuteRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Reply (Either RelationalError Relation)
34handleExecuteRelationalExpr ti sessionId conn expr = do
35 ret <- timeoutOrDie ti (executeRelationalExpr sessionId conn expr)
36 reply ret conn
38handleExecuteDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError ())
39handleExecuteDatabaseContextExpr ti sessionId conn dbexpr = do
40 ret <- timeoutOrDie ti (executeDatabaseContextExpr sessionId conn dbexpr)
41 reply ret conn
43handleExecuteDatabaseContextIOExpr :: Timeout -> SessionId -> Connection -> DatabaseContextIOExpr -> Reply (Either RelationalError ())
44handleExecuteDatabaseContextIOExpr ti sessionId conn dbexpr = do
45 ret <- timeoutOrDie ti (executeDatabaseContextIOExpr sessionId conn dbexpr)
46 reply ret conn
48handleExecuteHeadName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError HeadName)
49handleExecuteHeadName ti sessionId conn = do
50 ret <- timeoutOrDie ti (headName sessionId conn)
51 reply ret conn
53handleLogin :: Timeout -> Connection -> ProcessId -> Reply Bool
54handleLogin ti conn newClientProcessId = do
55 ret <- timeoutOrDie ti (addClientNode conn newClientProcessId)
56 case ret of
57 Right () -> reply (Right True) conn
58 Left err -> reply (Left err) conn
60handleExecuteGraphExpr :: Timeout -> SessionId -> Connection -> TransactionGraphOperator -> Reply (Either RelationalError ())
61handleExecuteGraphExpr ti sessionId conn graphExpr = do
62 ret <- timeoutOrDie ti (executeGraphExpr sessionId conn graphExpr)
63 reply ret conn
65handleExecuteTransGraphRelationalExpr :: Timeout -> SessionId -> Connection -> TransGraphRelationalExpr -> Reply (Either RelationalError Relation)
66handleExecuteTransGraphRelationalExpr ti sessionId conn graphExpr = do
67 ret <- timeoutOrDie ti (executeTransGraphRelationalExpr sessionId conn graphExpr)
68 reply ret conn
70handleExecuteTypeForRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Reply (Either RelationalError Relation)
71handleExecuteTypeForRelationalExpr ti sessionId conn relExpr = do
72 ret <- timeoutOrDie ti (typeForRelationalExpr sessionId conn relExpr)
73 reply ret conn
75handleRetrieveInclusionDependencies :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError (Map IncDepName InclusionDependency))
76handleRetrieveInclusionDependencies ti sessionId conn = do
77 ret <- timeoutOrDie ti (inclusionDependencies sessionId conn)
78 reply ret conn
80handleRetrievePlanForDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError DatabaseContextExpr)
81handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr = do
82 ret <- timeoutOrDie ti (planForDatabaseContextExpr sessionId conn dbExpr)
83 reply ret conn
85handleRetrieveTransactionGraph :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)
86handleRetrieveTransactionGraph ti sessionId conn = do
87 ret <- timeoutOrDie ti (transactionGraphAsRelation sessionId conn)
88 reply ret conn
90handleRetrieveHeadTransactionId :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError TransactionId)
91handleRetrieveHeadTransactionId ti sessionId conn = do
92 ret <- timeoutOrDie ti (headTransactionId sessionId conn)
93 reply ret conn
95handleCreateSessionAtCommit :: Timeout -> Connection -> TransactionId -> Reply (Either RelationalError SessionId)
96handleCreateSessionAtCommit ti conn commitId = do
97 ret <- timeoutOrDie ti (createSessionAtCommit conn commitId)
98 reply ret conn
100handleCreateSessionAtHead :: Timeout -> Connection -> HeadName -> Reply (Either RelationalError SessionId)
101handleCreateSessionAtHead ti conn headn = do
102 ret <- timeoutOrDie ti (createSessionAtHead conn headn)
103 reply ret conn
105handleCloseSession :: Timeout -> SessionId -> Connection -> Reply ()
106handleCloseSession ti sessionId conn = do
107 ret <- timeoutOrDie ti (closeSession sessionId conn)
108 case ret of
109 Right () -> reply (Right ()) conn
110 Left err -> reply (Left err) conn
112handleRetrieveAtomTypesAsRelation :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)
113handleRetrieveAtomTypesAsRelation ti sessionId conn = do
114 ret <- timeoutOrDie ti (atomTypesAsRelation sessionId conn)
115 reply ret conn
117-- | Returns a relation which lists the names of relvars in the current session as well as its types.
118handleRetrieveRelationVariableSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)
119handleRetrieveRelationVariableSummary ti sessionId conn = do
120 ret <- timeoutOrDie ti (relationVariablesAsRelation sessionId conn)
121 reply ret conn
123handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError SchemaName)
124handleRetrieveCurrentSchemaName ti sessionId conn = do
125 ret <- timeoutOrDie ti (currentSchemaName sessionId conn)
126 reply ret conn
128handleExecuteSchemaExpr :: Timeout -> SessionId -> Connection -> SchemaExpr -> Reply (Either RelationalError ())
129handleExecuteSchemaExpr ti sessionId conn schemaExpr = do
130 ret <- timeoutOrDie ti (executeSchemaExpr sessionId conn schemaExpr)
131 reply ret conn
133handleLogout :: Timeout -> Connection -> Reply Bool
134handleLogout _ =
135 --liftIO $ closeRemote_ conn
136 reply (pure True)
138handleTestTimeout :: Timeout -> SessionId -> Connection -> Reply Bool
139handleTestTimeout ti _ conn = do
140 ret <- timeoutOrDie ti (threadDelay 100000 >> pure True)
141 reply ret conn
143handleRetrieveSessionIsDirty :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Bool)
144handleRetrieveSessionIsDirty ti sessionId conn = do
145 ret <- timeoutOrDie ti (disconnectedTransactionIsDirty sessionId conn)
146 reply ret conn
148handleExecuteAutoMergeToHead :: Timeout -> SessionId -> Connection -> MergeStrategy -> HeadName -> Reply (Either RelationalError ())
149handleExecuteAutoMergeToHead ti sessionId conn strat headName' = do
150 ret <- timeoutOrDie ti (autoMergeToHead sessionId conn strat headName')
151 reply ret conn
153handleRetrieveTypeConstructorMapping :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError TypeConstructorMapping)
154handleRetrieveTypeConstructorMapping ti sessionId conn = do
155 ret <- timeoutOrDie ti (C.typeConstructorMapping sessionId conn)
156 reply ret conn