4819b42 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP: tutd now connects to remote daemon

4819b42AgentM11 years ago

ProjectM36/Base.hs+1−1

compare with master

unifiedsplit

@@ -246,7 +246,7 @@ data DatabaseExpr where

246 AddInclusionDependency :: IncDepName -> InclusionDependency -> DatabaseExpr

247 RemoveInclusionDependency :: IncDepName -> DatabaseExpr

248 MultipleExpr :: [DatabaseExpr] -> DatabaseExpr

249− deriving (Show,Eq)

249+ deriving (Show, Eq, Binary, Generic)

250

251type DatabaseState a = State DatabaseContext a

252

ProjectM36/Client.hs+39−15

@@ -20,14 +20,18 @@ module ProjectM36.Client

20 processPersistence,

21 transactionGraphAsRelation,

22 headName,

23+ remoteDBLookupName,

24+ defaultServerPort,

23 headTransactionUUID,

25 headTransactionUUID,

24 PersistenceStrategy(..),

26 PersistenceStrategy(..),

25 RelationalExpr(..),

27 RelationalExpr(..),

26 DatabaseExpr(..),

28 DatabaseExpr(..),

27 Attribute(..),

29 Attribute(..),

28 attributesFromList,

30 attributesFromList,

31+ createNodeId,

29 TransactionGraphOperator(..),

32 TransactionGraphOperator(..),

30 Atomable,

33 Atomable,

34+ NodeId(..),

31 Atom(..),

35 Atom(..),

32 AtomType(..)) where

36 AtomType(..)) where

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

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

@@ -43,7 +47,7 @@ import ProjectM36.TransactionGraph.Persist

43import ProjectM36.Attribute

47import ProjectM36.Attribute

44import ProjectM36.Persist (DiskSync(..))

48import ProjectM36.Persist (DiskSync(..))

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

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

46−import Network.Transport.TCP (createTransport, defaultTCPParameters)

50+import Network.Transport.TCP (createTransport, defaultTCPParameters, encodeEndPointAddress)

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

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

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

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

49import Control.Distributed.Process.ManagedProcess.Client (call)

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

@@ -53,12 +57,12 @@ import Data.UUID (UUID)

53import Data.UUID.V4 (nextRandom)

57import Data.UUID.V4 (nextRandom)

54import Control.Concurrent.STM

58import Control.Concurrent.STM

55import Data.Word

59import Data.Word

56−import Control.Distributed.Process (ProcessId)

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

57import Control.Exception (IOException)

61import Control.Exception (IOException)

58import Control.Concurrent.MVar

62import Control.Concurrent.MVar

59import qualified Data.Map as M

63import qualified Data.Map as M

61−type Hostname = StringType

65+type Hostname = String

63type Port = Word16

67type Port = Word16

@@ -67,8 +71,14 @@ type DatabaseName = String

67data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy |

71data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy |

68 RemoteProcessConnectionInfo DatabaseName NodeId

72 RemoteProcessConnectionInfo DatabaseName NodeId

74+createNodeId :: Hostname -> Port -> NodeId

75+createNodeId host port = NodeId $ encodeEndPointAddress host (show port) 0

76+

77+defaultServerPort :: Port

78+defaultServerPort = 6543

79+

70data Connection = InProcessConnection PersistenceStrategy (TVar (DisconnectedTransaction, TransactionGraph)) |

80data Connection = InProcessConnection PersistenceStrategy (TVar (DisconnectedTransaction, TransactionGraph)) |

71− RemoteProcessConnection ProcessId

81+ RemoteProcessConnection LocalNode ProcessId -- perhaps should reference the local node as well

73data ConnectionError = SetupDatabaseDirectoryError PersistenceError |

83data ConnectionError = SetupDatabaseDirectoryError PersistenceError |

74 IOExceptionError IOException |

84 IOExceptionError IOException |

@@ -105,11 +115,13 @@ connectProjectM36 (InProcessConnectionInfo strat) = do

105connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId) = do

115connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId) = do

106 connStatus <- newEmptyMVar

116 connStatus <- newEmptyMVar

107 eLocalNode <- commonLocalNode

117 eLocalNode <- commonLocalNode

118+ let dbName = remoteDBLookupName databaseName

119+ putStrLn $ show serverNodeId ++ " " ++ dbName

108 case eLocalNode of

120 case eLocalNode of

109 Left err -> pure (Left err)

121 Left err -> pure (Left err)

110 Right localNode -> do

122 Right localNode -> do

111 runProcess localNode $ do

123 runProcess localNode $ do

