ff20471 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP: more client-server stability changes

commitff204715a323d25f78750d72fde158e365102631 authorAgentM <agentm@themactionfaction.com> dateMon 16 Nov 2015, 23:18 (11 years ago) parent6dd3abd

7 files changed+93−42

compare with master

unifiedsplit

ProjectM36/Client.hs+29−22 ProjectM36/Daemon/EntryPoints.hs+28−1 ProjectM36/Daemon/Main.hs+21−12 ProjectM36/Daemon/ParseArgs.hs+1−1 ProjectM36/Daemon/RemoteCallTypes.hs+6−1 ProjectM36/Error.hs+2−1 TutorialD/Interpreter.hs+6−4

ProjectM36/Client.hs+29−22

@@ -16,7 +16,6 @@ module ProjectM36.Client

1616 typeForRelationalExpr,

1717 inclusionDependencies,

1818 planForDatabaseContextExpr,

19− attributesForRelationalExpr,

2019 processPersistence,

2120 transactionGraphAsRelation,

2221 headName,

@@ -37,7 +36,6 @@ module ProjectM36.Client

3736import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well

3837import qualified ProjectM36.Base as B

3938import ProjectM36.Error

40−import ProjectM36.Relation

4139import ProjectM36.StaticOptimizer

4240import Control.Monad.State

4341import ProjectM36.Transaction

@@ -50,17 +48,19 @@ import ProjectM36.Daemon.RemoteCallTypes (RemoteExecution(..))

5048import Network.Transport.TCP (createTransport, defaultTCPParameters, encodeEndPointAddress)

5149import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode)

5250import Control.Distributed.Process.Extras.Internal.Types (whereisRemote)

53−import Control.Distributed.Process.ManagedProcess.Client (call)

51+import Control.Distributed.Process.ManagedProcess.Client (call, safeCall)

5452import Control.Distributed.Process (NodeId(..))

5553

5654import Data.UUID (UUID)

5755import Data.UUID.V4 (nextRandom)

5856import Control.Concurrent.STM

5957import Data.Word

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

58+import Control.Distributed.Process (ProcessId, Process, getSelfPid)

6159import Control.Exception (IOException)

6260import Control.Concurrent.MVar

6361import qualified Data.Map as M

62+import Control.Distributed.Process.Serializable (Serializable)

63+--import Control.Distributed.Process.Debug

6464

6565type Hostname = String

6666

@@ -165,13 +165,21 @@ runProcessResult localNode proc = do

165165 liftIO $ putMVar ret val

166166 takeMVar ret

167167

168+remoteCall :: (Serializable a, Serializable b) => Connection -> a -> IO b

169+remoteCall (InProcessConnection _ _) _ = error "remoteCall called on local connection"

170+remoteCall (RemoteProcessConnection localNode serverProcessId) arg = runProcessResult localNode $ do

171+ pid <- getSelfPid

172+ liftIO $ putStrLn (show serverProcessId)

173+ ret <- safeCall serverProcessId arg

174+ case ret of

175+ Left err -> error (show err)

176+ Right ret' -> pure ret'

177+

168178executeRelationalExpr :: Connection -> RelationalExpr -> IO (Either RelationalError Relation)

169179executeRelationalExpr (InProcessConnection _ tvar) expr = atomically $ do

170180 ((DisconnectedTransaction _ context), _) <- readTVar tvar

171181 return $ evalState (RE.evalRelationalExpr expr) context

172−executeRelationalExpr (RemoteProcessConnection localNode serverProcessId) relExpr = do

173− runProcessResult localNode $ do

174− call serverProcessId (ExecuteRelationalExpr relExpr)

182+executeRelationalExpr conn@(RemoteProcessConnection _ _) relExpr = remoteCall conn (ExecuteRelationalExpr relExpr)

175183

176184executeDatabaseContextExpr :: Connection -> DatabaseExpr -> IO (Maybe RelationalError)

177185executeDatabaseContextExpr (InProcessConnection _ tvar) expr = atomically $ do

