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

git.iko.soy/project-m36

WIP: tutd now connects to remote daemon

-executing relational and database context expressions

commit4819b425962103de71349ec807ca9a9c1e095884 authorAgentM <agentm@themactionfaction.com> dateSun 15 Nov 2015, 22:37 (11 years ago) parent9f0f8f3

9 files changed+105−45

compare with master

unifiedsplit

ProjectM36/Base.hs+1−1 ProjectM36/Client.hs+39−15 ProjectM36/Daemon/EntryPoints.hs+12−2 ProjectM36/Daemon/Main.hs+13−11 ProjectM36/Daemon/ParseArgs.hs+10−2 ProjectM36/Daemon/RemoteCallTypes.hs+4−1 TutorialD/Interpreter.hs+2−3 TutorialD/tutd.hs+23−9 project-m36.cabal+1−1

ProjectM36/Base.hs+1−1

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

246246 AddInclusionDependency :: IncDepName -> InclusionDependency -> DatabaseExpr

247247 RemoveInclusionDependency :: IncDepName -> DatabaseExpr

248248 MultipleExpr :: [DatabaseExpr] -> DatabaseExpr

249− deriving (Show,Eq)

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

250250

251251type DatabaseState a = State DatabaseContext a

252252

ProjectM36/Client.hs+39−15

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

2020 processPersistence,

2121 transactionGraphAsRelation,

2222 headName,

23+ remoteDBLookupName,

24+ defaultServerPort,

2325 headTransactionUUID,

2426 PersistenceStrategy(..),

2527 RelationalExpr(..),

2628 DatabaseExpr(..),

2729 Attribute(..),

2830 attributesFromList,

31+ createNodeId,

2932 TransactionGraphOperator(..),

3033 Atomable,

34+ NodeId(..),

3135 Atom(..),

3236 AtomType(..)) where

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

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

4347import ProjectM36.Attribute

4448import ProjectM36.Persist (DiskSync(..))

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

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

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

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

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

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

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

5357import Data.UUID.V4 (nextRandom)

5458import Control.Concurrent.STM

5559import Data.Word

56−import Control.Distributed.Process (ProcessId)

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

5761import Control.Exception (IOException)

5862import Control.Concurrent.MVar

5963import qualified Data.Map as M

6064

61−type Hostname = StringType

65+type Hostname = String

6266

6367type Port = Word16

6468

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

6771data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy |

6872 RemoteProcessConnectionInfo DatabaseName NodeId

6973

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

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

76+

77+defaultServerPort :: Port

78+defaultServerPort = 6543

79+

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

71− RemoteProcessConnection ProcessId

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

7282

7383data ConnectionError = SetupDatabaseDirectoryError PersistenceError |

7484 IOExceptionError IOException |

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

105115connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId) = do

106116 connStatus <- newEmptyMVar

107117 eLocalNode <- commonLocalNode

118+ let dbName = remoteDBLookupName databaseName

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

108120 case eLocalNode of

109121 Left err -> pure (Left err)

110122 Right localNode -> do

111123 runProcess localNode $ do

112− mServerProcessId <- whereisRemote serverNodeId (remoteDBLookupName databaseName)

124+ mServerProcessId <- whereisRemote serverNodeId dbName

113125 case mServerProcessId of

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

115127 Just serverProcessId -> do

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

117129 if not loginConfirmation then

118130 liftIO $ putMVar connStatus (Left LoginError)

119131 else do

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

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

121133 status <- takeMVar connStatus

122134 pure status

123135

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

141153

142154close :: Connection -> IO ()

143155close (InProcessConnection _ _) = pure ()

144−close (RemoteProcessConnection serverProcessId) = do

145− eLocalNode <- commonLocalNode

146− case eLocalNode of

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

148− Right localNode -> do

149− runProcess localNode $ do

150− call serverProcessId Logout

151− pure ()

156+close (RemoteProcessConnection localNode serverProcessId) = do

157+ runProcessResult localNode $ do

158+ call serverProcessId Logout

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

152167

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

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

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

156171 return $ evalState (RE.evalRelationalExpr expr) context

172+executeRelationalExpr (RemoteProcessConnection localNode serverProcessId) relExpr = do

173+ runProcessResult localNode $ do

174+ call serverProcessId (ExecuteRelationalExpr relExpr)

157175

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

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

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

164182 let newDiscon = DisconnectedTransaction parentUUID context'

165183 writeTVar tvar (newDiscon, graph)

166184 return Nothing

185+executeDatabaseContextExpr (RemoteProcessConnection localNode serverProcessId) dbExpr = do