112− mServerProcessId <- whereisRemote serverNodeId (remoteDBLookupName databaseName)

124+ mServerProcessId <- whereisRemote serverNodeId dbName

113 case mServerProcessId of

125 case mServerProcessId of

114 Nothing -> liftIO $ putMVar connStatus $ Left (NoSuchDatabaseByNameError databaseName)

126 Nothing -> liftIO $ putMVar connStatus $ Left (NoSuchDatabaseByNameError databaseName)

115 Just serverProcessId -> do

127 Just serverProcessId -> do

@@ -117,7 +129,7 @@ connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId) = do

117 if not loginConfirmation then

129 if not loginConfirmation then

118 liftIO $ putMVar connStatus (Left LoginError)

130 liftIO $ putMVar connStatus (Left LoginError)

119 else do

131 else do

120− liftIO $ putMVar connStatus (Right $ RemoteProcessConnection serverProcessId)

132+ liftIO $ putMVar connStatus (Right $ RemoteProcessConnection localNode serverProcessId)

121 status <- takeMVar connStatus

133 status <- takeMVar connStatus

122 pure status

134 pure status

123

135

@@ -141,19 +153,25 @@ connectPersistentProjectM36 strat sync dbdir freshDiscon freshGraph = do

141

153

142close :: Connection -> IO ()

154close :: Connection -> IO ()

143close (InProcessConnection _ _) = pure ()

155close (InProcessConnection _ _) = pure ()

144−close (RemoteProcessConnection serverProcessId) = do

156+close (RemoteProcessConnection localNode serverProcessId) = do

145− eLocalNode <- commonLocalNode

146− case eLocalNode of

147− Left _ -> pure () --consider returning an error or exception

148− Right localNode -> do

157+ runProcessResult localNode $ do

149− runProcess localNode $ do

150− call serverProcessId Logout

158+ call serverProcessId Logout

151− pure ()

159+

160+runProcessResult :: LocalNode -> Process a -> IO a

161+runProcessResult localNode proc = do

162+ ret <- newEmptyMVar

163+ runProcess localNode $ do

164+ val <- proc

165+ liftIO $ putMVar ret val

166+ takeMVar ret

152

167

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

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

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

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

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

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

156 return $ evalState (RE.evalRelationalExpr expr) context

171 return $ evalState (RE.evalRelationalExpr expr) context

172+executeRelationalExpr (RemoteProcessConnection localNode serverProcessId) relExpr = do

173+ runProcessResult localNode $ do

174+ call serverProcessId (ExecuteRelationalExpr relExpr)

157

175

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

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

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

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

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

164 let newDiscon = DisconnectedTransaction parentUUID context'

182 let newDiscon = DisconnectedTransaction parentUUID context'

165 writeTVar tvar (newDiscon, graph)

183 writeTVar tvar (newDiscon, graph)

166 return Nothing

184 return Nothing

185+executeDatabaseContextExpr (RemoteProcessConnection localNode serverProcessId) dbExpr = do

186+ runProcessResult localNode $ call serverProcessId (ExecuteDatabaseContextExpr dbExpr)

167

187

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

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

169executeGraphExpr (InProcessConnection strat tvar) graphExpr = do

189executeGraphExpr (InProcessConnection strat tvar) graphExpr = do

@@ -242,6 +262,10 @@ headName (InProcessConnection _ tvar) = do

242 pure $ case transactionForUUID parentUUID graph of

262 pure $ case transactionForUUID parentUUID graph of

243 Left _ -> Nothing

263 Left _ -> Nothing

244 Right parentTrans -> headNameForTransaction parentTrans graph

264 Right parentTrans -> headNameForTransaction parentTrans graph

245−

265+headName (RemoteProcessConnection localNode serverProcessId) = do

266+ runProcessResult localNode $ do

267+ ret <- call serverProcessId ExecuteHeadName

268+ pure ret

269+

246

270

247

271

ProjectM36/Daemon/EntryPoints.hs+12−2

@@ -2,7 +2,6 @@ module ProjectM36.Daemon.EntryPoints where

2import ProjectM36.Base

3import ProjectM36.Client

4import ProjectM36.Error

5−import ProjectM36.Daemon.RemoteCallTypes

6import Control.Distributed.Process (Process)

5import Control.Distributed.Process (Process)

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

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

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

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

@@ -13,6 +12,17 @@ handleExecuteRelationalExpr conn expr = do

13 ret <- liftIO $ executeRelationalExpr conn expr

12 ret <- liftIO $ executeRelationalExpr conn expr

14 reply ret conn

13 reply ret conn