@@ -182,8 +190,7 @@ executeDatabaseContextExpr (InProcessConnection _ tvar) expr = atomically $ do

182190 let newDiscon = DisconnectedTransaction parentUUID context'

183191 writeTVar tvar (newDiscon, graph)

184192 return Nothing

185−executeDatabaseContextExpr (RemoteProcessConnection localNode serverProcessId) dbExpr = do

186− runProcessResult localNode $ call serverProcessId (ExecuteDatabaseContextExpr dbExpr)

193+executeDatabaseContextExpr conn@(RemoteProcessConnection _ _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr dbExpr)

187194

188195executeGraphExpr :: Connection -> TransactionGraphOperator -> IO (Maybe RelationalError)

189196executeGraphExpr (InProcessConnection strat tvar) graphExpr = do

@@ -202,15 +209,15 @@ executeGraphExpr (InProcessConnection strat tvar) graphExpr = do

202209 --this should really grab a lock at the beginning of the method to be threadsafe

203210 processPersistence strat newGraph

204211 return Nothing

205−executeGraphExpr (RemoteProcessConnection localNode serverProcessId) graphExpr = do

206− runProcessResult localNode $ do

207− call serverProcessId (ExecuteGraphExpr graphExpr)

212+executeGraphExpr conn@(RemoteProcessConnection _ _) graphExpr = remoteCall conn (ExecuteGraphExpr graphExpr)

208213

209214commit :: Connection -> IO (Maybe RelationalError)

210−commit conn = executeGraphExpr conn Commit

215+commit conn@(InProcessConnection _ _) = executeGraphExpr conn Commit

216+commit conn@(RemoteProcessConnection _ _) = remoteCall conn (ExecuteGraphExpr Commit)

211217

212218rollback :: Connection -> IO (Maybe RelationalError)

213−rollback conn = executeGraphExpr conn Rollback

219+rollback conn@(InProcessConnection _ _) = executeGraphExpr conn Rollback

220+rollback conn@(RemoteProcessConnection _ _) = remoteCall conn (ExecuteGraphExpr Rollback)

214221

215222processPersistence :: PersistenceStrategy -> TransactionGraph -> IO ()

216223processPersistence NoPersistence _ = return ()

@@ -219,43 +226,43 @@ processPersistence (CrashSafePersistence dbdir) graph = transactionGraphPersist

219226

220227typeForRelationalExpr :: Connection -> RelationalExpr -> IO (Either RelationalError Relation)

221228typeForRelationalExpr conn@(InProcessConnection _ _) relExpr = atomically $ typeForRelationalExprSTM conn relExpr

229+typeForRelationalExpr conn@(RemoteProcessConnection _ _) relExpr = remoteCall conn (ExecuteTypeForRelationalExpr relExpr)

222230

223231typeForRelationalExprSTM :: Connection -> RelationalExpr -> STM (Either RelationalError Relation)

224232typeForRelationalExprSTM (InProcessConnection _ tvar) relExpr = do

225233 (DisconnectedTransaction _ context, _) <- readTVar tvar

226234 pure $ evalState (RE.typeForRelationalExpr relExpr) context

235+typeForRelationalExprSTM _ _ = error "typeForRelationalExprSTM called on non-local connection"

227236

228237inclusionDependencies :: Connection -> IO (M.Map IncDepName InclusionDependency)

229238inclusionDependencies (InProcessConnection _ tvar) = do

230239 atomically $ do

231240 ((DisconnectedTransaction _ context), _) <- readTVar tvar

232241 pure (B.inclusionDependencies context)

242+inclusionDependencies conn@(RemoteProcessConnection _ _) = remoteCall conn RetrieveInclusionDependencies

243+

233244

234245planForDatabaseContextExpr :: Connection -> DatabaseExpr -> IO (Either RelationalError DatabaseExpr)

235246planForDatabaseContextExpr (InProcessConnection _ tvar) dbExpr = do

236247 atomically $ do

237248 ((DisconnectedTransaction _ context), _) <- readTVar tvar

