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