86c34e2 · project-m36 · git.iko.soy

git.iko.soy/project-m36

add timeout to EntryPoints.hs

EntryPoints.hs is essential because polymorphic handleCall return values confuse the call/return transmission and end up hanging the client or server

commit86c34e29ede655c9e030619d32528cf0c82c6e6b authorAgentM <agentm@themactionfaction.com> dateMon 16 Jan 2017, 14:05 (10 years ago) parentdff848d

5 files changed+107−86

compare with master

unifiedsplit

src/bin/TutorialD/tutd.hs+1−1 src/lib/ProjectM36/Server.hs+25−23 src/lib/ProjectM36/Server/Config.hs+4−2 src/lib/ProjectM36/Server/EntryPoints.hs+71−58 src/lib/ProjectM36/Server/ParseArgs.hs+6−2

src/bin/TutorialD/tutd.hs+1−1

@@ -5,7 +5,7 @@ import ProjectM36.Client

55import System.IO

66import Options.Applicative

77import System.Exit

8−#if __GLASGOW_HASKELL__ >= 800

8+#if __GLASGOW_HASKELL__ < 800

99import Data.Monoid

1010#endif

1111

src/lib/ProjectM36/Server.hs+25−23

@@ -12,36 +12,38 @@ import Control.Distributed.Process.Node (initRemoteTable, runProcess, newLocalNo

1212import Control.Distributed.Process.Extras.Time (Delay(..))

1313import Control.Distributed.Process (Process, register, RemoteTable, getSelfPid)

1414import Control.Distributed.Process.ManagedProcess (defaultProcess, UnhandledMessagePolicy(..), ProcessDefinition(..), handleCall, serve, InitHandler, InitResult(..))

15−import System.IO (hPutStrLn, stderr)

1615import qualified Control.Distributed.Process.Extras.Internal.Types as DIT

1716import Control.Concurrent.MVar (putMVar, MVar)

17+import System.IO (stderr, hPutStrLn)

1818

1919-- the state should be a mapping of remote connection to the disconnected transaction- the graph should be the same, so discon must be removed from the stm tuple

20−serverDefinition :: ProcessDefinition Connection

21−serverDefinition = defaultProcess {

20+--trying to refactor this for less repetition is very challenging because the return type cannot be polymorphic or the distributed-process call gets confused and drops messages

21+serverDefinition :: Timeout -> ProcessDefinition Connection

22+serverDefinition ti = defaultProcess {

2223 apiHandlers = [

23− handleCall (\conn (ExecuteHeadName sessionId) -> handleExecuteHeadName sessionId conn),

24− handleCall (\conn (ExecuteRelationalExpr sessionId expr) -> handleExecuteRelationalExpr sessionId conn expr),

25− handleCall (\conn (ExecuteDatabaseContextExpr sessionId expr) -> handleExecuteDatabaseContextExpr sessionId conn expr),

26− handleCall (\conn (ExecuteDatabaseContextIOExpr sessionId expr) -> handleExecuteDatabaseContextIOExpr sessionId conn expr),

27− handleCall (\conn (ExecuteGraphExpr sessionId expr) -> handleExecuteGraphExpr sessionId conn expr),

28− handleCall (\conn (ExecuteTransGraphRelationalExpr sessionId expr) -> handleExecuteTransGraphRelationalExpr sessionId conn expr),

29− handleCall (\conn (ExecuteTypeForRelationalExpr sessionId expr) -> handleExecuteTypeForRelationalExpr sessionId conn expr),

30− handleCall (\conn (RetrieveInclusionDependencies sessionId) -> handleRetrieveInclusionDependencies sessionId conn),

31− handleCall (\conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr) -> handleRetrievePlanForDatabaseContextExpr sessionId conn dbExpr),

32− handleCall (\conn (RetrieveHeadTransactionId sessionId) -> handleRetrieveHeadTransactionId sessionId conn),

33− handleCall (\conn (RetrieveTransactionGraph sessionId) -> handleRetrieveTransactionGraph sessionId conn),

34− handleCall (\conn (Login procId) -> handleLogin conn procId),

35− handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead headn conn),

36− handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit commitId conn),

37− handleCall (\conn (CloseSession sessionId) -> handleCloseSession sessionId conn),

38− handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation sessionId conn),

39− handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary sessionId conn),

40− handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName sessionId conn),

41− handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr sessionId conn schemaExpr)

