git.iko.soy/project-m36
on 18f736a help sign in
project-m36/src/lib/ProjectM36/Server.hs
133 lines 8.2 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 (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),
45 handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),
46 handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn),
47 handleCall (\conn (ExecuteAutoMergeToHead sessionId strat headName') -> handleExecuteAutoMergeToHead ti sessionId conn strat headName'),
48 handleCall (\conn (RetrieveTypeConstructorMapping sessionId) -> handleRetrieveTypeConstructorMapping ti sessionId conn),
49 handleCall (\conn Logout -> handleLogout ti conn)
50 ] ++ testModeHandlers,
51 unhandledMessagePolicy = Terminate
52 --unhandledMessagePolicy = Log
53 }
54 where
55 testModeHandlers = if not testBool then
56 []
57 else
58 [handleCall (\conn (TestTimeout sessionId) -> handleTestTimeout ti sessionId conn)]
61initServer :: InitHandler (Connection, DatabaseName, Maybe (MVar EndPointAddress), EndPointAddress) Connection
62initServer (conn, dbname, mAddressMVar, saddress) = do
63 registerDB dbname
64 case mAddressMVar of
65 Nothing -> pure ()
66 Just addressMVar -> liftIO $ putMVar addressMVar saddress
67 --traceShowM ("server started on " ++ show saddress)
68 pure $ InitOk conn Infinity
70registerDB :: DatabaseName -> Process ()
71registerDB dbname = do
72 self <- getSelfPid
73 let dbname' = remoteDBLookupName dbname
74 register dbname' self
75 --liftIO $ putStrLn $ "registered " ++ (show self) ++ " " ++ dbname'
77-- | A notification callback which logs the notification to stderr and does nothing else.
78loggingNotificationCallback :: NotificationCallback
79loggingNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received \"" ++ show notName ++ "\": " ++ show evaldNot
81checkFSType :: Bool -> PersistenceStrategy -> IO Bool
82checkFSType performCheck strat =
83 case strat of
84 NoPersistence -> pure True
85 MinimalPersistence _ -> pure True
86 CrashSafePersistence path ->
87 if performCheck then do
88 -- if the path does not (yet) exist, then walk back a step- the db directory may not yet have been created
89 fullpathexists <- doesDirectoryExist path
90 let fscheckpath = if fullpathexists then
91 path
92 else
93 takeDirectory path
94 fsTypeSupportsJournaling fscheckpath
95 else
96 pure True
98checkFSErrorMsg :: String
99checkFSErrorMsg = "The filesystem does not support journaling so writes may not be crash-safe. Use --disable-fscheck to disable this fatal error."
101-- | 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.
102launchServer :: ServerConfig -> Maybe (MVar EndPointAddress) -> IO Bool
103launchServer daemonConfig mAddressMVar = do
104 checkFSResult <- checkFSType (checkFS daemonConfig) (persistenceStrategy daemonConfig)
105 if not checkFSResult then do
106 hPutStrLn stderr checkFSErrorMsg
107 pure False
108 else do
109 econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig))
110 case econn of
111 Left err -> do
112 hPutStrLn stderr ("Failed to create database connection: " ++ show err)
113 pure False
114 Right conn -> do
115 let hostname = bindHost daemonConfig
116 port = bindPort daemonConfig
117 etransport <- createTransport hostname (show port) defaultTCPParameters
118 case etransport of
119 Left err -> error ("failed to create transport: " ++ show err)
120 Right transport -> do
121 eEndpoint <- newEndPoint transport
122 case eEndpoint of
123 Left err -> hPutStrLn stderr ("Failed to create transport: " ++ show err) >> pure False
124 Right endpoint -> do
125 localTCPNode <- newLocalNode transport initRemoteTable
126 --traceShowM ("newLocalNode in Server " ++ show (localNodeId localTCPNode))
127 runProcess localTCPNode $ do
128 let testBool = testMode daemonConfig
129 reqTimeout = perRequestTimeout daemonConfig
130 serve (conn, databaseName daemonConfig, mAddressMVar, address endpoint) initServer (serverDefinition testBool reqTimeout)
131 liftIO $ putStrLn "serve returned"
132 pure True