git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/lib/ProjectM36/Server.hs
139 lines 8.8 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(..))
8import ProjectM36.FSType
10import Control.Monad.IO.Class (liftIO)
11import Network.Transport.TCP (createTransport, defaultTCPParameters)
12import Network.Transport (EndPointAddress(..), newEndPoint, address)
13import Control.Distributed.Process.Node (initRemoteTable, runProcess, newLocalNode, initRemoteTable)
14import Control.Distributed.Process.Extras.Time (Delay(..))
15import Control.Distributed.Process (Process, register, getSelfPid)
16import Control.Distributed.Process.ManagedProcess (defaultProcess, UnhandledMessagePolicy(..), ProcessDefinition(..), handleCall, serve, InitHandler, InitResult(..))
17import Control.Concurrent.MVar (putMVar, MVar)
18import System.IO (stderr, hPutStrLn)
19import System.FilePath (takeDirectory)
20import System.Directory (doesDirectoryExist)
22-- 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
23--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
24serverDefinition :: Bool -> Timeout -> ProcessDefinition Connection
25serverDefinition testBool ti = defaultProcess {
26 apiHandlers = [
27 handleCall (\conn (ExecuteHeadName sessionId) -> handleExecuteHeadName ti sessionId conn),
28 handleCall (\conn (ExecuteRelationalExpr sessionId expr) -> handleExecuteRelationalExpr ti sessionId conn expr),
29 handleCall (\conn (ExecuteDataFrameExpr sessionId expr) -> handleExecuteDataFrameExpr ti sessionId conn expr),
30 handleCall (\conn (ExecuteDatabaseContextExpr sessionId expr) -> handleExecuteDatabaseContextExpr ti sessionId conn expr),
31 handleCall (\conn (ExecuteDatabaseContextIOExpr sessionId expr) -> handleExecuteDatabaseContextIOExpr ti sessionId conn expr),
32 handleCall (\conn (ExecuteGraphExpr sessionId expr) -> handleExecuteGraphExpr ti sessionId conn expr),
33 handleCall (\conn (ExecuteTransGraphRelationalExpr sessionId expr) -> handleExecuteTransGraphRelationalExpr ti sessionId conn expr),
34 handleCall (\conn (ExecuteTypeForRelationalExpr sessionId expr) -> handleExecuteTypeForRelationalExpr ti sessionId conn expr),
35 handleCall (\conn (RetrieveInclusionDependencies sessionId) -> handleRetrieveInclusionDependencies ti sessionId conn),
36 handleCall (\conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr) -> handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr),
37 handleCall (\conn (RetrieveHeadTransactionId sessionId) -> handleRetrieveHeadTransactionId ti sessionId conn),
38 handleCall (\conn (RetrieveTransactionGraph sessionId) -> handleRetrieveTransactionGraph ti sessionId conn),
39 handleCall (\conn (Login procId) -> handleLogin ti conn procId),
40 handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead ti conn headn),
41 handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit ti conn commitId),
42 handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn),
43 handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn),
44 handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn),
45 handleCall (\conn (RetrieveAtomFunctionSummary sessionId) -> handleRetrieveAtomFunctionSummary ti sessionId conn),
46 handleCall (\conn (RetrieveDatabaseContextFunctionSummary sessionId) -> handleRetrieveDatabaseContextFunctionSummary ti sessionId conn),
47 handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),
48 handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),
49 handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn),
50 handleCall (\conn (ExecuteAutoMergeToHead sessionId strat headName') -> handleExecuteAutoMergeToHead ti sessionId conn strat headName'),
51 handleCall (\conn (RetrieveTypeConstructorMapping sessionId) -> handleRetrieveTypeConstructorMapping ti sessionId conn),
52 handleCall (\conn Logout -> handleLogout ti conn)
53 ] ++ testModeHandlers,
54 unhandledMessagePolicy = Terminate
55 --unhandledMessagePolicy = Log
56 }
57 where
58 testModeHandlers = if not testBool then
59 []
60 else
61 [handleCall (\conn (TestTimeout sessionId) -> handleTestTimeout ti sessionId conn)]
64initServer :: InitHandler (Connection, DatabaseName, Maybe (MVar EndPointAddress), EndPointAddress) Connection
65initServer (conn, dbname, mAddressMVar, saddress) = do
66 registerDB dbname
67 case mAddressMVar of
68 Nothing -> pure ()
69 Just addressMVar -> liftIO $ putMVar addressMVar saddress
70 --traceShowM ("server started on " ++ show saddress)
71 pure $ InitOk conn Infinity
73registerDB :: DatabaseName -> Process ()
74registerDB dbname = do
75 self <- getSelfPid
76 let dbname' = remoteDBLookupName dbname
77 register dbname' self
78 --liftIO $ putStrLn $ "registered " ++ (show self) ++ " " ++ dbname'
80-- | A notification callback which logs the notification to stderr and does nothing else.
81loggingNotificationCallback :: NotificationCallback
82loggingNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received \"" ++ show notName ++ "\": " ++ show evaldNot
84checkFSType :: Bool -> PersistenceStrategy -> IO Bool
85checkFSType performCheck strat =
86 case strat of
87 NoPersistence -> pure True
88 MinimalPersistence _ -> pure True
89 CrashSafePersistence path ->
90 if performCheck then do
91 -- if the path does not (yet) exist, then walk back a step- the db directory may not yet have been created
92 fullpathexists <- doesDirectoryExist path
93 let fscheckpath = if fullpathexists then
94 path
95 else
96 takeDirectory path
97 fsTypeSupportsJournaling fscheckpath
98 else
99 pure True
101checkFSErrorMsg :: String
102checkFSErrorMsg = "The filesystem does not support journaling so writes may not be crash-safe. Use --disable-fscheck to disable this fatal error."
104-- | 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.
105launchServer :: ServerConfig -> Maybe (MVar EndPointAddress) -> IO Bool
106launchServer daemonConfig mAddressMVar = do
107 checkFSResult <- checkFSType (checkFS daemonConfig) (persistenceStrategy daemonConfig)
108 if not checkFSResult then do
109 hPutStrLn stderr checkFSErrorMsg
110 pure False
111 else do
112 econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig))
113 case econn of
114 Left err -> do
115 hPutStrLn stderr ("Failed to create database connection: " ++ show err)
116 pure False
117 Right conn -> do
118 let hostname = bindHost daemonConfig
119 port = bindPort daemonConfig
120#if MIN_VERSION_network_transport_tcp(0,6,0)
121 etransport <- createTransport hostname (show port) (\nam -> (hostname, nam)) defaultTCPParameters
122#else
123 etransport <- createTransport hostname (show port) defaultTCPParameters
124#endif
125 case etransport of
126 Left err -> error ("failed to create transport: " ++ show err)
127 Right transport -> do
128 eEndpoint <- newEndPoint transport
129 case eEndpoint of
130 Left err -> hPutStrLn stderr ("Failed to create transport: " ++ show err) >> pure False
131 Right endpoint -> do
132 localTCPNode <- newLocalNode transport initRemoteTable
133 --traceShowM ("newLocalNode in Server " ++ show (localNodeId localTCPNode))
134 runProcess localTCPNode $ do
135 let testBool = testMode daemonConfig
136 reqTimeout = perRequestTimeout daemonConfig
137 serve (conn, databaseName daemonConfig, mAddressMVar, address endpoint) initServer (serverDefinition testBool reqTimeout)
138 liftIO $ putStrLn "serve returned"
139 pure True