Server.hs

{-# 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
import qualified Data.Text as T
import System.Random (initStdGen)

type TestMode = Bool

requestHandlers :: TestMode -> Maybe Timeout -> RequestHandlers ServerState
requestHandlers testFlag ti =
  [
    RequestHandler (\sState (Login dbName roleName) -> do
                       addClientLogin dbName sState
                       conn <- getConn sState
                       let roleNameFromMutualTLS = connectionRoleName sState
                           roleName' = maybe roleName T.pack roleNameFromMutualTLS
                           clientId = connectionClientId sState
                       handleLogin conn clientId (connectionSocketContext sState) roleName'),
     RequestHandler (\sState Logout -> do
                        conn <- getConn sState                        
                        handleLogout ti conn),
    RequestHandler $ \sState (ExecuteHeadName sessionId) -> do
      --socket -> dbname --maybe create a socket->client state mapping in the server state, too
      conn <- getConn sState
      handleExecuteCurrentHead ti sessionId conn,
    RequestHandler (\sState (ExecuteRelationalExpr sessionId expr) -> do
                       conn <- getConn sState
                       handleExecuteRelationalExpr ti sessionId conn expr),
     RequestHandler (\sState (ExecuteDataFrameExpr sessionId expr) -> do
                        conn <- getConn sState
                        handleExecuteDataFrameExpr ti sessionId conn expr),     
     RequestHandler (\sState (ExecuteDatabaseContextExpr sessionId expr) -> do
                        conn <- getConn sState
                        handleExecuteDatabaseContextExpr ti sessionId conn expr),
     RequestHandler (\sState (ExecuteDatabaseContextIOExpr sessionId expr) -> do
                        conn <- getConn sState
                        handleExecuteDatabaseContextIOExpr ti sessionId conn expr),
     RequestHandler (\sState (ExecuteGraphExpr sessionId expr) -> do
                        conn <- getConn sState
                        handleExecuteTransactionGraphExpr ti sessionId conn expr),
     RequestHandler (\sState (ExecuteTransGraphRelationalExpr sessionId expr) -> do
                       conn <- getConn sState
                       handleExecuteTransGraphRelationalExpr ti sessionId conn expr),
     RequestHandler (\sState (ExecuteTypeForRelationalExpr sessionId expr) -> do
                       conn <- getConn sState                        
                       handleExecuteTypeForRelationalExpr ti sessionId conn expr),
     RequestHandler (\sState (RetrieveInclusionDependencies sessionId) -> do
                        conn <- getConn sState
                        handleRetrieveInclusionDependencies ti sessionId conn),
     RequestHandler (\sState (RetrievePlanForDatabaseContextExpr sessionId dbExpr) -> do
                       conn <- getConn sState                        
                       handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr),
     RequestHandler (\sState (RetrievePlanForRelationalExpr sessionId expr) -> do
                       conn <- getConn sState                        
                       handleRetrievePlanForRelationalExpr ti sessionId conn expr),
     RequestHandler (\sState (RetrieveHeadTransactionId sessionId) -> do
                       conn <- getConn sState                        
                       handleRetrieveHeadTransactionId ti sessionId conn),
     RequestHandler (\sState (RetrieveTransactionGraph sessionId) -> do
                       conn <- getConn sState                        
                       handleRetrieveTransactionGraph ti sessionId conn),
     RequestHandler (\sState (CreateSessionAtHead headn) -> do
                       conn <- getConn sState                        
                       handleCreateSessionAtHead ti conn headn),
     RequestHandler (\sState (CreateSessionAtTransactionId commitId) -> do
                        conn <- getConn sState
                        handleCreateSessionAtTransactionId ti conn commitId),
     RequestHandler (\sState (CloseSession sessionId) -> do
                        conn <- getConn sState                 
                        handleCloseSession sessionId conn),
     RequestHandler (\sState (RetrieveAtomTypesAsRelation sessionId) -> do
                        conn <- getConn sState                                         
                        handleRetrieveAtomTypesAsRelation ti sessionId conn),
     RequestHandler (\sState (RetrieveRelationVariableSummary sessionId) -> do
                        conn <- getConn sState                        
                        handleRetrieveRelationVariableSummary ti sessionId conn),
     RequestHandler (\sState (RetrieveAtomFunctionSummary sessionId) -> do
                        conn <- getConn sState
                        handleRetrieveAtomFunctionSummary ti sessionId conn),
     RequestHandler (\sState (RetrieveDatabaseContextFunctionSummary sessionId) -> do
                        conn <- getConn sState
                        handleRetrieveDatabaseContextFunctionSummary ti sessionId conn),     RequestHandler (\sState (RetrieveCurrentSchemaName sessionId) -> do
                       conn <- getConn sState
                       handleRetrieveCurrentSchemaName ti sessionId conn),
     RequestHandler (\sState (ExecuteSchemaExpr sessionId schemaExpr) -> do
                        conn <- getConn sState
                        handleExecuteSchemaExpr ti sessionId conn schemaExpr),
     RequestHandler (\sState (RetrieveSessionIsDirty sessionId) -> do
                        conn <- getConn sState
                        handleRetrieveSessionIsDirty ti sessionId conn),
     RequestHandler (\sState (ExecuteAutoMergeToHead sessionId strat headName') -> do
                        conn <- getConn sState                        
                        handleExecuteAutoMergeToHead ti sessionId conn strat headName'),
     RequestHandler (\sState (RetrieveTypeConstructorMapping sessionId) -> do
                        conn <- getConn sState
                        handleRetrieveTypeConstructorMapping ti sessionId conn),
     RequestHandler (\sState (ExecuteValidateMerkleHashes sessionId) -> do
                        conn <- getConn sState                        
                        handleValidateMerkleHashes ti sessionId conn),
     RequestHandler (\sState (GetDDLHash sessionId) -> do
                        conn <- getConn sState
                        handleGetDDLHash ti sessionId conn),
     RequestHandler (\sState (RetrieveDDLAsRelation sessionId) -> do
                        conn <- getConn sState
                        handleRetrieveDDLAsRelation ti sessionId conn),
     RequestHandler (\sState (RetrieveRegisteredQueries sessionId) -> do
                        conn <- getConn sState
                        handleRetrieveRegisteredQueries ti sessionId conn),
     RequestHandler (\sState (ConvertSQLQuery sessionId q) -> do
                        conn <- getConn sState
                        handleConvertSQLQuery ti sessionId conn q),
     RequestHandler (\sState (ConvertSQLUpdates sessionId updates) -> do
                        conn <- getConn sState
                        handleConvertSQLUpdates ti sessionId conn updates),
     RequestHandler (\sState (RetrieveNotificationsAsRelation sessionId) -> do
                        conn <- getConn sState
                        handleRetrieveNotificationsAsRelation ti sessionId conn),
     RequestHandler (\sState (ExecuteAlterTransactionGraphExpr sessionId expr) -> do
                        conn <- getConn sState
                        handleExecuteAlterTransactionGraphExpr ti sessionId conn expr),
     RequestHandler (\sState (ExecuteAlterLoginRolesExpr sessionId expr) -> do
                        conn <- getConn sState
                        handleExecuteAlterLoginRolesExpr ti sessionId conn expr)
     ] ++ if testFlag then testModeHandlers ti else []

getConn :: ConnectionState ServerState -> IO Connection
getConn connState = do
  let sock = lockless (lockingSocket (connectionSocketContext connState))
      sState = connectionServerState connState
  mConn <- connectionForClient sock sState
  case mConn of
    Nothing -> error "failed to find socket in client map"
    Just conn@RemoteConnection{} -> pure conn
    Just conn@(InProcessConnection connInfo) -> do
      -- add role info
      let clientNodes = ipClientNodes connInfo
          clientId = connectionClientId connState
      mClientNode <- atomically $ StmMap.lookup clientId clientNodes
      let mRoleName = case mClientNode of
                        Nothing -> Nothing
                        Just InProcessClientInfo{} -> Nothing
                        Just (RemoteClientInfo _ roleName) -> Just roleName
      case mRoleName of
        Nothing -> pure conn
        Just roleName -> 
          pure (InProcessConnection (connInfo { ipRoleName = roleName }))

testModeHandlers :: Maybe Timeout -> RequestHandlers ServerState
testModeHandlers ti = [RequestHandler (\sState (TestTimeout sessionId) -> do
                                          conn <- getConn sState
                                          handleTestTimeout ti sessionId conn)]

                 
-- | A notification callback which logs the notification to stderr and does nothing else.
loggingNotificationCallback :: NotificationCallback
loggingNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received \"" ++ show notName ++ "\": " ++ show evaldNot

checkFSType :: Bool -> PersistenceStrategy -> IO Bool  
checkFSType performCheck strat = 
  case strat of 
    NoPersistence -> pure True
    MinimalPersistence _ -> pure True
    CrashSafePersistence path -> 
      if performCheck then do
        -- if the path does not (yet) exist, then walk back a step- the db directory may not yet have been created
        fullpathexists <- doesDirectoryExist path
        let fscheckpath = if fullpathexists then
                           path
                          else
                           takeDirectory path
        fsTypeSupportsJournaling fscheckpath
      else
        pure True
        
checkFSErrorMsg :: String        
checkFSErrorMsg = "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
  stateDBMap :: StmMap.Map DatabaseName Connection,
  --map clients to database names- after logging in, clients are afixed to specific database names
  stateClientMap :: StmMap.Map SocketString DatabaseName
  }

-- add a client socket to the database mapping
addClientLogin :: DatabaseName -> ConnectionState ServerState -> IO ()
addClientLogin dbName cState = do
  let clientMap = stateClientMap (connectionServerState cState)
      sock = lockless (lockingSocket (connectionSocketContext cState))
  atomically $ do
    mVal <- StmMap.lookup (show sock) clientMap
    case mVal of
      Nothing -> StmMap.insert dbName (show sock) clientMap
      Just _ -> pure () --TODO: throw exception- user already logged in
  
connectionForClient :: Socket -> ServerState -> IO (Maybe Connection)
connectionForClient sock sState =
  atomically $ do
    mdbname <- StmMap.lookup (show sock) (stateClientMap sState)
    case mdbname of
      Nothing -> pure Nothing
      Just dbname -> 
        StmMap.lookup dbname (stateDBMap sState)

initialServerState :: DatabaseName -> Connection -> IO ServerState
initialServerState dbName conn = 
  atomically $ do
  dbmap <- StmMap.new
  clientMap <- StmMap.new
  StmMap.insert conn dbName dbmap
  pure (ServerState { stateDBMap = dbmap, stateClientMap = 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 daemonConfig mAddr = do
  checkFSResult <- checkFSType (checkFS daemonConfig) (persistenceStrategy daemonConfig)
  if not checkFSResult then do
    hPutStrLn stderr checkFSErrorMsg
    pure False
    else do
      rando <- initStdGen
      econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig) basicDatabaseContext rando "admin")
      case econn of 
        Left err -> do      
          hPutStrLn stderr ("Failed to create database connection: " ++ show err)
          pure False
        Right conn -> do
          let mTimeout = fromIntegral <$>
                case perRequestTimeout daemonConfig of
                  0 -> Nothing
                  v -> Just v
          (sockSpec, sockAddr) <- resolveRemoteServerAddress (bindAddress daemonConfig)
          sState <- initialServerState (databaseName daemonConfig) conn
          serve (requestHandlers (testMode daemonConfig) mTimeout) sState (connConfig daemonConfig) sockSpec sockAddr mAddr