24+ handleCall (\conn (ExecuteHeadName sessionId) -> handleExecuteHeadName ti sessionId conn),

25+ handleCall (\conn (ExecuteRelationalExpr sessionId expr) -> handleExecuteRelationalExpr ti sessionId conn expr),

26+ handleCall (\conn (ExecuteDatabaseContextExpr sessionId expr) -> handleExecuteDatabaseContextExpr ti sessionId conn expr),

27+ handleCall (\conn (ExecuteDatabaseContextIOExpr sessionId expr) -> handleExecuteDatabaseContextIOExpr ti sessionId conn expr),

28+ handleCall (\conn (ExecuteGraphExpr sessionId expr) -> handleExecuteGraphExpr ti sessionId conn expr),

29+ handleCall (\conn (ExecuteTransGraphRelationalExpr sessionId expr) -> handleExecuteTransGraphRelationalExpr ti sessionId conn expr),

30+ handleCall (\conn (ExecuteTypeForRelationalExpr sessionId expr) -> handleExecuteTypeForRelationalExpr ti sessionId conn expr),

31+ handleCall (\conn (RetrieveInclusionDependencies sessionId) -> handleRetrieveInclusionDependencies ti sessionId conn),

32+ handleCall (\conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr) -> handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr),

33+ handleCall (\conn (RetrieveHeadTransactionId sessionId) -> handleRetrieveHeadTransactionId ti sessionId conn),

34+ handleCall (\conn (RetrieveTransactionGraph sessionId) -> handleRetrieveTransactionGraph ti sessionId conn),

35+ handleCall (\conn (Login procId) -> handleLogin ti conn procId),

36+ handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead ti headn conn),

37+ handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit ti commitId conn),

38+ handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn),

39+ handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn),

40+ handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn),

41+ handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),

42+ handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr)

4243 ],

4344 unhandledMessagePolicy = Log

4445 }

46+

4547

4648initServer :: InitHandler (Connection, DatabaseName, Maybe (MVar Port), Port) Connection

4749initServer (conn, dbname, mPortMVar, portNum) = do

@@ -82,7 +84,7 @@ launchServer daemonConfig mPortMVar = do

8284 Right transport -> do

8385 localTCPNode <- newLocalNode transport remoteTable

8486 runProcess localTCPNode $ do

85− serve (conn, databaseName daemonConfig, mPortMVar, port) initServer serverDefinition

87+ serve (conn, databaseName daemonConfig, mPortMVar, port) initServer (serverDefinition (perRequestTimeout daemonConfig))

8688 liftIO $ putStrLn "serve returned"

8789 pure True

8890

src/lib/ProjectM36/Server/Config.hs+4−2

@@ -5,7 +5,8 @@ data ServerConfig = ServerConfig { persistenceStrategy :: PersistenceStrategy,

55 databaseName :: DatabaseName,

66 bindHost :: Hostname,

77 bindPort :: Port,

8− ghcPkgPaths :: [String] -- used for AtomFunction dynamic compilation

8+ ghcPkgPaths :: [String], -- used for AtomFunction dynamic compilation

9+ perRequestTimeout :: Int

910 }

1011

1112defaultServerConfig :: ServerConfig

@@ -13,5 +14,6 @@ defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence,

1314 databaseName = "base",

1415 bindHost = "127.0.0.1",

1516 bindPort = 6543,

16− ghcPkgPaths = []

17+ ghcPkgPaths = [],

18+ perRequestTimeout = 0

1719 }

src/lib/ProjectM36/Server/EntryPoints.hs+71−58

@@ -3,104 +3,117 @@ import ProjectM36.Base hiding (inclusionDependencies)

33import ProjectM36.IsomorphicSchema

44import ProjectM36.Client

55import ProjectM36.Error

6−import Control.Distributed.Process (Process, ProcessId)

6+import Control.Distributed.Process (Process, ProcessId, die)

77import Control.Distributed.Process.ManagedProcess (ProcessReply)

88import Control.Distributed.Process.ManagedProcess.Server (reply)

99import Control.Monad.IO.Class (liftIO)

1010import Data.Map

11+import System.Timeout

1112

12−handleExecuteRelationalExpr :: SessionId -> Connection -> RelationalExpr -> Process (ProcessReply (Either RelationalError Relation) Connection)

13−handleExecuteRelationalExpr sessionId conn expr = do

14− ret <- liftIO $ executeRelationalExpr sessionId conn expr