238249 pure $ evalState (applyStaticDatabaseOptimization dbExpr) context

250+planForDatabaseContextExpr conn@(RemoteProcessConnection _ _) dbExpr = remoteCall conn (RetrievePlanForDatabaseContextExpr dbExpr)

239251

240252transactionGraphAsRelation :: Connection -> IO (Either RelationalError Relation)

241253transactionGraphAsRelation (InProcessConnection _ tvar) = do

242254 atomically $ do

243255 (discon, graph) <- readTVar tvar

244256 pure $ graphAsRelation discon graph

245−

246−attributesForRelationalExpr :: Connection -> RelationalExpr -> IO (Either RelationalError Attributes)

247−attributesForRelationalExpr conn relExpr = atomically $ do

248− eRelType <- typeForRelationalExprSTM conn relExpr

249− pure $ case eRelType of

250− Left err -> Left err

251− Right relType -> Right $ attributes relType

252−

257+transactionGraphAsRelation conn@(RemoteProcessConnection _ _) = remoteCall conn RetrieveTransactionGraph

258+

253259-- | Returns the UUID for the connection's disconnected transaction committed parent transaction.

254260headTransactionUUID :: Connection -> IO (UUID)

255261headTransactionUUID (InProcessConnection _ tvar) = do

256262 atomically $ do

257263 (DisconnectedTransaction parentUUID _, _) <- readTVar tvar

258264 pure parentUUID

265+headTransactionUUID conn@(RemoteProcessConnection _ _) = remoteCall conn RetrieveHeadTransactionUUID

259266

260267-- | Returns Just the name of the head of the current disconnected transaction or Nothing.

261268headName :: Connection -> IO (Maybe HeadName)

ProjectM36/Daemon/EntryPoints.hs+28−1

@@ -1,11 +1,13 @@

11module ProjectM36.Daemon.EntryPoints where

2−import ProjectM36.Base

2+import ProjectM36.Base hiding (inclusionDependencies)

33import ProjectM36.Client

44import ProjectM36.Error

55import Control.Distributed.Process (Process)

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

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

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

9+import Data.Map

10+import Data.UUID (UUID)

911

1012handleExecuteRelationalExpr :: Connection -> RelationalExpr -> Process (ProcessReply (Either RelationalError Relation) Connection)

1113handleExecuteRelationalExpr conn expr = do

@@ -28,4 +30,29 @@ handleLogin conn = reply True conn

2830handleExecuteGraphExpr :: Connection -> TransactionGraphOperator -> Process (ProcessReply (Maybe RelationalError) Connection)

2931handleExecuteGraphExpr conn graphExpr = do

3032 ret <- liftIO $ executeGraphExpr conn graphExpr

33+ reply ret conn

34+

35+handleExecuteTypeForRelationalExpr :: Connection -> RelationalExpr -> Process (ProcessReply (Either RelationalError Relation) Connection)

36+handleExecuteTypeForRelationalExpr conn relExpr = do

37+ ret <- liftIO $ typeForRelationalExpr conn relExpr

38+ reply ret conn

39+

40+handleRetrieveInclusionDependencies :: Connection -> Process (ProcessReply (Map IncDepName InclusionDependency) Connection)

41+handleRetrieveInclusionDependencies conn = do

42+ ret <- liftIO $ inclusionDependencies conn

43+ reply ret conn

44+

45+handleRetrievePlanForDatabaseContextExpr :: Connection -> DatabaseExpr -> Process (ProcessReply (Either RelationalError DatabaseExpr) Connection)

46+handleRetrievePlanForDatabaseContextExpr conn dbExpr = do

47+ ret <- liftIO $ planForDatabaseContextExpr conn dbExpr

48+ reply ret conn

49+

50+handleRetrieveTransactionGraph :: Connection -> Process (ProcessReply (Either RelationalError Relation) Connection)

51+handleRetrieveTransactionGraph conn = do

52+ ret <- liftIO $ transactionGraphAsRelation conn

53+ reply ret conn

54+

