{-# 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
      --socket -> dbname --maybe create a socket->client state mapping in the server state, too
      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)]

                 
-- | A notification callback which logs the notification to stderr and does nothing else.
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
        -- if the path does not (yet) exist, then walk back a step- the db directory may not yet have been created
        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."

-- Sockets do not implement hashable, so we just use their string values as keys
type SocketString = String

data ServerState =
  ServerState {
  --map available databases to local database configurations
  ServerState -> Map DatabaseName Connection
stateDBMap :: StmMap.Map DatabaseName Connection,
  --map clients to database names- after logging in, clients are afixed to specific database names
  ServerState -> Map DatabaseName DatabaseName
stateClientMap :: StmMap.Map SocketString DatabaseName
  }

-- add a client socket to the database mapping
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 () --TODO: throw exception- user already logged in
  
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 })
-- | 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.
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)


          --curryer only supports IPv4 for now
          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)"