13+timeoutOrDie :: Int -> IO a -> Process a

14+timeoutOrDie micros act = do

15+ if micros == 0 then

16+ liftIO act

17+ else do

18+ mRes <- liftIO (timeout micros act)

19+ case mRes of

20+ Just res -> pure res

21+ Nothing -> die ("TIMEOUT" :: String)

22+

23+type Timeout = Int

24+

25+handleExecuteRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Process (ProcessReply (Either RelationalError Relation) Connection)

26+handleExecuteRelationalExpr ti sessionId conn expr = do

27+ ret <- timeoutOrDie ti (executeRelationalExpr sessionId conn expr)

1528 reply ret conn

1629

17−handleExecuteDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> Process (ProcessReply (Maybe RelationalError) Connection)

18−handleExecuteDatabaseContextExpr sessionId conn dbexpr = do

19− ret <- liftIO $ executeDatabaseContextExpr sessionId conn dbexpr

30+handleExecuteDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Process (ProcessReply (Maybe RelationalError) Connection)

31+handleExecuteDatabaseContextExpr ti sessionId conn dbexpr = do

32+ ret <- timeoutOrDie ti (executeDatabaseContextExpr sessionId conn dbexpr)

2033 reply ret conn

2134

22−handleExecuteDatabaseContextIOExpr :: SessionId -> Connection -> DatabaseContextIOExpr -> Process (ProcessReply (Maybe RelationalError) Connection)

23−handleExecuteDatabaseContextIOExpr sessionId conn dbexpr = do

24− ret <- liftIO $ executeDatabaseContextIOExpr sessionId conn dbexpr

35+handleExecuteDatabaseContextIOExpr :: Timeout -> SessionId -> Connection -> DatabaseContextIOExpr -> Process (ProcessReply (Maybe RelationalError) Connection)

36+handleExecuteDatabaseContextIOExpr ti sessionId conn dbexpr = do

37+ ret <- timeoutOrDie ti (executeDatabaseContextIOExpr sessionId conn dbexpr)

2538 reply ret conn

2639

27−handleExecuteHeadName :: SessionId -> Connection -> Process (ProcessReply (Maybe HeadName) Connection)

28−handleExecuteHeadName sessionId conn = do

29− ret <- liftIO $ headName sessionId conn

40+handleExecuteHeadName :: Timeout -> SessionId -> Connection -> Process (ProcessReply (Maybe HeadName) Connection)

41+handleExecuteHeadName ti sessionId conn = do

42+ ret <- timeoutOrDie ti (headName sessionId conn)

3043 reply ret conn

3144

32−handleLogin :: Connection -> ProcessId -> Process (ProcessReply Bool Connection)

33−handleLogin conn newClientProcessId = do

34− liftIO (addClientNode conn newClientProcessId)

45+handleLogin :: Timeout -> Connection -> ProcessId -> Process (ProcessReply Bool Connection)

46+handleLogin ti conn newClientProcessId = do

47+ _ <- timeoutOrDie ti (addClientNode conn newClientProcessId)

3548 reply True conn

3649

37−handleExecuteGraphExpr :: SessionId -> Connection -> TransactionGraphOperator -> Process (ProcessReply (Maybe RelationalError) Connection)

38−handleExecuteGraphExpr sessionId conn graphExpr = do

39− ret <- liftIO $ executeGraphExpr sessionId conn graphExpr

50+handleExecuteGraphExpr :: Timeout -> SessionId -> Connection -> TransactionGraphOperator -> Process (ProcessReply (Maybe RelationalError) Connection)

51+handleExecuteGraphExpr ti sessionId conn graphExpr = do

52+ ret <- timeoutOrDie ti (executeGraphExpr sessionId conn graphExpr)

4053 reply ret conn

4154

42−handleExecuteTransGraphRelationalExpr :: SessionId -> Connection -> TransGraphRelationalExpr -> Process (ProcessReply (Either RelationalError Relation) Connection)

43−handleExecuteTransGraphRelationalExpr sessionId conn graphExpr = do

44− ret <- liftIO $ executeTransGraphRelationalExpr sessionId conn graphExpr

55+handleExecuteTransGraphRelationalExpr :: Timeout -> SessionId -> Connection -> TransGraphRelationalExpr -> Process (ProcessReply (Either RelationalError Relation) Connection)

56+handleExecuteTransGraphRelationalExpr ti sessionId conn graphExpr = do