55+handleRetrieveHeadTransactionUUID :: Connection -> Process (ProcessReply UUID Connection)

56+handleRetrieveHeadTransactionUUID conn = do

57+ ret <- liftIO $ headTransactionUUID conn

3158 reply ret conn

ProjectM36/Daemon/Main.hs+21−12

@@ -1,7 +1,7 @@

11{-# LANGUAGE ScopedTypeVariables #-}

22import ProjectM36.Client

33import ProjectM36.Daemon.ParseArgs (parseConfig, persistenceStrategy, databaseName)

4−import ProjectM36.Daemon.EntryPoints (handleExecuteRelationalExpr, handleExecuteDatabaseContextExpr, handleLogin, handleExecuteHeadName, handleExecuteGraphExpr)

4+import ProjectM36.Daemon.EntryPoints (handleExecuteRelationalExpr, handleExecuteDatabaseContextExpr, handleLogin, handleExecuteHeadName, handleExecuteGraphExpr, handleExecuteTypeForRelationalExpr, handleRetrieveInclusionDependencies,handleRetrievePlanForDatabaseContextExpr, handleRetrieveTransactionGraph, handleRetrieveHeadTransactionUUID)

55import ProjectM36.Daemon.RemoteCallTypes (RemoteExecution(..))

77import System.Exit (exitFailure, exitSuccess)

@@ -10,7 +10,7 @@ import Control.Monad.IO.Class (liftIO)

1010import Network.Transport.TCP (createTransport, defaultTCPParameters)

1111import Control.Distributed.Process.Node (initRemoteTable, runProcess, newLocalNode)

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

13−import Control.Distributed.Process (ProcessId, spawnLocal, Process, register, RemoteTable)

13+import Control.Distributed.Process (Process, register, RemoteTable, getSelfPid)

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

1515import Control.Monad (forever)

1616import System.IO (hPutStrLn, stderr)

@@ -22,19 +22,30 @@ serverDefinition = defaultProcess {

2222 handleCall (\conn ExecuteHeadName -> handleExecuteHeadName conn),

2323 handleCall (\conn (ExecuteRelationalExpr expr) -> handleExecuteRelationalExpr conn expr),

2424 handleCall (\conn (ExecuteDatabaseContextExpr expr) -> handleExecuteDatabaseContextExpr conn expr),

25− handleCall (\conn (ExecuteGraphExpr expr) -> handleExecuteGraphExpr conn expr)

25+ handleCall (\conn (ExecuteGraphExpr expr) -> handleExecuteGraphExpr conn expr),

26+ handleCall (\conn (ExecuteTypeForRelationalExpr expr) -> handleExecuteTypeForRelationalExpr conn expr),

27+ handleCall (\conn RetrieveInclusionDependencies -> handleRetrieveInclusionDependencies conn),

28+ handleCall (\conn (RetrievePlanForDatabaseContextExpr dbExpr) -> handleRetrievePlanForDatabaseContextExpr conn dbExpr),

29+ handleCall (\conn RetrieveHeadTransactionUUID -> handleRetrieveHeadTransactionUUID conn),

30+ handleCall (\conn RetrieveTransactionGraph -> handleRetrieveTransactionGraph conn)

2631 ],

2732 unhandledMessagePolicy = Log

2833 }

2934

30−initServer :: InitHandler Connection Connection

31−initServer conn = return $ InitOk conn Infinity

32−

33−launchServer :: Connection -> Process ProcessId

34−launchServer conn = spawnLocal (serve conn initServer serverDefinition)

35+initServer :: InitHandler (Connection, DatabaseName) Connection

36+initServer (conn, dbname) = do

37+ registerDB dbname

38+ pure $ InitOk conn Infinity

3539

3640remoteTable :: RemoteTable

3741remoteTable = DIT.__remoteTable initRemoteTable

42+

43+registerDB :: DatabaseName -> Process ()

44+registerDB dbname = do

45+ self <- getSelfPid

46+ let dbname' = remoteDBLookupName dbname