186+ runProcessResult localNode $ call serverProcessId (ExecuteDatabaseContextExpr dbExpr)

167187

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

169189executeGraphExpr (InProcessConnection strat tvar) graphExpr = do

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

242262 pure $ case transactionForUUID parentUUID graph of

243263 Left _ -> Nothing

244264 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+

246270

247271

ProjectM36/Daemon/EntryPoints.hs+12−2

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

22import ProjectM36.Base

33import ProjectM36.Client

44import ProjectM36.Error

5−import ProjectM36.Daemon.RemoteCallTypes

65import Control.Distributed.Process (Process)

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

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

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

1312 ret <- liftIO $ executeRelationalExpr conn expr

1413 reply ret conn

1514

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+

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

17−handleLogin conn = reply True conn

26+handleLogin conn = do

27+ reply True conn

1828

ProjectM36/Daemon/Main.hs+13−11

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

11{-# LANGUAGE ScopedTypeVariables #-}

22import ProjectM36.Client

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

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

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

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

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

77import System.Exit (exitFailure, exitSuccess)

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

1919serverDefinition :: ProcessDefinition Connection

2020serverDefinition = defaultProcess {

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

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

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

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

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

2325 ],

24− unhandledMessagePolicy = Drop

26+ unhandledMessagePolicy = Log

2527 }

2628

2729initServer :: InitHandler Connection Connection

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

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

4345 exitFailure

4446 Right conn -> do

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

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

4648 case etransport of

4749 Left err -> error (show err)

4850 Right transport -> do

4951 localTCPNode <- newLocalNode transport remoteTable

5052 runProcess localTCPNode $ do

5153 serverPid <- launchServer conn

52− register "project-m36" serverPid

53− liftIO $ do

54− putStrLn (show serverPid)

55− _ <- forever $ threadDelay 1000000

56− putStrLn "Server Exit."

57− exitSuccess

54+ let dbname = remoteDBLookupName (databaseName daemonConfig)

55+ register dbname serverPid

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

57+ _ <- forever $ threadDelay 1000000

58+ putStrLn "Server Exit."

59+ exitSuccess

5860

5961

ProjectM36/Daemon/ParseArgs.hs+10−2

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

11module ProjectM36.Daemon.ParseArgs where

22import ProjectM36.Base

3+import ProjectM36.Client

34import Options.Applicative

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

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

7+ databaseName :: DatabaseName

8+ }

710parseArgs :: Parser DaemonConfig

8−parseArgs = DaemonConfig <$> parsePersistenceStrategy

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

912

1013parsePersistenceStrategy :: Parser PersistenceStrategy

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

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

2023 fsyncOpt = switch (short 'f' <>

2124 long "fsync" <>

2225 help "Fsync all new transactions.")

26+

27+parseDatabaseName :: Parser DatabaseName

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

29+ long "dbname" <>

30+ metavar "DATABASE NAME")

2331

2432parseConfig :: IO DaemonConfig

2533parseConfig = execParser $ info parseArgs idm

ProjectM36/Daemon/RemoteCallTypes.hs+4−1

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

77data RemoteExecution = Login |

88 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

112112 where

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

114114

115−data InterpreterConfig = InterpreterConfig {

116− persistenceStrategy :: PersistenceStrategy

117− }

115+data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy |

116+ RemoteInterpreterConfig C.NodeId C.DatabaseName

118117

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

120119reprLoop config conn = do

TutorialD/tutd.hs+23−9

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

66import Options.Applicative

77import 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−-}

169parseArgs :: Parser InterpreterConfig

17−parseArgs = InterpreterConfig <$> parsePersistenceStrategy

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

11+ RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName

1812

1913parsePersistenceStrategy :: Parser PersistenceStrategy

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

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

2923 fsyncOpt = switch (short 'f' <>

3024 long "fsync" <>

3125 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)

3241

3342opts :: ParserInfo InterpreterConfig

3443opts = info parseArgs idm

44+

45+connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo

46+connectionInfoForConfig (LocalInterpreterConfig pStrategy) = InProcessConnectionInfo pStrategy

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

3548

3649main :: IO ()

3750main = do

3851 interpreterConfig <- execParser opts

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

52+ let connInfo = connectionInfoForConfig interpreterConfig

53+ dbconn <- connectProjectM36 connInfo

4054 case dbconn of

4155 Left err -> do

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

project-m36.cabal+1−1

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

143143 C-sources: ProjectM36/DirectoryFsync.c

144144 Default-Language: Haskell2010

145145

146−Executable daemon

146+Executable project-m36-daemon

147147 Build-Depends: base,

148148 distributed-process-client-server,

149149 distributed-process-extras,