git.iko.soy/project-m36
on master help sign in
WIP Client.hs partially implemented with remote action
6518e14AgentM
ProjectM36/Client.hs+64−11
compare with master
unifiedsplit
@@ -7,8 +7,8 @@ module ProjectM36.Client
7 DatabaseName,
7 DatabaseName,
8 ConnectionError,
8 ConnectionError,
9 connectProjectM36,
9 connectProjectM36,
10− disconnectedTransaction,
10+-- disconnectedTransaction,
11− transactionGraph,
11+-- transactionGraph,
12 close,
12 close,
13 executeRelationalExpr,
13 executeRelationalExpr,
14 executeDatabaseContextExpr,
14 executeDatabaseContextExpr,
@@ -34,25 +34,48 @@ import ProjectM36.TransactionGraph
34import ProjectM36.TransactionGraph.Persist
34import ProjectM36.TransactionGraph.Persist
35import ProjectM36.Attribute
35import ProjectM36.Attribute
36import ProjectM36.Persist (DiskSync(..))
36import ProjectM36.Persist (DiskSync(..))
37+import ProjectM36.Daemon.RemoteCallTypes (RemoteExecution(..))
38+import Network.Transport.TCP (createTransport, defaultTCPParameters)
39+import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode)
40+import Control.Distributed.Process.Extras.Internal.Types (whereisRemote)
41+import Control.Distributed.Process.ManagedProcess.Client (call)
42+import Control.Distributed.Process (NodeId(..))
43+
37import Data.UUID.V4 (nextRandom)
44import Data.UUID.V4 (nextRandom)
38import Control.Concurrent.STM
45import Control.Concurrent.STM
39import Data.Word
46import Data.Word
40−
47+import Control.Distributed.Process (ProcessId)
41−type DatabaseName = StringType
48+import Control.Exception (IOException)
49+import Control.Concurrent.MVar
42
50
43type Hostname = StringType
51type Hostname = StringType
44
52
45type Port = Word16
53type Port = Word16
46
54
55+type DatabaseName = String
56+
47−data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy
57+data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy |
48− --TCPRemoteConnectionInfo HeadName DatabaseName Hostname Port
58+ RemoteProcessConnectionInfo DatabaseName NodeId
49
59
50−data Connection = InProcessConnection PersistenceStrategy (TVar (DisconnectedTransaction, TransactionGraph))
60+data Connection = InProcessConnection PersistenceStrategy (TVar (DisconnectedTransaction, TransactionGraph)) |
51− -- TCPRemoteConnection
61+ RemoteProcessConnection ProcessId
52
62
53−data ConnectionError = SetupDatabaseDirectoryError PersistenceError
63+data ConnectionError = SetupDatabaseDirectoryError PersistenceError |
64+ IOExceptionError IOException |
65+ NoSuchDatabaseByNameError DatabaseName |
66+ LoginError
54− deriving (Show, Eq)
67+ deriving (Show, Eq)
55
68
69+remoteDBLookupName :: DatabaseName -> String
70+remoteDBLookupName = (++) "db-"
71+
72+commonLocalNode :: IO (Either ConnectionError LocalNode)
73+commonLocalNode = do
74+ eLocalTransport <- createTransport "127.0.0.1" "0" defaultTCPParameters
75+ case eLocalTransport of
76+ Left err -> pure (Left $ IOExceptionError err)
77+ Right localTransport -> newLocalNode localTransport initRemoteTable >>= pure . Right
78+
56-- connect to an in-process database
79-- connect to an in-process database
57connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection)
80connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection)
58--create a new in-memory database/transaction graph
81--create a new in-memory database/transaction graph
@@ -68,6 +91,25 @@ connectProjectM36 (InProcessConnectionInfo strat) = do
68 return $ Right $ InProcessConnection strat tvar
91 return $ Right $ InProcessConnection strat tvar
69 MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshDiscon freshGraph
92 MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshDiscon freshGraph
70 CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshDiscon freshGraph
93 CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshDiscon freshGraph
94+
95+connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId) = do
96+ connStatus <- newEmptyMVar
97+ eLocalNode <- commonLocalNode
98+ case eLocalNode of
99+ Left err -> pure (Left err)
100+ Right localNode -> do
101+ runProcess localNode $ do
102+ mServerProcessId <- whereisRemote serverNodeId (remoteDBLookupName databaseName)
103+ case mServerProcessId of
104+ Nothing -> liftIO $ putMVar connStatus $ Left (NoSuchDatabaseByNameError databaseName)
105+ Just serverProcessId -> do
106+ loginConfirmation <- call serverProcessId Login
107+ if not loginConfirmation then
108+ liftIO $ putMVar connStatus (Left LoginError)
109+ else do
110+ liftIO $ putMVar connStatus (Right $ RemoteProcessConnection serverProcessId)
111+ status <- takeMVar connStatus
112+ pure status
71
113
72connectPersistentProjectM36 :: PersistenceStrategy ->
114connectPersistentProjectM36 :: PersistenceStrategy ->
73 DiskSync ->
115 DiskSync ->
@@ -87,14 +129,25 @@ connectPersistentProjectM36 strat sync dbdir freshDiscon freshGraph = do
87 tvar <- newTVarIO (freshDiscon, graph')
129 tvar <- newTVarIO (freshDiscon, graph')
88 return $ Right $ InProcessConnection strat tvar
130 return $ Right $ InProcessConnection strat tvar
89
131
132+{-
133+-- if these are operated remotely, they are too expensive- keep the working space (discon) on the server
90disconnectedTransaction :: Connection -> IO (DisconnectedTransaction)
134disconnectedTransaction :: Connection -> IO (DisconnectedTransaction)
91disconnectedTransaction (InProcessConnection _ tvar) = liftM fst (readTVarIO tvar)
135disconnectedTransaction (InProcessConnection _ tvar) = liftM fst (readTVarIO tvar)
92
136
93transactionGraph :: Connection -> IO (TransactionGraph)
137transactionGraph :: Connection -> IO (TransactionGraph)
94transactionGraph (InProcessConnection _ tvar) = liftM snd (readTVarIO tvar)
138transactionGraph (InProcessConnection _ tvar) = liftM snd (readTVarIO tvar)
139+-}
95
140
96close :: Connection -> IO ()
141close :: Connection -> IO ()
97−close (InProcessConnection _ _) = return ()
142+close (InProcessConnection _ _) = pure ()
143+close (RemoteProcessConnection serverProcessId) = do
144+ eLocalNode <- commonLocalNode
145+ case eLocalNode of
146+ Left _ -> pure () --consider returning an error or exception
147+ Right localNode -> do
148+ runProcess localNode $ do
149+ call serverProcessId Logout
150+ pure ()
98
151
99executeRelationalExpr :: Connection -> RelationalExpr -> IO (Either RelationalError Relation)
152executeRelationalExpr :: Connection -> RelationalExpr -> IO (Either RelationalError Relation)
100executeRelationalExpr (InProcessConnection _ tvar) expr = atomically $ do
153executeRelationalExpr (InProcessConnection _ tvar) expr = atomically $ do
ProjectM36/Daemon/EndPoints.hs → ProjectM36/Daemon/EntryPoints.hsrenamed+5−2
@@ -1,8 +1,8 @@
1−module ProjectM36.Daemon.EndPoints where
1+module ProjectM36.Daemon.EntryPoints where
2import ProjectM36.Base
2import ProjectM36.Base
3import ProjectM36.Client
3import ProjectM36.Client
4import ProjectM36.Error
4import ProjectM36.Error
5−
5+import ProjectM36.Daemon.RemoteCallTypes
6import Control.Distributed.Process (Process)
6import Control.Distributed.Process (Process)
7import Control.Distributed.Process.ManagedProcess (ProcessReply)
7import Control.Distributed.Process.ManagedProcess (ProcessReply)
8import Control.Distributed.Process.ManagedProcess.Server (reply)
8import Control.Distributed.Process.ManagedProcess.Server (reply)
@@ -12,4 +12,7 @@ handleExecuteRelationalExpr :: Connection -> RelationalExpr -> Process (ProcessR
12handleExecuteRelationalExpr conn expr = do
12handleExecuteRelationalExpr conn expr = do
13 ret <- liftIO $ executeRelationalExpr conn expr
13 ret <- liftIO $ executeRelationalExpr conn expr
14 reply ret conn
14 reply ret conn
15+
16+handleLogin :: Connection -> Process (ProcessReply Bool Connection)
17+handleLogin conn = reply True conn
15
18
ProjectM36/Daemon/Main.hs+5−2
@@ -1,7 +1,8 @@
1{-# LANGUAGE ScopedTypeVariables #-}
1{-# LANGUAGE ScopedTypeVariables #-}
2import ProjectM36.Client
2import ProjectM36.Client
3import ProjectM36.Daemon.ParseArgs (parseConfig, persistenceStrategy)
3import ProjectM36.Daemon.ParseArgs (parseConfig, persistenceStrategy)
4−import ProjectM36.Daemon.EndPoints (handleExecuteRelationalExpr)
4+import ProjectM36.Daemon.EntryPoints (handleExecuteRelationalExpr, handleLogin)
5+import ProjectM36.Daemon.RemoteCallTypes (RemoteExecution(..))
5
6
6import System.Exit (exitFailure, exitSuccess)
7import System.Exit (exitFailure, exitSuccess)
7import Control.Concurrent (threadDelay)
8import Control.Concurrent (threadDelay)
@@ -17,7 +18,9 @@ import qualified Control.Distributed.Process.Extras.Internal.Types as DIT
17
18
18serverDefinition :: ProcessDefinition Connection
19serverDefinition :: ProcessDefinition Connection
19serverDefinition = defaultProcess {
20serverDefinition = defaultProcess {
21+ apiHandlers = [handleCall (\conn Login -> handleLogin conn),
20− apiHandlers = [handleCall (\conn (expr :: RelationalExpr) -> handleExecuteRelationalExpr conn expr)],
22+ handleCall (\conn (ExecuteRelationalExpr expr) -> handleExecuteRelationalExpr conn expr)
23+ ],
21 unhandledMessagePolicy = Drop
24 unhandledMessagePolicy = Drop
22 }
25 }
23
26
ProjectM36/Daemon/RemoteCallTypes.hsnew file+9
@@ -0,0 +1,9 @@
1+{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}
2+module ProjectM36.Daemon.RemoteCallTypes where
3+import ProjectM36.Base
4+import GHC.Generics
5+import Data.Binary
6+
7+data RemoteExecution = Login |
8+ Logout |
9+ ExecuteRelationalExpr RelationalExpr deriving (Binary, Generic)
TutorialD/Interpreter.hs+9−8
@@ -22,6 +22,7 @@ import Control.Monad.State
22import System.Console.Haskeline
22import System.Console.Haskeline
23import System.Directory (getHomeDirectory)
23import System.Directory (getHomeDirectory)
24import qualified Data.Text as T
24import qualified Data.Text as T
25+import Data.UUID (UUID)
25
26
26{-
27{-
27context ops are read-only operations which only operate on the database context (relvars and constraints)
28context ops are read-only operations which only operate on the database context (relvars and constraints)
@@ -43,8 +44,8 @@ interpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eo
43 liftM ImportOp ((importCSVP <|> tutdImportP) <* eof) <|>
44 liftM ImportOp ((importCSVP <|> tutdImportP) <* eof) <|>
44 liftM ExportOp (exportCSVP <* eof)
45 liftM ExportOp (exportCSVP <* eof)
45
46
46−promptText :: DisconnectedTransaction -> TransactionGraph -> StringType
47+promptText :: UUID -> TransactionGraph -> StringType
47−promptText (DisconnectedTransaction parentUUID _) graph = "TutorialD (" `T.append` transInfo `T.append` "): "
48+promptText parentUUID graph = "TutorialD (" `T.append` transInfo `T.append` "): "
48 where
49 where
49 transInfo = case transactionForUUID parentUUID graph of
50 transInfo = case transactionForUUID parentUUID graph of
50 Left _ -> "unknown"
51 Left _ -> "unknown"
@@ -62,7 +63,7 @@ evalTutorialD conn expr = case expr of
62 --this does not pass through the ProjectM36.Client library because the operations
63 --this does not pass through the ProjectM36.Client library because the operations
63 --are specific to the interpreter, though some operations may be of general use in the future
64 --are specific to the interpreter, though some operations may be of general use in the future
64 (RODatabaseContextOp execOp) -> do
65 (RODatabaseContextOp execOp) -> do
65− (DisconnectedTransaction _ context) <- disconnectedTransaction conn
66+ (DisconnectedTransaction _ context) <- disconnectedTransaction conn -- !
66 return $ evalRODatabaseContextOp context execOp
67 return $ evalRODatabaseContextOp context execOp
67
68
68 (DatabaseExprOp execOp) -> do
69 (DatabaseExprOp execOp) -> do
@@ -78,21 +79,21 @@ evalTutorialD conn expr = case expr of
78 Nothing -> return QuietSuccessResult
79 Nothing -> return QuietSuccessResult
79
80
80 (ROGraphOp execOp) -> do
81 (ROGraphOp execOp) -> do
81− discon <- disconnectedTransaction conn
82+ discon <- disconnectedTransaction conn -- !
82 graph <- transactionGraph conn
83 graph <- transactionGraph conn
83 case evalROGraphOp discon graph execOp of
84 case evalROGraphOp discon graph execOp of
84 Left err -> barf err
85 Left err -> barf err
85 Right rel -> return $ DisplayResult $ showRelation rel
86 Right rel -> return $ DisplayResult $ showRelation rel
86
87
87 (ImportOp execOp) -> do
88 (ImportOp execOp) -> do
88− (DisconnectedTransaction _ context) <- disconnectedTransaction conn
89+ (DisconnectedTransaction _ context) <- disconnectedTransaction conn -- !
89 exprErr <- evalDataImportOperator execOp context
90 exprErr <- evalDataImportOperator execOp context
90 case exprErr of
91 case exprErr of
91 Left err -> barf err
92 Left err -> barf err
92 Right dbexpr -> evalTutorialD conn (DatabaseExprOp dbexpr)
93 Right dbexpr -> evalTutorialD conn (DatabaseExprOp dbexpr)
93
94
94 (ExportOp execOp) -> do
95 (ExportOp execOp) -> do
95− (DisconnectedTransaction _ context) <- disconnectedTransaction conn
96+ (DisconnectedTransaction _ context) <- disconnectedTransaction conn -- !
96 exprErr <- evalDataExportOperator execOp context
97 exprErr <- evalDataExportOperator execOp context
97 case exprErr of
98 case exprErr of
98 Just err -> barf err
99 Just err -> barf err
@@ -109,9 +110,9 @@ reprLoop :: InterpreterConfig -> Connection -> IO ()
109reprLoop config conn = do
110reprLoop config conn = do
110 homeDirectory <- getHomeDirectory
111 homeDirectory <- getHomeDirectory
111 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
112 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
112− discon <- disconnectedTransaction conn
113+ (DisconnectedTransaction parentUUID _) <- disconnectedTransaction conn
113 graph <- transactionGraph conn
114 graph <- transactionGraph conn
114− maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText discon graph))
115+ maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText parentUUID graph))
115 case maybeLine of
116 case maybeLine of
116 Nothing -> return ()
117 Nothing -> return ()
117 Just line -> do
118 Just line -> do
project-m36.cabal+47−2
@@ -46,6 +46,7 @@ Library
46 ,base64-bytestring
46 ,base64-bytestring
47 ,data-interval
47 ,data-interval
48 ,extended-reals
48 ,extended-reals
49+ ,network-transport
49--required for persistent db driver
50--required for persistent db driver
50 ,persistent
51 ,persistent
51 ,persistent-template
52 ,persistent-template
@@ -53,6 +54,14 @@ Library
53 ,path-pieces
54 ,path-pieces
54 ,conduit
55 ,conduit
55 ,resourcet
56 ,resourcet
57+--needed for remote access
58+ ,distributed-process-client-server
59+ ,distributed-process-extras
60+ ,distributed-process-async
61+ ,distributed-process
62+ ,network-transport-tcp
63+ ,network-transport
64+ ,distributed-process
56 Exposed-Modules: ProjectM36.Error,
65 Exposed-Modules: ProjectM36.Error,
57 ProjectM36.Transaction,
66 ProjectM36.Transaction,
58 ProjectM36.TransactionGraph,
67 ProjectM36.TransactionGraph,
@@ -82,7 +91,43 @@ Library
82 Default-Language: Haskell2010
91 Default-Language: Haskell2010
83
92
84Executable tutd
93Executable tutd
85− Build-Depends: base, project-m36
94+ Build-Depends: base >=4.8 && <4.9,
95+ project-m36,
96+ containers,
97+ unordered-containers,
98+ hashable,
99+ mtl,
100+ uuid,
101+ deepseq-generics,
102+ vector,
103+ text,
104+ vector-binary-instances,
105+ time,
106+ hashable-time,
107+ bytestring,
108+ distributed-process-client-server,
109+ distributed-process-extras,
110+ distributed-process-async,
111+ distributed-process,
112+ network-transport-tcp,
113+ network-transport,
114+ distributed-process,
115+ stm,
116+ deepseq,
117+ binary,
118+ data-interval,
119+ unix,
120+ parallel,
121+ cassava,
122+ gnuplot,
123+ directory,
124+ filepath,
125+ temporary,
126+ parsec,
127+ haskeline,
128+ base64-bytestring,
129+ optparse-applicative,
130+ attoparsec
86 Other-Modules: ProjectM36.Error,
131 Other-Modules: ProjectM36.Error,
87 ProjectM36.Base,
132 ProjectM36.Base,
88 ProjectM36.RelationalExpression,
133 ProjectM36.RelationalExpression,
@@ -101,12 +146,12 @@ Executable tutd
101
146
102Executable daemon
147Executable daemon
103 Build-Depends: project-m36,
148 Build-Depends: project-m36,
104− base >=4.8 && <4.9,
105 distributed-process-client-server,
149 distributed-process-client-server,
106 distributed-process-extras,
150 distributed-process-extras,
107 distributed-process-async,
151 distributed-process-async,
108 distributed-process,
152 distributed-process,
109 network-transport-tcp,
153 network-transport-tcp,
154+ network-transport,
110 distributed-process,
155 distributed-process,
111 binary,
156 binary,
112 transformers,
157 transformers,