57+ ret <- timeoutOrDie ti (executeTransGraphRelationalExpr sessionId conn graphExpr)

4558 reply ret conn

4659

47−handleExecuteTypeForRelationalExpr :: SessionId -> Connection -> RelationalExpr -> Process (ProcessReply (Either RelationalError Relation) Connection)

48−handleExecuteTypeForRelationalExpr sessionId conn relExpr = do

49− ret <- liftIO $ typeForRelationalExpr sessionId conn relExpr

60+handleExecuteTypeForRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Process (ProcessReply (Either RelationalError Relation) Connection)

61+handleExecuteTypeForRelationalExpr ti sessionId conn relExpr = do

62+ ret <- timeoutOrDie ti (typeForRelationalExpr sessionId conn relExpr)

5063 reply ret conn

5164

52−handleRetrieveInclusionDependencies :: SessionId -> Connection -> Process (ProcessReply (Either RelationalError (Map IncDepName InclusionDependency)) Connection)

53−handleRetrieveInclusionDependencies sessionId conn = do

54− ret <- liftIO $ inclusionDependencies sessionId conn

65+handleRetrieveInclusionDependencies :: Timeout -> SessionId -> Connection -> Process (ProcessReply (Either RelationalError (Map IncDepName InclusionDependency)) Connection)

66+handleRetrieveInclusionDependencies ti sessionId conn = do

67+ ret <- timeoutOrDie ti (inclusionDependencies sessionId conn)

5568 reply ret conn

5669

57−handleRetrievePlanForDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> Process (ProcessReply (Either RelationalError DatabaseContextExpr) Connection)

58−handleRetrievePlanForDatabaseContextExpr sessionId conn dbExpr = do

59− ret <- liftIO $ planForDatabaseContextExpr sessionId conn dbExpr

70+handleRetrievePlanForDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Process (ProcessReply (Either RelationalError DatabaseContextExpr) Connection)

71+handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr = do

72+ ret <- timeoutOrDie ti (planForDatabaseContextExpr sessionId conn dbExpr)

6073 reply ret conn

6174

62−handleRetrieveTransactionGraph :: SessionId -> Connection -> Process (ProcessReply (Either RelationalError Relation) Connection)

63−handleRetrieveTransactionGraph sessionId conn = do

64− ret <- liftIO $ transactionGraphAsRelation sessionId conn

75+handleRetrieveTransactionGraph :: Timeout -> SessionId -> Connection -> Process (ProcessReply (Either RelationalError Relation) Connection)

76+handleRetrieveTransactionGraph ti sessionId conn = do

77+ ret <- timeoutOrDie ti (transactionGraphAsRelation sessionId conn)

6578 reply ret conn

6679

67−handleRetrieveHeadTransactionId :: SessionId -> Connection -> Process (ProcessReply (Maybe TransactionId) Connection)

68−handleRetrieveHeadTransactionId sessionId conn = do

69− ret <- liftIO $ headTransactionId sessionId conn

80+handleRetrieveHeadTransactionId :: Timeout -> SessionId -> Connection -> Process (ProcessReply (Maybe TransactionId) Connection)

81+handleRetrieveHeadTransactionId ti sessionId conn = do

82+ ret <- timeoutOrDie ti (headTransactionId sessionId conn)

7083 reply ret conn

7184

72−handleCreateSessionAtCommit :: TransactionId -> Connection -> Process (ProcessReply (Either RelationalError SessionId) Connection)

73−handleCreateSessionAtCommit commitId conn = do

74− ret <- liftIO $ createSessionAtCommit commitId conn

85+handleCreateSessionAtCommit :: Timeout -> TransactionId -> Connection -> Process (ProcessReply (Either RelationalError SessionId) Connection)

86+handleCreateSessionAtCommit ti commitId conn = do

87+ ret <- timeoutOrDie ti (createSessionAtCommit commitId conn)

7588 reply ret conn

7689

77−handleCreateSessionAtHead :: HeadName -> Connection -> Process (ProcessReply (Either RelationalError SessionId) Connection)

78−handleCreateSessionAtHead headn conn = do

79− ret <- liftIO $ createSessionAtHead headn conn

90+handleCreateSessionAtHead :: Timeout -> HeadName -> Connection -> Process (ProcessReply (Either RelationalError SessionId) Connection)

91+handleCreateSessionAtHead ti headn conn = do

92+ ret <- timeoutOrDie ti (createSessionAtHead headn conn)