15+handleExecuteDatabaseContextExpr :: Connection -> DatabaseExpr -> Process (ProcessReply (Maybe RelationalError) Connection)

16+handleExecuteDatabaseContextExpr conn dbexpr = do

17+ ret <- liftIO $ executeDatabaseContextExpr conn dbexpr

18+ reply ret conn

19+

20+handleExecuteHeadName :: Connection -> Process (ProcessReply (Maybe HeadName) Connection)

21+handleExecuteHeadName conn = do

22+ ret <- liftIO $ headName conn

23+ reply ret conn

24+

16handleLogin :: Connection -> Process (ProcessReply Bool Connection)

25handleLogin :: Connection -> Process (ProcessReply Bool Connection)

17−handleLogin conn = reply True conn

26+handleLogin conn = do

27+ reply True conn

ProjectM36/Daemon/Main.hs+13−11

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

1{-# LANGUAGE ScopedTypeVariables #-}

2import ProjectM36.Client

3−import ProjectM36.Daemon.ParseArgs (parseConfig, persistenceStrategy)

3+import ProjectM36.Daemon.ParseArgs (parseConfig, persistenceStrategy, databaseName)

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

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

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

7import System.Exit (exitFailure, exitSuccess)

@@ -19,9 +19,11 @@ import qualified Control.Distributed.Process.Extras.Internal.Types as DIT

19serverDefinition :: ProcessDefinition Connection

20serverDefinition = defaultProcess {

21 apiHandlers = [handleCall (\conn Login -> handleLogin conn),

22+ handleCall (\conn ExecuteHeadName -> handleExecuteHeadName conn),

22− handleCall (\conn (ExecuteRelationalExpr expr) -> handleExecuteRelationalExpr conn expr)

23+ handleCall (\conn (ExecuteRelationalExpr expr) -> handleExecuteRelationalExpr conn expr),

24+ handleCall (\conn (ExecuteDatabaseContextExpr expr) -> handleExecuteDatabaseContextExpr conn expr)

23 ],

25 ],

24− unhandledMessagePolicy = Drop

26+ unhandledMessagePolicy = Log

25 }

27 }

27initServer :: InitHandler Connection Connection

29initServer :: InitHandler Connection Connection

@@ -42,18 +44,18 @@ main = do

42 hPutStrLn stderr ("Failed to create database connection: " ++ show err)

44 hPutStrLn stderr ("Failed to create database connection: " ++ show err)

43 exitFailure

45 exitFailure

44 Right conn -> do

46 Right conn -> do

45− etransport <- createTransport "127.0.0.1" "6543" defaultTCPParameters

47+ etransport <- createTransport "127.0.0.1" (show defaultServerPort) defaultTCPParameters

46 case etransport of

48 case etransport of

47 Left err -> error (show err)

49 Left err -> error (show err)

48 Right transport -> do

50 Right transport -> do

49 localTCPNode <- newLocalNode transport remoteTable

51 localTCPNode <- newLocalNode transport remoteTable

50 runProcess localTCPNode $ do

52 runProcess localTCPNode $ do

51 serverPid <- launchServer conn

53 serverPid <- launchServer conn

54+ let dbname = remoteDBLookupName (databaseName daemonConfig)

52− register "project-m36" serverPid

55+ register dbname serverPid

53− liftIO $ do

54− putStrLn (show serverPid)

56+ liftIO $ putStrLn $ show serverPid ++ " " ++ dbname

55− _ <- forever $ threadDelay 1000000

57+ _ <- forever $ threadDelay 1000000

56− putStrLn "Server Exit."

58+ putStrLn "Server Exit."

57− exitSuccess

59+ exitSuccess

ProjectM36/Daemon/ParseArgs.hs+10−2

@@ -1,11 +1,14 @@

1module ProjectM36.Daemon.ParseArgs where

2import ProjectM36.Base

3+import ProjectM36.Client

3import Options.Applicative

4import Options.Applicative

5−data DaemonConfig = DaemonConfig { persistenceStrategy :: PersistenceStrategy }

6+data DaemonConfig = DaemonConfig { persistenceStrategy :: PersistenceStrategy,

7+ databaseName :: DatabaseName

8+ }

7parseArgs :: Parser DaemonConfig

10parseArgs :: Parser DaemonConfig

8−parseArgs = DaemonConfig <$> parsePersistenceStrategy

11+parseArgs = DaemonConfig <$> parsePersistenceStrategy <*> parseDatabaseName

10parsePersistenceStrategy :: Parser PersistenceStrategy

13parsePersistenceStrategy :: Parser PersistenceStrategy

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

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

