{-# LANGUAGE ScopedTypeVariables #-}
module ProjectM36.Server where
import ProjectM36.Client
import ProjectM36.Server.EntryPoints
import ProjectM36.Server.RemoteCallTypes
import ProjectM36.Server.Config (ServerConfig(..))
import ProjectM36.FSType
import Control.Concurrent.MVar (MVar)
import System.IO (stderr, hPutStrLn)
import System.FilePath (takeDirectory)
import System.Directory (doesDirectoryExist)
import Network.RPC.Curryer.Server
import Network.Socket
import qualified StmContainers.Map as StmMap
import Control.Concurrent.STM
type TestMode = Bool
requestHandlers :: TestMode -> Maybe Timeout -> RequestHandlers ServerState
requestHandlers :: TestMode -> Maybe Timeout -> RequestHandlers ServerState
requestHandlers TestMode
testFlag Maybe Timeout
ti =
[
(ConnectionState ServerState -> Login -> IO TestMode)
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (Login DatabaseName
dbName) -> do
DatabaseName -> ConnectionState ServerState -> IO ()
addClientLogin DatabaseName
dbName ConnectionState ServerState
sState
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Connection -> Locking Socket -> IO TestMode
handleLogin Connection
conn (ConnectionState ServerState -> Locking Socket
forall a. ConnectionState a -> Locking Socket
connectionSocket ConnectionState ServerState
sState)),
(ConnectionState ServerState -> Logout -> IO TestMode)
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState Logout
Logout -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout -> Connection -> IO TestMode
handleLogout Maybe Timeout
ti Connection
conn),
(ConnectionState ServerState
-> ExecuteHeadName -> IO (Either RelationalError HeadName))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler ((ConnectionState ServerState
-> ExecuteHeadName -> IO (Either RelationalError HeadName))
-> RequestHandler ServerState)
-> (ConnectionState ServerState
-> ExecuteHeadName -> IO (Either RelationalError HeadName))
-> RequestHandler ServerState
forall a b. (a -> b) -> a -> b
$ \ConnectionState ServerState
sState (ExecuteHeadName SessionId
sessionId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId -> Connection -> IO (Either RelationalError HeadName)
handleExecuteHeadName Maybe Timeout
ti SessionId
sessionId Connection
conn,
(ConnectionState ServerState
-> ExecuteRelationalExpr -> IO (Either RelationalError Relation))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteRelationalExpr SessionId
sessionId RelationalExpr
expr) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId
-> Connection
-> RelationalExpr
-> IO (Either RelationalError Relation)
handleExecuteRelationalExpr Maybe Timeout
ti SessionId
sessionId Connection
conn RelationalExpr
expr),
(ConnectionState ServerState
-> ExecuteDataFrameExpr -> IO (Either RelationalError DataFrame))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteDataFrameExpr SessionId
sessionId DataFrameExpr
expr) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId
-> Connection
-> DataFrameExpr
-> IO (Either RelationalError DataFrame)
handleExecuteDataFrameExpr Maybe Timeout
ti SessionId
sessionId Connection
conn DataFrameExpr
expr),
(ConnectionState ServerState
-> ExecuteDatabaseContextExpr -> IO (Either RelationalError ()))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteDatabaseContextExpr SessionId
sessionId DatabaseContextExpr
expr) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId
-> Connection
-> DatabaseContextExpr
-> IO (Either RelationalError ())
handleExecuteDatabaseContextExpr Maybe Timeout
ti SessionId
sessionId Connection
conn DatabaseContextExpr
expr),
(ConnectionState ServerState
-> ExecuteDatabaseContextIOExpr -> IO (Either RelationalError ()))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteDatabaseContextIOExpr SessionId
sessionId DatabaseContextIOExpr
expr) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId
-> Connection
-> DatabaseContextIOExpr
-> IO (Either RelationalError ())
handleExecuteDatabaseContextIOExpr Maybe Timeout
ti SessionId
sessionId Connection
conn DatabaseContextIOExpr
expr),
(ConnectionState ServerState
-> ExecuteGraphExpr -> IO (Either RelationalError ()))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteGraphExpr SessionId
sessionId TransactionGraphOperator
expr) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId
-> Connection
-> TransactionGraphOperator
-> IO (Either RelationalError ())
handleExecuteGraphExpr Maybe Timeout
ti SessionId
sessionId Connection
conn TransactionGraphOperator
expr),
(ConnectionState ServerState
-> ExecuteTransGraphRelationalExpr
-> IO (Either RelationalError Relation))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteTransGraphRelationalExpr SessionId
sessionId TransGraphRelationalExpr
expr) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId
-> Connection
-> TransGraphRelationalExpr
-> IO (Either RelationalError Relation)
handleExecuteTransGraphRelationalExpr Maybe Timeout
ti SessionId
sessionId Connection
conn TransGraphRelationalExpr
expr),
(ConnectionState ServerState
-> ExecuteTypeForRelationalExpr
-> IO (Either RelationalError Relation))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteTypeForRelationalExpr SessionId
sessionId RelationalExpr
expr) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId
-> Connection
-> RelationalExpr
-> IO (Either RelationalError Relation)
handleExecuteTypeForRelationalExpr Maybe Timeout
ti SessionId
sessionId Connection
conn RelationalExpr
expr),
(ConnectionState ServerState
-> RetrieveInclusionDependencies
-> IO (Either RelationalError (Map HeadName InclusionDependency)))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveInclusionDependencies SessionId
sessionId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId
-> Connection
-> IO (Either RelationalError (Map HeadName InclusionDependency))
handleRetrieveInclusionDependencies Maybe Timeout
ti SessionId
sessionId Connection
conn),
(ConnectionState ServerState
-> RetrievePlanForDatabaseContextExpr
-> IO (Either RelationalError GraphRefDatabaseContextExpr))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrievePlanForDatabaseContextExpr SessionId
sessionId DatabaseContextExpr
dbExpr) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId
-> Connection
-> DatabaseContextExpr
-> IO (Either RelationalError GraphRefDatabaseContextExpr)
handleRetrievePlanForDatabaseContextExpr Maybe Timeout
ti SessionId
sessionId Connection
conn DatabaseContextExpr
dbExpr),
(ConnectionState ServerState
-> RetrieveHeadTransactionId
-> IO (Either RelationalError SessionId))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveHeadTransactionId SessionId
sessionId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId -> Connection -> IO (Either RelationalError SessionId)
handleRetrieveHeadTransactionId Maybe Timeout
ti SessionId
sessionId Connection
conn),
(ConnectionState ServerState
-> RetrieveTransactionGraph
-> IO (Either RelationalError Relation))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveTransactionGraph SessionId
sessionId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId -> Connection -> IO (Either RelationalError Relation)
handleRetrieveTransactionGraph Maybe Timeout
ti SessionId
sessionId Connection
conn),
(ConnectionState ServerState
-> CreateSessionAtHead -> IO (Either RelationalError SessionId))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (CreateSessionAtHead HeadName
headn) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> Connection -> HeadName -> IO (Either RelationalError SessionId)
handleCreateSessionAtHead Maybe Timeout
ti Connection
conn HeadName
headn),
(ConnectionState ServerState
-> CreateSessionAtCommit -> IO (Either RelationalError SessionId))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (CreateSessionAtCommit SessionId
commitId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> Connection -> SessionId -> IO (Either RelationalError SessionId)
handleCreateSessionAtCommit Maybe Timeout
ti Connection
conn SessionId
commitId),
(ConnectionState ServerState -> CloseSession -> IO ())
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (CloseSession SessionId
sessionId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
SessionId -> Connection -> IO ()
handleCloseSession SessionId
sessionId Connection
conn),
(ConnectionState ServerState
-> RetrieveAtomTypesAsRelation
-> IO (Either RelationalError Relation))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveAtomTypesAsRelation SessionId
sessionId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId -> Connection -> IO (Either RelationalError Relation)
handleRetrieveAtomTypesAsRelation Maybe Timeout
ti SessionId
sessionId Connection
conn),
(ConnectionState ServerState
-> RetrieveRelationVariableSummary
-> IO (Either RelationalError Relation))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveRelationVariableSummary SessionId
sessionId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId -> Connection -> IO (Either RelationalError Relation)
handleRetrieveRelationVariableSummary Maybe Timeout
ti SessionId
sessionId Connection
conn),
(ConnectionState ServerState
-> RetrieveAtomFunctionSummary
-> IO (Either RelationalError Relation))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveAtomFunctionSummary SessionId
sessionId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId -> Connection -> IO (Either RelationalError Relation)
handleRetrieveAtomFunctionSummary Maybe Timeout
ti SessionId
sessionId Connection
conn),
(ConnectionState ServerState
-> RetrieveDatabaseContextFunctionSummary
-> IO (Either RelationalError Relation))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveDatabaseContextFunctionSummary SessionId
sessionId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId -> Connection -> IO (Either RelationalError Relation)
handleRetrieveDatabaseContextFunctionSummary Maybe Timeout
ti SessionId
sessionId Connection
conn), (ConnectionState ServerState
-> RetrieveCurrentSchemaName
-> IO (Either RelationalError HeadName))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveCurrentSchemaName SessionId
sessionId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId -> Connection -> IO (Either RelationalError HeadName)
handleRetrieveCurrentSchemaName Maybe Timeout
ti SessionId
sessionId Connection
conn),
(ConnectionState ServerState
-> ExecuteSchemaExpr -> IO (Either RelationalError ()))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteSchemaExpr SessionId
sessionId SchemaExpr
schemaExpr) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId
-> Connection
-> SchemaExpr
-> IO (Either RelationalError ())
handleExecuteSchemaExpr Maybe Timeout
ti SessionId
sessionId Connection
conn SchemaExpr
schemaExpr),
(ConnectionState ServerState
-> RetrieveSessionIsDirty -> IO (Either RelationalError TestMode))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveSessionIsDirty SessionId
sessionId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId -> Connection -> IO (Either RelationalError TestMode)
handleRetrieveSessionIsDirty Maybe Timeout
ti SessionId
sessionId Connection
conn),
(ConnectionState ServerState
-> ExecuteAutoMergeToHead -> IO (Either RelationalError ()))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteAutoMergeToHead SessionId
sessionId MergeStrategy
strat HeadName
headName') -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId
-> Connection
-> MergeStrategy
-> HeadName
-> IO (Either RelationalError ())
handleExecuteAutoMergeToHead Maybe Timeout
ti SessionId
sessionId Connection
conn MergeStrategy
strat HeadName
headName'),
(ConnectionState ServerState
-> RetrieveTypeConstructorMapping
-> IO (Either RelationalError TypeConstructorMapping))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveTypeConstructorMapping SessionId
sessionId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId
-> Connection
-> IO (Either RelationalError TypeConstructorMapping)
handleRetrieveTypeConstructorMapping Maybe Timeout
ti SessionId
sessionId Connection
conn),
(ConnectionState ServerState
-> ExecuteValidateMerkleHashes -> IO (Either RelationalError ()))
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteValidateMerkleHashes SessionId
sessionId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout
-> SessionId -> Connection -> IO (Either RelationalError ())
handleValidateMerkleHashes Maybe Timeout
ti SessionId
sessionId Connection
conn)
] RequestHandlers ServerState
-> RequestHandlers ServerState -> RequestHandlers ServerState
forall a. [a] -> [a] -> [a]
++ if TestMode
testFlag then Maybe Timeout -> RequestHandlers ServerState
testModeHandlers Maybe Timeout
ti else []
getConn :: ConnectionState ServerState -> IO Connection
getConn :: ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
connState = do
let sock :: Socket
sock = Locking Socket -> Socket
forall a. Locking a -> a
lockless (ConnectionState ServerState -> Locking Socket
forall a. ConnectionState a -> Locking Socket
connectionSocket ConnectionState ServerState
connState)
sState :: ServerState
sState = ConnectionState ServerState -> ServerState
forall a. ConnectionState a -> a
connectionServerState ConnectionState ServerState
connState
Maybe Connection
mConn <- Socket -> ServerState -> IO (Maybe Connection)
connectionForClient Socket
sock ServerState
sState
case Maybe Connection
mConn of
Maybe Connection
Nothing -> DatabaseName -> IO Connection
forall a. HasCallStack => DatabaseName -> a
error DatabaseName
"failed to find socket in client map"
Just Connection
conn -> Connection -> IO Connection
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection
conn
testModeHandlers :: Maybe Timeout -> RequestHandlers ServerState
testModeHandlers :: Maybe Timeout -> RequestHandlers ServerState
testModeHandlers Maybe Timeout
ti = [(ConnectionState ServerState -> TestTimeout -> IO TestMode)
-> RequestHandler ServerState
forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (TestTimeout SessionId
sessionId) -> do
Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
Maybe Timeout -> SessionId -> Connection -> IO TestMode
handleTestTimeout Maybe Timeout
ti SessionId
sessionId Connection
conn)]
loggingNotificationCallback :: NotificationCallback
loggingNotificationCallback :: NotificationCallback
loggingNotificationCallback HeadName
notName EvaluatedNotification
evaldNot = Handle -> DatabaseName -> IO ()
hPutStrLn Handle
stderr (DatabaseName -> IO ()) -> DatabaseName -> IO ()
forall a b. (a -> b) -> a -> b
$ DatabaseName
"Notification received \"" DatabaseName -> DatabaseName -> DatabaseName
forall a. [a] -> [a] -> [a]
++ HeadName -> DatabaseName
forall a. Show a => a -> DatabaseName
show HeadName
notName DatabaseName -> DatabaseName -> DatabaseName
forall a. [a] -> [a] -> [a]
++ DatabaseName
"\": " DatabaseName -> DatabaseName -> DatabaseName
forall a. [a] -> [a] -> [a]
++ EvaluatedNotification -> DatabaseName
forall a. Show a => a -> DatabaseName
show EvaluatedNotification
evaldNot
checkFSType :: Bool -> PersistenceStrategy -> IO Bool
checkFSType :: TestMode -> PersistenceStrategy -> IO TestMode
checkFSType TestMode
performCheck PersistenceStrategy
strat =
case PersistenceStrategy
strat of
PersistenceStrategy
NoPersistence -> TestMode -> IO TestMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestMode
True
MinimalPersistence DatabaseName
_ -> TestMode -> IO TestMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestMode
True
CrashSafePersistence DatabaseName
path ->
if TestMode
performCheck then do
TestMode
fullpathexists <- DatabaseName -> IO TestMode
doesDirectoryExist DatabaseName
path
let fscheckpath :: DatabaseName
fscheckpath = if TestMode
fullpathexists then
DatabaseName
path
else
DatabaseName -> DatabaseName
takeDirectory DatabaseName
path
DatabaseName -> IO TestMode
fsTypeSupportsJournaling DatabaseName
fscheckpath
else
TestMode -> IO TestMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestMode
True
checkFSErrorMsg :: String
checkFSErrorMsg :: DatabaseName
checkFSErrorMsg = DatabaseName
"The filesystem does not support journaling so writes may not be crash-safe. Use --disable-fscheck to disable this fatal error."
type SocketString = String
data ServerState =
ServerState {
ServerState -> Map DatabaseName Connection
stateDBMap :: StmMap.Map DatabaseName Connection,
ServerState -> Map DatabaseName DatabaseName
stateClientMap :: StmMap.Map SocketString DatabaseName
}
addClientLogin :: DatabaseName -> ConnectionState ServerState -> IO ()
addClientLogin :: DatabaseName -> ConnectionState ServerState -> IO ()
addClientLogin DatabaseName
dbName ConnectionState ServerState
cState = do
let clientMap :: Map DatabaseName DatabaseName
clientMap = ServerState -> Map DatabaseName DatabaseName
stateClientMap (ConnectionState ServerState -> ServerState
forall a. ConnectionState a -> a
connectionServerState ConnectionState ServerState
cState)
sock :: Socket
sock = Locking Socket -> Socket
forall a. Locking a -> a
lockless (ConnectionState ServerState -> Locking Socket
forall a. ConnectionState a -> Locking Socket
connectionSocket ConnectionState ServerState
cState)
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Maybe DatabaseName
mVal <- DatabaseName
-> Map DatabaseName DatabaseName -> STM (Maybe DatabaseName)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
StmMap.lookup (Socket -> DatabaseName
forall a. Show a => a -> DatabaseName
show Socket
sock) Map DatabaseName DatabaseName
clientMap
case Maybe DatabaseName
mVal of
Maybe DatabaseName
Nothing -> DatabaseName
-> DatabaseName -> Map DatabaseName DatabaseName -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
StmMap.insert DatabaseName
dbName (Socket -> DatabaseName
forall a. Show a => a -> DatabaseName
show Socket
sock) Map DatabaseName DatabaseName
clientMap
Just DatabaseName
_ -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
connectionForClient :: Socket -> ServerState -> IO (Maybe Connection)
connectionForClient :: Socket -> ServerState -> IO (Maybe Connection)
connectionForClient Socket
sock ServerState
sState =
STM (Maybe Connection) -> IO (Maybe Connection)
forall a. STM a -> IO a
atomically (STM (Maybe Connection) -> IO (Maybe Connection))
-> STM (Maybe Connection) -> IO (Maybe Connection)
forall a b. (a -> b) -> a -> b
$ do
Maybe DatabaseName
mdbname <- DatabaseName
-> Map DatabaseName DatabaseName -> STM (Maybe DatabaseName)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
StmMap.lookup (Socket -> DatabaseName
forall a. Show a => a -> DatabaseName
show Socket
sock) (ServerState -> Map DatabaseName DatabaseName
stateClientMap ServerState
sState)
case Maybe DatabaseName
mdbname of
Maybe DatabaseName
Nothing -> Maybe Connection -> STM (Maybe Connection)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Connection
forall a. Maybe a
Nothing
Just DatabaseName
dbname ->
DatabaseName
-> Map DatabaseName Connection -> STM (Maybe Connection)
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
StmMap.lookup DatabaseName
dbname (ServerState -> Map DatabaseName Connection
stateDBMap ServerState
sState)
initialServerState :: DatabaseName -> Connection -> IO ServerState
initialServerState :: DatabaseName -> Connection -> IO ServerState
initialServerState DatabaseName
dbName Connection
conn =
STM ServerState -> IO ServerState
forall a. STM a -> IO a
atomically (STM ServerState -> IO ServerState)
-> STM ServerState -> IO ServerState
forall a b. (a -> b) -> a -> b
$ do
Map DatabaseName Connection
dbmap <- STM (Map DatabaseName Connection)
forall key value. STM (Map key value)
StmMap.new
Map DatabaseName DatabaseName
clientMap <- STM (Map DatabaseName DatabaseName)
forall key value. STM (Map key value)
StmMap.new
Connection -> DatabaseName -> Map DatabaseName Connection -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
StmMap.insert Connection
conn DatabaseName
dbName Map DatabaseName Connection
dbmap
ServerState -> STM ServerState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerState :: Map DatabaseName Connection
-> Map DatabaseName DatabaseName -> ServerState
ServerState { stateDBMap :: Map DatabaseName Connection
stateDBMap = Map DatabaseName Connection
dbmap, stateClientMap :: Map DatabaseName DatabaseName
stateClientMap = Map DatabaseName DatabaseName
clientMap })
launchServer :: ServerConfig -> Maybe (MVar SockAddr) -> IO Bool
launchServer :: ServerConfig -> Maybe (MVar SockAddr) -> IO TestMode
launchServer ServerConfig
daemonConfig Maybe (MVar SockAddr)
mAddr = do
TestMode
checkFSResult <- TestMode -> PersistenceStrategy -> IO TestMode
checkFSType (ServerConfig -> TestMode
checkFS ServerConfig
daemonConfig) (ServerConfig -> PersistenceStrategy
persistenceStrategy ServerConfig
daemonConfig)
if TestMode -> TestMode
not TestMode
checkFSResult then do
Handle -> DatabaseName -> IO ()
hPutStrLn Handle
stderr DatabaseName
checkFSErrorMsg
TestMode -> IO TestMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestMode
False
else do
Either ConnectionError Connection
econn <- ConnectionInfo -> IO (Either ConnectionError Connection)
connectProjectM36 (PersistenceStrategy
-> NotificationCallback -> [DatabaseName] -> ConnectionInfo
InProcessConnectionInfo (ServerConfig -> PersistenceStrategy
persistenceStrategy ServerConfig
daemonConfig) NotificationCallback
loggingNotificationCallback (ServerConfig -> [DatabaseName]
ghcPkgPaths ServerConfig
daemonConfig))
case Either ConnectionError Connection
econn of
Left ConnectionError
err -> do
Handle -> DatabaseName -> IO ()
hPutStrLn Handle
stderr (DatabaseName
"Failed to create database connection: " DatabaseName -> DatabaseName -> DatabaseName
forall a. [a] -> [a] -> [a]
++ ConnectionError -> DatabaseName
forall a. Show a => a -> DatabaseName
show ConnectionError
err)
TestMode -> IO TestMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestMode
False
Right Connection
conn -> do
let hostname :: DatabaseName
hostname = ServerConfig -> DatabaseName
bindHost ServerConfig
daemonConfig
port :: PortNumber
port = Port -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ServerConfig -> Port
bindPort ServerConfig
daemonConfig)
let addrHints :: AddrInfo
addrHints = AddrInfo
defaultHints { addrSocketType :: SocketType
addrSocketType = SocketType
Stream, addrFamily :: Family
addrFamily = Family
AF_INET }
[AddrInfo]
hostAddrs <- Maybe AddrInfo
-> Maybe DatabaseName -> Maybe DatabaseName -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
addrHints) (DatabaseName -> Maybe DatabaseName
forall a. a -> Maybe a
Just DatabaseName
hostname) Maybe DatabaseName
forall a. Maybe a
Nothing
case [AddrInfo]
hostAddrs of
[] -> Handle -> DatabaseName -> IO ()
hPutStrLn Handle
stderr (DatabaseName
"Failed to resolve: " DatabaseName -> DatabaseName -> DatabaseName
forall a. Semigroup a => a -> a -> a
<> DatabaseName
hostname) IO () -> IO TestMode -> IO TestMode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestMode -> IO TestMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestMode
False
(AddrInfo [AddrInfoFlag]
_ Family
_ SocketType
_ ProtocolNumber
_ (SockAddrInet PortNumber
_ Timeout
addr32) Maybe DatabaseName
_):[AddrInfo]
_ -> do
let hostAddr :: (Word8, Word8, Word8, Word8)
hostAddr = Timeout -> (Word8, Word8, Word8, Word8)
hostAddressToTuple Timeout
addr32
mTimeout :: Maybe Timeout
mTimeout = Int -> Timeout
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Timeout) -> Maybe Int -> Maybe Timeout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case ServerConfig -> Int
perRequestTimeout ServerConfig
daemonConfig of
Int
0 -> Maybe Int
forall a. Maybe a
Nothing
Int
v -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
v
ServerState
sState <- DatabaseName -> Connection -> IO ServerState
initialServerState (ServerConfig -> DatabaseName
databaseName ServerConfig
daemonConfig) Connection
conn
RequestHandlers ServerState
-> ServerState
-> (Word8, Word8, Word8, Word8)
-> PortNumber
-> Maybe (MVar SockAddr)
-> IO TestMode
forall s.
RequestHandlers s
-> s
-> (Word8, Word8, Word8, Word8)
-> PortNumber
-> Maybe (MVar SockAddr)
-> IO TestMode
serve (TestMode -> Maybe Timeout -> RequestHandlers ServerState
requestHandlers (ServerConfig -> TestMode
testMode ServerConfig
daemonConfig) Maybe Timeout
mTimeout) ServerState
sState (Word8, Word8, Word8, Word8)
hostAddr PortNumber
port Maybe (MVar SockAddr)
mAddr
[AddrInfo]
_ -> DatabaseName -> IO TestMode
forall a. HasCallStack => DatabaseName -> a
error DatabaseName
"unsupported socket addressing mode (IPv4 only currently)"