git.iko.soy/project-m36
on ffe683a help sign in
project-m36/ProjectM36/Client.hs
287 lines 13 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module ProjectM36.Client
3 (ConnectionInfo(..),
4 Connection(..),
5 Port,
6 Hostname,
7 DatabaseName,
8 ConnectionError,
9 connectProjectM36,
10 close,
11 executeRelationalExpr,
12 executeDatabaseContextExpr,
13 executeGraphExpr,
14 commit,
15 rollback,
16 typeForRelationalExpr,
17 inclusionDependencies,
18 planForDatabaseContextExpr,
19 processPersistence,
20 transactionGraphAsRelation,
21 headName,
22 remoteDBLookupName,
23 defaultServerPort,
24 headTransactionUUID,
25 defaultDatabaseName,
26 defaultRemoteConnectionInfo,
27 PersistenceStrategy(..),
28 RelationalExpr(..),
29 DatabaseExpr(..),
30 Attribute(..),
31 attributesFromList,
32 createNodeId,
33 TransactionGraphOperator(..),
34 Atomable,
35 NodeId(..),
36 Atom(..),
37 AtomType(..)) where
38import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well
39import qualified ProjectM36.Base as B
40import ProjectM36.Error
41import ProjectM36.StaticOptimizer
42import Control.Monad.State
43import ProjectM36.Transaction
44import qualified ProjectM36.RelationalExpression as RE
45import ProjectM36.TransactionGraph
46import ProjectM36.TransactionGraph.Persist
47import ProjectM36.Attribute
48import ProjectM36.Persist (DiskSync(..))
49import ProjectM36.Daemon.RemoteCallTypes
50import Network.Transport.TCP (createTransport, defaultTCPParameters, encodeEndPointAddress)
51import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode)
52import Control.Distributed.Process.Extras.Internal.Types (whereisRemote)
53import Control.Distributed.Process.ManagedProcess.Client (call, safeCall)
54import Control.Distributed.Process (NodeId(..))
56import Data.UUID (UUID)
57import Data.UUID.V4 (nextRandom)
58import Control.Concurrent.STM
59import Data.Word
60import Control.Distributed.Process (ProcessId, Process)
61import Control.Exception (IOException)
62import Control.Concurrent.MVar
63import qualified Data.Map as M
64import Control.Distributed.Process.Serializable (Serializable)
65--import Control.Distributed.Process.Debug
67type Hostname = String
69type Port = Word16
71type DatabaseName = String
73data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy |
74 RemoteProcessConnectionInfo DatabaseName NodeId
76createNodeId :: Hostname -> Port -> NodeId
77createNodeId host port = NodeId $ encodeEndPointAddress host (show port) 0
79defaultServerPort :: Port
80defaultServerPort = 6543
82defaultDatabaseName :: DatabaseName
83defaultDatabaseName = "base"
85defaultRemoteConnectionInfo :: ConnectionInfo
86defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (createNodeId "127.0.0.1" defaultServerPort)
88data Connection = InProcessConnection PersistenceStrategy (TVar (DisconnectedTransaction, TransactionGraph)) |
89 RemoteProcessConnection LocalNode ProcessId -- perhaps should reference the local node as well
91data ConnectionError = SetupDatabaseDirectoryError PersistenceError |
92 IOExceptionError IOException |
93 NoSuchDatabaseByNameError DatabaseName |
94 LoginError
95 deriving (Show, Eq)
97remoteDBLookupName :: DatabaseName -> String
98remoteDBLookupName = (++) "db-"
100commonLocalNode :: IO (Either ConnectionError LocalNode)
101commonLocalNode = do
102 eLocalTransport <- createTransport "127.0.0.1" "0" defaultTCPParameters
103 case eLocalTransport of
104 Left err -> pure (Left $ IOExceptionError err)
105 Right localTransport -> newLocalNode localTransport initRemoteTable >>= pure . Right
107-- connect to an in-process database
108connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection)
109--create a new in-memory database/transaction graph
110connectProjectM36 (InProcessConnectionInfo strat) = do
111 freshUUID <- nextRandom
112 let bootstrapContext = RE.basicDatabaseContext
113 freshDiscon = newDisconnectedTransaction freshUUID bootstrapContext
114 freshGraph = bootstrapTransactionGraph freshUUID bootstrapContext
115 case strat of
116 --create date examples graph for now- probably should be empty context in the future
117 NoPersistence -> do
118 tvar <- newTVarIO (freshDiscon, freshGraph)
119 return $ Right $ InProcessConnection strat tvar
120 MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshDiscon freshGraph
121 CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshDiscon freshGraph
123connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId) = do
124 connStatus <- newEmptyMVar
125 eLocalNode <- commonLocalNode
126 let dbName = remoteDBLookupName databaseName
127 putStrLn $ show serverNodeId ++ " " ++ dbName
128 case eLocalNode of
129 Left err -> pure (Left err)
130 Right localNode -> do
131 runProcess localNode $ do
132 mServerProcessId <- whereisRemote serverNodeId dbName
133 case mServerProcessId of
134 Nothing -> liftIO $ putMVar connStatus $ Left (NoSuchDatabaseByNameError databaseName)
135 Just serverProcessId -> do
136 loginConfirmation <- call serverProcessId Login
137 if not loginConfirmation then
138 liftIO $ putMVar connStatus (Left LoginError)
139 else do
140 liftIO $ putMVar connStatus (Right $ RemoteProcessConnection localNode serverProcessId)
141 status <- takeMVar connStatus
142 pure status
144connectPersistentProjectM36 :: PersistenceStrategy ->
145 DiskSync ->
146 FilePath ->
147 DisconnectedTransaction ->
148 TransactionGraph ->
149 IO (Either ConnectionError Connection)
150connectPersistentProjectM36 strat sync dbdir freshDiscon freshGraph = do
151 err <- setupDatabaseDir sync dbdir freshGraph
152 case err of
153 Just err' -> return $ Left (SetupDatabaseDirectoryError err')
154 Nothing -> do
155 graph <- transactionGraphLoad dbdir emptyTransactionGraph
156 case graph of
157 Left err' -> return $ Left (SetupDatabaseDirectoryError err')
158 Right graph' -> do
159 tvar <- newTVarIO (freshDiscon, graph')
160 return $ Right $ InProcessConnection strat tvar
162close :: Connection -> IO ()
163close (InProcessConnection _ _) = pure ()
164close (RemoteProcessConnection localNode serverProcessId) = do
165 runProcessResult localNode $ do
166 call serverProcessId Logout
168runProcessResult :: LocalNode -> Process a -> IO a
169runProcessResult localNode proc = do
170 ret <- newEmptyMVar
171 runProcess localNode $ do
172 val <- proc
173 liftIO $ putMVar ret val
174 takeMVar ret
176remoteCall :: (Serializable a, Serializable b) => Connection -> a -> IO b
177remoteCall (InProcessConnection _ _) _ = error "remoteCall called on local connection"
178remoteCall (RemoteProcessConnection localNode serverProcessId) arg = runProcessResult localNode $ do
179 ret <- safeCall serverProcessId arg
180 case ret of
181 Left err -> error (show err)
182 Right ret' -> pure ret'
184executeRelationalExpr :: Connection -> RelationalExpr -> IO (Either RelationalError Relation)
185executeRelationalExpr (InProcessConnection _ tvar) expr = atomically $ do
186 ((DisconnectedTransaction _ context), _) <- readTVar tvar
187 return $ evalState (RE.evalRelationalExpr expr) context
188executeRelationalExpr conn@(RemoteProcessConnection _ _) relExpr = remoteCall conn (ExecuteRelationalExpr relExpr)
190executeDatabaseContextExpr :: Connection -> DatabaseExpr -> IO (Maybe RelationalError)
191executeDatabaseContextExpr (InProcessConnection _ tvar) expr = atomically $ do
192 ((DisconnectedTransaction parentUUID context), graph) <- readTVar tvar
193 case runState (RE.evalContextExpr expr) context of
194 (Just err,_) -> return $ Just err
195 (Nothing, context') -> do
196 let newDiscon = DisconnectedTransaction parentUUID context'
197 writeTVar tvar (newDiscon, graph)
198 return Nothing
199executeDatabaseContextExpr conn@(RemoteProcessConnection _ _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr dbExpr)
201executeGraphExpr :: Connection -> TransactionGraphOperator -> IO (Maybe RelationalError)
202executeGraphExpr (InProcessConnection strat tvar) graphExpr = do
203 freshUUID <- nextRandom
204 manip <- atomically $ do
205 (discon, graph) <- readTVar tvar
206 case evalGraphOp freshUUID discon graph graphExpr of
207 Left err -> return $ Left err
208 Right (discon', graph') -> do
209 writeTVar tvar (discon', graph')
210 return $ Right (discon', graph')
211 case manip of
212 Left err -> return $ Just err
213 Right (_, newGraph) -> do
214 --update filesystem database, if necessary
215 --this should really grab a lock at the beginning of the method to be threadsafe
216 processPersistence strat newGraph
217 return Nothing
218executeGraphExpr conn@(RemoteProcessConnection _ _) graphExpr = remoteCall conn (ExecuteGraphExpr graphExpr)
220commit :: Connection -> IO (Maybe RelationalError)
221commit conn@(InProcessConnection _ _) = executeGraphExpr conn Commit
222commit conn@(RemoteProcessConnection _ _) = remoteCall conn (ExecuteGraphExpr Commit)
224rollback :: Connection -> IO (Maybe RelationalError)
225rollback conn@(InProcessConnection _ _) = executeGraphExpr conn Rollback
226rollback conn@(RemoteProcessConnection _ _) = remoteCall conn (ExecuteGraphExpr Rollback)
228processPersistence :: PersistenceStrategy -> TransactionGraph -> IO ()
229processPersistence NoPersistence _ = return ()
230processPersistence (MinimalPersistence dbdir) graph = transactionGraphPersist NoDiskSync dbdir graph
231processPersistence (CrashSafePersistence dbdir) graph = transactionGraphPersist FsyncDiskSync dbdir graph
233typeForRelationalExpr :: Connection -> RelationalExpr -> IO (Either RelationalError Relation)
234typeForRelationalExpr conn@(InProcessConnection _ _) relExpr = atomically $ typeForRelationalExprSTM conn relExpr
235typeForRelationalExpr conn@(RemoteProcessConnection _ _) relExpr = remoteCall conn (ExecuteTypeForRelationalExpr relExpr)
237typeForRelationalExprSTM :: Connection -> RelationalExpr -> STM (Either RelationalError Relation)
238typeForRelationalExprSTM (InProcessConnection _ tvar) relExpr = do
239 (DisconnectedTransaction _ context, _) <- readTVar tvar
240 pure $ evalState (RE.typeForRelationalExpr relExpr) context
241typeForRelationalExprSTM _ _ = error "typeForRelationalExprSTM called on non-local connection"
243inclusionDependencies :: Connection -> IO (M.Map IncDepName InclusionDependency)
244inclusionDependencies (InProcessConnection _ tvar) = do
245 atomically $ do
246 ((DisconnectedTransaction _ context), _) <- readTVar tvar
247 pure (B.inclusionDependencies context)
248inclusionDependencies conn@(RemoteProcessConnection _ _) = remoteCall conn RetrieveInclusionDependencies
251planForDatabaseContextExpr :: Connection -> DatabaseExpr -> IO (Either RelationalError DatabaseExpr)
252planForDatabaseContextExpr (InProcessConnection _ tvar) dbExpr = do
253 atomically $ do
254 ((DisconnectedTransaction _ context), _) <- readTVar tvar
255 pure $ evalState (applyStaticDatabaseOptimization dbExpr) context
256planForDatabaseContextExpr conn@(RemoteProcessConnection _ _) dbExpr = remoteCall conn (RetrievePlanForDatabaseContextExpr dbExpr)
258transactionGraphAsRelation :: Connection -> IO (Either RelationalError Relation)
259transactionGraphAsRelation (InProcessConnection _ tvar) = do
260 atomically $ do
261 (discon, graph) <- readTVar tvar
262 pure $ graphAsRelation discon graph
263transactionGraphAsRelation conn@(RemoteProcessConnection _ _) = remoteCall conn RetrieveTransactionGraph
265-- | Returns the UUID for the connection's disconnected transaction committed parent transaction.
266headTransactionUUID :: Connection -> IO (UUID)
267headTransactionUUID (InProcessConnection _ tvar) = do
268 atomically $ do
269 (DisconnectedTransaction parentUUID _, _) <- readTVar tvar
270 pure parentUUID
271headTransactionUUID conn@(RemoteProcessConnection _ _) = remoteCall conn RetrieveHeadTransactionUUID
273-- | Returns Just the name of the head of the current disconnected transaction or Nothing.
274headName :: Connection -> IO (Maybe HeadName)
275headName (InProcessConnection _ tvar) = do
276 atomically $ do
277 (DisconnectedTransaction parentUUID _, graph) <- readTVar tvar
278 pure $ case transactionForUUID parentUUID graph of
279 Left _ -> Nothing
280 Right parentTrans -> headNameForTransaction parentTrans graph
281headName (RemoteProcessConnection localNode serverProcessId) = do
282 runProcessResult localNode $ do
283 ret <- call serverProcessId ExecuteHeadName
284 pure ret