git.iko.soy/project-m36
on fd05d50 help sign in
project-m36/src/lib/ProjectM36/Server.hs
104 lines 6.9 kB history raw
1{-# LANGUAGE ScopedTypeVariables #-}
2module ProjectM36.Server where
4import ProjectM36.Client
5import ProjectM36.Server.EntryPoints
6import ProjectM36.Server.RemoteCallTypes
7import ProjectM36.Server.Config (ServerConfig(..))
9import Control.Monad.IO.Class (liftIO)
10import Network.Transport.TCP (createTransport, defaultTCPParameters)
11import Network.Transport (EndPointAddress(..), newEndPoint, address)
12import Control.Distributed.Process.Node (initRemoteTable, runProcess, newLocalNode, initRemoteTable)
13import Control.Distributed.Process.Extras.Time (Delay(..))
14import Control.Distributed.Process (Process, register, getSelfPid)
15import Control.Distributed.Process.ManagedProcess (defaultProcess, UnhandledMessagePolicy(..), ProcessDefinition(..), handleCall, serve, InitHandler, InitResult(..))
16import Control.Concurrent.MVar (putMVar, MVar)
17import System.IO (stderr, hPutStrLn)
19-- the state should be a mapping of remote connection to the disconnected transaction- the graph should be the same, so discon must be removed from the stm tuple
20--trying to refactor this for less repetition is very challenging because the return type cannot be polymorphic or the distributed-process call gets confused and drops messages
21serverDefinition :: Bool -> Timeout -> ProcessDefinition Connection
22serverDefinition testBool ti = defaultProcess {
23 apiHandlers = [
24 handleCall (\conn (ExecuteHeadName sessionId) -> handleExecuteHeadName ti sessionId conn),
25 handleCall (\conn (ExecuteRelationalExpr sessionId expr) -> handleExecuteRelationalExpr ti sessionId conn expr),
26 handleCall (\conn (ExecuteDatabaseContextExpr sessionId expr) -> handleExecuteDatabaseContextExpr ti sessionId conn expr),
27 handleCall (\conn (ExecuteDatabaseContextIOExpr sessionId expr) -> handleExecuteDatabaseContextIOExpr ti sessionId conn expr),
28 handleCall (\conn (ExecuteGraphExpr sessionId expr) -> handleExecuteGraphExpr ti sessionId conn expr),
29 handleCall (\conn (ExecuteTransGraphRelationalExpr sessionId expr) -> handleExecuteTransGraphRelationalExpr ti sessionId conn expr),
30 handleCall (\conn (ExecuteTypeForRelationalExpr sessionId expr) -> handleExecuteTypeForRelationalExpr ti sessionId conn expr),
31 handleCall (\conn (RetrieveInclusionDependencies sessionId) -> handleRetrieveInclusionDependencies ti sessionId conn),
32 handleCall (\conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr) -> handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr),
33 handleCall (\conn (RetrieveHeadTransactionId sessionId) -> handleRetrieveHeadTransactionId ti sessionId conn),
34 handleCall (\conn (RetrieveTransactionGraph sessionId) -> handleRetrieveTransactionGraph ti sessionId conn),
35 handleCall (\conn (Login procId) -> handleLogin ti conn procId),
36 handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead ti conn headn),
37 handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit ti conn commitId),
38 handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn),
39 handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn),
40 handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn),
41 handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),
42 handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),
43 handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn),
44 handleCall (\conn (ExecuteAutoMergeToHead sessionId strat headName') -> handleExecuteAutoMergeToHead ti sessionId conn strat headName'),
45 handleCall (\conn Logout -> handleLogout ti conn)
46 ] ++ testModeHandlers,
47 unhandledMessagePolicy = Terminate
48 --unhandledMessagePolicy = Log
49 }
50 where
51 testModeHandlers = if not testBool then
52 []
53 else
54 [handleCall (\conn (TestTimeout sessionId) -> handleTestTimeout ti sessionId conn)]
57initServer :: InitHandler (Connection, DatabaseName, Maybe (MVar EndPointAddress), EndPointAddress) Connection
58initServer (conn, dbname, mAddressMVar, saddress) = do
59 registerDB dbname
60 case mAddressMVar of
61 Nothing -> pure ()
62 Just addressMVar -> liftIO $ putMVar addressMVar saddress
63 --traceShowM ("server started on " ++ show saddress)
64 pure $ InitOk conn Infinity
66registerDB :: DatabaseName -> Process ()
67registerDB dbname = do
68 self <- getSelfPid
69 let dbname' = remoteDBLookupName dbname
70 register dbname' self
71 --liftIO $ putStrLn $ "registered " ++ (show self) ++ " " ++ dbname'
73-- | A notification callback which logs the notification to stderr and does nothing else.
74loggingNotificationCallback :: NotificationCallback
75loggingNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received \"" ++ show notName ++ "\": " ++ show evaldNot
77-- | A synchronous function to start the project-m36 daemon given an appropriate 'ServerConfig'. Note that this function only returns if the server exits. Returns False if the daemon exited due to an error. If the second argument is not Nothing, the port is put after the server is ready to service the port.
78launchServer :: ServerConfig -> Maybe (MVar EndPointAddress) -> IO Bool
79launchServer daemonConfig mAddressMVar = do
80 econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig))
81 case econn of
82 Left err -> do
83 hPutStrLn stderr ("Failed to create database connection: " ++ show err)
84 pure False
85 Right conn -> do
86 let hostname = bindHost daemonConfig
87 port = bindPort daemonConfig
88 etransport <- createTransport hostname (show port) defaultTCPParameters
89 case etransport of
90 Left err -> error ("failed to create transport: " ++ show err)
91 Right transport -> do
92 eEndpoint <- newEndPoint transport
93 case eEndpoint of
94 Left err -> hPutStrLn stderr ("Failed to create transport: " ++ show err) >> pure False
95 Right endpoint -> do
96 localTCPNode <- newLocalNode transport initRemoteTable
97 --traceShowM ("newLocalNode in Server " ++ show (localNodeId localTCPNode))
98 runProcess localTCPNode $ do
99 let testBool = testMode daemonConfig
100 reqTimeout = perRequestTimeout daemonConfig
101 serve (conn, databaseName daemonConfig, mAddressMVar, address endpoint) initServer (serverDefinition testBool reqTimeout)
102 liftIO $ putStrLn "serve returned"
103 pure True