{-# 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 :: Bool -> Maybe Timeout -> RequestHandlers ServerState
requestHandlers Bool
testFlag Maybe Timeout
ti =
  [
    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 Bool
handleLogin Connection
conn (forall a. ConnectionState a -> Locking Socket
connectionSocket ConnectionState ServerState
sState)),
     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 Bool
handleLogout Maybe Timeout
ti Connection
conn),
    forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler forall a b. (a -> b) -> a -> b
$ \ConnectionState ServerState
sState (ExecuteHeadName TransactionId
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
-> TransactionId
-> Connection
-> IO (Either RelationalError NotificationName)
handleExecuteHeadName Maybe Timeout
ti TransactionId
sessionId Connection
conn,
    forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteRelationalExpr TransactionId
sessionId RelationalExpr
expr) -> do
                       Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState                        
                       Maybe Timeout
-> TransactionId
-> Connection
-> RelationalExpr
-> IO (Either RelationalError Relation)
handleExecuteRelationalExpr Maybe Timeout
ti TransactionId
sessionId Connection
conn RelationalExpr
expr),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteDataFrameExpr TransactionId
sessionId DataFrameExpr
expr) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> DataFrameExpr
-> IO (Either RelationalError DataFrame)
handleExecuteDataFrameExpr Maybe Timeout
ti TransactionId
sessionId Connection
conn DataFrameExpr
expr),     
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteDatabaseContextExpr TransactionId
sessionId DatabaseContextExpr
expr) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> DatabaseContextExpr
-> IO (Either RelationalError ())
handleExecuteDatabaseContextExpr Maybe Timeout
ti TransactionId
sessionId Connection
conn DatabaseContextExpr
expr),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteDatabaseContextIOExpr TransactionId
sessionId DatabaseContextIOExpr
expr) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> DatabaseContextIOExpr
-> IO (Either RelationalError ())
handleExecuteDatabaseContextIOExpr Maybe Timeout
ti TransactionId
sessionId Connection
conn DatabaseContextIOExpr
expr),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteGraphExpr TransactionId
sessionId TransactionGraphOperator
expr) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> TransactionGraphOperator
-> IO (Either RelationalError ())
handleExecuteGraphExpr Maybe Timeout
ti TransactionId
sessionId Connection
conn TransactionGraphOperator
expr),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteTransGraphRelationalExpr TransactionId
sessionId TransGraphRelationalExpr
expr) -> do
                       Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                       Maybe Timeout
-> TransactionId
-> Connection
-> TransGraphRelationalExpr
-> IO (Either RelationalError Relation)
handleExecuteTransGraphRelationalExpr Maybe Timeout
ti TransactionId
sessionId Connection
conn TransGraphRelationalExpr
expr),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteTypeForRelationalExpr TransactionId
sessionId RelationalExpr
expr) -> do
                       Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState                        
                       Maybe Timeout
-> TransactionId
-> Connection
-> RelationalExpr
-> IO (Either RelationalError Relation)
handleExecuteTypeForRelationalExpr Maybe Timeout
ti TransactionId
sessionId Connection
conn RelationalExpr
expr),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveInclusionDependencies TransactionId
sessionId) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> IO
     (Either RelationalError (Map NotificationName InclusionDependency))
handleRetrieveInclusionDependencies Maybe Timeout
ti TransactionId
sessionId Connection
conn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrievePlanForDatabaseContextExpr TransactionId
sessionId DatabaseContextExpr
dbExpr) -> do
                       Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState                        
                       Maybe Timeout
-> TransactionId
-> Connection
-> DatabaseContextExpr
-> IO (Either RelationalError GraphRefDatabaseContextExpr)
handleRetrievePlanForDatabaseContextExpr Maybe Timeout
ti TransactionId
sessionId Connection
conn DatabaseContextExpr
dbExpr),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveHeadTransactionId TransactionId
sessionId) -> do
                       Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState                        
                       Maybe Timeout