8093 reply ret conn

8194

82−handleCloseSession :: SessionId -> Connection -> Process (ProcessReply () Connection)

83−handleCloseSession sessionId conn = do

84− liftIO $ closeSession sessionId conn

95+handleCloseSession :: Timeout -> SessionId -> Connection -> Process (ProcessReply () Connection)

96+handleCloseSession ti sessionId conn = do

97+ _ <- timeoutOrDie ti (closeSession sessionId conn)

8598 reply () conn

8699

87−handleRetrieveAtomTypesAsRelation :: SessionId -> Connection -> Process (ProcessReply (Either RelationalError Relation) Connection)

88−handleRetrieveAtomTypesAsRelation sessionId conn = do

89− ret <- liftIO $ atomTypesAsRelation sessionId conn

100+handleRetrieveAtomTypesAsRelation :: Timeout -> SessionId -> Connection -> Process (ProcessReply (Either RelationalError Relation) Connection)

101+handleRetrieveAtomTypesAsRelation ti sessionId conn = do

102+ ret <- timeoutOrDie ti (atomTypesAsRelation sessionId conn)

90103 reply ret conn

91104

92105-- | Returns a relation which lists the names of relvars in the current session as well as its types.

93−handleRetrieveRelationVariableSummary :: SessionId -> Connection -> Process (ProcessReply (Either RelationalError Relation) Connection)

94−handleRetrieveRelationVariableSummary sessionId conn = do

95− ret <- liftIO $ relationVariablesAsRelation sessionId conn

106+handleRetrieveRelationVariableSummary :: Timeout -> SessionId -> Connection -> Process (ProcessReply (Either RelationalError Relation) Connection)

107+handleRetrieveRelationVariableSummary ti sessionId conn = do

108+ ret <- timeoutOrDie ti (relationVariablesAsRelation sessionId conn)

96109 reply ret conn

97110

98−handleRetrieveCurrentSchemaName :: SessionId -> Connection -> Process (ProcessReply (Maybe SchemaName) Connection)

99−handleRetrieveCurrentSchemaName sessionId conn = do

100− ret <- liftIO $ currentSchemaName sessionId conn

111+handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Process (ProcessReply (Maybe SchemaName) Connection)

112+handleRetrieveCurrentSchemaName ti sessionId conn = do

113+ ret <- timeoutOrDie ti (currentSchemaName sessionId conn)

101114 reply ret conn

102115

103−handleExecuteSchemaExpr :: SessionId -> Connection -> SchemaExpr -> Process (ProcessReply (Maybe RelationalError) Connection)

104−handleExecuteSchemaExpr sessionId conn schemaExpr = do

105− ret <- liftIO $ executeSchemaExpr sessionId conn schemaExpr

116+handleExecuteSchemaExpr :: Timeout -> SessionId -> Connection -> SchemaExpr -> Process (ProcessReply (Maybe RelationalError) Connection)

117+handleExecuteSchemaExpr ti sessionId conn schemaExpr = do

118+ ret <- timeoutOrDie ti (executeSchemaExpr sessionId conn schemaExpr)

106119 reply ret conn

src/lib/ProjectM36/Server/ParseArgs.hs+6−2

@@ -6,7 +6,7 @@ import ProjectM36.Server.Config

66import Data.Monoid

88parseArgs :: Parser ServerConfig

9−parseArgs = ServerConfig <$> parsePersistenceStrategy <*> parseDatabaseName <*> parseHostname <*> parsePort <*> many parseGhcPkgPaths

9+parseArgs = ServerConfig <$> parsePersistenceStrategy <*> parseDatabaseName <*> parseHostname <*> parsePort <*> many parseGhcPkgPaths <*> parseTimeout

1010

1111parsePersistenceStrategy :: Parser PersistenceStrategy

1212parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>

@@ -42,8 +42,12 @@ parsePort = option auto (short 'p' <>

4242parseGhcPkgPaths :: Parser String

4343parseGhcPkgPaths = strOption (long "ghc-pkg-dir" <>

4444 metavar "GHC_PACKAGE_DIRECTORY")

45+

46+parseTimeout :: Parser Int

47+parseTimeout = option auto (long "timeout" <>

48+ metavar "MICROSECONDS" <>

49+ value (perRequestTimeout defaultServerConfig))

4550

4651parseConfig :: IO ServerConfig

4752parseConfig = execParser $ info parseArgs idm

4853

49−