47+ register dbname' self

48+ liftIO $ putStrLn $ "registered " ++ (show self) ++ " " ++ dbname'

3849

3950main :: IO ()

4051main = do

@@ -51,10 +62,8 @@ main = do

5162 Right transport -> do

5263 localTCPNode <- newLocalNode transport remoteTable

5364 runProcess localTCPNode $ do

54− serverPid <- launchServer conn

55− let dbname = remoteDBLookupName (databaseName daemonConfig)

56− register dbname serverPid

57− liftIO $ putStrLn $ show serverPid ++ " " ++ dbname

65+ serve (conn, databaseName daemonConfig) initServer serverDefinition

66+ liftIO $ putStrLn "serve returned"

5867 _ <- forever $ threadDelay 1000000

5968 putStrLn "Server Exit."

6069 exitSuccess

ProjectM36/Daemon/ParseArgs.hs+1−1

@@ -26,7 +26,7 @@ parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>

2626

2727parseDatabaseName :: Parser DatabaseName

2828parseDatabaseName = strOption (short 'n' <>

29− long "dbname" <>

29+ long "database" <>

3030 metavar "DATABASE NAME")

3131

3232parseConfig :: IO DaemonConfig

ProjectM36/Daemon/RemoteCallTypes.hs+6−1

@@ -10,5 +10,10 @@ data RemoteExecution = Login |

1010 ExecuteRelationalExpr RelationalExpr |

1111 ExecuteDatabaseContextExpr DatabaseExpr |

1212 ExecuteGraphExpr TransactionGraphOperator |

13− ExecuteHeadName

13+ ExecuteHeadName |

14+ ExecuteTypeForRelationalExpr RelationalExpr |

15+ RetrieveInclusionDependencies |

16+ RetrievePlanForDatabaseContextExpr DatabaseExpr |

17+ RetrieveTransactionGraph |

18+ RetrieveHeadTransactionUUID

1419 deriving (Binary, Generic)

ProjectM36/Error.hs+2−1

@@ -8,6 +8,7 @@ import Control.DeepSeq.Generics (genericRnf)

88import GHC.Generics (Generic)

99import qualified Data.Text as T

1010import Data.Binary

11+import Data.Typeable

1112

1213data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

1314 | TupleAttributeCountMismatchError Int --attribute name

@@ -38,7 +39,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

3839 | RelationValuedAttributesNotSupportedError [AttributeName]

3940 | ImportError T.Text -- really? This should be broken out into some other error type- this has nothing to do with relational algebra

4041 | ExportError T.Text

41− deriving (Show,Eq,Generic,Binary)

42+ deriving (Show,Eq,Generic,Binary,Typeable)

4243

4344instance NFData RelationalError where rnf = genericRnf

4445

TutorialD/Interpreter.hs+6−4

@@ -16,6 +16,8 @@ import ProjectM36.Base

1616import ProjectM36.Relation.Show.Term

1717import ProjectM36.TransactionGraph

1818import qualified ProjectM36.Client as C

19+import ProjectM36.Relation (attributes)

20+

1921import Text.Parsec

2022import Text.Parsec.String

2123import Control.Monad.State

@@ -84,11 +86,11 @@ evalTutorialD conn expr = case expr of

8486 (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) -> do

8587 -- collect attributes from relvar name

8688 -- is there a race condition here? The attributes of the relvar may have since changed, no?

87− eImportAttributes <- C.attributesForRelationalExpr conn (RelationVariable relVarName)

88− case eImportAttributes of

89+ eImportType <- C.typeForRelationalExpr conn (RelationVariable relVarName)

90+ case eImportType of

8991 Left err -> barf err

90− Right importAttributes -> do

91− exprErr <- evalRelVarDataImportOperator execOp importAttributes

92+ Right importType -> do

93+ exprErr <- evalRelVarDataImportOperator execOp (attributes importType)

9294 case exprErr of

9395 Left err -> barf err

9496 Right dbexpr -> evalTutorialD conn (DatabaseExprOp dbexpr)