-> TransactionId
-> Connection
-> IO (Either RelationalError TransactionId)
handleRetrieveHeadTransactionId Maybe Timeout
ti TransactionId
sessionId Connection
conn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveTransactionGraph TransactionId
sessionId) -> do
                       Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState                        
                       Maybe Timeout
-> TransactionId
-> Connection
-> IO (Either RelationalError Relation)
handleRetrieveTransactionGraph Maybe Timeout
ti TransactionId
sessionId Connection
conn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (CreateSessionAtHead NotificationName
headn) -> do
                       Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState                        
                       Maybe Timeout
-> Connection
-> NotificationName
-> IO (Either RelationalError TransactionId)
handleCreateSessionAtHead Maybe Timeout
ti Connection
conn NotificationName
headn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (CreateSessionAtCommit TransactionId
commitId) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> Connection
-> TransactionId
-> IO (Either RelationalError TransactionId)
handleCreateSessionAtCommit Maybe Timeout
ti Connection
conn TransactionId
commitId),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (CloseSession TransactionId
sessionId) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState                 
                        TransactionId -> Connection -> IO ()
handleCloseSession TransactionId
sessionId Connection
conn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveAtomTypesAsRelation TransactionId
sessionId) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState                                         
                        Maybe Timeout
-> TransactionId
-> Connection
-> IO (Either RelationalError Relation)
handleRetrieveAtomTypesAsRelation Maybe Timeout
ti TransactionId
sessionId Connection
conn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveRelationVariableSummary TransactionId
sessionId) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState                        
                        Maybe Timeout
-> TransactionId
-> Connection
-> IO (Either RelationalError Relation)
handleRetrieveRelationVariableSummary Maybe Timeout
ti TransactionId
sessionId Connection
conn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveAtomFunctionSummary TransactionId
sessionId) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> IO (Either RelationalError Relation)
handleRetrieveAtomFunctionSummary Maybe Timeout
ti TransactionId
sessionId Connection
conn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveDatabaseContextFunctionSummary TransactionId
sessionId) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> IO (Either RelationalError Relation)
handleRetrieveDatabaseContextFunctionSummary Maybe Timeout
ti TransactionId
sessionId Connection
conn),     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveCurrentSchemaName TransactionId
sessionId) -> do
                       Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                       Maybe Timeout
-> TransactionId
-> Connection
-> IO (Either RelationalError NotificationName)
handleRetrieveCurrentSchemaName Maybe Timeout
ti TransactionId
sessionId Connection
conn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteSchemaExpr TransactionId
sessionId SchemaExpr
schemaExpr) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> SchemaExpr
-> IO (Either RelationalError ())
handleExecuteSchemaExpr Maybe Timeout
ti TransactionId
sessionId Connection
conn SchemaExpr
schemaExpr),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveSessionIsDirty TransactionId
sessionId) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId -> Connection -> IO (Either RelationalError Bool)
handleRetrieveSessionIsDirty Maybe Timeout
ti TransactionId
sessionId Connection
conn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteAutoMergeToHead TransactionId
sessionId MergeStrategy
strat NotificationName
headName') -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState                        
                        Maybe Timeout
-> TransactionId
-> Connection
-> MergeStrategy
-> NotificationName
-> IO (Either RelationalError ())
handleExecuteAutoMergeToHead Maybe Timeout
ti TransactionId
sessionId Connection
conn MergeStrategy
strat NotificationName
headName'),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveTypeConstructorMapping TransactionId
sessionId) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> IO (Either RelationalError TypeConstructorMapping)
handleRetrieveTypeConstructorMapping Maybe Timeout
ti TransactionId
sessionId Connection
conn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ExecuteValidateMerkleHashes TransactionId
sessionId) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState                        
                        Maybe Timeout