@@ -20,6 +23,11 @@ parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>

20 fsyncOpt = switch (short 'f' <>

23 fsyncOpt = switch (short 'f' <>

21 long "fsync" <>

24 long "fsync" <>

22 help "Fsync all new transactions.")

25 help "Fsync all new transactions.")

26+

27+parseDatabaseName :: Parser DatabaseName

28+parseDatabaseName = strOption (short 'n' <>

29+ long "dbname" <>

30+ metavar "DATABASE NAME")

24parseConfig :: IO DaemonConfig

32parseConfig :: IO DaemonConfig

25parseConfig = execParser $ info parseArgs idm

33parseConfig = execParser $ info parseArgs idm

ProjectM36/Daemon/RemoteCallTypes.hs+4−1

@@ -6,4 +6,7 @@ import Data.Binary

7data RemoteExecution = Login |

8 Logout |

9− ExecuteRelationalExpr RelationalExpr deriving (Binary, Generic)

9+ ExecuteRelationalExpr RelationalExpr |

10+ ExecuteDatabaseContextExpr DatabaseExpr |

11+ ExecuteHeadName

12+ deriving (Binary, Generic)

TutorialD/Interpreter.hs+2−3

@@ -112,9 +112,8 @@ evalTutorialD conn expr = case expr of

112 where

113 barf err = return $ DisplayErrorResult (T.pack (show err))

114

115−data InterpreterConfig = InterpreterConfig {

115+data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy |

116− persistenceStrategy :: PersistenceStrategy

116+ RemoteInterpreterConfig C.NodeId C.DatabaseName

117− }

118

117

119reprLoop :: InterpreterConfig -> C.Connection -> IO ()

118reprLoop :: InterpreterConfig -> C.Connection -> IO ()

120reprLoop config conn = do

119reprLoop config conn = do

TutorialD/tutd.hs+23−9

@@ -6,15 +6,9 @@ import System.IO

6import Options.Applicative

7import System.Exit

9−{-

10−invocation:

11−tutd

12−-no arguments indicates to run without persistence

13−tutd -d /database-directory

14−-persist to the database directory

15−-}

16parseArgs :: Parser InterpreterConfig

9parseArgs :: Parser InterpreterConfig

17−parseArgs = InterpreterConfig <$> parsePersistenceStrategy

10+parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <|>

11+ RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName

19parsePersistenceStrategy :: Parser PersistenceStrategy

13parsePersistenceStrategy :: Parser PersistenceStrategy

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

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

@@ -29,14 +23,34 @@ parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>

29 fsyncOpt = switch (short 'f' <>

23 fsyncOpt = switch (short 'f' <>

30 long "fsync" <>

24 long "fsync" <>

31 help "Fsync all new transactions.")

25 help "Fsync all new transactions.")

26+

27+parseDatabaseName :: Parser DatabaseName

28+parseDatabaseName = strOption (long "database" <>

29+ help "Remote database name")

30+

31+parseNodeId :: Parser NodeId

32+parseNodeId = createNodeId <$>

33+ strOption (long "host" <>

34+ short 'h' <>

35+ help "Remote host name" <>

36+ value "127.0.0.1") <*>

37+ option auto (long "port" <>

38+ short 'p' <>

39+ help "Remote port" <>

40+ value defaultServerPort)

33opts :: ParserInfo InterpreterConfig

42opts :: ParserInfo InterpreterConfig

34opts = info parseArgs idm

43opts = info parseArgs idm

44+

45+connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo

46+connectionInfoForConfig (LocalInterpreterConfig pStrategy) = InProcessConnectionInfo pStrategy

47+connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName) = RemoteProcessConnectionInfo remoteDBName remoteNodeId

36main :: IO ()

49main :: IO ()

37main = do

50main = do

38 interpreterConfig <- execParser opts

51 interpreterConfig <- execParser opts

52+ let connInfo = connectionInfoForConfig interpreterConfig

39− dbconn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy interpreterConfig))

53+ dbconn <- connectProjectM36 connInfo

40 case dbconn of

54 case dbconn of

41 Left err -> do

55 Left err -> do

42 hPutStrLn stderr ("Failed to create database connection: " ++ show err)

56 hPutStrLn stderr ("Failed to create database connection: " ++ show err)

project-m36.cabal+1−1

@@ -143,7 +143,7 @@ Executable tutd

143 C-sources: ProjectM36/DirectoryFsync.c

144 Default-Language: Haskell2010

145

146−Executable daemon

146+Executable project-m36-daemon

147 Build-Depends: base,

148 distributed-process-client-server,

149 distributed-process-extras,