-> TransactionId -> Connection -> IO (Either RelationalError ())
handleValidateMerkleHashes Maybe Timeout
ti TransactionId
sessionId Connection
conn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (GetDDLHash TransactionId
sessionId) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> IO (Either RelationalError SecureHash)
handleGetDDLHash Maybe Timeout
ti TransactionId
sessionId Connection
conn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveDDLAsRelation TransactionId
sessionId) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> IO (Either RelationalError Relation)
handleRetrieveDDLAsRelation Maybe Timeout
ti TransactionId
sessionId Connection
conn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveRegisteredQueries TransactionId
sessionId) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> IO (Either RelationalError Relation)
handleRetrieveRegisteredQueries Maybe Timeout
ti TransactionId
sessionId Connection
conn),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ConvertSQLQuery TransactionId
sessionId Query
q) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> Query
-> IO (Either RelationalError DataFrameExpr)
handleConvertSQLQuery Maybe Timeout
ti TransactionId
sessionId Connection
conn Query
q),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (ConvertSQLUpdates TransactionId
sessionId [DBUpdate]
updates) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> [DBUpdate]
-> IO (Either RelationalError DatabaseContextExpr)
handleConvertSQLUpdates Maybe Timeout
ti TransactionId
sessionId Connection
conn [DBUpdate]
updates),
     forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (RetrieveNotificationsAsRelation TransactionId
sessionId) -> do
                        Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                        Maybe Timeout
-> TransactionId
-> Connection
-> IO (Either RelationalError Relation)
handleRetrieveNotificationsAsRelation Maybe Timeout
ti TransactionId
sessionId Connection
conn)
     ] forall a. [a] -> [a] -> [a]
++ if Bool
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 = forall a. Locking a -> a
lockless (forall a. ConnectionState a -> Locking Socket
connectionSocket ConnectionState ServerState
connState)
      sState :: ServerState
sState = 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 -> forall a. HasCallStack => DatabaseName -> a
error DatabaseName
"failed to find socket in client map"
    Just Connection
conn -> 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 = [forall a b serverState.
(Serialise a, Serialise b) =>
(ConnectionState serverState -> a -> IO b)
-> RequestHandler serverState
RequestHandler (\ConnectionState ServerState
sState (TestTimeout TransactionId
sessionId) -> do
                                          Connection
conn <- ConnectionState ServerState -> IO Connection
getConn ConnectionState ServerState
sState
                                          Maybe Timeout -> TransactionId -> Connection -> IO Bool
handleTestTimeout Maybe Timeout
ti TransactionId
sessionId Connection
conn)]

                 
-- | A notification callback which logs the notification to stderr and does nothing else.
loggingNotificationCallback :: NotificationCallback
loggingNotificationCallback :: NotificationCallback
loggingNotificationCallback NotificationName
notName EvaluatedNotification
evaldNot = Handle -> DatabaseName -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ DatabaseName
"Notification received \"" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> DatabaseName
show NotificationName
notName forall a. [a] -> [a] -> [a]
++ DatabaseName
"\": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> DatabaseName
show EvaluatedNotification
evaldNot

checkFSType :: Bool -> PersistenceStrategy -> IO Bool  
checkFSType :: Bool -> PersistenceStrategy -> IO Bool
checkFSType Bool
performCheck PersistenceStrategy
strat = 
  case PersistenceStrategy
strat of 
    PersistenceStrategy
NoPersistence -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    MinimalPersistence DatabaseName
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    CrashSafePersistence DatabaseName
path -> 
      if Bool
performCheck then do
        -- if the path does not (yet) exist, then walk back a step- the db directory may not yet have been created
        Bool
fullpathexists <- DatabaseName -> IO Bool
doesDirectoryExist DatabaseName
path
        let fscheckpath :: DatabaseName
fscheckpath = if Bool
fullpathexists then
                           DatabaseName
path
                          else
                           DatabaseName -> DatabaseName
takeDirectory DatabaseName
path
        DatabaseName -> IO Bool
fsTypeSupportsJournaling DatabaseName
fscheckpath
      else
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
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 (forall a. ConnectionState a -> a
connectionServerState ConnectionState ServerState
cState)
      sock :: Socket
sock = forall a. Locking a -> a
lockless (forall a. ConnectionState a -> Locking Socket
connectionSocket ConnectionState ServerState
cState)
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
    Maybe DatabaseName
mVal <- forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
StmMap.lookup (forall a. Show a => a -> DatabaseName
show Socket
sock) Map DatabaseName DatabaseName
clientMap
    case Maybe DatabaseName
mVal of
      Maybe DatabaseName
Nothing -> forall key value.
Hashable key =>
value -> key -> Map key value -> STM ()
StmMap.insert DatabaseName
dbName (forall a. Show a => a -> DatabaseName
show Socket
sock) Map DatabaseName DatabaseName
clientMap
      Just DatabaseName
_ -> 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 =
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
    Maybe DatabaseName
mdbname <- forall key value.
Hashable key =>
key -> Map key value -> STM (Maybe value)
StmMap.lookup (forall a. Show a => a -> DatabaseName
show Socket
sock) (ServerState -> Map DatabaseName DatabaseName
stateClientMap ServerState
sState)
    case Maybe DatabaseName
mdbname of
      Maybe DatabaseName
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      Just DatabaseName
dbname -> 
        forall key value.
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 = 
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
  Map DatabaseName Connection
dbmap <- forall key value. STM (Map key value)
StmMap.new
  Map DatabaseName DatabaseName
clientMap <- forall key value. STM (Map key value)
StmMap.new
  forall key value.
Hashable key =>
value -> key -> Map key value -> STM ()
StmMap.insert Connection
conn DatabaseName
dbName Map DatabaseName Connection
dbmap
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 Bool
launchServer ServerConfig
daemonConfig Maybe (MVar SockAddr)
mAddr = do
  Bool
checkFSResult <- Bool -> PersistenceStrategy -> IO Bool
checkFSType (ServerConfig -> Bool
checkFS ServerConfig
daemonConfig) (ServerConfig -> PersistenceStrategy
persistenceStrategy ServerConfig
daemonConfig)
  if Bool -> Bool
not Bool
checkFSResult then do
    Handle -> DatabaseName -> IO ()
hPutStrLn Handle
stderr DatabaseName
checkFSErrorMsg
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    else do
      Either ConnectionError Connection
econn <- ConnectionInfo -> IO (Either ConnectionError Connection)
connectProjectM36 (PersistenceStrategy
-> NotificationCallback
-> [DatabaseName]
-> DatabaseContext
-> ConnectionInfo
InProcessConnectionInfo (ServerConfig -> PersistenceStrategy
persistenceStrategy ServerConfig
daemonConfig) NotificationCallback
loggingNotificationCallback (ServerConfig -> [DatabaseName]
ghcPkgPaths ServerConfig
daemonConfig) DatabaseContext
basicDatabaseContext)
      case Either ConnectionError Connection
econn of 
        Left ConnectionError
err -> do      
          Handle -> DatabaseName -> IO ()
hPutStrLn Handle
stderr (DatabaseName
"Failed to create database connection: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> DatabaseName
show ConnectionError
err)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        Right Connection
conn -> do
          let mTimeout :: Maybe Timeout
mTimeout = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                case ServerConfig -> Int
perRequestTimeout ServerConfig
daemonConfig of
                  Int
0 -> forall a. Maybe a
Nothing
                  Int
v -> forall a. a -> Maybe a
Just Int
v
          (SockSpec
sockSpec, SockAddr
sockAddr) <- RemoteServerAddress -> IO (SockSpec, SockAddr)
resolveRemoteServerAddress (ServerConfig -> RemoteServerAddress
bindAddress ServerConfig
daemonConfig)
          ServerState
sState <- DatabaseName -> Connection -> IO ServerState
initialServerState (ServerConfig -> DatabaseName
databaseName ServerConfig
daemonConfig) Connection
conn
          forall s.
RequestHandlers s
-> s -> SockSpec -> SockAddr -> Maybe (MVar SockAddr) -> IO Bool
serve (Bool -> Maybe Timeout -> RequestHandlers ServerState
requestHandlers (ServerConfig -> Bool
testMode ServerConfig
daemonConfig) Maybe Timeout
mTimeout) ServerState
sState SockSpec
sockSpec SockAddr
sockAddr Maybe (MVar SockAddr)
mAddr